C 11 APR 08 - SN  - ENABLE USAGE DURING G3(MP2) RUNS
C  6 MAR 08 - HN  - MRMPINP: ALLOW READING THE GMCPT CHOICE
C  7 DEC 07 - MWS - MP2INP: CODE=DDI SHOULD FORCE PARALLEL EXECUTION
C 20 AUG 07 - DGF - CHOOSE IMS MP2 GRADIENT AS DEFAULT FOR FMO
C 21 MAY 07 - MWS - NUMCOR: CHANGE (N-1)D TO BE VALENCE FOR GA,IN,TL
C 22 DEC 06 - DGF - SYNCHRONISE MP2PAR
C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C 22 FEB 06 - MWS - IMPLEMENT OPTION FOR NO SYMMETRY IN MP2 STEP
C 14 NOV 05 - DGF - PAD COMMON BLOCK ENRGYS
C 19 SEP 05 - MWS - ADJUSTMENT FOR H OR I FUNCTION RUNS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  1 JUN 05 - CMA - ALLOW ZAPT2 GRADIENTS
C 30 APR 05 - DGF - REMOVE IN-CORE MP2 ABORT, SYNCHRONISE SYMBLK
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL
C  7 SEP 04 - MWS - PAD COMMON BLOCK INTFIL
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C  9 DEC 03 - MWS - MP2INP: MOVED GRADIENT CHECKING TO INPUTA.SRC
C  3 SEP 03 - CMA - CHANGES TO ALLOW CPHF ITERATION LIMIT INPUT
C 12 DEC 02 - CMA - PERMIT CPHF BASIS SELECTION, EFFICIENCY IMPROVEMENTS
C 17 AUG 02 - MWS - MP2INP: MAKEFP RUNS MUST GENERATE DENSITY
C 22 MAY 02 - MWS - NEW CALLING ARG FOR UHFNOS
C 24 JAN 02 - CMA - UMP2SA,UMP2PA: ALLOW NOCCB>NOCCA, IF NACORE>NBCORE
C 16 NOV 01 - MWS - MP2NOS: A BETTER FORMAT STATEMENT FOR ELECTRON SUMS
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C  1 AUG 01 - SAV - MP2ZRT: FIX MULTI-PASS DIRECT ZAPT TRANSFORMATION
C 25 JUN 01 - MWS - ALTER COMMON BLOCK WFNOPT
C 29 DEC 00 - MWS - ZAPTS: TRAP FOR MULTIPASS DIRECT ZAPT JOBS.
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER
C 11 JUN 00 - MWS - MP2NRG,UMP2EN,ZAPTEN: ALWAYS ALLOCATE HONDO INT BUF
C  1 MAY 00 - MWS - NO SYMMETRY OPTION IN TRFOPT COMMON
C 25 MAR 00 - KKB/LNB - SET MPPROP FOR MP2 COSMO SP ENERGY
C  7 MAR 00 - MWS - TRAP CASE OF NO VALENCE ELECTRONS
C 21 DEC 99 - MWS - CHANGE INTEGRAL SYMMETRY TEST
C 25 OCT 99 - MWS - ZAPTEN: STORE EMP2 INTO COMMON
C  6 JUN 99 - RLB - ZAPTEN: FIX BUG IF MORE SINGLY THAN DOUBLY OCCUPIED
C  9 APR 99 - RLB - ZAPTEN,ZAPTS,SINGS,MP2ZT7,MP2ZRT,MP2Z23,MP2Z4,MP2ZE,
C                   MP2ZE1,MP2ZE2,MP2ZE3,MP2ZE4 - NEW CODE FOR ZAPT MP2
C 26 MAR 99 - MWS - MP2INP: READ OSPT KEYWORD
C 13 FEB 99 - MWS - MP2INP,MP2NOS: CHANGES RELATED TO SPHER HARMONICS
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C 27 OCT 98 - MAF - MP2INP,UMP2EN: ALLOW USE OF SPHER HARMONICS
C  6 JAN 98 - MWS - CHANGE RAOPEN,RAWRIT,RAREAD,RACLOS CALLS
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 21 FEB 97 - VK  - UMP2EN: MOD FOR PARALLEL+FIX MEMORY BUG, ADD UMP2PA
C 18 DEC 96 - MWS - MP2C1,MP2C1P: PASS DIMENSION SIZES TO DIRJK
C 29 SEP 96 - MWS - MP2NRG,UMP2EN: GHONDO BUFFER SIZE IS MAX NEEDED
C 11 JUL 96 - MWS - ALLOW MP2 PROPS IN NONGRADIENT RUNS, ADD MP2NOS
C 13 JUN 96 - VAG - ADD VARIABLE FOR CI TYPE TO SCFOPT COMMON
C  4 JUN 96 - SPW - MP2INP: ALLOW FROZEN CORE FOR MP2 GRADIENTS
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C 11 NOV 95 - SPW - MP2INP,WFNMP2: CHANGES FOR MP2 GRADIENT
C 14 SEP 95 - MWS - FIX FOR SCHWARZ SCREENING UNDESIRED.
C 26 JUL 95 - MWS - LOOPS SHOULD BE TERMINATED BY CONTINUE
C 19 JUN 95 - MWS - WFNMP2: FIX RECOMPUTATION OF AO INTS ON 1 NODE
C 24 MAY 95 - MWS - WFNMP2,MP2INP,MP2C1P,MP2P: ALLOW DUPL. AO INT LIST
C  1 FEB 95 - MWS - FIX BUG WITH CHECK RUNS
C 13 DEC 94 - MWS - REMOVE PARALLEL BUG INTRODUCED 13-NOV-94
C 13 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS, DELETE DEAD CODE -UMP4C4B-
C 27 OCT 94 - MWS - FIX LENGTH OF /ENRGYS/
C 14 OCT 94 - MWS - MP2INP: PULL THE PLUG ON PARALLEL LCD JOBS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  5 AUG 94 - MWS - MP2O1,MP2NRG,UMP2EN: USE DOUBLE LABEL PACKING
C 19 JUL 94 - BMB - MP2SND: FIX PARALLEL BUG
C 30 JUN 94 - JHJ - MP2NRG,MP2OE: LMO-MP2 IMPLEMENTED FOR METHOD=3
C  1 JUN 94 - MWS - KEEP TRFOPT COMMON CONSISTENT
C  5 APR 94 - NM  - NEW MP2 PROGRAM PORTED FROM HONDO
C
C        -         -         -         -         -         -         - C
C*MODULE MP2     *DECK MP2INP
      SUBROUTINE MP2INP(MPTEST)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION MAKEFP,IMS
C
      CHARACTER*8 CXBASIS
C
      LOGICAL LMOMP2,MPTEST,MP2PRP,LALLOW
      LOGICAL PK,PANDK,BLOCK,ABEL,ABELPT,DIRTRF
      LOGICAL GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT,INITGDDI
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /CXTHRM/ CXTHERM(11),CXZPE,METHCX,ICXBAS,CXBASIS
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2LOC/ LMOMP2
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PKFIL / PK,PANDK,BLOCK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /ZRFPAR/ GZRF,FIND(3),GNUCF,EBORN,DIELEC,IZRF,ICALC
C
      LOGICAL ISEPS, USEPS
      COMMON /ISEPS/  ISEPS, USEPS
C
      PARAMETER (NNAM=16)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA WRDMP2 /8HMP2     /
      DATA QNAM   /8HNACORE  ,8HNBCORE  ,8HMPTEST  ,8HLMOMP2  ,
     *             8HCUTOFF  ,8HMETHOD  ,8HAOINTS  ,8HNWORD   ,
     *             8HMP2PRP  ,8HOSPT    ,8HCPHFBS  ,8HMAXITC  ,
     *             8HNOSYM   ,8HCODE    ,8HSCSPT   ,8HMEMPRI  /
      DATA KQNAM  /1,1,0,0,  3,1,5,1,  0,5,5,1,  1,5,5,1/
C
      DATA ENERGY /8HENERGY  /
      DATA DUP,DIST/8HDUP     ,8HDIST    /
      DATA RHF,UHF,ROHF,GVB/8HRHF     ,8HUHF     ,8HROHF    ,8HGVB     /
      DATA ZAPT,RMP,UMP/8HZAPT    ,8HRMP     ,8HUMP     /
      DATA ANONE/8HNONE    /
      DATA MAKEFP/8HMAKEFP  /
      DATA BASISMO,BASISAO/8HBASISMO ,8HBASISAO /
      DATA SERIAL,DDI,IMS/8HSERIAL  ,8HDDI     ,8HIMS     /
      DATA VSCF/8HVSCF    /, G3MP2/8HG3MP2   /
C
C     ----- SET UP FOR ALL SCF LEVEL MP2 RUNS, READ $MP2 INPUT -----
C
      CALL DERCHK(NDER)
C
      NORB  = NQMT
      NBF   = NUM
      NOA   = NA
      NOB   = NB
      NOMIT = 0
      CPHFBS= ANONE
C
C        THIS IS OK FOR RHF AND UHF REFERENCES, SO LONG AS WE FORCE
C        THE MP2PRP FLAG TO BE ON.
C
C QUESTION
      IF(RUNTYP.EQ.MAKEFP  .AND.  SCFTYP.EQ.ROHF) THEN
         IF(MASWRK) WRITE(IW,*) 'ROHF+MP2 CANNOT MAKE DENSITY MATRIX.'
         IF(MASWRK) WRITE(IW,*) 'THEREFORE RUNTYP=MAKEFP IS SENSELESS'
         IF(MASWRK) WRITE(IW,*) 'UNLESS YOU USE RHF OR UHF REFERENCES'
         CALL ABRT
      END IF
C
C          METHOD = 1 IS IN-CORE MP2, NOT IMPLEMENTED
C          METHOD = 2 IS SEGMENTED DIRECT OR CONVENTIONAL MP2
C          METHOD = 3 IS ALTERNATIVE CONVENTIONAL MP2
C
      MPTEST= .FALSE.
      LMOMP2= .FALSE.
      CUTOFF= 1.0D-09
      IF(NFG.NE.0) CUTOFF = 1.0D-12
      METHOD= 2
      IF(ITRFAO.EQ.1) AOINTS=DUP
      IF(ITRFAO.EQ.2) AOINTS=DIST
      NWDMP2=0
      MP2PRP=.FALSE.
      OSPT = ANONE
      IF(SCFTYP.EQ.UHF)  OSPT = UMP
      IF(SCFTYP.EQ.ROHF) OSPT = ZAPT
      MAXITC= 50
      NOSYMT=  0
C           SELECT CODE TO BE USED.
C           VSCF REQUIRES DIPOLES, AND SO SPENDS SOME TIME
C           IN GRADIENT CODES, EVEN THOUGH IT HAS NDER=0
      CODEMP=SERIAL
      IF(GOPARR) CODEMP=DDI
      IF(ISGDDI) CODEMP=IMS
      IF(ISGDDI .AND. RUNTYP.EQ.VSCF) CODEMP=DDI
      SCSPT=ANONE
      MEMPRI=1000000
C
C     IZCORE IS THE NUMBER OF ELECTRONS IN THE ECP, IF ANY.
C
C     INITIALIZE NACORE (#ALPHA CORE ELECTRONS) AND NBCORE (#BETA CORES)
C
      NACORE = NUMCOR()
      NBCORE = -1
C
      CALL NAMEIO(IR,JRET,WRDMP2,NNAM,QNAM,KQNAM,
     *            NACORE,NBCORE,MPTEST,LMOMP2,CUTOFF,METHOD,AOINTS,
     *            NWDMP2,MP2PRP,OSPT,CPHFBS,MAXITC,NOSYMT,CODEMP,
     *            SCSPT,MEMPRI,0,0,0,  0,0,0,0,0,
     *    0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0,
     *    0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0)
C
      IF (NBCORE.EQ.-1) NBCORE = NACORE
      IF (NBCORE.NE.NACORE .AND. SCFTYP.EQ.ROHF) THEN
         IF (MASWRK) WRITE(IW,*) 'WARNING: NBCORE SET EQUAL TO',
     *                           ' NACORE FOR ROHF'
         NBCORE = NACORE
      END IF
C
C    ----- G3(MP2) NEEDS MP2(FULL) FOR 6-31G(D), BUT NOT G3-LARGE ------
C
      IF(RUNTYP.EQ.G3MP2 .AND. ICXBAS.LT.2) THEN
         NACORE = 0
         NBCORE = 0
      END IF
C
      IF(JRET.EQ.2) THEN
         IF (MASWRK) WRITE(IW,*) 'ERROR READING $MP2 GROUP'
         CALL ABRT
      END IF
      NERR = 0
C
C     --- SET UP WHICH CPHF BASIS WILL BE USED ---
C
      IF(CPHFBS.EQ.ANONE) THEN
         IF(SCFTYP.EQ.RHF .AND. NACORE.EQ.0) THEN
            MAXITC= 50
            CPHFBS=BASISMO
         ELSE
            CPHFBS=BASISAO
         END IF
      END IF
C
C     --- OPTIONAL PROPERTIES DURING SINGLE POINT ENERGY RUN ---
C     AT PRESENT WE HAVE GRADIENTS (I.E. DENSITY OF 1ST ORDER
C     WAVEFUNCTION) ONLY FOR THE RHF, UHF, AND ZAPT CASES, BUT NOT RMP2.
C
C     (FOR A MP2-COSMO SINGLE-POINT-ENERGY, THE MP2 DENSITY IS
C      ALWAYS NEEDED TO GET AND ITERATE THE MP2 SURFACE CHARGES)
C
      IF(ISEPS.AND.(MPLEVL.EQ.2).AND.(RUNTYP.EQ.ENERGY)) MP2PRP=.TRUE.
      IF(RUNTYP.EQ.MAKEFP) MP2PRP=.TRUE.
C
      IF(MP2PRP) THEN
         MPPROP = 1
      ELSE
         MPPROP = 0
      END IF
C
C        ANALYTIC GRADIENTS WILL ALWAYS DO DENSITY MATRIX
C        ROHF/RMP2 GRADIENT CODE DOES NOT EXIST
      IF(NDER.GT.0  .AND.  (NGLEVL.LT.1 .OR. NHLEVL.LT.2)) MPPROP=0
      IF(SCFTYP.EQ.ROHF  .AND.  OSPT.EQ.RMP) MPPROP=0
C
      IF(MPPROP.GT.0) THEN
         IF(NGLEVL.EQ.1  .OR.  NHLEVL.EQ.2) THEN
            IF(MASWRK) WRITE(IW,9005)
            NERR=NERR+1
         END IF
      END IF
C
      IF(SCFTYP.EQ. RHF) OSPT=ANONE
      IF(SCFTYP.EQ. UHF) OSPT=UMP
      IF(SCFTYP.EQ.ROHF) THEN
         IF(OSPT.NE.ZAPT  .AND.  OSPT.NE.RMP) THEN
            IF(MASWRK) WRITE(IW,9010) OSPT
            NERR=NERR+1
         END IF
      END IF
C
      IF(MASWRK) WRITE(IW,9020) NACORE,NBCORE,LMOMP2,AOINTS,METHOD,
     *                          NWDMP2,MP2PRP,OSPT,CUTOFF,CPHFBS,
     *                          CODEMP
C
C     ----- LMO E(MP2) DECOMPOSITION WORKS ONLY FOR ALT. TRANSF. -----
C
      IF(LMOMP2) METHOD = 3
C
C     ----- CHECK RUN FOR SENSIBILITY
C
      IF(LMOMP2  .AND.  GOPARR) THEN
         IF(MASWRK) WRITE(IW,9035)
         NERR = NERR+1
      END IF
      IF(LMOMP2  .AND.  SCFTYP.NE.RHF) THEN
         IF(MASWRK) WRITE(IW,9080)
         NERR = NERR+1
      END IF
      LALLOW = SCFTYP.EQ.RHF .OR. SCFTYP.EQ.UHF .OR.
     *        (SCFTYP.EQ.ROHF .AND. OSPT.EQ.ZAPT)
      IF(NDER.GT.0  .AND. (.NOT. LALLOW)) THEN
         IF(MASWRK) WRITE(IW,9090)
         NERR = NERR+1
      END IF
      IF(SCFTYP.EQ.GVB) THEN
         IF(MASWRK) WRITE(IW,9110)
         NERR = NERR+1
      END IF
      IF(GZRF.NE.0.0D+00) THEN
         IF(MASWRK) WRITE(IW,9120)
         NERR = NERR+1
      END IF
      IF(CPHFBS.NE.BASISMO .AND. CPHFBS.NE.BASISAO) THEN
         IF(MASWRK) WRITE(IW,9130)
         NERR = NERR+1
      END IF
      IF(SCFTYP.NE.RHF .AND. CPHFBS.EQ.BASISMO) THEN
         IF(MASWRK) WRITE(IW,9140)
         CPHFBS=BASISAO
      END IF
      IF(NACORE.NE.0 .AND. CPHFBS.EQ.BASISMO) THEN
         IF(MASWRK) WRITE(IW,9150)
         CPHFBS=BASISAO
      END IF
C
      TOL=CUTOFF
C
C     ----- FILL UP PAIR INDEX ARRAY IN COMMON -----
C
      DO 5 I=1,NBF
         IA(I) = (I*I-I)/2
    5 CONTINUE
C
      IF(MASWRK) WRITE(IW,9030) NACORE,NBCORE,NOA,NOB,NORB,NBF
C
      IF(NORB.LE.NOA) THEN
         IF (MASWRK) WRITE(IW,9040)
         NERR = NERR+1
      END IF
      IF(NORB.LE.NACORE .OR. NORB.LE.NBCORE) THEN
         IF(MASWRK) WRITE(IW,9060) NACORE,NBCORE,NORB
         NERR = NERR+1
      END IF
      IF(NACORE.GT.NOA  .OR.  NBCORE.GT.NOB .OR. (NACORE.EQ.NOA
     *   .AND.NBCORE.EQ.NOB)) THEN
         IF(MASWRK) WRITE(IW,9065) NACORE,NBCORE,NOA,NOB
         NERR = NERR+1
      END IF
C
      ITRFAO=0
      IF(AOINTS.EQ.DUP)  ITRFAO=1
      IF(AOINTS.EQ.DIST) ITRFAO=2
      IF(ITRFAO.EQ.0) THEN
         IF(MASWRK) WRITE(IW,*) 'ILLEGAL STRING INPUT FOR -AOINTS-'
         NERR = NERR+1
      END IF
C
      IF(CODEMP.NE.SERIAL.AND.CODEMP.NE.DDI.AND.CODEMP.NE.IMS) THEN
         IF(MASWRK) WRITE(IW,9160) CODEMP
         NERR = NERR+1
      END IF
      IF(CODEMP.EQ.DDI) THEN
         GOPARR=.TRUE.
      END IF
      IF(CODEMP.EQ.IMS) THEN
         IF(SCFTYP.NE.RHF) THEN
            IF(MASWRK) WRITE(IW,9162)
            NERR = NERR+1
         END IF
      END IF
C
C     SET UP LOGICAL INTEGER MOCPHF
C
      MOCPHF = 0
      IF(CPHFBS.EQ.BASISMO) MOCPHF = 1
C
C        ABELIAN GROUPS USE SYMMETRY DURING THE TRANSFORMATION,
C        WHICH CAN REALLY SPEED THINGS UP.
C
      ABEL = ABELPT()
      IF(.NOT.ABEL  .AND.  MASWRK) WRITE(IW,9070)
C
C        USE -J- LIST SO THAT 2E- INTEGRALS ARE COMPUTED ONLY ONCE.
C        AN EXCEPTION IS NON-ABELIAN GROUPS, WHICH USE SYMMETRY IN
C        THE -J- INTEGRALS DRIVING THE SCF, AND THEN REGENERATE A C1
C        -J- INTEGRAL LIST FOR THE MP2 TRANSFORMATION, SEE -WFNMP2-
C
      NOPK = 1
      PK   = .FALSE.
      PANDK= .FALSE.
C
      IF(NERR.GT.0) THEN
         IF(MASWRK) WRITE(IW,9050)
         CALL ABRT
      END IF
      RETURN
C
 9005 FORMAT(//1X,'*** ERROR ***'/
     *         1X,'MP2 PROPERTIES (OF FIRST ORDER WAVEFUNCTION)',
     *            ' REQUIRE THE EXECUTION'/
     *         1X,'OF PART OF THE GRADIENT CODE, BUT YOU HAVE ALSO',
     *            ' CHOSEN EITHER'/
     *         1X,'$CONTRL NUMGRD=.TRUE. OR $HESS METHOD=FULLNUM')
 9010 FORMAT(//1X,'*** ERROR ***'/
     *         1X,'SCFTYP=ROHF DOES NOT PERMIT OSPT=',A8)
 9020 FORMAT(/10X,23(1H-)/10X,'MP2 CONTROL INFORMATION'/10X,23(1H-)/
     *        10X,'NACORE = ',I8,2X,'NBCORE = ',I8/
     *        10X,'LMOMP2 = ',L8,2X,'AOINTS = ',A8/
     *        10X,'METHOD = ',I8,2X,'NWORD  = ',I15/
     *        10X,'MP2PRP = ',L8,2X,'OSPT   = ',A8/
     *        10X,'CUTOFF = ',1P,E8.2,2X,'CPHFBS = ', A8/
     *        10X,'CODE   = ',A8)
 9030 FORMAT(/10X,'NUMBER OF CORE -A-  ORBITALS = ',I5/
     *        10X,'NUMBER OF CORE -B-  ORBITALS = ',I5/
     *        10X,'NUMBER OF OCC. -A-  ORBITALS = ',I5/
     *        10X,'NUMBER OF OCC. -B-  ORBITALS = ',I5/
     *        10X,'NUMBER OF MOLECULAR ORBITALS = ',I5/
     *        10X,'NUMBER OF   BASIS  FUNCTIONS = ',I5/)
 9035 FORMAT(1X,'*** SORRY ***'/
     *       1X,'THE MP2 LOCALIZED ORBITAL ANALYSIS WORKS ONLY'/
     *       1X,'FOR THE "ALTERNATIVE MP2 TRANSFORMATION".  THIS'/
     *       1X,'TRANSFORMATION DOES NOT RUN IN PARALLEL.  YOU CAN'/
     *       1X,'ONLY RUN THIS MP2 LOCALIZED ANALYSIS SEQUENTIALLY.')
 9040 FORMAT(1X,'***ERROR*** MP2 HAS NO VIRTUAL ORBITALS.')
 9050 FORMAT(5X,'*** PROGRAM STOPPED IN -MP2INP- ***')
 9060 FORMAT(' INCONSISTENT INPUT PARAMETERS IN -$MP2- .',
     *       ' NACORE,NBCORE,NORB = ',3I5)
 9065 FORMAT(1X,'*** ERROR DETECTED ***'/
     *       1X,'NACORE=',I5,' NBCORE=',I5,' OCCUPIED ALPHA,BETA=',2I5//
     *       1X,'IF THE FROZEN CORE CONTAINS ALL ELECTRONS, THERE'/
     *       1X,'IS NO NEED TO DO THIS RUN, AS E(MP2) = E(SCF).'//
     *       1X,'IF NACORE OR NBCORE IS GREATER THAN THE NUMBER OF'/
     *       1X,'ALPHA OR BETA ELECTRONS,'/
     *       1X,'PLEASE RETHINK YOUR RUN PARAMETERS'//)
 9070 FORMAT(/1X,'**** EFFICIENCY NOTE ****'/
     *        1X,'THE MP2 TRANSFORMATION CANNOT USE SYMMETRY WHEN',
     *           ' THE GROUP IS NON-ABELIAN.'/
     *        1X,'YOU MAY BE ABLE TO SPEED UP THIS RUN BY USING AN',
     *           ' ABELIAN SUBGROUP IN $DATA.'/)
 9080 FORMAT(1X,'*** ERROR ***',
     *          ' THE -LMOMP2- OPTION WORKS ONLY FOR SCFTYP=RHF.')
 9090 FORMAT(1X,'*** ERROR *** ',
     *          'MP2 GRADIENT IS AVAILABLE ONLY FOR RHF, UHF, AND ZAPT')
 9110 FORMAT(1X,'*** ERROR *** ',
     *          'MP2 ENERGY IS NOT AVAILABLE FOR SCFTYP=GVB')
 9120 FORMAT(1X,'*** ERROR *** ',
     *          'MP2 IS INCOMPATIBLE WITH USE OF SCRF')
 9130 FORMAT(1X,'*** ERROR *** ',
     *          'CPHFBS REQUIRES EITHER BASISMO OR BASISAO')
 9140 FORMAT(1X,'*** NOTE *** ',
     *          'CPHFBS=BASISMO ONLY AVAILABLE FOR RHF. ',
     *          'CONTINUING WITH CPHFBS=BASISAO')
 9150 FORMAT(1X,'*** NOTE *** ',
     *          'CPHFBS=BASISMO ONLY AVAILABLE FOR NACORE=0. ',
     *          'CONTINUING WITH CPHFBS=BASISAO')
 9160 FORMAT(1X,'*** ERROR ***'/
     *       1X,'$MP2 CODE=',A8,' IS NOT AVAILABLE.'/
     *       1X,'CHOOSE FROM: SERIAL,DDI,IMS ONLY.')
 9162 FORMAT(1X,'*** ERROR ***'/
     *       1X,'$MP2 CODE=IMS IS AVAILABLE FOR SCFTYP=RHF ONLY.')
      END
C
C*MODULE MP2     *DECK MRMPINP
      SUBROUTINE MRMPINP(MPTEST)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL MPTEST,RDVECS,GOPARR,DSKWRK,MASWRK,OK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MRPTIN/ TYPMRPT,INORBMC
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
C     NAMELIST INPUT TO SELECT TYPE OF MULTIREFERENCE PT
C
      PARAMETER (NNAM=2)
      DIMENSION QNAM(NNAM), KQNAM(NNAM)
      DATA GNAM /8HMRMP    /
      DATA QNAM /8HMRPT    ,8HRDVECS  /
      DATA KQNAM /5,0/
C
      DATA DEMRPT,RMCQD,GVVPT,GMCQDPT
     *   /8HDETMRPT ,8HMCQDPT  ,8HGVVPT   ,8HGMCPT   /
C
      DATA DETPT/8HDETPT   /
      DATA GRPMQ/8HMCQDPT  /,GRPMQ1/8HMCQD1   /,
     *     GRPV/8H $VEC   /,GRPV1/8H $VEC1  /
C
      DATA TRNSTN/8HTRANSITN/
C
      MPTEST = .FALSE.
C
C        --- READ SELECTION SWITCH FOR MULTIREFERENCE PT OPTIONS ---
C        IN PRINCIPAL, ONE MIGHT READ ORBITAL SPACE INPUTS IN THIS
C        GROUP, RATHER THAN LEAVING THEM IN THE METHOD-SPECIFIC
C        INPUT GROUPS.
C
      TYPMRPT = DEMRPT
      IF(RUNTYP.EQ.TRNSTN) TYPMRPT = RMCQD
      RDVECS  = .FALSE.
C
      CALL NAMEIO(IR,JRET,GNAM,NNAM,QNAM,KQNAM,
     *            TYPMRPT,RDVECS,
     *             0,0,
     *             0,0,0,0,0,  0,0,0,0,0, 0,0,0,0,0,  0,0,0,0,0,
     *             0,0,0,0,0,  0,0,0,0,0, 0,0,0,0,0,  0,0,0,0,0,
     *             0,0,0,0,0,  0,0,0,0,0, 0,0,0,0,0,  0,0,0,0,0)
C
      NERR = 0
      IF(JRET.EQ.2) THEN
         NERR=NERR+1
      END IF
C
      OK = .FALSE.
      IF(TYPMRPT.EQ.DEMRPT)  OK = .TRUE.
      IF(TYPMRPT.EQ.RMCQD)   OK = .TRUE.
      IF(TYPMRPT.EQ.GVVPT)   OK = .TRUE.
      IF(TYPMRPT.EQ.GMCQDPT) OK = .TRUE.
      IF(.NOT.OK) THEN
         IF(MASWRK) WRITE(IW,9020) TYPMRPT
         IF(MASWRK) WRITE(IW,9010)
         NERR=NERR+1
      END IF
C
      IF(RUNTYP.EQ.TRNSTN  .AND.  TYPMRPT.NE.RMCQD) THEN
         IF(MASWRK) WRITE(IW,9030)
         NERR=NERR+1
      END IF
      IF(RUNTYP.EQ.TRNSTN  .AND.  .NOT.RDVECS) THEN
         IF(MASWRK) WRITE(IW,9040)
         NERR=NERR+1
      END IF
C
      IF(NERR.GT.0) THEN
         IF(MASWRK) WRITE(IW,9010)
         CALL ABRT
      END IF
C
C        IT IS USEFUL TO BE ABLE TO SKIP MCSCF IF THE CONVERGED
C        MCSCF ORBITALS CAN BE READ FROM THE INPUT.
C
      INORBMC = 0
      IF(RDVECS) INORBMC = 1
C
      IF(MASWRK) WRITE(IW,9100) TYPMRPT,RDVECS
C
C        THE IVANIC MRPT/MCQDPT DETERMINANT-BASED PROGRAM
C
      IF(TYPMRPT.EQ.DEMRPT) THEN
         NPRINT=-5
         CALL DMRINP(NPRINT,DETPT)
      END IF
C
C        THE NAKANO/HIRAO MRPT/MCQDPT GUGA-BASED PROGRAM
C
      IF (TYPMRPT.EQ.RMCQD) THEN
         IF(RUNTYP.NE.TRNSTN) THEN
            CALL MQREAD(GRPMQ,GRPV,MASWRK)
         ELSE
C                PARAMETERS WILL BE OUTPUT AT EACH MCQDPT RUN LATER
            CALL MQREAD(GRPMQ1,GRPV1,.FALSE.)
         END IF
      END IF
C
C        VAN VLECK PERTURBATION THEORY
C
      IF (TYPMRPT.EQ.RMCQD) THEN
         CONTINUE
      END IF
C
      RETURN
C
 9010 FORMAT(1X,'ERROR WAS FOUND IN YOUR $MRMP INPUT GROUP'/
     *       1X,'PLEASE FIX AND TRY AGAIN.'/)
 9020 FORMAT(/1X,'ILLEGAL MULTI-REFERENCE PERTURBATION METHOD ',A8,
     *          ' CHOSEN.')
 9030 FORMAT(/1X,'SPIN-ORBIT PERTURBATION IS ONLY AVAILABLE IN THE',
     *          ' MRPT=MCQDPT PROGRAM.')
 9040 FORMAT(/1X,'RDVECS=.FALSE. IS NOT SUPPORTED FOR SO-MCQDPT JOBS.')
 9100 FORMAT(/1X,42(1H-)/
     *       1X,'MULTIREFERENCE PERTURBATION THEORY CONTROL'/
     *       1X,42(1H-)/
     *       1X,'MRPT=',A8,' READ CONVERGED MCSCF VECTORS=',L2/)
      END
C*MODULE MP2     *DECK NUMCOR
      INTEGER FUNCTION NUMCOR()
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
      DIMENSION NCORES(103)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NEX,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA NCORES /2*0,
     *             2*1,                     6*1,
     *             2*5,                     6*5,
     *             2*9,          10*9,    9,5*14,
     *             2*18,         10*18,  18,5*23,
     *             2*27,  14*27, 10*34,  34,5*39,
     *             2*43,  14*43,    50/
C
C        RETURN THE NUMBER OF CHEMICAL CORE ORBITALS, OF COURSE
C        OMITTING ANY DROPPED BY USE OF EFFECTIVE CORE POTENTIALS.
C
C     APRIL 2007.
C        THE MAIN GROUP SP BLOCK WAS CHANGED FROM 6*14, 6*23, 6*39 TO
C        REMOVE THE GROUP 13'S D SHELLS FROM BEING DEFINED AS "CORE".
C        RATIONAL IS THE FOLLOWING MINI EIGENDATA (KEEP IN MIND THAT
C        THESE MAY BE OFF BY -0.1 HARTREE OR MORE DUE TO THE SMALL
C        BASIS, E.G. SBKJC'S EIGENVALUE FOR GA'S 5D IS -1.15)
C
C             N=4 ROW    ZN      GA      GE      AS
C             (N-1)S   -5.617  -6.289  -7.097  -7.942
C             (N-1)P   -3.822  -4.379  -5.068  -5.793
C             (N-1)D   -0.765  -1.025  -1.474  -1.956
C               NS     -0.288  -0.407  -0.539  -0.672
C               NP       N/A   -0.201  -0.280  -0.363
C
C             N=5 ROW    CD      IN      SN      SB
C             (N-1)S   -4.424  -4.955  -5.493  -6.043
C             (N-1)P   -3.028  -3.488  -3.752  -4.927
C             (N-1)D   -0.736  -1.047  -1.354  -1.672
C               NS     -0.260  -0.369  -0.474  -0.579
C               NP       N/A   -0.195  -0.263  -0.332
C
C             N=6 ROW    HG      TL      PB      BI
C             (N-1)S   -4.143  -4.585  -5.018  -5.461
C             (N-1)P   -2.820  -3.206  -3.594  -3.966
C             (N-1)D   -0.700  -0.957  -1.210  -1.461
C               NS     -0.260  -0.360  -0.456  -0.551
C               NP       N/A   -0.192  -0.255  -0.320
C
C        SBKJC RETAINS (N-1) S, P, AND D SHELLS IN SEMI-CORE SETS
C        FOR GA, IN, TL, WHOSE EIGEN DATA ARGUE THAT (N-1)D IS
C        MORE LIKE "SUBVALENCE" THAN "CORE".
C
      NCORE = 0
      DO 100 I=1,NAT
         IZ = INT(ZAN(I)) + IZCORE(I)
         IF(IZ.LE.0) GO TO 100
         IF((IZ.GT.103) .AND. MASWRK) WRITE(IW,*)
     *          'Z.GT.103 IN SETTING CORE COUNT'
         IF(IZ.GT.103) CALL ABRT
         NCORE = NCORE + NCORES(IZ) - IZCORE(I)/2
  100 CONTINUE
C
      NUMCOR = NCORE
      RETURN
      END
C*MODULE MP2     *DECK MP2NOS
      SUBROUTINE MP2NOS
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000)
C
      COMMON /ENRGMP/ EMP2,EMP3,EMP4
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,MNUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWORD,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NO,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA CHECK/8HCHECK   /
C
C        ALLOCATE MEMORY TO GENERATE MP2 NATURAL ORBITALS
C
      L0 = NQMT
      L1 = NBF
      L2 = (NBF*NBF+NBF)/2
      L3 = NBF*NBF
      CALL VALFM(LOADFM)
      LEIG   = LOADFM + 1
      LIWRK  = LEIG   + L1
      LSCR   = LIWRK  + L1
      LDA    = LSCR   + 8*L1
      LDB    = LDA    + L2
      LVEC   = LDB    + L2
      LSPHLF = LVEC   + L3
      LSMHLF = LSPHLF + L3
      LAST   = LSMHLF + L3
      NEEDNO = LAST - LOADFM - 1
      CALL GETFM(NEEDNO)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL UHFNOS(X(LEIG),X(LIWRK),X(LSCR),X(LDA),X(LDB),X(LVEC),
     *            X(LSPHLF),X(LSMHLF),L0,L1,L2,1)
C
      OCCSUM = 0.0D+00
      VIRSUM = 0.0D+00
      DO 100 I=1,NOA
         OCCSUM = OCCSUM + X(LEIG-1+I)
  100 CONTINUE
      DO 110 I=NOA+1,L0
         VIRSUM = VIRSUM + X(LEIG-1+I)
  110 CONTINUE
C
      IF(MASWRK) THEN
         WRITE(IW,9110)
         WRITE(IW,9120) (X(LEIG-1+I),I=1,L0)
         WRITE(IW,9130) OCCSUM,VIRSUM
         WRITE(IW,9140)
         WRITE(IP,8000) EMP2
         WRITE(IP,8010) ' $VEC'
         CALL PUSQL(X(LVEC),L0,L1,L1)
         WRITE(IP,8010) ' $END'
         CALL FLSHBF(IP)
      END IF
C
  800 CONTINUE
      CALL RETFM(NEEDNO)
      RETURN
C
 8000 FORMAT('MP2 NATURAL ORBITALS, E(MP2)=',F20.10)
 8010 FORMAT(A5)
 9110 FORMAT(/1X,'MP2 NATURAL ORBITAL OCCUPATION NUMBERS ARE')
 9120 FORMAT(1X,10F7.4)
 9130 FORMAT(1X,'THERE ARE',F11.4,' ELECTRONS IN PRINCIPAL MP2',
     *          ' NATURAL ORBITALS.'/
     *       1X,'THERE ARE',F11.4,' ELECTRONS IN SECONDARY MP2',
     *          ' NATURAL ORBITALS.')
 9140 FORMAT(1X,'THE MP2 NATURAL ORBITALS HAVE BEEN PUNCHED.')
      END
C*MODULE MP2     *DECK MP2NRG
      SUBROUTINE MP2NRG
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT,DBUG,DIRSCF,PACK2E,FDIFF,ABEL,ABELPT,
     *        GOPARR,DSKWRK,MASWRK,LMOMP2,DIRTRF
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXGSH=30, MXG2=MXGSH*MXGSH,
     *           MXRT=100, MXATM=2000, MXAO=8192)
C
      COMMON /DIRMEM/ LPQRJ,IVEC,IDEN,IFCK,NUM,NOCC,NDIM,MINPQ,MAXPQ
      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 /FMCOM / X(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,MNUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /MP2DAF/ IDAF20,NAV20
      COMMON /MP2LOC/ LMOMP2
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NO,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /MP2PRT/ SOME,OUT,DBUG
      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 /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TSYM(432),INVT(48),NT
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
      DATA CHECK/8HCHECK   /, RMP2/8HMP2     /
C
C     ----- MAIN CLOSED-SHELL MP2 ENERGY DRIVER -----
C
      SOME=NPRINT.NE.-5 .AND. MASWRK
      OUT =EXETYP.EQ.RMP2 .AND. MASWRK
      IF(MASWRK) WRITE(IW,9000) NACORE,NOA,NQMT,NBF
C
      CALL GOTFM(NGOTMX)
      IF(NWDMP2.GT.0) NGOTMX=MIN(NGOTMX,NWDMP2)
C
      NOC  = NOA - NACORE
      NVIR = NO  - NOA
      NORB = NO  - NACORE
      NBF2 = (NBF*NBF+NBF)/2
      NBF3 = NBF * NBF
C
      NUM  = NBF
      IDEN = 0
      IFCK = 0
      NDIM  = MAX(NBF2,NVIR*NOC)
C
C        ---- OPTION TO DEFEAT SYMMETRY USAGE ----
C
      ABEL=ABELPT()
      IF(NOSYMT.EQ.1) CALL SYMOFF
C
C    ----- MEMORY POINTERS FOR MP2 ENERGY -----
C
C IVEC    : MATRIX OF MO COEFFICIENTS        NBF  *  NBF
C IPTR1   : PARTIALLY TRANSFORMED INTEGRAL   NOC  *  NBF
C IPTR2   : PARTIALLY TRANSFORMED INTEGRAL   NVIR *  NBF
C IENG    : ORBITAL ENERGIES                 NBF
C ILAB    : MOSLAB    |                      NBF
C IIRP    : MOSIRP    |---> SEE SYM          NBF
C IDEG    : MOSDEG    |                      NBF
C IWRK    : WORK: S, MO, ETC.                NBF * NBF
C         : HOLDS (PQ|RJ)                    NBF * NBF OR NINTMX
C IWRK2   : HOLDS Q MATRIX                   (NBF*(NBF+1))/2
C         : HOLDS INDICES FOR (PQ|RS)        NBF * NBF OR NINTMX
C IWRK3   : TEMP STORAGE OF Q*S*V            NBF
C IEIJ    : PAIR ENERGY                      NOC * NOC
C IEI     : ORBITAL CONTRIBUTION TO E2       NOC
C IMINT   : MO INTEGRAL (IA|JB) (OUT-OF-CORE)NOC * NDIM * LPASS
C IPQRJ   : PARTIALLY TRANSFORMED INTEGRAL   NBF * NDIM * LPASS
C IIODA   : TEMP STORAGE FOR MO INT FOR IO   NOC * NVIR
C
C  ----- THE FOLLOWING LIST IS FOR DIRECT MP2 -----
C IGHND   : AO INTEGRALS FOR DIRECT METHOD   MAXG --> NANGM**4
C IXINTS  : EXCHANGE INTEGRALS               (NSHELL**2 + NSHELL)/2
C IDDIJ   : WORK SPACE FOR AO INTEGRAL       49*MXG2
C
C
      CALL VALFM(LOADFM)
      IVEC   = 1    + LOADFM
      IPTR1  = IVEC + NBF*NBF
      IPTR2  = IPTR1+ NOC*NBF
      IENG   = IPTR2+ NVIR*NBF
      ILAB   = IENG + NBF
      IIRP   = ILAB + NBF
      IDEG   = IIRP + NBF
      LAST   = IDEG + NBF
      NEEDA  = LAST - LOADFM - 1
      CALL GETFM(NEEDA)
C
C    ----- SET UP TRANSPOSE MATRIX OF MO COEFFICIENTS -----
C
      CALL VALFM(LOADFM)
      IWRK   = 1    + LOADFM
      LAST   = IWRK + NBF*NBF
      NEEDB  = LAST - LOADFM - 1
      CALL GETFM(NEEDB)
C
      CALL DAREAD(IDAF,IODA,X(IWRK),NBF3,15,0)
      CALL DAREAD(IDAF,IODA,X(IENG),NBF ,17,0)
C
      MAXC = IDAMAX(NBF*NQMT,X(IWRK),1)
      IF(ABS(X(IWRK+MAXC-1)).GT.1.0D+02) THEN
         MAXM = 1 + MAXC/NUM
         MAXA = MAXC - NUM*(MAXM-1)
         IF(MASWRK) WRITE(IW,9020) ABS(X(IWRK+MAXC-1)),MAXA,MAXM
      END IF
C
C          SUBTRACTING CORE ORBITALS
C
      DO 15 J=1,NORB
         X(J+IENG-1)=X(J+NACORE +IENG-1)
         DO 10 I=1,NBF
            X(I+ NBF*(J-1)+IVEC-1)=X(I+NBF*(J-1+NACORE)+IWRK-1)
  10     CONTINUE
  15  CONTINUE
C
C          TRANSPOSING OCCUPIED SPACE
C
      DO 25 J=1,NOC
         DO 20 I=1,NBF
            X(J+NOC*(I-1)+IPTR1-1)=X(I+NBF*(J-1+NACORE)+IWRK-1)
   20    CONTINUE
   25 CONTINUE
C
C          TRANSPOSING VIRTUAL SPACE
C
      DO 35 J=1,NVIR
         DO 30 I=1,NBF
            X(J+NVIR*(I-1)+IPTR2-1)=X(I+NBF*(J-1+NOA)+IWRK-1)
   30    CONTINUE
   35 CONTINUE
      CALL RETFM(NEEDB)
C
C     ----- ASSIGN -IRREP- LABEL TO MO'S -----
C
      CALL VALFM(LOADFM)
      IWRK  = 1     + LOADFM
      IWRK2 = IWRK  + NBF2
      IWRK3 = IWRK2 + NBF3
      LAST  = IWRK3 + NBF
      NEEDC = LAST -LOADFM - 1
      CALL GETFM(NEEDC)
      IF(EXETYP.EQ.CHECK) GO TO 50
C
      CALL DAREAD(IDAF,IODA,X(IWRK),NBF2,12,0)
      CALL DAREAD(IDAF,IODA,X(IWRK2),NBF3,45,0)
      CALL TRFSYM(X(ILAB),X(IIRP),X(IDEG),X(IWRK2),X(IWRK),X(IVEC),
     *            X(IWRK3),IA,NQMT,NBF,NORB,NBF)
C
   50 CONTINUE
      CALL RETFM(NEEDC)
C
      NTSAVE = NT
      IF(DIRSCF  .AND.  .NOT.ABEL) NT=1
C
C     ----- INTEGRAL STORAGE FOR DIRECT OR CONVENTIONAL MP2 -----
C     BEWARE!  THE DIRECT TRANSFORMATIONS PASS STORAGE LOCATIONS
C     FOR THE TRANSFORMED INTEGRAL ARRAY AND THE VECTORS THROUGH
C     THE -LPQRJ- AND -IVEC- VARIABLES IN COMMON.  THE NUMBER OF
C     MO-S IN THE 1ST INDEX TRANSFORM IS -NOCC-, WHICH IS SET LATER.
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      IF(LMAX.EQ.5) NANGM = 21
      IF(LMAX.EQ.6) NANGM = 28
      MAXG = NANGM**4
      NSH2 = (NSHELL*NSHELL+NSHELL)/2
C
      CALL VALFM(LOADFM)
      MINTMX=NINTMX
      IF(NINTIC.NE.0) MINTMX=0
      IF(DIRSCF) THEN
         LGHND  = 1      + LOADFM
         LXINTS = LGHND  + MAXG
         LDDIJ  = LXINTS + NSH2
         LXX    = LDDIJ  + 49*MXG2
         LIX    = LXX    + NINTMX
         LAST   = LIX    + NINTMX
      ELSE
         LGHND  = 1      + LOADFM
         LXINTS = LGHND
         LDDIJ  = LXINTS
         LXX    = LDDIJ
         LIX    = LXX    + MINTMX
         LAST   = LIX    + MINTMX
         IF(NINTIC.NE.0) THEN
            LXX  = LBUFPIC
            LIX  = LIXIC
         ENDIF
      END IF
      NEEDD = LAST - LOADFM - 1
      CALL GETFM(NEEDD)
C
      IF(DIRSCF) THEN
         IF(EXETYP.EQ.CHECK) THEN
            CALL VCLR(X(LXINTS),1,NSH2)
         ELSE
            IF(ISCHWZ.EQ.1) THEN
               CALL DAREAD(IDAF,IODA,X(LXINTS),NSH2,54,0)
            ELSE
               CALL DCOPY(NSH2,1.0D+01,0,X(LXINTS),1)
            END IF
         END IF
      END IF
C
C         THE LAST TWO BRANCHES ARE TO ENABLE TESTING
C
      NGOT = NGOTMX - NEEDA - NEEDD
      IF(DIRSCF  .AND.  SOME) WRITE(IW,9050)
      IF(GOPARR) GO TO 600
      IF(METHOD.EQ.3) GO TO 400
      IF(METHOD.EQ.4) GO TO 600
C
C     ----- SEQUENTIAL SEGMENTED MP2 TRANSFORMATION -----
C     THE "SEGMENTED" TRANSFORMATION USES MORE MEMORY BUT LESS DISK
C     THAN THE "ALTERNATIVE" METHOD IMPLEMENTED BELOW.  IT HAS BOTH
C     DIRECT AND CONVENTIONAL TRANSFORMATIONS.
C
      NEED  = 2*NBF3
      LEFT  = NGOT - NEED
      NMIN  = NDIM*NBF
      MNMEM = NEEDA + NEEDD + NEED + NMIN*1
      MXMEM = NEEDA + NEEDD + NEED + NMIN*NOC
      IF(SOME) WRITE(IW,9110) MNMEM,MXMEM
C
      IF(NMIN.GT.LEFT) THEN
         NTOT = NEEDA + NEEDD + NEED + NMIN
         IF(MASWRK) WRITE(IW,9120) NTOT,NGOTMX
         IF(DIRSCF) THEN
            IF(MASWRK) WRITE(IW,9130)
            CALL ABRT
         ELSE
            IF(MASWRK) WRITE(IW,9140)
            GO TO 400
         END IF
      END IF
C
      LPASS = MIN(NOC,LEFT/NMIN)
      NPASS = (NOC+LPASS-1)/LPASS
      LPASS = (NOC+NPASS-1)/NPASS
C
      CALL VALFM(LOADFM)
      LWRK1 = 1     + LOADFM
      LWRK2 = LWRK1 + NBF3
      LPQRJ = LWRK2 + NBF3
      LAST  = LPQRJ + NDIM*NBF*LPASS
      NEEDE = LAST - LOADFM - 1
      CALL GETFM(NEEDE)
C
      MEM = NEEDA + NEEDD + NEEDE
      IF(SOME) WRITE(IW,9150) LPASS,NPASS,MEM
      IF(EXETYP.EQ.CHECK) GO TO 700
C
      CALL MP2S(E2,X(IENG),X(IVEC),X(LPQRJ),X(LXX),X(LIX),X(LWRK1),
     *          X(LWRK2),X(IIRP),NBF,NBF3,NOC,NVIR,NDIM,
     *          IJK,NPASS,LPASS,X(LGHND),X(LXINTS),X(LDDIJ),NINTMX,
     *          MAXG,NSH2,MXG2)
      GO TO 700
C
C     ----- SEQUENTIAL ALTERNATIVE OUT-OF-CORE MP2 TRANSFORMATION -----
C     THIS METHOD USES LESS MEMORY THAN THE SEGMENTED TRANSFORMATION,
C     BUT BECAUSE OF THIS IT REQUIRES MORE DISK STORAGE.  THERE IS
C     ONLY A CONVENTIONAL DISK STORAGE METHOD IMPLEMENTED.
C
  400 CONTINUE
      IF(DIRSCF) THEN
         IF(MASWRK) WRITE(IW,*) 'DIRECT MP2 REQUIRES SEGMENTED TRANSF.'
         CALL ABRT
      END IF
      NDAR20 = NVIR*NOC
C
      NEED = 2*NBF3 + NDAR20 + NOC*NOC + NOC
      LEFT = NGOT - NEED
      NMIN = NDIM*NOC
      MNMEM = NEEDA + NEEDD + NEED + NMIN*1
      MXMEM = NEEDA + NEEDD + NEED + NMIN*NBF
      IF(SOME) WRITE(IW,9210) MNMEM,MXMEM
C
      IF(NMIN.GT.LEFT) THEN
         NTOT = NEEDA + NEEDD + NEED + NMIN
         IF(MASWRK) WRITE(IW,9220) NTOT,NGOTMX
         CALL ABRT
      END IF
C
      LPASS  = LEFT/NMIN
      NPASS  = ((NBF-1)/LPASS) + 1
      IF(LPASS.GE.NBF) LPASS=NBF
C
      CALL VALFM(LOADFM)
      LWRK1 = 1     + LOADFM
      LWRK2 = LWRK1 + NBF3
      LIODA = LWRK2 + NBF3
      LEIJ  = LIODA + NDAR20
      LEI   = LEIJ  + NOC*NOC
      LMINT = LEI   + NOC
      IF (LMOMP2) THEN
         LU    = LMINT + NOC*NDIM*LPASS
         LAST  = LU    + NOC*NOC
      ELSE
         LAST  = LMINT + NOC*NDIM*LPASS
      END IF
      NEEDE = LAST - LOADFM - 1
      CALL GETFM(NEEDE)
C
      MEM = NEEDA + NEEDD + NEEDE
      IF(SOME) WRITE(IW,9250) LPASS,NPASS,MEM
      IF(EXETYP.EQ.CHECK) GO TO 700
C
C     ----- GET LMO TRANSFORMATION MATRIX -----
C
      IF (LMOMP2) CALL DAREAD(IDAF,IODA,X(LU),NOC*NOC,73,0)
C
C        DIRECT ACCESS FILE 20 IS USED IN THIS METHOD
C
      IDAF20 = 20
      CALL RAOPEN(IDAF20,X(LIODA),0,NDAR20,NDAR20,NPRINT)
C
      CALL MP2O(X(IVEC),X(IPTR2),X(LMINT),X(LXX),
     *          X(LIX),X(LWRK1),X(LWRK2),NBF,NOC,
     *          NVIR,NDIM,IJK,LPASS,NPASS,X(LIODA),
     *          NINTMX,NDAR20)
      CALL MP2OS(X(LMINT),X(IIRP),NBF,NOC,NVIR,X(LIODA))
      CALL MP2OE(X(IENG),X(LMINT),X(LEIJ),X(LEI),X(LU),E2,
     *           NBF,NOC,NVIR,X(LIODA))
C
      CALL RACLOS(IDAF20,'DELETE')
      GO TO 700
C
C     ----- PARALLEL -MP2- -----
C
  600 CONTINUE
C
      NEED  = 2*NBF3 + NPROC
      LEFT  = NGOT - NEED
      NMIN  = NDIM*NBF
      IF(NMIN.GT.LEFT) THEN
         NTOT = NEEDA + NEEDD + NEED + NMIN
         IF(MASWRK) WRITE(IW,9320) NTOT,NGOTMX
         CALL ABRT
      END IF
C
C         -NOCP- ORBITALS WILL BE TRANSFORMED BY EACH NODE,
C         DOING -MOCP- OF THEN IN EACH PASS.  -IOCP- IS THE
C         INDEX OF THE FIRST ORBITAL ASSIGNED TO EACH NODE.
C
      IAP = ME+1
      NOCP = (NOC+NPROC-1)/NPROC
      MOCP = MIN(NOCP,LEFT/NMIN)
      NPASS= (NOCP+MOCP-1)/MOCP
      NOCP = NOCP-1
      NOCL = NOC-NPROC*NOCP
      IF(IAP.LE.NOCL) NOCP=NOCP+1
      IOCP = (IAP-1)*NOCP+1
      IF(IAP.GT.NOCL) IOCP = IOCP+NOCL
      MOCP = MIN(NOCP,MOCP)
C
      MNMEM = NEEDA + NEEDD + NEED + NMIN*1
      MXMEM = NEEDA + NEEDD + NEED + NMIN*NOCP
      IF(SOME) WRITE(IW,9310) MNMEM,MXMEM
C
      CALL VALFM(LOADFM)
      LWRK1 = 1     + LOADFM
      LWRK2 = LWRK1 + NBF3
      LJFLG = LWRK2 + NBF3
      LPQRJ = LJFLG + NPROC
      LAST  = LPQRJ + NDIM*NBF*MOCP
      NEEDE = LAST - LOADFM - 1
      CALL GETFM(NEEDE)
C
      MEM = NEEDA + NEEDD + NEEDE
      IF(SOME) WRITE(IW,9350) MOCP,NPASS,MEM
      IF(EXETYP.EQ.CHECK) GO TO 700
C
      CALL MP2P(E2,X(IENG),X(IVEC),X(LPQRJ),X(LXX),X(LIX),
     *          X(LWRK1),X(LWRK2),X(IIRP),NBF,NOC,NVIR,
     *          NDIM,IJK,IOCP,NOCP,MOCP,NPASS,X(LGHND),X(LXINTS),
     *          X(LDDIJ),NINTMX,MAXG,NSH2,MXG2,X(LJFLG),NPROC-1)
      CALL DDI_GSUMF(1200,E2,1)
C
  700 CONTINUE
      CALL RETFM(NEEDE)
      CALL RETFM(NEEDD)
      CALL RETFM(NEEDA)
C
C     ----- PRINT ENERGY DATA -----
C
      EHF =ESCF
      EMP2=EHF+E2
      IF(MASWRK) WRITE(IW,9010) EHF,E2,EMP2
C
      NT = NTSAVE
      IF(NOSYMT.EQ.1) CALL SYMON
      RETURN
C
 9000 FORMAT(/1X,26('-'),3X,46(1H-)/
     *        1X,'RHF-MP2 ENERGY CALCULATION',3X,
     *           'PROGRAM WRITTEN BY M.DUPUIS,C.DANIEL,A.MARQUEZ'/
     *        1X,26('-'),3X,46(1H-)/
     *        1X,'NCORE=',I5,'   NOCC=',I5,'   NMOS=',I5,'   NAOS=',I5)
 9010 FORMAT(/1X,'RESULTS OF MOLLER-PLESSET 2ND ORDER CORRECTION ARE'/
     *       13X,'  E(0)=',1X,F20.10/
     *       13X,'  E(1)=',9X,'0.0'/
     *       13X,'  E(2)=',1X,F20.10/
     *       13X,'E(MP2)=',1X,F20.10)
 9020 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-7 FDIFF=.FALSE.'/
     *        1X,' $MP2    CUTOFF=1D-10 (OR 11)'/)
 9050 FORMAT(/1X,'**** EFFICIENCY NOTE ****'/
     *        1X,'THE DIRECT MP2 TRANSFORMATION WILL COMPUTE THE AO',
     *           ' INTEGRALS ONCE EVERY PASS.'/
     *        1X,'INCREASING MEMORY TO DECREASE PASSES WILL OBVIOUSLY',
     *           ' SAVE CPU TIME.')
C
 9110 FORMAT(/1X,'MEMORY REQUIREMENTS FOR SEGMENTED MP2 TRANSFORMATION'/
     *       1X,'  MINIMUM=',I15,' WORDS, USING 1 MOLECULAR ORBITAL',
     *          ' PER PASS'/
     *       1X,'  MAXIMUM=',I15,' WORDS, MAKING ONLY 1 INTEGRAL PASS')
 9120 FORMAT(1X,'THERE IS INSUFFICIENT MEMORY TO RUN THE SEGMENTED',
     *       1X,'MP2 TRANSFORMATION.'/
     *       1X,'REQUIRED,AVAILABLE MEMORY=',2I15,' WORDS.')
 9130 FORMAT(1X,'**** ERROR: TOO LITTLE MEMORY TO RUN DIRECT MP2 *****'/
     *       1X,'INCREASE MEMORY TO AT LEAST THE MINIMUM SHOWN.')
 9140 FORMAT(1X,'ABANDONING SEGMENTED TRANSFORMATION,',
     *       1X,'TRYING ALTERNATIVE TRANSFORMATION...')
 9150 FORMAT(1X,'CHOOSING THE SEGMENTED MP2 TRANSFORMATION...'/
     *       1X,'  NUMBER OF MOS/PASS = ',I4/
     *       1X,'  NUMBER OF PASSES   = ',I4/
     *       1X,'  MEMORY USED = ',I15,' WORDS.')
C
 9210 FORMAT(/1X,'MEMORY REQUIREMENTS FOR ALTERNATIVE MP2',
     *          ' TRANSFORMATION'/
     *       1X,'  MINIMUM=',I15,' WORDS, USING 1 ATOMIC ORBITAL',
     *          ' PER PASS'/
     *       1X,'  MAXIMUM=',I15,' WORDS, MAKING ONLY 1 INTEGRAL PASS')
 9220 FORMAT(1X,'THERE IS INSUFFICIENT MEMORY TO RUN THE ALTERNATIVE',
     *       1X,'MP2 TRANSFORMATION.'/
     *       1X,'REQUIRED,AVAILABLE MEMORY=',2I15,' WORDS.'/
     *       1X,'INCREASE MEMORY TO AT LEAST THE MINIMUM SHOWN.')
 9250 FORMAT(1X,'CHOOSING THE ALTERNATIVE MP2 TRANSFORMATION...'/
     *       1X,'  NUMBER OF AOS/PASS = ',I4/
     *       1X,'  NUMBER OF PASSES   = ',I4/
     *       1X,'  MEMORY USED = ',I15,' WORDS.')
C
 9310 FORMAT(/1X,'MEMORY REQUIREMENTS FOR PARALLEL MP2 TRANSFORMATION'/
     *       1X,'  MINIMUM=',I15,' WORDS, USING 1 ORBITAL PER PASS'/
     *       1X,'  MAXIMUM=',I15,' WORDS, MAKING ONLY 1 INTEGRAL PASS')
 9320 FORMAT(1X,'THERE IS INSUFFICIENT MEMORY TO RUN THE PARALLEL',
     *       1X,'MP2 TRANSFORMATION.'/
     *       1X,'REQUIRED,AVAILABLE MEMORY=',2I15,' WORDS.'/
     *       1X,'INCREASE MEMORY TO AT LEAST THE MINIMUM SHOWN.')
 9350 FORMAT(1X,'PARAMETERS FOR THE PARALLEL MP2 TRANSFORMATION'/
     *       1X,'  NUMBER OF MOS/NODE/PASS = ',I4/
     *       1X,'  NUMBER OF PASSES        = ',I4/
     *       1X,'  MEMORY USED = ',I15,' WORDS.')
      END
C*MODULE MP2     *DECK MP2O
      SUBROUTINE MP2O(C,CVT,XPQRJ,XX,IX,X,Y,NBF,
     *                NOC,NVIR,NDIM,NFT,LPASS,NPASS,IODA20,
     *                NINTMX,NDAR20)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT,DBUG
C
      COMMON /MP2DAF/ IDAF20,NAV20
      COMMON /MP2PRT/ SOME,OUT,DBUG
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      DIMENSION C(NBF,*),CVT(NVIR,*),XPQRJ(NOC,NDIM,LPASS),
     *          X(NBF,NBF),Y(NBF,NBF),XX(NINTMX),IX(NINTMX),
     *          IODA20(NDAR20)
C
      CALL VCLR(XPQRJ,1,NOC*NDIM*LPASS)
      CALL TSECND(TIM1)
C
C     ----- LOOP OVER PASSES OF -R- -----
C
      DO 100 IPASS=1,NPASS
C
      MINR = LPASS*(IPASS-1) + 1
      MAXR = LPASS*(IPASS-1) + LPASS
      IF(MAXR.GT.NBF) MAXR=NBF
      NUMR = MAXR - MINR + 1
C
C     ----- FORM (PQ/RJ) = SUM OVER S OF (PQ/RS) * C(S,J) -----
C
      CALL MP2O1(NFT,XPQRJ,XX,IX,C,NBF,NOC,NDIM,
     *           MINR,MAXR,NUMR)
C
C     ----- FORM (PI/RJ) , AND THEN (AI/RJ) -----
C
      CALL MP2C23(XPQRJ,X,Y,C,NBF,NVIR,NOC,NOC,NDIM,NUMR)
C
C     ----- FORM (AI/BJ) -----
C
      CALL VCLR(X,1,NOC*NUMR)
      CALL VCLR(Y,1,NOC*NBF)
      MAI=0
      DO 45 MA=1,NVIR
         DO 40 MI=1,NOC
            MAI=MAI+1
C
            DO 15 MR=1,NUMR
               DO 10 MJ=1,NOC
                  X(MR,MJ)=XPQRJ(MJ,MAI,MR)
   10          CONTINUE
   15       CONTINUE
C
            MATMP = MA
            CALL MRARBR(CVT(1,MINR),NVIR,MATMP,NUMR,X,NBF,NOC,Y,NBF)
C
            IF(IPASS.EQ.1) GO TO 30
            CALL RAREAD(IDAF20,IODA20,X,NBF*NOC,MAI,0)
C
            DO 25 MJ=1,NOC
               DO 20 MB=1,MA
                  Y(MB,MJ)=Y(MB,MJ)+X(MB,MJ)
   20          CONTINUE
   25       CONTINUE
   30       CONTINUE
C
            CALL RAWRIT(IDAF20,IODA20,Y,NBF*NOC,MAI,0)
   40    CONTINUE
   45 CONTINUE
C
      IF(SOME) THEN
         CALL TSECND(TIM2)
         TIME = TIM2 - TIM1
         TIM1 = TIM2
         WRITE(IW,9020) IPASS,TIME
         CALL FLSHBF(IW)
      END IF
  100 CONTINUE
C
      IF(SOME) WRITE(IW,9030)
      RETURN
C
 9020 FORMAT(1X,'PASS #',I4,' TOOK',F12.2,' SECONDS.')
 9030 FORMAT(1X,'DONE WITH TRANSFORMATION (PQ|RS) TO (IA|JB)')
      END
C*MODULE MP2     *DECK MP2O1
      SUBROUTINE MP2O1(NFT,XPQRJ,XX,IX,CO,NBF,NOC,NDIM,
     *                 MINR,MAXR,NUMR)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SKIPP,SKIPQ,SKIPR,SKIPS,PACK2E,GOPARR,DSKWRK,MASWRK
C
      DIMENSION CO(NBF,*),XPQRJ(NOC,NDIM,*),XX(*),IX(*)
C
      PARAMETER (MXAO=8192)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
C     ON ENTRY THE ORBITALS CO IS MULTIPLIED BY THE
C     AO INTEGRAL XX; THE LABELS ARE PACKED IN IX
C     ON RETURN XPQRJ IS FILLED
C
      CALL VCLR(XPQRJ,1,NUMR*NDIM*NOC)
C
C     ----- FORM (PQ/RJ) = SUM OVER S OF (PQ/RS) * C(S,J) -----
C
      CALL SEQREW(NFT)
C     FIRST, PROCESS IN CORE INTEGRALS
      NPACKIC=0
  100 CONTINUE
      IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
        NXX=NXXIC
        NINT=NXX
      ELSE
C       IF ALL IN CORE BAIL OUT
        IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 200
        CALL PREAD(NFT,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
        IF(NXX.EQ.0) GO TO 200
        NINT=IABS(NXX)
        IF(NINT.LE.NINTMX) GO TO 105
      IF(MASWRK) WRITE(IW,9999)
      IF(MASWRK) WRITE(IW,9998)
      CALL ABRT
  105 CONTINUE
      ENDIF
C
      DO 150 M=1,NINT
                       NPACK = NPACKIC+M
      VAL1=XX(NPACK)
      VAL3=VAL1
C
                       IF (LABSIZ .EQ. 2) THEN
*I32                     LABEL = IX( 2*NPACK - 1 )
*I32                     IPACK = ISHFT( LABEL, -16 )
*I32                     JPACK = IAND(  LABEL, 65535 )
*I32                     LABEL = IX( 2*NPACK     )
*I32                     KPACK = ISHFT( LABEL, -16 )
*I32                     LPACK = IAND(  LABEL, 65535 )
*I64                     LABEL = IX(NPACK)
*I64                     IPACK = ISHFT( LABEL, -48 )
*I64                     JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64                     KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64                     LPACK = IAND( LABEL, 65535 )
                       ELSE IF (LABSIZ .EQ. 1) THEN
*I32                     LABEL = IX(NPACK)
*I32                     IPACK = ISHFT( LABEL, -24 )
*I32                     JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32                     KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32                     LPACK = IAND( LABEL, 255 )
*I64                     IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                       LABEL = IX( NPACK/2 )
*I64                       IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64                       JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64                       LPACK = IAND( LABEL, 255 )
*I64                     ELSE
*I64                       LABEL = IX( (NPACK/2)+1 )
*I64                       IPACK = ISHFT( LABEL, -56 )
*I64                       JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64                       LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64                     END IF
                       END IF
                       MP = IPACK
                       MQ = JPACK
                       MR = KPACK
                       MS = LPACK
C
      SKIPS=MS.LT.MINR.OR.MS.GT.MAXR
      SKIPR=MR.LT.MINR.OR.MR.GT.MAXR
      SKIPP=MP.LT.MINR.OR.MP.GT.MAXR
      SKIPQ=MQ.LT.MINR.OR.MQ.GT.MAXR
      IF(SKIPS.AND.SKIPR.AND.SKIPQ.AND.SKIPP) GO TO 150
      MPQ=IA(MP)+MQ
      MRS=IA(MR)+MS
      IF(MP.EQ.MQ) VAL1 = VAL1+VAL1
      IF(MR.EQ.MS) VAL3 = VAL3+VAL3
C
      IF(SKIPR) GO TO 141
      DO 140 MJ=1,NOC
         XPQRJ(MJ,MPQ,MR-MINR+1)=XPQRJ(MJ,MPQ,MR-MINR+1)+VAL1*CO(MS,MJ)
  140 CONTINUE
  141 IF(SKIPS) GO TO 143
      DO 142 MJ=1,NOC
         XPQRJ(MJ,MPQ,MS-MINR+1)=XPQRJ(MJ,MPQ,MS-MINR+1)+VAL1*CO(MR,MJ)
  142 CONTINUE
  143 IF(SKIPP) GO TO 145
      DO 144 MJ=1,NOC
         XPQRJ(MJ,MRS,MP-MINR+1)=XPQRJ(MJ,MRS,MP-MINR+1)+VAL3*CO(MQ,MJ)
  144 CONTINUE
  145 IF(SKIPQ) GO TO 150
      DO 146 MJ=1,NOC
         XPQRJ(MJ,MRS,MQ-MINR+1)=XPQRJ(MJ,MRS,MQ-MINR+1)+VAL3*CO(MP,MJ)
  146 CONTINUE
C
  150 CONTINUE
      IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C     SWITCH TO INTEGRALS ON DISK
      IF(NXX.GT.0) GO TO 100
  200 CONTINUE
      RETURN
 9999 FORMAT(' INCONSISTENT FILE PARAMETERS IN -MP2O1-. STOP')
 9998 FORMAT(5X,'*** PROGRAM STOP IN -MP2O1- ***')
      END
C
C*MODULE MP2     *DECK MP2OE
      SUBROUTINE MP2OE(E,AIBJ,EIJ,EI,U,E2,
     *                 NBF,NOC,NVIR,IODA20)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT,DBUG,LMOMP2
C
      DIMENSION E(*),AIBJ(NBF,NOC,NOC),EIJ(NOC,NOC),EI(NOC),IODA20(*)
      DIMENSION U(NOC,NOC)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2DAF/ IDAF20,NAV20
      COMMON /MP2LOC/ LMOMP2
      COMMON /MP2PRT/ SOME,OUT,DBUG
C
      DATA ZERO /0.0D+00/
      DATA PT5  /0.5D+00/
C
C     ----- CALCULATE E(2) AND ORBITAL-PAIR CONTRIBUTIONS TO E(2) -----
C
      E2=ZERO
      DO 15 MJ=1,NOC
         DO 10 MI=1,NOC
            EIJ(MI,MJ)=ZERO
   10    CONTINUE
   15 CONTINUE
C
      DO 590 MA=1,NVIR
         DO 520 MI=1,NOC
            MAI=MI+NOC*(MA-1)
            CALL RAREAD(IDAF20,IODA20,AIBJ(1,1,MI),NBF*NOC,MAI,0)
  520    CONTINUE
         DO 580 MI=1,NOC
            DO 570 MB=1,MA
               MAX=NOC
               IF(MB.EQ.MA) MAX=MI
               DO 560 MJ=1,MAX
                  IF (.NOT. LMOMP2) THEN
                     XAIBJ=AIBJ(MB,MJ,MI)
                     XAJBI=AIBJ(MB,MI,MJ)
                     DAIBJ=XAIBJ/(E(MA+NOC)+E(MB+NOC)-E(MI)-E(MJ))
                  ELSE
                     XAIBJ = ZERO
                     XAJBI = ZERO
                     DAIBJ = ZERO
                     DO 540 L = 1,NOC
                        DO 530 K = 1,NOC
                           XAIBJ = XAIBJ + U(L,MI)*AIBJ(MB,L,K)*U(K,MJ)
                           XAJBI = XAJBI + U(L,MJ)*AIBJ(MB,L,K)*U(K,MI)
                           DAIBJ = DAIBJ + U(L,MI)*U(K,MJ)*
     *                     AIBJ(MB,L,K)/(E(MA+NOC)+E(MB+NOC)-E(K)-E(L))
  530                   CONTINUE
  540                CONTINUE
                  END IF
                  EAIBJ=(XAIBJ+XAIBJ-XAJBI)*DAIBJ
                  IF(MB.NE.MA.OR.MJ.NE.MI) EAIBJ=EAIBJ+EAIBJ
                  E2=E2-EAIBJ
                  IF(MI.EQ.MJ) EAIBJ=EAIBJ*PT5
                  EIJ(MI,MJ)=EIJ(MI,MJ)-EAIBJ
                  EIJ(MJ,MI)=EIJ(MJ,MI)-EAIBJ
  560          CONTINUE
  570       CONTINUE
  580    CONTINUE
  590 CONTINUE
C
      IF(.NOT.OUT .AND. .NOT. LMOMP2) RETURN
C
C     ----- PERFORM ENERGY CHECKS -----
C
      DO 770 MI=1,NOC
         DUM=ZERO
         DO 760 MJ=1,NOC
            IF(MJ.NE.MI) EIJ(MI,MJ) = EIJ(MI,MJ)*PT5
            E2IJ=EIJ(MI,MJ)
            DUM=DUM+E2IJ
  760    CONTINUE
         EI(MI)=DUM
  770 CONTINUE
      E2DUM=ZERO
      DO 790 MI=1,NOC
         E2DUM=E2DUM+EI(MI)
  790 CONTINUE
C
      IF (SOME) THEN
         WRITE(IW,9999) E2
         WRITE(IW,9998) E2DUM
         WRITE(IW,9997)
      END IF
      CALL PRSQ(EIJ,NOC,NOC,NOC)
      IF(SOME) WRITE(IW,9996)
      CALL PRSQ(EI ,  1,NOC,  1)
      RETURN
C
 9999 FORMAT(/,'                                 E(2) = ',F16.9)
 9998 FORMAT(/,' SUM OF ORBITAL CONTRIBUTIONS TO E(2) = ',F16.9)
 9997 FORMAT(/,'   ORBITAL-PAIR CONTRIBUTIONS TO E(2)',/,3X,34(1H-))
 9996 FORMAT(/,'        ORBITAL CONTRIBUTIONS TO E(2)',/,8X,29(1H-))
      END
C
C*MODULE MP2     *DECK MP2OS
      SUBROUTINE MP2OS(AIBJ,MOSIRP,NBF,NOC,NVIR,IODA20)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SYM2EI
C
      COMMON /MP2DAF/ IDAF20,NAV20
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
C
      DIMENSION AIBJ(NBF,NOC,NOC),MOSIRP(*),IODA20(*)
C
      DATA ZERO /0.0D+00/
C
      IF(NIRRED.EQ.1) RETURN
C
C     ----- SIFT INTEGRALS FOR SYMMETRY ZEROES -----
C
      DO 50 MA=1,NVIR
         DO 10 MI=1,NOC
            MAI=MI+NOC*(MA-1)
            CALL RAREAD(IDAF20,IODA20,AIBJ(1,1,MI),NBF*NOC,MAI,0)
   10    CONTINUE
         ISYMA = MOSIRP(MA+NOC)
         DO 30 MI=1,NOC
            ISYMI = MOSIRP(MI)
            DO 25 MB=1,MA
               ISYMB = MOSIRP(MB+NOC)
               MAX=NOC
               IF(MB.EQ.MA) MAX=MI
               DO 20 MJ=1,MAX
                  ISYMJ = MOSIRP(MJ)
                  IF(.NOT.SYM2EI(ISYMA,ISYMI,ISYMB,ISYMJ))
     *                 AIBJ(MB,MJ,MI)=ZERO
                  IF(.NOT.SYM2EI(ISYMA,ISYMJ,ISYMB,ISYMI))
     *                 AIBJ(MB,MI,MJ)=ZERO
   20          CONTINUE
   25       CONTINUE
   30    CONTINUE
         DO 40 MI=1,NOC
            MAI=MI+NOC*(MA-1)
            CALL RAWRIT(IDAF20,IODA20,AIBJ(1,1,MI),NBF*NOC,MAI,0)
   40    CONTINUE
   50 CONTINUE
      RETURN
      END
C
C*MODULE MP2     *DECK MP2C1
      SUBROUTINE MP2C1(NFT8,XPQRJ,XX,IX,C,NUM,NOC,NDIM,
     *                 GHONDO,XINTS,DDIJ,MAXG,NSH2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,FDIFF,DIRTRF,PACK2E
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION XPQRJ(NOC,NDIM,NUM),C(NUM,*),XX(*),IX(*),
     *          GHONDO(MAXG),XINTS(NSH2),DDIJ(*)
C
      COMMON /DIRCAS/ I2CASE
      COMMON /DIRMEM/ IPQRJ,IVEC,IDEN,IFCK,NNNUM,NOCC,NNNDIM,MINPQ,MAXPQ
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
C     ----- FORM (PQ/RJ) = SUM OVER S OF (PQ/RS) * C(S,J) -----
C
      CALL VCLR(XPQRJ,1,NOC*NDIM*NUM)
C
C     ----- DIRECT MP2 -----
C
      IF(DIRSCF) THEN
         I2CASE=3
         NOCC = NOC
         DIRTRF=.TRUE.
         NINTICS=NINTIC
         NINTIC=0
         CALL DIRJK(GHONDO,XINTS,DDIJ,XX,IX,MAXG,NSH2)
         NINTIC=NINTICS
C
C     ----- DISK BASED -----
C
      ELSE
         CALL SEQREW(NFT8)
C        FIRST, PROCESS IN CORE INTEGRALS
         NPACKIC=0
   10    CONTINUE
         IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
            NXX=NXXIC
            NINT=NXX
         ELSE
C           IF ALL IN CORE BAIL OUT
            IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) RETURN
            CALL PREAD(NFT8,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
            IF(NXX.EQ.0) RETURN
            NINT=IABS(NXX)
            IF(NINT.GT.NINTMX) THEN
               IF(MASWRK) WRITE(IW,9999)
               IF(MASWRK) WRITE(IW,9998)
               CALL ABRT
            END IF
         ENDIF
         CALL ONETRF(XPQRJ,C,NDIM,NUM,NOC,XX,IX,NXX,NPACKIC)
         IF(NPACKIC.EQ.0) NPACKIC=NINTIC
         IF(NXX.GT.0) GO TO 10
      END IF
      RETURN
 9999 FORMAT(' INCONSISTENT FILE PARAMETERS IN -MP2C1-. STOP')
 9998 FORMAT(5X,'*** PROGRAM STOP IN -MP2C1- ***')
      END
C*MODULE MP2     *DECK MP2C1P
      SUBROUTINE MP2C1P(NFT,XPQRJ,XX,IX,C,NUM,NOC,NDIM,
     *                  GHONDO,XINTS,DDIJ,JFLG,NPM1,MAXG,NSH2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRTRF,DIRSCF,FDIFF,GOPARR,DSKWRK,MASWRK,PACK2E
C
      DIMENSION XPQRJ(NOC,NDIM,*),C(NUM,*),XX(*),IX(*),JFLG(0:NPM1),
     *          GHONDO(MAXG),XINTS(NSH2),DDIJ(*)
C
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /DIRCAS/ I2CASE
      COMMON /DIRMEM/ IPQRJ,IVEC,IDEN,IFCK,NNNUM,NOCC,NNNDIM,MINPQ,MAXPQ
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
C     ----- FORM (PQ/RJ) = SUM OVER S OF (PQ/RS) * C(S,J) -----
C
      CALL VCLR(XPQRJ,1,NOC*NDIM*NUM)
C
C     ----- DIRECT MP2 -----
C
      IF(DIRSCF) THEN
         I2CASE=3
         NOCC = NOC
         DIRTRF=.TRUE.
         NINTICS=NINTIC
         NINTIC=0
         CALL DIRJK(GHONDO,XINTS,DDIJ,XX,IX,MAXG,NSH2)
         NINTIC=NINTICS
C
C     ----- CONVENTIONAL MP2 -----
C
      ELSE
C
         DO 100 KAP=0,NPROC-1
            JFLG(KAP)=1
  100    CONTINUE
         KAP = -1
         IFLG=  1
C
         CALL SEQREW(NFT)
C        FIRST, PROCESS IN CORE INTEGRALS
         NPACKIC=0
  300    CONTINUE
C
C           READ DUPLICATED OR DISTRIBUTED AO INTEGRAL LIST
C
         IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
            NXX=NXXIC
            NINT=NXX
         ELSE
C           IF ALL IN CORE BAIL OUT
            IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) RETURN
            IF(ITRFAO.EQ.1) THEN
              CALL PREAD(NFT,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
            ELSE
              CALL PREADP(NFT,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX,
     *                    KAP,IFLG,JFLG,NPROC)
              IF(IFLG.EQ.0) THEN
                 CALL SEQREW(NFT)
                 RETURN
              END IF
            END IF
         ENDIF
C
         IF(NXX.EQ.0) GO TO 400
         NINT=ABS(NXX)
         IF(NINT.GT.NINTMX) CALL ABRT
C
C           CARRY OUT FIRST INDEX TRANSFORMATION
C
         CALL ONETRF(XPQRJ,C,NDIM,NUM,NOC,XX,IX,NXX,NPACKIC)
         IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C
  400    CONTINUE
         IF(ITRFAO.EQ.1  .AND.  NXX.LE.0) THEN
            CALL SEQREW(NFT)
            RETURN
         END IF
         GO TO 300
      END IF
      RETURN
      END
C*MODULE MP2     *DECK MP2C23
      SUBROUTINE MP2C23(XPQRJ,X,Y,C,NBF,NVIR,NOC,NOCC,NDIM,NUMR)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION C(NBF,*),XPQRJ(NOCC,NDIM,NBF),X(NBF,NBF),Y(NBF,NBF)
C
C     ----- FORM (PI|RJ) , AND THEN (AI|RJ) -----
C        ON ENTRY XPQRJ IS MULTIPLIED BY OCCUPIED MO'S
C        AND THEN VIRTUAL.  ON EXIT XPQRJ IS REWRITTEN TO
C        CONTAIN 3-INDEX TRANSFORMED INTEGRAL
C           FIRST MATRIX MULTIPLY INVOLVES Y BEING RETURNED FROM
C        MULTIPLICATION OF X, CONTAINING ONE-INDEX TRANSFORMED
C        INTEGRALS, AND C, MO COEFFICIENTS FOR OCCUPIED
C        ORBITALS.
C           THE SECOND MATRIX MULTIPLY RETURNS X AFTER MULTIPLYING
C        A TRANSPOSE OF MO COEFFICIENTS FOR VIRTUAL ORBITALS
C        AND Y, THE TWO-INDEX TRANSFORMED INTEGRALS.
C
      DO 35 MR=1,NUMR
      DO 30 MJ=1,NOCC
         CALL VCLR(X,1,NBF*NBF)
         CALL VCLR(Y,1,NBF*NBF)
         MPQ=0
         DO 15 MP=1,NBF
            DO 10 MQ=1,MP
               MPQ=MPQ+1
               X(MP,MQ)=XPQRJ(MJ,MPQ,MR)
               X(MQ,MP)=X(MP,MQ)
   10       CONTINUE
   15    CONTINUE
C
         CALL MRARBR(X,NBF,NBF,NBF,C,NBF,NOC,Y,NBF)
         CALL MRTRBR(C(1,NOC+1),NBF,NBF,NVIR,Y,NBF,NOC,X,NBF)
         MAI=0
         DO 25 MA=1,NVIR
            DO 20 MI=1,NOC
               MAI=MAI+1
               XPQRJ(MJ,MAI,MR)=X(MA,MI)
   20       CONTINUE
   25    CONTINUE
C
   30 CONTINUE
   35 CONTINUE
      RETURN
      END
C
C*MODULE MP2     *DECK MP2S
      SUBROUTINE MP2S(E2,E,C,XPQRJ,XX,IX,X,Y,MOSIRP,NBF,NBF3,
     *                NOC,NVIR,NDIM,IJK,NPASS,LPASS,
     *                GHONDO,XINTS,DDIJ,NINTMX,MAXG,NSH2,MXG2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,OUT,DBUG
C
      DIMENSION E(*),C(NBF,*),XPQRJ(*),X(NBF3),Y(NBF3),MOSIRP(*),
     *          GHONDO(MAXG),XINTS(NSH2),DDIJ(MXG2),
     *          XX(NINTMX),IX(NINTMX)
C
      COMMON /IOFILE/ IR,IW,IP,IK,IPK,IDAF,NAV,IODA(950)
      COMMON /DIRMEM/ IPQKL,IVEC,IDEN,IFCK,NUM,NOCC,NNNDIM,MINPQ,MAXPQ
      COMMON /MP2PRT/ SOME,OUT,DBUG
C
      PARAMETER (ZERO=0.0D+00)
C
      E2 = ZERO
      J0 = 1
      CALL TSECND(TIM1)
C
C     ----- LOOP OVER NUMBER OF PASSES -----
C     ----- FOR ALL  J = J0, ..., J0+NOCC-1 -----
C
      DO 100 IPASS=1,NPASS
         NOCC = MIN(NOC,J0+LPASS-1)-J0+1
C
C     ----- FORM -(PQ/RJ)- -----
C
         CALL MP2C1(IJK,XPQRJ,XX,IX,C(1,J0),
     *              NBF,NOCC,NDIM,GHONDO,XINTS,DDIJ,MAXG,NSH2)
C
C     ----- FORM -(AI/RJ)- ALL A,I -----
C
         CALL MP2C23(XPQRJ,X,Y,C,NBF,NVIR,NOC,NOCC,NDIM,NBF)
C
C     ----- FORM -(AI/BJ)-  ALL B -----
C
         CALL MP2S4(XPQRJ,X,Y,C(1,NOC+1),MOSIRP,J0,NOC,NVIR,NBF,
     *              NOCC,NDIM)
C
C     ------ CALCULATE PARTIAL CONTRIBUTION TO E(2) FROM THIS
C            BATCH -----
C
C     E(2) = SUM (J)  SUM(AIB) (AI/BJ) * ( 2*(AI/BJ)-(BI/AJ) ) /
C                              (E(A)+E(B)-E(I)-E(J))
C
         CALL MP2SE(E,XPQRJ,E2,J0,NOC,NVIR,NOCC,NDIM)
C
         J0 = J0+NOCC
         IVEC = IVEC+NOCC*NBF
C
         IF(SOME) THEN
            CALL TSECND(TIM2)
            TIME = TIM2-TIM1
            TIM1 = TIM2
            WRITE(IW,9020) IPASS,TIME
            CALL FLSHBF(IW)
         END IF
  100 CONTINUE
C
      IF(SOME) WRITE(IW,9030)
      RETURN
C
 9020 FORMAT(1X,'PASS #',I4,' TOOK',F12.2,' SECONDS.')
 9030 FORMAT(1X,'DONE WITH PARTIAL TRANSFORMATION (PQ|RS) TO (IA|JB)')
      END
C
C*MODULE MP2     *DECK MP2S4
      SUBROUTINE MP2S4(XPQRJ,X,Y,CV,MOSIRP,J0,NOC,NVIR,NBF,NOCC,NDIM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (ZERO=0.0D+00)
C
      LOGICAL SYM2EI
C
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
C
      DIMENSION XPQRJ(NOCC,NDIM,NBF),X(NBF,*),Y(NBF,*),CV(NBF,*),
     *          MOSIRP(*)
C
C     ----- FORM (AI/BJ) FOR CURRENT BATCH OF J -----
C
      MAI = 0
      IF(NIRRED.EQ.1) THEN
         DO 35 MA=1,NVIR
            DO 30 MI=1,NOC
               MAI = MAI+1
               DO 15 MJ=1,NOCC
                  DO 10 MR=1,NBF
                     X(MR,MJ) = XPQRJ(MJ,MAI,MR)
   10             CONTINUE
   15          CONTINUE
C
               CALL MRTRBR(CV,NBF,NBF,NVIR,X,NBF,NOCC,Y,NBF)
               DO 25 MB=1,NVIR
                  DO 20 MJ=1,NOCC
                     XPQRJ(MJ,MAI,MB) = Y(MB,MJ)
   20             CONTINUE
   25          CONTINUE
   30       CONTINUE
   35    CONTINUE
      ELSE
         DO 65 MA=1,NVIR
            DO 60 MI=1,NOC
               MAI = MAI+1
               DO 45 MJ=1,NOCC
                  DO 40 MR=1,NBF
                     X(MR,MJ) = XPQRJ(MJ,MAI,MR)
   40             CONTINUE
   45          CONTINUE
               DO 55 MJ=1,NOCC
                  DO 50 MB=1,NVIR
                     IF(SYM2EI(MOSIRP(MB+NOC),MOSIRP(MJ+J0-1),
     *                         MOSIRP(MA+NOC),MOSIRP(MI))) THEN
                        XPQRJ(MJ,MAI,MB)=DDOT(NBF,CV(1,MB),1,X(1,MJ),1)
                     ELSE
                        XPQRJ(MJ,MAI,MB) = ZERO
                     END IF
   50             CONTINUE
   55          CONTINUE
   60       CONTINUE
   65    CONTINUE
      END IF
      RETURN
      END
C
C*MODULE MP2     *DECK MP2SE
      SUBROUTINE MP2SE(E,AIBJ,E2,J0,NOC,NVIR,NOCC,NDIM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
C
      DIMENSION AIBJ(NOCC,NDIM,NVIR),E(*)
C
C     ----- FORM PARTIAL CONTRIBUTION TO THE E(2) ENERGY -----
C
      MAI = 0
      DO 25 MA=1,NVIR
         DO 20 MI=1,NOC
            MAI = MAI+1
            DO 15 MB=1,NVIR
               MBI = NOC*(MB-1)+MI
               DO 10 MJ=1,NOCC
                  XAIBJ = AIBJ(MJ,MAI,MB)
                  IF(ABS(XAIBJ).LT.TOL) GO TO 10
                  XAJBI = AIBJ(MJ,MBI,MA)
                  DAIBJ = E(MA+NOC)+E(MB+NOC)-E(MI)-E(MJ+J0-1)
                  E2 = E2-XAIBJ*(XAIBJ+XAIBJ-XAJBI)/DAIBJ
   10          CONTINUE
   15       CONTINUE
   20    CONTINUE
   25 CONTINUE
C
      RETURN
      END
C*MODULE MP2     *DECK MP2P
      SUBROUTINE MP2P(E2,E,C,XPQRJ,XX,IX,X,Y,MOSIRP,NUM,
     *                NOC,NVIR,NDIM,IJK,IOCP1,NOCP,MOCP,NPASS,
     *                GHONDO,XINTS,DDIJ,NINTMX,MAXG,NSH2,MXG2,
     *                JFLG,NPM1)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,OUT,DBUG
      LOGICAL GOPARR,DSKWRK,MASWRK,DIRSCF,FDIFF,DSKSAV
C
      DIMENSION E(*),C(NUM,*),XPQRJ(*),XX(NINTMX),IX(NINTMX),
     *          X(*),Y(*),MOSIRP(*),GHONDO(MAXG),XINTS(NSH2),
     *          DDIJ(MXG2),JFLG(0:NPM1)
C
      COMMON /DIRMEM/ IPQKL,IVEC,IDEN,IFCK,NUMX,NOCC,NDIMX,MINPQ,MAXPQ
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PRT/ SOME,OUT,DBUG
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00)
C
C        ----- MAIN DRIVER FOR PARALLEL MP2 TRANSFORMATION -----
C        THIS NODE IS ASSIGNED OCCUPIED MO-S IN THE RANGE IOCP1-IOCP2
C        ON EACH PASS, IT DOES MO-S IN THE RANGE IOCP-JOCP
C
      E2 = ZERO
      IF(SOME) CALL TSECND(TIM1)
C
      DSKSAV = DSKWRK
      IF(.NOT.DIRSCF) DSKWRK=.TRUE.
C
      IPASS = 0
      IOCP2 = MIN(NOC,IOCP1+NOCP-1)
      IOCP = IOCP1
      IVEC0 = IVEC
  100 CONTINUE
      IPASS = IPASS+1
      JOCP = MIN(IOCP2,IOCP+MOCP-1)
      NOCC = JOCP-IOCP+1
      IVEC = IVEC0 + (IOCP-1)*NUM
      IF(NOCC.GT.0) THEN
C
C           (PQ|RS) --> (PQ|RJ)...DIRECT OR CONVENTIONAL
C           (PQ|RJ) --> (AI|RJ)
C           (AI|RJ) --> (AI|BJ)
C           FORM ENERGY CONTRIBUTION
C
         CALL MP2C1P(IJK,XPQRJ,XX,IX,C(1,IOCP),NUM,NOCC,NDIM,
     *               GHONDO,XINTS,DDIJ,JFLG,NPM1,MAXG,NSH2)
         CALL MP2C23(XPQRJ,X,Y,C,NUM,NVIR,NOC,NOCC,NDIM,NUM)
         CALL MP2S4(XPQRJ,X,Y,C(1,NOC+1),MOSIRP,IOCP,NOC,NVIR,NUM,
     *              NOCC,NDIM)
         CALL MP2SE(E,XPQRJ,E2,IOCP,NOC,NVIR,NOCC,NDIM)
C
C           EVEN IF THERE ARE NO MOS FOR THIS PROCESSOR TO COMPUTE
C           TRANSFORMED INTEGRALS FOR, THIS PROCESSOR MUST STILL
C           PARTICIPATE IN ALL GLOBAL BROADCASTS
C
      ELSE
         CALL TRFBRD(IJK,XX,IX,NINTMX,JFLG,NPROC)
      END IF
C
      IF(SOME) THEN
         CALL TSECND(TIM2)
         TIME = TIM2 - TIM1
         TIM1 = TIM2
         WRITE(IW,9020) IPASS,TIME
         CALL FLSHBF(IW)
      END IF
C
      IOCP  = JOCP+1
      IF(IPASS.LT.NPASS) GO TO 100
C
      DSKWRK = DSKSAV
      RETURN
C
 9020 FORMAT(1X,'PASS #',I4,' TOOK',F12.2,' SECONDS.')
      END
C*MODULE MP2     *DECK UMP2EN
      SUBROUTINE UMP2EN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXGSH=30, MXG2=MXGSH*MXGSH,
     *           MXRT=100, MXATM=2000, MXAO=8192)
C
      LOGICAL SOME,OUT,DBUG,PACK2E,GOPARR,DSKWRK,MASWRK,
     *        ABEL,ABELPT,DIRSCF,FDIFF,DIRTRF
C
      COMMON /DIRMEM/ LPQRJ,IVEC,IDEN,IFCK,NUM,NOCC,NDIM,MINPQ,MAXPQ
      COMMON /FMCOM / X(1)
      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 /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,MNUM,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 /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /MP2DAF/ IDAF20,NAV20
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NO,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /MP2PRT/ SOME,OUT,DBUG
      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 /ONEELC/ EONE,E1A,E1B
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TSYM(432),INVT(48),NT
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA CHECK /8HCHECK   /, RMP2/8HMP2     /
      DATA UHF,ROHF /8HUHF     ,8HROHF    /
C
      SOME = NPRINT.NE.-5  .AND. MASWRK
      OUT  = EXETYP.EQ.RMP2 .AND. MASWRK
      IF(SCFTYP.EQ.UHF  .AND.  MASWRK)
     *           WRITE(IW,9000) NACORE,NBCORE,NOA,NOB,NQMT,NBF
      IF(SCFTYP.EQ.ROHF  .AND.  MASWRK)
     *           WRITE(IW,9005) NACORE,NOA,NOB,NQMT,NBF
C
      CALL GOTFM(NGOTMX)
      IF(NWDMP2.GT.0) NGOTMX = MIN(NGOTMX,NWDMP2)
C
      NOCA =NOA-NACORE
      NVIRA=NO -NOA
      NOCB =NOB-NBCORE
      NVIRB=NO -NOB
      NORBA=NO -NACORE
      NORBB=NO -NBCORE
C
      NBF2 =(NBF*NBF+NBF)/2
      NBF3 =NBF*NBF
C
      NUM  = NBF
      IDEN = 0
      IFCK = 0
      NOCC = NOCA+NOCB
      NDIM = MAX(NBF2,NVIRB*NOCA,NVIRA*NOCB)
C
C        ---- OPTION TO DEFEAT SYMMETRY USAGE ----
C
      ABEL=ABELPT()
      IF(NOSYMT.EQ.1) CALL SYMOFF
C
C     ----- MEMORY ALLOCATION FOR UMP2 CALCULATION -----
C
C  LVECA    : MATRIX OF MO COEFFICIENTS (A)     NBF    * NBF
C  LEIGA    : ORBITAL ENERGIES          (A)     NBF
C  LLABA    : MOSLAB(A) |               (A)     NBF
C  LIRPA    : MOSIRP(A) |---> SEE SYM   (A)     NBF
C  LDEGA    : MOSDEG(A) |               (A)     NBF
C  LVECB    : MATRIX OF MO COEFFICIENTS (B)     NBF    * NBF
C  LEIGB    : ORBITAL ENERGIES          (B)     NBF
C  LLABB    : MOSLAB(B) |               (B)     NBF
C  LIRPB    : MOSIRP(B) |---> SEE SYM   (B)     NBF
C  LDEGB    : MOSDEG(B) |               (B)     NBF
C
      CALL VALFM(LOADFM)
      LVECA  = 1      + LOADFM
      LEIGA  = LVECA  + NBF3
      LLABA  = LEIGA  + NBF
      LIRPA  = LLABA  + NBF
      LDEGA  = LIRPA  + NBF
      LVECB  = LDEGA  + NBF
      LEIGB  = LVECB  + NBF3
      LLABB  = LEIGB  + NBF
      LIRPB  = LLABB  + NBF
      LDEGB  = LIRPB  + NBF
      LAST   = LDEGB  + NBF
      NEEDA = LAST - LOADFM - 1
      CALL GETFM(NEEDA)
C
C     ----- SET UP TRANSPOSE MATRIX OF MO COEFFICIENTS -----
C
      CALL VALFM(LOADFM)
      LTMPVA = 1      + LOADFM
      LTMPVB = LTMPVA + NBF3
      LAST   = LTMPVB + NBF3
      NEEDB = LAST - LOADFM - 1
      CALL GETFM(NEEDB)
C
C           READ MO'S AND E'S, BOTH ALPHA AND BETA
C
      CALL DAREAD(IDAF,IODA,X(LTMPVA),NBF3,15,0)
      CALL DAREAD(IDAF,IODA,X(LEIGA) ,NBF ,17,0)
      CALL DAREAD(IDAF,IODA,X(LTMPVB),NBF3,19,0)
      CALL DAREAD(IDAF,IODA,X(LEIGB) ,NBF ,21,0)
C
      MAXCA = IDAMAX(NBF*NQMT,X(LTMPVA),1)
      MAXCB = IDAMAX(NBF*NQMT,X(LTMPVB),1)
      CMAXA = ABS(X(LTMPVA+MAXCA-1))
      CMAXB = ABS(X(LTMPVB+MAXCB-1))
      IF(MAX(CMAXA,CMAXB).GT.1.0D+02) THEN
         IF(CMAXA.GT.CMAXB) THEN
            MAXM = 1 + MAXCA/NUM
            MAXA = MAXCA - NUM*(MAXM-1)
            IF(MASWRK) WRITE(IW,9020) 'ALPHA',CMAXA,MAXA,MAXM
         ELSE
            MAXM = 1 + MAXCB/NUM
            MAXA = MAXCB - NUM*(MAXM-1)
            IF(MASWRK) WRITE(IW,9020) 'BETA',CMAXB,MAXA,MAXM
         END IF
      END IF
C
      IF(MASWRK  .AND.  SCFTYP.EQ.ROHF) THEN
         WRITE(IW,9410)
         WRITE(IW,9420)
         WRITE(IW,9440) (X(LEIGA+I),I=0,NBF-1)
         WRITE(IW,9430)
         WRITE(IW,9440) (X(LEIGB+I),I=0,NBF-1)
      END IF
C
      DO 10 J=1,NORBA
      X(J           +LEIGA-1)=X(J         +NACORE +LEIGA-1)
      DO 10 I=1,NBF
   10 X(I+ NBF*(J-1)+LVECA-1)=X(I+NBF*(J-1+NACORE)+LTMPVA-1)
      DO 15 J=1,NORBB
      X(J           +LEIGB-1)=X(J         +NBCORE +LEIGB-1)
      DO 15 I=1,NBF
   15 X(I+ NBF*(J-1)+LVECB-1)=X(I+NBF*(J-1+NBCORE)+LTMPVB-1)
      CALL RETFM(NEEDB)
C
C     ----- ASSIGN -IRREP- LABEL TO MO'S -----
C
      CALL VALFM(LOADFM)
      LS   = 1    + LOADFM
      LQ   = LS   + NBF2
      LWRK = LQ   + NBF3
      LAST = LWRK + NBF
      NEEDC = LAST - LOADFM - 1
      CALL GETFM(NEEDC)
      IF(EXETYP.EQ.CHECK) GO TO 50
C
      CALL DAREAD(IDAF,IODA,X(LS),NBF2,12,0)
      CALL DAREAD(IDAF,IODA,X(LQ),NBF3,45,0)
      CALL TRFSYM(X(LLABA),X(LIRPA),X(LDEGA),X(LQ),X(LS),X(LVECA),
     *            X(LWRK),IA,NQMT,NBF,NORBA,NBF)
C
      IF(OUT) THEN
         IF(MASWRK) WRITE(IW,9610)
         IF(MASWRK) WRITE(IW,9630)
         CALL PREVS(X(LVECA),X(LEIGA),X(LLABA),NORBA,NBF,NBF,1)
      END IF
C
      CALL DAREAD(IDAF,IODA,X(LQ),NBF3,45,0)
      CALL TRFSYM(X(LLABB),X(LIRPB),X(LDEGB),
     *            X(LQ),X(LS),X(LVECB),X(LWRK),IA,NQMT,NBF,NORBB,NBF)
C
      IF(OUT) THEN
         IF(MASWRK) WRITE(IW,9620)
         IF(MASWRK) WRITE(IW,9630)
         CALL PREVS(X(LVECB),X(LEIGB),X(LLABB),NORBB,NBF,NBF,1)
      END IF
   50 CONTINUE
      CALL RETFM(NEEDC)
C
      NTSAVE = NT
      IF(DIRSCF  .AND.  .NOT.ABEL) NT=1
C
C     ----- INTEGRAL STORAGE FOR DIRECT OR CONVENTIONAL MP2 -----
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      IF(LMAX.EQ.5) NANGM = 21
      IF(LMAX.EQ.6) NANGM = 28
      MAXG = NANGM**4
      NSH2 = (NSHELL*NSHELL+NSHELL)/2
C
      CALL VALFM(LOADFM)
      IF(DIRSCF) THEN
         LGHND  = 1      + LOADFM
         LXINTS = LGHND  + MAXG
         LDDIJ  = LXINTS + NSH2
         LXX    = LDDIJ  + 49*MXG2
         LIX    = LXX    + MAX(NINTMX,NUM*NOCA,NUM*NOCB)
         LAST   = LIX    + NINTMX
      ELSE
         LGHND  = 1      + LOADFM
         LXINTS = LGHND
         LDDIJ  = LXINTS
         LXX    = LDDIJ
         LIX    = LXX    + MAX(NINTMX,NUM*NOCA,NUM*NOCB)
         LAST   = LIX    + NINTMX
      END IF
      NEEDD = LAST - LOADFM - 1
      CALL GETFM(NEEDD)
C
      IF(DIRSCF) THEN
         IF(EXETYP.EQ.CHECK) THEN
            CALL VCLR(X(LXINTS),1,NSH2)
         ELSE
            IF(ISCHWZ.EQ.1) THEN
               CALL DAREAD(IDAF,IODA,X(LXINTS),NSH2,54,0)
            ELSE
               CALL DCOPY(NSH2,1.0D+01,0,X(LXINTS),1)
            END IF
         END IF
      END IF
C
C     ----- SELECT TRANSFORMATION METHOD -----
C
      NGOT = NGOTMX - NEEDA - NEEDD
      IF(DIRSCF  .AND.  SOME) WRITE(IW,9050)
      IF(GOPARR) GO TO 600
      IF(METHOD.EQ.3) GO TO 400
C
C     ----- SEQUENTIAL SEGMENTED MP2 TRANSFORMATION -----
C
      NOCX = MAX(NOCA,NOCB)
      NEED = NBF3 + MAX(NBF3,NBF*(NOCA+NOCB))
      LEFT = NGOT - NEED
      NMIN = NDIM*NBF
      MNMEM = NEEDA + NEEDD + NEED + NMIN*2*1
      MXMEM = NEEDA + NEEDD + NEED + NMIN*(NOCA+NOCB)
      IF(MASWRK) WRITE(IW,9110) MNMEM,MXMEM
C
      IF(NMIN*2.GT.LEFT) THEN
         NTOT = NEEDA + NEEDD + NEED + NMIN*2
         IF(MASWRK) WRITE(IW,9120) NTOT,NGOTMX
         IF(DIRSCF) THEN
            IF(MASWRK) WRITE(IW,9130)
            CALL ABRT
         ELSE
            IF(MASWRK) WRITE(IW,9140)
            GO TO 400
         END IF
      END IF
C
      LPASS = MIN(NOCX,LEFT/(NMIN*2))
      NPASS = (NOCX+LPASS-1)/LPASS
      LPASS = (NOCX+NPASS-1)/NPASS
C
      CALL VALFM(LOADFM)
      LX    = 1     + LOADFM
      LY    = LX    + MAX(NBF3,NBF*(NOCA+NOCB))
      LPQRJ = LY    + NBF3
      LAST  = LPQRJ + NDIM*NBF*LPASS*2
      NEEDE = LAST - LOADFM - 1
      CALL GETFM(NEEDE)
C         COMBINED OCCUPIED VECTOR STORAGE
      IVEC = LX
C
      MEM = NEEDA + NEEDD + NEEDE
      IF(MASWRK) WRITE(IW,9150) LPASS,NPASS,MEM
      IF(EXETYP.EQ.CHECK) GO TO 700
C
C     TRY TO TRANSFORM AT LEAST ONE ALPHA AND ONE BETA MO AT A TIME
C     (PQ|RS) -> (PQ|RJ) (ALPHA AND BETA)
C     THEN, IN THE SAME WAY AS THE IN-CORE TRANSFORMATION, COMPLETE
C     THE (AA|AA) INTEGRALS, COMPUTE ITS CONTRIBUTION TO THE ENERGY
C     AND THE COMPLETE THE (AA|BB) AND (BB|BB) USING THE PREVIOUS
C     MEMORY SPACE
C     REQUIRES AT LEAST: NDIM*NBF*2 WORDS
C
      CALL UMP2SA(X(LPQRJ),X(LVECA),X(LVECB),X(LEIGA),X(LEIGB),X(LIRPA),
     *            X(LIRPB),X(LX),X(LY),X(LXX),X(LIX),NOCA,NVIRA,NOCB,
     *            NVIRB,NBF,NDIM,LPASS,IJK,E2,
     *            X(LGHND),X(LXINTS),X(LDDIJ),NINTMX,MAXG,NSH2,MXG2)
      GO TO 700
C
C     ----- SEQUENTIAL ALTERNATIVE OUT-OF-CORE ALGORITHM -----
C
  400 CONTINUE
      IF(DIRSCF) THEN
         IF(MASWRK) WRITE(IW,*) 'DIRECT MP2 REQUIRES SEGMENTED TRANSF.'
         CALL ABRT
      END IF
      NDAR20= MAX(2*(NVIRA*NOCA)+NVIRB*NOCB,2*(NVIRB*NOCB)+NVIRA*NOCA)
C
      NEED = 2*NBF3 + NDAR20
      LEFT = NGOT - NEED
      NMIN = NDIM*(NOCA+NOCB)
      MNMEM = NEEDA + NEEDD + NEED + NMIN*1
      MXMEM = NEEDA + NEEDD + NEED + NMIN*NBF
      IF(MASWRK) WRITE(IW,9210) MNMEM,MXMEM
C
      IF(NMIN.GT.LEFT) THEN
         NTOT = NEEDA + NEEDD + NEED + NMIN
         IF(MASWRK) WRITE(IW,9220) NEED,NGOTMX
         CALL ABRT
      END IF
C
      LPASS=MIN(NBF,LEFT/NMIN)
      NPASS=(NBF+LPASS-1)/LPASS
      LPASS=(NBF+NPASS-1)/NPASS
C
      CALL VALFM(LOADFM)
      LX     = 1      + LOADFM
      LY     = LX     + NBF3
      LDAR20 = LY     + NBF3
      LPQRJ  = LDAR20 + NDAR20
      LAST   = LPQRJ  + (NOCA+NOCB)*NDIM*LPASS
      NEEDE = LAST - LOADFM - 1
      CALL GETFM(NEEDE)
C             A FEW OF THE ARRAYS ARE OVERLAPPED
      LEIJ  = LX
      LEI   = LY
      LAIBJ = LPQRJ
C
      MEM = NEEDA + NEEDD + NEEDE
      WRITE(IW,9250) LPASS,NPASS,MEM
      IF(EXETYP.EQ.CHECK) GO TO 700
C
C         THIS METHOD USES SCRATCH FILE -DASORT-
C
      IDAF20 = 20
      CALL RAOPEN(IDAF20,X(LDAR20),0,NDAR20,NDAR20,NPRINT)
C
C     IF NOCA<NOCB, THERE WILL BE PROBLEMS WITH THE INPENDING CALL
C     TO UMPC2B (INSIDE UMP2O) UNLESS WE SWITCH THE A AND B ORDER
C
      IF (NOCA.GE.NOCB) THEN
C
      CALL UMP2O(X(LVECA),X(LVECB),X(LPQRJ),X(LX),X(LY),X(LXX),X(LIX),
     *           NBF,NDIM,NOCA+NOCB,NOCA,NVIRA,NOCB,NVIRB,LPASS,
     *           X(LDAR20),IJK,NINTMX,NDAR20)
C
      CALL UMPOE1(X(LEIGA),X(LAIBJ),X(LEIJ),X(LEI),X(LIRPA),
     *            NBF,NOCA,NVIRA,X(LDAR20),0,0)
      CALL UMPOE1(X(LEIGB),X(LAIBJ),X(LEIJ),X(LEI),X(LIRPB),
     *            NBF,NOCB,NVIRB,X(LDAR20),1,NOCA*NVIRA)
      CALL UMPOE2(X(LEIGA),X(LEIGB),X(LAIBJ),X(LEIJ),X(LEI),
     *            E2,NBF,NOCA,NVIRA,NOCB,NVIRB,
     *            X(LDAR20),X(LIRPA),X(LIRPB))
C
      ELSE
C
      CALL UMP2O(X(LVECB),X(LVECA),X(LPQRJ),X(LX),X(LY),X(LXX),X(LIX),
     *           NBF,NDIM,NOCA+NOCB,NOCB,NVIRB,NOCA,NVIRA,LPASS,
     *           X(LDAR20),IJK,NINTMX,NDAR20)
C
      CALL UMPOE1(X(LEIGA),X(LAIBJ),X(LEIJ),X(LEI),X(LIRPA),
     *            NBF,NOCA,NVIRA,X(LDAR20),0,NOCB*NVIRB)
      CALL UMPOE1(X(LEIGB),X(LAIBJ),X(LEIJ),X(LEI),X(LIRPB),
     *            NBF,NOCB,NVIRB,X(LDAR20),1,0)
      CALL UMPOE2(X(LEIGB),X(LEIGA),X(LAIBJ),X(LEIJ),X(LEI),
     *            E2,NBF,NOCB,NVIRB,NOCA,NVIRA,
     *            X(LDAR20),X(LIRPB),X(LIRPA))
      END IF
C
      CALL RACLOS(IDAF20,'DELETE')
      GO TO 700
C
C     ----- PARALLEL UMP2/RMP2 -----
C
  600 CONTINUE
      NEED = NBF3 + MAX(NBF3,NBF*(NOCA+NOCB)) + NPROC
      LEFT = NGOT - NEED
      NMIN = NDIM*NBF
      IF(NMIN*2.GT.LEFT) THEN
         NTOT = NEEDA + NEEDD + NEED + NMIN*2
         IF (MASWRK) WRITE(IW,9320) NTOT,NGOTMX
         CALL ABRT
      END IF
C
C     (ADAPTED FROM THE MP2NRG ROUTINE)
C     -IOCP- IS THE INDEX OF THE 1ST ALPHA MO TRANSFORMED BY THE NODE,
C     -NOA- IS NUMBER OF ALPHA ORBITALS TO BE TRANSFORMED BY THE NODE,
C     -NOB- IS NUBER OF BETA ORBITALS TO BE TRANSFORMED BY THE NODE.
C     -NOCP- IS # OF ALPHA ORB. TO BE TRANSFORMED BY EACH NODE
C     -MOCP- IS A # OF ORBITALS TRANSFORMED BY EACH NODE WITH EACH PASS
C
C     -ME- BELOW IS WHAT ACTUALLY DETERMINES WHICH PROCESSOR ARE YOU ON.
C     WE TRY TO DISTRIBUTE AS EVENLY AS POSSIBLE THE OCCUPIED ORBITALS
C     TO ALL AVAILABLE NODES. FOR EXAMPLE, 5 MOS WILL BE DISTRIBUTED TO
C     3 NODES IN THIS WAY: 2  2  1 (MASTER NODE IS FIRST).
C
      NOCX=MAX(NOCA,NOCB)
      IAP=ME+1
      NOCP=(NOCX+NPROC-1)/NPROC
      MOCP=MIN(NOCX,LEFT/(NMIN*2))
      NPASS=(NOCP+MOCP-1)/MOCP
      NOCP=NOCP-1
      NOCL=NOCX-NPROC*NOCP
      IF(IAP.LE.NOCL) NOCP=NOCP+1
      IOCP=(IAP-1)*NOCP+1
      IF(IAP.GT.NOCL) IOCP=IOCP+NOCL
      MOCP=MIN(NOCP,MOCP)
C
C     THIS FIGURES OUT HOW MANY ALPHA AND BETA ELECTRONS ARE IN NOCP
C     ORBITALS ASSIGNED TO THE PARTICULAR NODE
C
      LIND=IOCP+NOCP-1
      IF(LIND.LE.NOCA) THEN
         NOA=NOCP
      ELSE
         NOA=NOCA+1-IOCP
      END IF
      IF(NOA.LT.0) NOA=0
      IF(LIND.LE.NOCB) THEN
         NOB=NOCP
      ELSE
         NOB=NOCB+1-IOCP
      END IF
      IF(NOB.LT.0) NOB=0
C
      MNMEM = NEEDA + NEEDD + NEED + NMIN*2*1
      MXMEM = NEEDA + NEEDD + NEED + NMIN*2*NOCX
      IF(MASWRK) WRITE(IW,9310) MNMEM,MXMEM
C
      CALL VALFM(LOADFM)
      LX    = 1     + LOADFM
      LY    = LX    + MAX(NBF3,NBF*(NOCA+NOCB))
      LJFLG = LY    + NBF3
      LPQRJ = LJFLG + NPROC
      LAST  = LPQRJ + NDIM*NBF*MOCP*2
      NEEDE = LAST - LOADFM - 1
      CALL GETFM(NEEDE)
C
C         COMBINED OCCUPIED VECTOR STORAGE
C
      IVEC = LX
C
      MEM = NEEDA + NEEDD + NEEDE
      IF(MASWRK) WRITE(IW,9350) MOCP,NPASS,MEM
      IF(EXETYP.EQ.CHECK) GO TO 700
C
C     TRY TO TRANSFORM AT LEAST ONE ALPHA AND ONE BETA MO AT A TIME
C     (PQ|RS) -> (PQ|RJ) (ALPHA AND BETA)
C     THEN, IN THE SAME WAY AS THE IN-CORE TRANSFORMATION, COMPLETE
C     THE (AA|AA) INTEGRALS, COMPUTE ITS CONTRIBUTION TO THE ENERGY
C     AND THE COMPLETE THE (AA|BB) AND (BB|BB) USING THE PREVIOUS
C     MEMORY SPACE
C     REQUIRES AT LEAST: NDIM*NBF*2 WORDS
C
      CALL UMP2PA(X(LPQRJ),X(LVECA),X(LVECB),X(LEIGA),X(LEIGB),X(LIRPA),
     *          X(LIRPB),X(LX),X(LY),X(LXX),X(LIX),NOCA,NOA,NVIRA,NOCB,
     *          NOB,NVIRB,NBF,NDIM,MOCP,IOCP,IJK,E2,
     *          X(LGHND),X(LXINTS),X(LDDIJ),NINTMX,MAXG,NSH2,MXG2,
     *          X(LJFLG),NPROC-1,NPASS)
      CALL DDI_GSUMF(1200,E2,1)
C
C     ...ALL MP2 OPTIONS BRANCH HERE TO RELEASE MEMORY...
C
  700 CONTINUE
      CALL RETFM(NEEDE)
      CALL RETFM(NEEDD)
      CALL RETFM(NEEDA)
C
C     ----- PRINT ENERGY DATA -----
C
      EHF =ESCF
      IF(SCFTYP.EQ.ROHF) THEN
         IF(MASWRK) WRITE(IW,9460) -E1A,-E1B,E2
         EMP2 = EHF + E2 - EONE
      ELSE
         EMP2 = EHF + E2
      END IF
      IF(MASWRK) WRITE(IW,9010) EHF,E2-EONE,EMP2
C
      NT = NTSAVE
      IF(NOSYMT.EQ.1) CALL SYMON
      RETURN
C
 9000 FORMAT(/1X,19(1H-),3X,39(1H-)/
     *        1X,'UHF-MP2 CALCULATION',3X,
     *           'PROGRAM WRITTEN BY S.MALUENDES,M.DUPUIS'/
     *        1X,19(1H-),3X,39(1H-)/
     *        1X,'NACORE,NBCORE=',2I4,' NALPHA,NBETA OCC=',2I5,
     *           ' NMOS=',I5,' NAOS=',I5)
 9005 FORMAT(/1X,29(1H-),3X,43(1H-)/
     *        1X,'RMP2 (ROHF-MBPT2) CALCULATION',3X,
     *           'PROGRAM BY M.DUPUIS,S.MALUENDES,N.MATSUNAGA'/
     *        1X,29(1H-),3X,43(1H-)/
     *        1X,'NCORE=',I4,'  NOCC ALPHA,BETA=',2I5,
     *           '  NMOS=',I5,'  NAOS=',I5)
 9010 FORMAT(/1X,'RESULTS OF MOLLER-PLESSET 2ND ORDER CORRECTION ARE'/
     *       10X,'     E(0)=',1X,F20.10/
     *       10X,'     E(1)=',9X,'0.0'/
     *       10X,'     E(2)=',1X,F20.10/
     *       10X,'   E(MP2)=',1X,F20.10)
 9020 FORMAT(/1X,'*** WARNING ***'/
     *        1X,'THE MAXIMUM ',A,' 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-7 FDIFF=.FALSE.'/
     *        1X,' $MP2    CUTOFF=1D-10 (OR 11)'/)
 9050 FORMAT(/1X,'**** EFFICIENCY NOTE ****'/
     *        1X,'THE DIRECT MP2 TRANSFORMATION WILL COMPUTE THE AO',
     *           ' INTEGRALS ONCE EVERY PASS.'/
     *        1X,'INCREASING MEMORY TO DECREASE PASSES WILL OBVIOUSLY',
     *           ' SAVE CPU TIME.')
C
 9110 FORMAT(/1X,'MEMORY REQUIREMENTS FOR SEGMENTED MP2 TRANSFORMATION'/
     *       1X,'  MINIMUM=',I15,' WORDS, USING 1 MOLECULAR ORBITAL',
     *          ' PER PASS'/
     *       1X,'  MAXIMUM=',I15,' WORDS, MAKING ONLY 1 INTEGRAL PASS')
 9120 FORMAT(1X,'THERE IS INSUFFICIENT MEMORY TO RUN THE SEGMENTED',
     *       1X,'MP2 TRANSFORMATION.'/
     *       1X,'REQUIRED,AVAILABLE MEMORY=',2I15,' WORDS.')
 9130 FORMAT(1X,'**** ERROR: TOO LITTLE MEMORY TO RUN DIRECT MP2 *****'/
     *       1X,'INCREASE MEMORY TO AT LEAST THE MINIMUM SHOWN.')
 9140 FORMAT(1X,'ABANDONING SEGMENTED TRANSFORMATION,',
     *       1X,'TRYING ALTERNATIVE TRANSFORMATION...')
 9150 FORMAT(1X,'CHOOSING THE SEGMENTED MP2 TRANSFORMATION...'/
     *       1X,'  NUMBER OF MOS/PASS = ',I4/
     *       1X,'  NUMBER OF PASSES   = ',I4/
     *       1X,'  MEMORY USED = ',I15,' WORDS.')
C
 9210 FORMAT(/1X,'MEMORY REQUIREMENTS FOR ALTERNATIVE MP2',
     *          ' TRANSFORMATION'/
     *       1X,'  MINIMUM=',I15,' WORDS, USING 1 MOLECULAR ORBITAL',
     *          ' PER PASS'/
     *       1X,'  MAXIMUM=',I15,' WORDS, MAKING ONLY 1 INTEGRAL PASS')
 9220 FORMAT(1X,'THERE IS INSUFFICIENT MEMORY TO RUN THE ALTERNATIVE',
     *       1X,'MP2 TRANSFORMATION.'/
     *       1X,'REQUIRED,AVAILABLE MEMORY=',2I15,' WORDS.'/
     *       1X,'INCREASE MEMORY TO AT LEAST THE MINIMUM SHOWN.')
 9250 FORMAT(1X,'CHOOSING THE ALTERNATIVE MP2 TRANSFORMATION...'/
     *       1X,'  NUMBER OF AOS/PASS = ',I4/
     *       1X,'  NUMBER OF PASSES   = ',I4/
     *       1X,'  MEMORY USED = ',I15,' WORDS.')
C
 9320 FORMAT(1X,'THERE IS INSUFFICIENT MEMORY TO RUN THE PARALLEL',
     *       1X,'MP2 TRANSFORMATION.'/
     *       1X,'REQUIRED,AVAILABLE MEMORY=',2I15,' WORDS.'/
     *       1X,'INCREASE MEMORY TO AT LEAST THE MINIMUM SHOWN.')
 9310 FORMAT(/1X,'MEMORY REQUIREMENTS FOR PARALLEL MP2 TRANSFORMATION'/
     *       1X,'  MINIMUM=',I15,' WORDS, USING 1 ORBITAL PER PASS'/
     *       1X,'  MAXIMUM=',I15,' WORDS, MAKING ONLY 1 INTEGRAL PASS')
 9350 FORMAT(1X,'PARAMETERS FOR THE PARALLEL MP2 TRANSFORMATION'/
     *       1X,'  NUMBER OF MOS/NODE/PASS = ',I4/
     *       1X,'  NUMBER OF PASSES        = ',I4/
     *       1X,'  MEMORY USED = ',I15,' WORDS.')
C
 9410 FORMAT(/5X,'ORBITALS AND ORBITAL ENERGIES ARE MODIFIED'/
     *        5X,'DEFINED UNIQUE ORBITAL ENERGIES ARE:')
 9420 FORMAT(7X,'ALPHA')
 9430 FORMAT(7X,'BETA')
 9440 FORMAT(5X,5F12.6)
 9460 FORMAT(/5X,'SINGLE EXCITATION CONTRIBUTION',
     *       /9X,'ALPHA',1X,F20.10,
     *       /9X,'BETA ',1X,F20.10,
     *       /5X,'DOUBLE EXCITATION CONTRIBUTION',
     *       /15X,F20.10)
C
 9610 FORMAT(/,' ----- ALPHA SET -----',/)
 9620 FORMAT(/,' ----- BETA SET -----',/)
 9630 FORMAT(/,'       MOLECULAR ORBITALS',
     *       /,'       ------------------')
      END
C*MODULE MP2     *DECK UMPC2A
      SUBROUTINE UMPC2A(XPQRJ,CA,NUM,NOCA,NOCCA,NVIRA,NOCC,NDIM,NUMR,
     *                  X,Y)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION XPQRJ(NOCC,NDIM,*),X(NUM,*),Y(NUM,*),CA(NUM,*)
C
C     (PQ|RJ) -> (AI|RJ) - FOR ALPHA SPIN -----
C
      DO 30 MR=1,NUMR
      DO 30 MJ=1,NOCCA
         MPQ=0
         DO 10 MP=1,NUM
         DO 10 MQ=1,MP
            MPQ=MPQ+1
            X(MP,MQ)=XPQRJ(MJ,MPQ,MR)
   10       X(MQ,MP)=X(MP,MQ)
C
         CALL MRARBR(X,NUM,NUM,NUM,CA,NUM,NOCA,Y,NUM)
         CALL MRTRBR(CA(1,NOCA+1),NUM,NUM,NVIRA,Y,NUM,NOCA,X,NUM)
         MAI=0
         DO 20 MA=1,NVIRA
         DO 20 MI=1,NOCA
            MAI=MAI+1
   20       XPQRJ(MJ,MAI,MR)=X(MA,MI)
   30 CONTINUE
C
      RETURN
      END
C*MODULE MP2     *DECK UMPC2B
      SUBROUTINE UMPC2B(XPQRJ,CA,CB,NUM,NOCA,NVIRA,NOCB,NVIRB,
     *                  NDIM,NUMR,NOCC,NOCCA,NOCCB,X,Y,Z)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION XPQRJ(NOCC,NDIM,*),X(NUM,*),Y(NUM,*),Z(NUM,*),
     *          CA(NUM,*),CB(NUM,*)
C
C     (PQ|RJ) -> (AI|RJ) - FOR BETA SPIN -----
C
      DO 40 MR=1,NUMR
C
C     ----- ( BETA  BETA  | R BETA ) -----
C     ----- ( ALPHA ALPHA | R BETA ) -----
C
      DO 40 MJ=1,NOCCB
         MPQ=0
         DO 10 MP=1,NUM
         DO 10 MQ=1,MP
            MPQ=MPQ+1
            X(MP,MQ)=XPQRJ(MJ+NOCCA,MPQ,MR)
   10       X(MQ,MP)=X(MP,MQ)
C
         CALL MRARBR(X,NUM,NUM,NUM,CB,NUM,NOCB,Y,NUM)
         CALL MRARBR(X,NUM,NUM,NUM,CA,NUM,NOCA,Z,NUM)
         CALL MRTRBR(CB(1,NOCB+1),NUM,NUM,NVIRB,Y,NUM,NOCB,X,NUM)
         CALL MRTRBR(CA(1,NOCA+1),NUM,NUM,NVIRA,Z,NUM,NOCA,Y,NUM)
C
         MAI=0
         DO 20 MA=1,NVIRB
         DO 20 MI=1,NOCB
            MAI=MAI+1
   20       XPQRJ(MJ+NOCCA,MAI,MR)=X(MA,MI)
C
         MAI=0
         DO 30 MA=1,NVIRA
         DO 30 MI=1,NOCA
            MAI=MAI+1
   30       XPQRJ(MJ      ,MAI,MR)=Y(MA,MI)
   40 CONTINUE
C
      RETURN
      END
C*MODULE MP2     *DECK UMP2PA
      SUBROUTINE UMP2PA(XPQRJ,CA,CB,EA,EB,MOSIRA,MOSIRB,X,Y,XX,IX,
     *           NOCA,NOA,NVIRA,NOCB,NOB,NVIRB,NUM,NDIM,MOCP,IOCP,
     *           NFT,E2,GHONDO,XINTS,DDIJ,NINTMX,MAXG,NSH2,
     *           MXG2,JFLG,NPM1,NPASS)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION XPQRJ(*),CA(NUM,*),CB(NUM,*),EA(*),EB(*),MOSIRA(*),
     *          MOSIRB(*),X(NUM,*),Y(NUM,*),XX(NINTMX),IX(NINTMX),
     *          GHONDO(MAXG),XINTS(NSH2),DDIJ(49,MXG2),JFLG(0:NPM1)
C
      LOGICAL SOME,OUT,DBUG,GOPARR,DSKWRK,MASWRK,DSKSAV,DIRSCF,FDIFF
C
      COMMON /DIRMEM/ IPQKL,IVEC,IDEN,IFCK,NNNUM,NOCC,NNNDIM,MINPQ,MAXPQ
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PRT/ SOME,OUT,DBUG
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- UHF/ROHF MP2 ENERGY PARALLEL COMPUTATION DRIVER -----
C     CONSTRUCTED FROM UMP2SA AND MP2P ROUTINES BY VISVALDAS KAIRYS
C     AND JOHN HEAD, DEPT. OF CHEM., U. OF HAWAII AT MANOA, HONOLULU HI
C
      E2 = ZERO
      E2A= ZERO
      E2B= ZERO
      E2C= ZERO
C
C     -IOCP- IS INDEX OF 1ST ALPHA MO TO BE TRANSFORMED BY THAT NODE,
C     -NOA- IS NUMBER OF ALPHA ORBITALS TO BE TRANSFORMED BY THE NODE,
C     -NOB- IS NUBER OF BETA ORBITALS TO BE TRANSFORMED BY THE NODE
C     -MOCP- IS A # OF ORBITALS TRANSFORMED BY EACH NODE WITH EACH PASS
C     EACH NODE GETS A SUBSET OF ORBITALS TO WORK WITH.  DURING EACH
C     PASS, A NODE WORKS WITH THE ORBITALS IOCA - JOCA AND IOCB - JOCB.
C     TO OBTAIN THEIR POSITION IN THE ORIGINAL SET OF MOS, ADD -IOCP-.
C     NUMBER OF OCC ORBITALS WHICH A NODE IS WORKING ON DURING THE
C     PASS ARE -NOCCA-, -NOCCB- AND -NOCC-.
C
      DSKSAV=DSKWRK
      IF(.NOT.DIRSCF) DSKWRK=.TRUE.
      IOCA=1
      IOCB=1
      IPASS=0
      CALL TSECND(TIM1)
C
  100 CONTINUE
      IPASS=IPASS+1
      JOCA=MIN(NOA,IOCA+MOCP-1)
      NOCCA=JOCA-IOCA+1
      JOCB=MIN(NOB,IOCB+MOCP-1)
      NOCCB=JOCB-IOCB+1
C
C     IF NOCCB IS GREATER THAN NOCCA, WE WILL GET INTO TROUBLE WITH THE
C     DIMENSIONS OF XPQRJ UNLESS WE CHANGE THE ORDER FOR NOCCB>NOCCA
C
      NOCC =NOCCA+NOCCB
      IF(NOCC.GT.0) THEN
      IF(NOCCA.GE.NOCCB) THEN
C
C     ------ COPY -ALPHA- AND -BETA- ORBITALS -----
C
      DO 10 I =1,NOCCA
      DO 10 MP=1,NUM
   10    X(MP,I      ) = CA(MP,IOCP+IOCA+I-2)
      DO 20 I =1,NOCCB
      DO 20 MP=1,NUM
   20    X(MP,I+NOCCA) = CB(MP,IOCP+IOCB+I-2)
C
C     ----- (PQ|RS) -> (PQ|RJ) -ALPHA- AND -BETA- -----
C
      CALL MP2C1P(NFT,XPQRJ,XX,IX,X,NUM,NOCC,NDIM,
     *           GHONDO,XINTS,DDIJ,JFLG,NPM1,MAXG,NSH2)
C
C     ----- (PQ|RJ) -ALPHA- -> (AI|RJ) ALL -ALPHA- -----
C
      CALL UMPC2A(XPQRJ,CA,NUM,NOCA,NOCCA,NVIRA,NOCC,
     *            NDIM,NUM,X,Y)
C
C     ----- (AI|RJ) -ALPHA- -> (AI|BJ) ALL -ALPHA- -----
C
      CALL UMPS4A(XPQRJ,MOSIRA,X,Y,CA(1,NOCA+1),NOCA,NOCCA,NVIRA,
     *            NOCC,NDIM,NUM,IOCA+IOCP-1)
C
C     ----- ENERGY CONTRIBUTION FROM CURRENT SET OF J -ALPHA- -----
C
      CALL UMPSE(EA,XPQRJ,NOCC,NDIM,NOCA,NVIRA,NOCCA,IOCA+IOCP-1,E2A)
C
      IF(NOCCB.EQ.0) GO TO 200
C
C     ----- (PQ|RJ) -BETA- -> (AI|RJ) -ALPHA- AND -BETA- -----
C
      CALL UMPC2B(XPQRJ,CA,CB,NUM,NOCA,NVIRA,NOCB,NVIRB,NDIM,NUM,
     *            NOCC,NOCCA,NOCCB,X,Y,XX)
C
C     ----- (AI|RJ) -> (AI|BJ) -ALPHA- AND -BETA- -----
C
      CALL UMPS4B(XPQRJ,MOSIRA,MOSIRB,X,Y,CB(1,NOCB+1),
     *            NOCA,NVIRA,NOCB,NVIRB,NUM,NDIM,NOCC,NOCCA,NOCCB,
     *            IOCB+IOCP-1)
C
C     ----- ENERGY CONTRIBUTION FROM CURRENT SET OF J -ALPHA- -----
C
      CALL UMPSE(EB,XPQRJ(NOCCA+1),NOCC,NDIM,NOCB,NVIRB,NOCCB,
     *           IOCB+IOCP-1,E2B)
C
C     ----- ENERGY CONTRIBUTION FROM CROSS TERM -----
C
      CALL UMPSEC(EA,EB,XPQRJ,NOCC,NOCA,NVIRA,NOCB,NVIRB,NDIM,NOCCB,
     *            IOCB+IOCP-1,E2C)
      ELSE
C
C     FOR NOCCB>NOCCA, WE HAVE TO CHANGE THE ORDER
C
      DO 110 I =1,NOCCB
      DO 110 MP=1,NUM
  110    X(MP,I      ) = CB(MP,IOCP+IOCB+I-2)
      DO 120 I =1,NOCCA
      DO 120 MP=1,NUM
  120    X(MP,I+NOCCB) = CA(MP,IOCP+IOCA+I-2)
C
C     ----- (PQ|RS) -> (PQ|RJ) -ALPHA- AND -BETA- -----
C
      CALL MP2C1P(NFT,XPQRJ,XX,IX,X,NUM,NOCC,NDIM,
     *           GHONDO,XINTS,DDIJ,JFLG,NPM1,MAXG,NSH2)
C
C     ----- (PQ|RJ) -BETA- -> (AI|RJ) ALL -BETA- -----
C
      CALL UMPC2A(XPQRJ,CB,NUM,NOCB,NOCCB,NVIRB,NOCC,
     *            NDIM,NUM,X,Y)
C
C     ----- (AI|RJ) -BETA- -> (AI|BJ) ALL -BETA- -----
C
      CALL UMPS4A(XPQRJ,MOSIRB,X,Y,CB(1,NOCB+1),NOCB,NOCCB,NVIRB,
     *            NOCC,NDIM,NUM,IOCB+IOCP-1)
C
C     ----- ENERGY CONTRIBUTION FROM CURRENT SET OF J -BETA- -----
C
      CALL UMPSE(EB,XPQRJ,NOCC,NDIM,NOCB,NVIRB,NOCCB,IOCB+IOCP-1,E2B)
C
      IF(NOCCA.EQ.0) GO TO 200
C
C     ----- (PQ|RJ) -ALPHA- -> (AI|RJ) -ALPHA- AND -BETA- -----
C
      CALL UMPC2B(XPQRJ,CB,CA,NUM,NOCB,NVIRB,NOCA,NVIRA,NDIM,NUM,
     *            NOCC,NOCCB,NOCCA,X,Y,XX)
C
C     ----- (AI|RJ) -> (AI|BJ) -ALPHA- AND -BETA- -----
C
      CALL UMPS4B(XPQRJ,MOSIRB,MOSIRA,X,Y,CA(1,NOCA+1),
     *            NOCB,NVIRB,NOCA,NVIRA,NUM,NDIM,NOCC,NOCCB,NOCCA,
     *            IOCA+IOCP-1)
C
C     ----- ENERGY CONTRIBUTION FROM CURRENT SET OF J -ALPHA- -----
C
      CALL UMPSE(EA,XPQRJ(NOCCB+1),NOCC,NDIM,NOCA,NVIRA,NOCCA,
     *           IOCA+IOCP-1,E2A)
C
C     ----- ENERGY CONTRIBUTION FROM CROSS TERM -----
C
      CALL UMPSEC(EB,EA,XPQRJ,NOCC,NOCB,NVIRB,NOCA,NVIRA,NDIM,NOCCA,
     *            IOCA+IOCP-1,E2C)
      END IF
C
      ELSE
         CALL TRFBRD(NFT,XX,IX,NINTMX,JFLG,NPROC)
      END IF
C
C        THIS PASS IS DONE, ARE THERE MORE?
C
  200 CONTINUE
      IF(SOME) THEN
         CALL TSECND(TIM2)
         TIME = TIM2 - TIM1
         TIM1 = TIM2
         WRITE(IW,9020) IPASS,TIME
         CALL FLSHBF(IW)
      END IF
      IOCB = JOCB+1
      IOCA = JOCA+1
      IF(IPASS.LT.NPASS) GO TO 100
C
      E2 = E2A+E2B+E2C
      IF(SOME) WRITE(IW,9030)
      DSKWRK=DSKSAV
      RETURN
C
 9020 FORMAT(1X,'PASS #',I4,' TOOK',F12.2,' SECONDS.')
 9030 FORMAT(1X,'DONE WITH PARTIAL TRANSFORMATION (PQ|RS) TO (IA|JB)')
      END
C*MODULE MP2     *DECK UMP2SA
      SUBROUTINE UMP2SA(XPQRJ,CA,CB,EA,EB,MOSIRA,MOSIRB,X,Y,XX,IX,
     *                  NOCA,NVIRA,NOCB,NVIRB,NUM,NDIM,LPASS,
     *                  NFT,E2,GHONDO,XINTS,DDIJ,NINTMX,MAXG,NSH2,MXG2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION XPQRJ(*),CA(NUM,*),CB(NUM,*),EA(*),EB(*),MOSIRA(*),
     *          MOSIRB(*),X(NUM,*),Y(NUM,*),XX(*),IX(NINTMX),
     *          GHONDO(MAXG),XINTS(NSH2),DDIJ(49,MXG2)
C
      LOGICAL SOME,OUT,DBUG
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PRT/ SOME,OUT,DBUG
C
      PARAMETER (ZERO=0.0D+00)
C
      E2 = ZERO
      E2A= ZERO
      E2B= ZERO
      E2C= ZERO
C
      IOCA=1
      IOCB=1
      IPASS=0
      CALL TSECND(TIM1)
C
  100 CONTINUE
      IPASS=IPASS+1
      JOCA=MIN(NOCA,IOCA+LPASS-1)
      NOCCA=JOCA-IOCA+1
      JOCB=MIN(NOCB,IOCB+LPASS-1)
      NOCCB=JOCB-IOCB+1
C
C     IF NOCCB IS GREATER THAN NOCCA, WE WILL GET INTO TROUBLE WITH THE
C     DIMENSIONS OF XPQRJ UNLESS WE CHANGE THE ORDER FOR NOCCB>NOCCA
C
      NOCC =NOCCA+NOCCB
      IF (NOCCA.GE.NOCCB) THEN
C
C     ------ COPY -ALPHA- AND -BETA- ORBITALS -----
C
      DO 10 I =1,NOCCA
      DO 10 MP=1,NUM
   10    X(MP,I      ) = CA(MP,IOCA+I-1)
C
      DO 20 I =1,NOCCB
      DO 20 MP=1,NUM
   20    X(MP,I+NOCCA) = CB(MP,IOCB+I-1)
C
C     ----- (PQ|RS) -> (PQ|RJ) -ALPHA- AND -BETA- -----
C
      CALL MP2C1(NFT,XPQRJ,XX,IX,X,NUM,NOCC,NDIM,
     *           GHONDO,XINTS,DDIJ,MAXG,NSH2)
C
C     ----- (PQ|RJ) -ALPHA- -> (AI|RJ) ALL -ALPHA- -----
C
      CALL UMPC2A(XPQRJ,CA,NUM,NOCA,NOCCA,NVIRA,NOCC,
     *            NDIM,NUM,X,Y)
C
C     ----- (AI|RJ) -ALPHA- -> (AI|BJ) ALL -ALPHA- -----
C
      CALL UMPS4A(XPQRJ,MOSIRA,X,Y,CA(1,NOCA+1),NOCA,NOCCA,NVIRA,
     *            NOCC,NDIM,NUM,IOCA)
C
C     ----- ENERGY CONTRIBUTION FROM CURRENT SET OF J -ALPHA- -----
C
      CALL UMPSE(EA,XPQRJ,NOCC,NDIM,NOCA,NVIRA,NOCCA,IOCA,E2A)
C
      IF(NOCCB.EQ.0) GO TO 200
C
C     ----- (PQ|RJ) -BETA- -> (AI|RJ) -ALPHA- AND -BETA- -----
C     ARRAY -XX- IS NOW USED FOR MATRIX MULTIPLICATION, NOT INT BUFFER
C
      CALL UMPC2B(XPQRJ,CA,CB,NUM,NOCA,NVIRA,NOCB,NVIRB,NDIM,NUM,
     *            NOCC,NOCCA,NOCCB,X,Y,XX)
C
C     ----- (AI|RJ) -> (AI|BJ) -ALPHA- AND -BETA- -----
C
      CALL UMPS4B(XPQRJ,MOSIRA,MOSIRB,X,Y,CB(1,NOCB+1),
     *            NOCA,NVIRA,NOCB,NVIRB,NUM,NDIM,NOCC,NOCCA,NOCCB,
     *            IOCB)
C
C     ----- ENERGY CONTRIBUTION FROM CURRENT SET OF J -ALPHA- -----
C
      CALL UMPSE(EB,XPQRJ(NOCCA+1),NOCC,NDIM,NOCB,NVIRB,NOCCB,IOCB,E2B)
C
C     ----- ENERGY CONTRIBUTION FROM CROSS TERM -----
C
      CALL UMPSEC(EA,EB,XPQRJ,NOCC,NOCA,NVIRA,NOCB,NVIRB,NDIM,NOCCB,
     *            IOCB,E2C)
C
      ELSE
C
C     NOW DO THE SAME PROCESS, BUT ADJUSTED FOR NOCCB>NOCCA
C     ------ COPY -ALPHA- AND -BETA- ORBITALS -----
C
      DO 110 I =1,NOCCB
      DO 110 MP=1,NUM
  110    X(MP,I      ) = CB(MP,IOCA+I-1)
C
      DO 120 I =1,NOCCA
      DO 120 MP=1,NUM
  120    X(MP,I+NOCCB) = CA(MP,IOCB+I-1)
C
C     ----- (PQ|RS) -> (PQ|RJ) -BETA- AND -ALPHA- -----
C
      CALL MP2C1(NFT,XPQRJ,XX,IX,X,NUM,NOCC,NDIM,
     *           GHONDO,XINTS,DDIJ,MAXG,NSH2)
C
C     ----- (PQ|RJ) -BETA- -> (AI|RJ) ALL -BETA- -----
C
      CALL UMPC2A(XPQRJ,CB,NUM,NOCB,NOCCB,NVIRB,NOCC,
     *            NDIM,NUM,X,Y)
C
C     ----- (AI|RJ) -BETA- -> (AI|BJ) ALL -BETA- -----
C
      CALL UMPS4A(XPQRJ,MOSIRB,X,Y,CB(1,NOCB+1),NOCB,NOCCB,NVIRB,
     *            NOCC,NDIM,NUM,IOCB)
C
C     ----- ENERGY CONTRIBUTION FROM CURRENT SET OF J -BETA- -----
C
      CALL UMPSE(EB,XPQRJ,NOCC,NDIM,NOCB,NVIRB,NOCCB,IOCB,E2B)
C
      IF(NOCCA.EQ.0) GO TO 200
C
C     ----- (PQ|RJ) -ALPHA- -> (AI|RJ) -ALPHA- AND -BETA- -----
C     ARRAY -XX- IS NOW USED FOR MATRIX MULTIPLICATION, NOT INT BUFFER
C
      CALL UMPC2B(XPQRJ,CB,CA,NUM,NOCB,NVIRB,NOCA,NVIRA,NDIM,NUM,
     *            NOCC,NOCCB,NOCCA,X,Y,XX)
C
C     ----- (AI|RJ) -> (AI|BJ) -ALPHA- AND -BETA- -----
C
      CALL UMPS4B(XPQRJ,MOSIRB,MOSIRA,X,Y,CA(1,NOCA+1),
     *            NOCB,NVIRB,NOCA,NVIRA,NUM,NDIM,NOCC,NOCCB,NOCCA,
     *            IOCA)
C
C     ----- ENERGY CONTRIBUTION FROM CURRENT SET OF J -ALPHA- -----
C
      CALL UMPSE(EA,XPQRJ(NOCCB+1),NOCC,NDIM,NOCA,NVIRA,NOCCA,IOCA,E2A)
C
C     ----- ENERGY CONTRIBUTION FROM CROSS TERM -----
C
      CALL UMPSEC(EB,EA,XPQRJ,NOCC,NOCB,NVIRB,NOCA,NVIRA,NDIM,NOCCA,
     *            IOCA,E2C)
C
      END IF
  200 CONTINUE
      IF(SOME) THEN
         CALL TSECND(TIM2)
         TIME = TIM2 - TIM1
         TIM1 = TIM2
         WRITE(IW,9020) IPASS,TIME
         CALL FLSHBF(IW)
      END IF
      IOCB = JOCB+1
      IOCA = JOCA+1
      IF(IOCA.LE.NOCA.OR.IOCB.LE.NOCB) GO TO 100
C
      E2 = E2A+E2B+E2C
      IF(SOME) WRITE(IW,9030)
      RETURN
C
 9020 FORMAT(1X,'PASS #',I4,' TOOK',F12.2,' SECONDS.')
 9030 FORMAT(1X,'DONE WITH PARTIAL TRANSFORMATION (PQ|RS) TO (IA|JB)')
      END
C
C*MODULE MP2     *DECK UMPS4A
      SUBROUTINE UMPS4A(XPQRJ,MOSIRA,X,Y,CVA,NOCA,NOCCA,NVIRA,NOCC,
     *                  NDIM,NUM,IOCA)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SYM2EI
C
      PARAMETER (ZERO=0.0D+00)
C
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
C
      DIMENSION XPQRJ(NOCC,NDIM,NUM),CVA(NUM,*),MOSIRA(*),
     *          X(NUM,*),Y(NUM,*)
C
C     ----- FORM (AI/BJ) -----
C     ----- SPIN CASE 1  :  A A A A -----
C
      IF(NIRRED.EQ.1) THEN
C
         MAI=0
         DO 30 MA=1,NVIRA
         DO 30 MI=1,NOCA
            MAI=MAI+1
C
            DO 10 MJ=1,NOCCA
            DO 10 MR=1,NUM
   10          X(MR,MJ)=XPQRJ(MJ,MAI,MR)
C
            CALL MRTRBR(CVA,NUM,NUM,NVIRA,X,NUM,NOCA,Y,NUM)
            DO 20 MB=1,NVIRA
            DO 20 MJ=1,NOCCA
   20          XPQRJ(MJ,MAI,MB)=Y(MB,MJ)
C
   30    CONTINUE
C
      ELSE
C
         MAI=0
         DO 130 MA=1,NVIRA
         DO 130 MI=1,NOCA
            MAI=MAI+1
C
            DO 110 MJ=1,NOCCA
            DO 110 MR=1,NUM
  110             X(MR,MJ)=XPQRJ(MJ,MAI,MR)
C
            DO 120 MJ=1,NOCCA
            DO 120 MB=1,NVIRA
            IF(SYM2EI(MOSIRA(MB+NOCA),MOSIRA(MJ+IOCA-1),
     *                MOSIRA(MA+NOCA),MOSIRA(MI))) THEN
               XPQRJ(MJ,MAI,MB) = DDOT(NUM,X(1,MJ),1,CVA(1,MB),1)
            ELSE
               XPQRJ(MJ,MAI,MB) = ZERO
            END IF
  120       CONTINUE
C
  130    CONTINUE
C
      END IF
C
      RETURN
      END
C
C*MODULE MP2     *DECK UMPS4B
      SUBROUTINE UMPS4B(XPQRJ,MOSIRA,MOSIRB,X,Y,CVB,NOCA,NVIRA,
     *                  NOCB,NVIRB,NUM,NDIM,NOCC,NOCCA,NOCCB,IOCB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (ZERO=0.0D+00)
C
      LOGICAL SYM2EI
C
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
C
      DIMENSION XPQRJ(NOCC,NDIM,*),CVB(NUM,*),
     *          MOSIRA(*),MOSIRB(*),X(NUM,*),Y(NUM,*)
C
C     ----- FORM (AI/BJ) -----
C
C
      IF(NIRRED.EQ.1) THEN
C
         MAI=0
         DO 50 MA=1,NVIRA
         DO 50 MI=1,NOCA
            MAI=MAI+1
C
C     ----- SPIN CASE 3  :  A A B B -----
C
            DO 30 MJ=1,NOCCB
            DO 30 MR=1,NUM
   30          X(MR,MJ)=XPQRJ(MJ,MAI,MR)
C
            CALL MRTRBR(CVB,NUM,NUM,NVIRB,X,NUM,NOCB,Y,NUM)
            DO 40 MB=1,NVIRB
            DO 40 MJ=1,NOCCB
   40          XPQRJ(MJ,MAI,MB)=Y(MB,MJ)
   50    CONTINUE
C
         MAI=0
         DO 80 MA=1,NVIRB
         DO 80 MI=1,NOCB
            MAI=MAI+1
C
C     ----- SPIN CASE 2  :  B B B B -----
C
         DO 60 MJ=1,NOCCB
         DO 60 MR=1,NUM
   60       X(MR,MJ)=XPQRJ(MJ+NOCCA,MAI,MR)
C
            CALL MRTRBR(CVB,NUM,NUM,NVIRB,X,NUM,NOCB,Y,NUM)
            DO 70 MB=1,NVIRB
            DO 70 MJ=1,NOCCB
   70          XPQRJ(MJ+NOCCA,MAI,MB)=Y(MB,MJ)
   80    CONTINUE
C
      ELSE
C
         MAI=0
         DO 150 MA=1,NVIRA
         DO 150 MI=1,NOCA
            MAI=MAI+1
C
C     ----- SPIN CASE 3  :  A A B B -----
C
            DO 130 MJ=1,NOCCB
            DO 130 MR=1,NUM
  130             X(MR,MJ)=XPQRJ(MJ,MAI,MR)
            DO 140 MJ=1,NOCCB
            DO 140 MB=1,NVIRB
               IF(SYM2EI(MOSIRB(MB+NOCB),MOSIRB(MJ+IOCB-1),
     *                   MOSIRA(MA+NOCA),MOSIRA(MI))) THEN
                  XPQRJ(MJ,MAI,MB) = DDOT(NUM,X(1,MJ),1,CVB(1,MB),1)
               ELSE
                  XPQRJ(MJ,MAI,MB) = ZERO
               END IF
  140       CONTINUE
  150    CONTINUE
C
         MAI=0
         DO 180 MA=1,NVIRB
         DO 180 MI=1,NOCB
            MAI=MAI+1
C
C     ----- SPIN CASE 2  :  B B B B -----
C
            DO 160 MJ =1,NOCCB
            DO 160 MR =1,NUM
  160          X(MR,MJ)=XPQRJ(MJ+NOCCA,MAI,MR)
            DO 170 MJ=1,NOCCB
            DO 170 MB=1,NVIRB
               IF(SYM2EI(MOSIRB(MB+NOCB),MOSIRB(MJ+IOCB-1),
     *                   MOSIRB(MA+NOCB),MOSIRB(MI))) THEN
                 XPQRJ(MJ+NOCCA,MAI,MB)=DDOT(NUM,X(1,MJ),1,CVB(1,MB),1)
               ELSE
                 XPQRJ(MJ+NOCCA,MAI,MB) = ZERO
            END IF
  170       CONTINUE
  180    CONTINUE
C
      END IF
C
      RETURN
      END
C
C*MODULE MP2     *DECK UMPSE
      SUBROUTINE UMPSE(EA,AIBJ,NOC,NDIM,NOCA,NVIRA,NOCCA,IOCA,E2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER(ZERO=0.0D+00,PT5=0.5D+00)
C
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
C
      DIMENSION EA(*),AIBJ(NOC,NDIM,*)
C
      E2A = ZERO
      MAI = 0
      DO 20 MA=1,NVIRA
      DO 20 MI=1,NOCA
         MAI = MAI+1
         DAI = EA(MA+NOCA)-EA(MI)
         DO 10 MB=1,MA
         MBI = MI+NOCA*(MB-1)
         DAIB = DAI+EA(MB+NOCA)
         DO 10 MJ=1,NOCCA
            DUM = AIBJ(MJ,MAI,MB)-AIBJ(MJ,MBI,MA)
            IF(ABS(DUM).LT.TOL) GO TO 10
            DAIBJ = DAIB-EA(MJ+IOCA-1)
            E2A = E2A-DUM**2/DAIBJ
   10    CONTINUE
   20 CONTINUE
      E2A = E2A*PT5
      E2  = E2+E2A
      RETURN
      END
C
C*MODULE MP2     *DECK UMPSEC
      SUBROUTINE UMPSEC(EA,EB,AIBJ,NOCC,NOCA,NVIRA,NOCB,NVIRB,
     *                  NDIM,NOCCB,IOCB,E2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER(ZERO=0.0D+00)
C
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
C
      DIMENSION EA(*),EB(*),AIBJ(NOCC,NDIM,*)
C
C     ----- SPIN CASE 3  :  A A B B -----
C     ----- SPIN CASE 4  :  B B A A -----
C     ----- SPIN CASE 5  :  A B B A -----
C     ----- SPIN CASE 6  :  B A A B -----
C
      E2C=ZERO
C
      MAI=0
      DO 30 MA=1,NVIRA
      DO 30 MI=1,NOCA
         MAI=MAI+1
         DAI=EA(MA+NOCA)-EA(MI)
         DO 20 MB=1,NVIRB
         DAIB=DAI+EB(MB+NOCB)
         DO 20 MJ=1,NOCCB
            XAIBJ=AIBJ(MJ,MAI,MB)
            IF(ABS(XAIBJ).LT.TOL) GO TO 20
            DAIBJ=DAIB-EB(MJ+IOCB-1)
            EAIBJ=XAIBJ**2/DAIBJ
            E2C=E2C-EAIBJ
   20    CONTINUE
   30 CONTINUE
      E2=E2+E2C
      RETURN
      END
C
C*MODULE MP2     *DECK UMP2O
      SUBROUTINE UMP2O(CA,CB,XPQRJ,X,Y,XX,IX,NUM,NDIM,NOC,
     *                 NOCA,NVIRA,NOCB,NVIRB,LPASS,IODA20,NFT,
     *                 NINTMX,NDAR20)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT,DBUG
C
      COMMON /MP2DAF/ IDAF20,NAV20
      COMMON /MP2PRT/ SOME,OUT,DBUG
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      DIMENSION CA(NUM,*),CB(NUM,*),XPQRJ(NOC,NDIM,LPASS),
     *          X(NUM,NUM),Y(NUM,NUM),XX(*),IX(NINTMX),IODA20(NDAR20)
C
      CALL TSECND(TIM1)
      IPASS= 0
C
C     ----- LOOP OVER PASSES OF -R- -----
C
      MINR=1
  100 MAXR=MIN(NUM,MINR+LPASS-1)
      NUMR=MAXR-MINR+1
      IPASS=IPASS+1
C
      DO 5 I=1,NOCA
      DO 5 MP=1,NUM
    5    X(MP,I     )=CA(MP,I)
      DO 6 I=1,NOCB
      DO 6 MP=1,NUM
    6    X(MP,I+NOCA)=CB(MP,I)
C
C     ----- FORM (PQ/RJ) = SUM OVER S OF (PQ/RS) * C(S,J) -----
C
      CALL MP2O1(NFT,XPQRJ,XX,IX,X,NUM,NOC,NDIM,
     *           MINR,MAXR,NUMR)
C
C     ----- FORM (PI/RJ) , AND THEN (AI/RJ) -----
C     ----- FOR -ALPHA- ONLY                -----
C
      CALL UMPC2A(XPQRJ,CA,NUM,NOCA,NOCA,NVIRA,NOC,NDIM,NUMR,
     *            X,Y)
C
C     ----- FORM (AI/BJ) -----
C     ----- SPIN CASE 1  -----
C
      MAI=0
      DO 40 MA=1,NVIRA
      DO 40 MI=1,NOCA
         MAI=MAI+1
C
         DO 10 MR=1,NUMR
         DO 10 MJ=1,NOCA
   10       X(MR,MJ)=XPQRJ(MJ,MAI,MR)
C
         MATMP = MA
         CALL MRTRBR(CA(MINR,NOCA+1),NUM,NUMR,MATMP,X,NUM,NOCA,Y,NUM)
         IF(MINR.NE.1) THEN
            CALL RAREAD(IDAF20,IODA20,X,NUM*NOCA,MAI,0)
            DO 20 MJ=1,NOCA
            DO 20 MB=1,MA
   20          Y(MB,MJ)=Y(MB,MJ)+X(MB,MJ)
         END IF
   40    CALL RAWRIT(IDAF20,IODA20,Y,NUM*NOCA,MAI,0)
C
C     ----- FORM (PI/RJ) , AND THEN (AI/RJ) -----
C     ----- FOR -BETA- ONLY                 -----
C     ARRAY -XX- IS NOW USED FOR MATRIX MULTIPLICATION, NOT INT BUFFER
C
      CALL UMPC2B(XPQRJ,CA,CB,NUM,NOCA,NVIRA,NOCB,NVIRB,
     *            NDIM,NUMR,NOC,NOCA,NOCB,X,Y,XX)
C
C     ----- FORM (AI|BJ) -----
C     ----- SPIN CASE 2  -----
C
      MAI1=NOCA*NVIRA
      MAI=0
      DO 140 MA=1,NVIRB
      DO 140 MI=1,NOCB
         MAI=MAI + 1
C
         DO 110 MR=1,NUMR
         DO 110 MJ=1,NOCB
  110       X(MR,MJ) =XPQRJ(MJ+NOCA,MAI,MR)
C
         MATMP = MA
         CALL MRTRBR(CB(MINR,NOCB+1),NUM,NUMR,MATMP,X,NUM,NOCB,Y,NUM)
         IF(MINR.NE.1) THEN
            CALL RAREAD(IDAF20,IODA20,X,NUM*NOCB,MAI+MAI1,0)
            DO 120 MJ=1,NOCB
            DO 120 MB=1,MA
  120          Y(MB,MJ)=Y(MB,MJ)+X(MB,MJ)
         END IF
  140 CALL RAWRIT(IDAF20,IODA20,Y,NUM*NOCB,MAI+MAI1,0)
C
C     ----- FORM (AI|BJ) -----
C     ----- SPIN CASE 3  -----
C
      MAI2=NVIRB*NOCB+MAI1
      MAI=0
      DO 240 MA=1,NVIRA
      DO 240 MI=1,NOCA
         MAI=MAI + 1
C
         DO 210 MR=1,NUMR
         DO 210 MJ=1,NOCB
  210       X(MR,MJ) =XPQRJ(MJ,MAI,MR)
C
         CALL MRTRBR(CB(MINR,NOCB+1),NUM,NUMR,NVIRB,X,NUM,NOCB,Y,NUM)
C
         IF(MINR.NE.1) THEN
            CALL RAREAD(IDAF20,IODA20,X,NUM*NOCB,MAI+MAI2,0)
            DO 220 MJ=1,NOCB
            DO 220 MB=1,NVIRB
  220          Y(MB,MJ)=Y(MB,MJ)+X(MB,MJ)
         END IF
  240 CALL RAWRIT(IDAF20,IODA20,Y,NUM*NOCB,MAI+MAI2,0)
C
C     ----- END OF LOOP OVER PASSES -----
C
      IF(SOME) THEN
         CALL TSECND(TIM2)
         TIME = TIM2 - TIM1
         TIM1 = TIM2
         WRITE(IW,9020) IPASS,TIME
         CALL FLSHBF(IW)
      END IF
      MINR=MAXR+1
      IF(MINR.LE.NUM) GO TO 100
C
      IF(SOME) WRITE(IW,9030)
      RETURN
C
 9020 FORMAT(1X,'PASS #',I4,' TOOK',F12.2,' SECONDS.')
 9030 FORMAT(1X,'DONE WITH PARTIAL TRANSFORMATION (PQ|RS) TO (IA|JB)')
      END
C*MODULE MP2     *DECK UMPOE1
      SUBROUTINE UMPOE1(E,AIBJ,EIJ,EI,MOSIRP,NUM,NOC,NVIR,
     *                 IODA20,ICASE,MAI1)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (ZERO=0.0D+00,PT5=0.5D+00)
C
      LOGICAL SOME,OUT,DBUG,SYM2EI
C
      DIMENSION E(*),AIBJ(NUM,NOC,NOC),EIJ(NOC,*),EI(*),MOSIRP(*),
     *          IODA20(*)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2ABM/ E2A,E2B,E2C
      COMMON /MP2DAF/ IDAF20,NAV20
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
      COMMON /MP2PRT/ SOME,OUT,DBUG
C
C     ----- SPIN CASE 1  :  A A A A    ICASE=0  -----
C                       OR
C     ----- SPIN CASE 2  :  B B B B    ICASE=1  -----
C
C     ----- CALCULATE E(2) AND ORBITAL-PAIR CONTRIBUTIONS TO E(2) -----
C
      E2=ZERO
      DO 10 MJ=1,NOC
      DO 10 MI=1,NOC
   10    EIJ(MI,MJ)=ZERO
C
      DO 50 MA=1,NVIR
         MAI=(MA-1)*NOC
         DO 20 MI=1,NOC
            MAI=MAI+1
   20       CALL RAREAD(IDAF20,IODA20,AIBJ(1,1,MI),NUM*NOC,MAI+MAI1,0)
         MAI=(MA-1)*NOC
         DO 40 MI=1,NOC
            DO 30 MB=1,MA
            DO 30 MJ=1,NOC
               IF(SYM2EI(MOSIRP(MJ),MOSIRP(MB+NOC),
     *                   MOSIRP(MI),MOSIRP(MA+NOC))) THEN
                  DUM=AIBJ(MB,MJ,MI)-AIBJ(MB,MI,MJ)
                  IF(ABS(DUM).LT.TOL) GO TO 30
                  DAIBJ=E(MA+NOC) + E(MB+NOC) - E(MI) - E(MJ)
                  EAIBJ=DUM**2/DAIBJ
                  E2=E2-EAIBJ
                  EAIBJ=EAIBJ*PT5
                  EIJ(MI,MJ)=EIJ(MI,MJ) - EAIBJ
                  EIJ(MJ,MI)=EIJ(MJ,MI) - EAIBJ
               END IF
   30       CONTINUE
   40    CONTINUE
   50 CONTINUE
C
      E2=E2*PT5
      IF(ICASE.EQ.0) E2A=E2
      IF(ICASE.EQ.1) E2B=E2+E2A
      IF(.NOT.OUT) RETURN
C
C     ----- PERFORM ENERGY CHECKS -----
C
      DO 70 MI=1,NOC
      DUM     =ZERO
      DO 60 MJ=1,NOC
      E2IJ    =EIJ(MI,MJ)
      IF(MJ.NE.MI) E2IJ=E2IJ*PT5
   60 DUM     =DUM+E2IJ
   70 EI(MI)  =DUM
      E2DUM   =ZERO
      DO 80 MI=1,NOC
   80 E2DUM   =E2DUM + EI(MI)
C
      IF(SOME) THEN
         IF(ICASE.EQ.0) WRITE(IW,9999) E2
         IF(ICASE.EQ.1) WRITE(IW,9995) E2
         WRITE(IW,9998) E2DUM
         WRITE(IW,9997)
         CALL PRSQ(EIJ,NOC,NOC,NOC)
         WRITE(IW,9996)
         CALL PRSQ(EI ,  1,NOC,  1)
      END IF
      RETURN
C
 9999 FORMAT(/,'SPIN CASE 1: A A A A             E(2) = ',F16.9)
 9998 FORMAT(/,' SUM OF ORBITAL CONTRIBUTIONS TO E(2) = ',F16.9)
 9997 FORMAT(/,'   ORBITAL-PAIR CONTRIBUTIONS TO E(2)',/,3X,34(1H-))
 9996 FORMAT(/,'        ORBITAL CONTRIBUTIONS TO E(2)',/,8X,29(1H-))
 9995 FORMAT(/,'SPIN CASE 2: B B B B             E(2) = ',F16.9)
      END
C
C*MODULE MP2     *DECK UMPOE2
      SUBROUTINE UMPOE2(EA,EB,AIBJ,EIJ,EI,E2,
     *        NBF,NOCA,NVIRA,NOCB,NVIRB,IODA20,MOSIA,MOSIB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT,DBUG,SYM2EI
C
      DIMENSION EA(*),EB(*),MOSIA(*),MOSIB(*),AIBJ(NBF,NOCB,NOCA),
     *          EIJ(NOCA,NOCA),EI(NOCA),IODA20(*)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2DAF/ IDAF20,NAV20
      COMMON /MP2PRT/ SOME,OUT,DBUG
      COMMON /MP2ABM/ E2A,E2B,E2C
C
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00)
C
C     ----- SPIN CASE 3  :  A A B B -----
C     ----- SPIN CASE 4  :  B B A A -----
C     ----- SPIN CASE 5  :  A B B A -----
C     ----- SPIN CASE 6  :  B A A B -----
C
C
C     ----- CALCULATE E(2) AND ORBITAL-PAIR CONTRIBUTIONS TO E(2) -----
C
      E2        =ZERO
      DO 10 MJ  =1,NOCA
      DO 10 MI  =1,NOCA
   10 EIJ(MI,MJ)=ZERO
C
      MAI     =0
      DO 50 MA=1,NVIRA
         DO 15 MI=1,NOCA
            MAI     =MAI + 1
            MAB     =MAI + NVIRA*NOCA + NVIRB*NOCB
            CALL RAREAD(IDAF20,IODA20,AIBJ(1,1,MI),NBF*NOCB,MAB,0)
   15    CONTINUE
         DO 40 MI=1,NOCA
            DO 30 MB=1,NVIRB
               DO 25 MJ=1,NOCB
                  IF(SYM2EI(MOSIB(MB+NOCB),MOSIB(MJ),
     *                      MOSIA(MA+NOCA),MOSIA(MI))) THEN
                     XAIBJ =AIBJ(MB,MJ,MI)
                     DAIBJ =EA(MA+NOCA) + EB(MB+NOCB) - EA(MI) - EB(MJ)
                     EAIBJ =(XAIBJ**2+XAIBJ**2+XAIBJ**2+XAIBJ**2)/DAIBJ
                     E2    =E2-EAIBJ
                     EAIBJ =EAIBJ*PT5*PT5
                     EIJ(MI,MJ)=EIJ(MI,MJ)-EAIBJ
                  END IF
   25          CONTINUE
   30       CONTINUE
   40    CONTINUE
   50 CONTINUE
C
      E2 =E2*PT5*PT5
      E2C=E2
      E2 =E2 + E2B
C
C     ----- PERFORM ENERGY CHECKS -----
C
      DO 70 MI=1,NOCA
      EI(MI)  =ZERO
      DUM     =ZERO
      DO 60 MJ=1,NOCB
      E2IJ    =EIJ(MI,MJ)
   60 DUM     =DUM+E2IJ
   70 EI(MI)  =DUM
      E2DUM   =ZERO
      DO 80 MI=1,NOCA
   80 E2DUM   =E2DUM+EI(MI)
C
      IF(SOME) THEN
         WRITE(IW,9999) E2C
         WRITE(IW,9998) E2DUM
         WRITE(IW,9997)
         CALL PRSQ(EIJ,NOCA,NOCA,NOCA)
         WRITE(IW,9996)
         CALL PRSQ(EI ,  1,NOCA,  1)
      END IF
      RETURN
C
 9999 FORMAT(/,' SPIN CASE 3+4+5+6:              E(2) = ',F16.9)
 9998 FORMAT(/,' SUM OF ORBITAL CONTRIBUTIONS TO E(2) = ',F16.9)
 9997 FORMAT(/,'   ORBITAL-PAIR CONTRIBUTIONS TO E(2)',/,3X,34(1H-))
 9996 FORMAT(/,'        ORBITAL CONTRIBUTIONS TO E(2)',/,8X,29(1H-))
      END
C*MODULE MP2     *DECK ZAPTEN
      SUBROUTINE ZAPTEN
C
C   THIS IS THE MAIN DRIVING PROGRAM FOR THE ZAPT MP2 ENERGY CALCULATION
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PACK2E,DIRSCF,FDIFF,ABEL,ABELPT,DIRTRF
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXGSH=30, MXG2=MXGSH*MXGSH,
     *           MXATM=2000, MXAO=8192)
C
      COMMON /CONV  / DENTOL,EN,ETOT,EHF,EHF0,DIFF,ITER,ICALP,ICBET
      COMMON /DIRMEM/ LPQRJ,IVEC,IDEN,IFCK,NUM,NOCC,NDIM,MINPQ,MAXPQ
      COMMON /DIRZPT/ LPASS,NJUMP
      COMMON /ENRGMP/ EMP2,EMP3,EMP4
      COMMON /FMCOM / X(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,MNUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NO,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PCKLAB/ LABSIZ
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TSYM(432),INVT(48),NT
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
      DATA CHECK/8HCHECK   /
C
C   ASK HOW MUCH MEMORY IS CURRENTLY AVAILABLE
C
      CALL GOTFM(NGOTMX)
C
C   SETTING INITIAL CONSTANTS
C
      NOCD = NOB - NACORE
      NOCS = NOA - NOB
      NOC  = NOCD + NOCS
      NVIR = NO - NOC - NACORE
      NORB = NO - NACORE
      WRITE(IW,9000) NACORE,NOCD,NOCS,NVIR
C
      NUM  = NBF
      NBF2 = (NBF*NBF + NBF)/2
      NBF3 = NBF*NBF
      NDIM = NBF2
C
      NMAXDS = MAX(NOCD,NOCS)
C
C        ---- OPTION TO DEFEAT SYMMETRY USAGE ----
C
      ABEL=ABELPT()
      IF(NOSYMT.EQ.1) CALL SYMOFF
C
C   ALLOCATION OF MEMORY FOR MOS AND ENERGIES
C
      CALL VALFM(LOADFM)
      IVEC   = 1    + LOADFM
      IENG   = IVEC + NBF*NBF
      ILAB   = IENG + NBF
      IIRP   = ILAB + NBF
      IDEG   = IIRP + NBF
      LAST   = IDEG + NBF
      NEEDA  = LAST - LOADFM - 1
      CALL GETFM(NEEDA)
C
C   MEMORY ALLOCATION FOR TEMPORARY USE OF MEMORY
C
      CALL VALFM(LOADFM)
      IWRK  = 1     + LOADFM
      LAST  = IWRK  + NBF3
      NEEDB = LAST  - LOADFM - 1
      CALL GETFM(NEEDB)
C
C   SUBTRACTING OUT CORE MOS
C   FIRST MUST READ IN MOS AND ORBITAL ENERGIES
C
      CALL DAREAD(IDAF,IODA,X(IWRK),NBF3,15,0)
      CALL DAREAD(IDAF,IODA,X(IENG),NBF ,17,0)
C
      MAXC = IDAMAX(NBF*NQMT,X(IWRK),1)
      IF(ABS(X(IWRK+MAXC-1)).GT.1.0D+02) THEN
         MAXM = 1 + MAXC/NUM
         MAXA = MAXC - NUM*(MAXM-1)
         WRITE(IW,9002) ABS(X(IWRK+MAXC-1)),MAXA,MAXM
      END IF
C
      DO 100 I = 1, NUM
         X(I + IENG - 1) = X(I + IENG + NACORE - 1)
         DO 110 J = 1, NBF
            X(J+IVEC+NBF*(I-1)-1) = X(J+NBF*(I-1+NACORE)+IWRK-1)
  110    CONTINUE
  100 CONTINUE
      CALL RETFM(NEEDB)
C
C     ----- ASSIGN -IRREP- LABEL TO MO'S -----
C
      CALL VALFM(LOADFM)
      IWRK  = 1     + LOADFM
      IWRK2 = IWRK  + NBF2
      IWRK3 = IWRK2 + NBF3
      LAST  = IWRK3 + NBF
      NEEDB = LAST  - LOADFM - 1
      CALL GETFM(NEEDB)
      IF(EXETYP.EQ.CHECK) GO TO 150
C
      CALL DAREAD(IDAF,IODA,X(IWRK),NBF2,12,0)
      CALL DAREAD(IDAF,IODA,X(IWRK2),NBF3,45,0)
      CALL TRFSYM(X(ILAB),X(IIRP),X(IDEG),X(IWRK2),X(IWRK),
     *            X(IVEC),X(IWRK3),IA,NQMT,NBF,NORB,NBF)
C
  150 CONTINUE
      CALL RETFM(NEEDB)
C
      NTSAVE = NT
      IF(DIRSCF  .AND.  .NOT.ABEL) NT=1
C
C   MEMORY ALLOCATION FOR 2 ELECTRON INTEGRAL STORAGE IN AO BASIS
C   NOTE: THIS IS ONLY FOR A CONVENTIONAL CALCULATION - THE DIRECT
C   CALCULATION IS COMING!
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      IF(LMAX.EQ.5) NANGM = 21
      IF(LMAX.EQ.6) NANGM = 28
      MAXG = NANGM**4
      NSH2 = (NSHELL*NSHELL+NSHELL)/2
C
      CALL VALFM(LOADFM)
      IF(DIRSCF) THEN
         WRITE(IW,9004)
         LGHND  = 1      + LOADFM
         LXINTS = LGHND  + MAXG
         LDDIJ  = LXINTS + NSH2
         LXX    = LDDIJ  + 49*MXG2
         LIX    = LXX    + NINTMX
         LAST   = LIX    + NINTMX*LABSIZ
      ELSE
         WRITE(IW,9005)
         LGHND  = 1      + LOADFM
         LXINTS = LGHND
         LDDIJ  = LXINTS
         LXX    = LDDIJ
         LIX    = LXX    + NINTMX
         LAST   = LIX    + NINTMX*LABSIZ
      ENDIF
      NEEDB = LAST - LOADFM - 1
      CALL GETFM(NEEDB)
      IF(NINTIC.NE.0) THEN
         WRITE(6,*) 'IN CORE INTEGRALS NOT CODED YET. SET NINTIC=0'
         CALL ABRT
      ENDIF
C
      IF(DIRSCF) THEN
         IF(EXETYP.EQ.CHECK) THEN
            CALL VCLR(X(LXINTS),1,NSH2)
         ELSE
            IF(ISCHWZ.EQ.1) THEN
               CALL DAREAD(IDAF,IODA,X(LXINTS),NSH2,54,0)
            ELSE
               CALL DCOPY(NSH2,1.0D+01,0,X(LXINTS),1)
            END IF
         END IF
      END IF
C
C   MEMORY ALLOCATION OF INTEGRAL STORAGE ARRAYS
C
C   THE TYPES OF INTEGRALS THAT MUST BE FORMED FOR THE EVALUATION
C   OF ENERGY TERMS REQUIRING DOUBLY OCCUPIED MOS
C
C             (MJ,MAI,MB)
C             (MJ,MXI,MB)
C             (MJ,MXI,MY)      TO BE STORED IN
C             (MJ,MAX,MY) ---------------------------> X(PQRJ)
C             (MJ,MAX,MX)      GENERIC ARRAY
C             (MJ,MAX,MB)
C             (MY,MAX,MB)
C
C   INTEGRAL TYPE TO BE USED IN ALL OTHER ENERGY TERMS
C
C                            THIS ARRAY MUST BE KEPT
C             (MY,MXY,MX) ---------------------------> X(LSINGS)
C                            FOR MANY ENERGY TERMS
C
C   MAX AND MIN MEMORY ALLOCATION FOR X(LSINGS) ARRAY
C
      NSNGMX = NOCS*(NOCS*NOCS)*NBF
C
      CALL GOTFM(NGOTMX)
      NEED  = 2*NBF3 + NSNGMX
      LEFT  = NGOTMX - NEED
C
C   MAX AND MIN MEMORY ALLOCATION FOR X(LPQRJ) ARRAY
C
      NMAX  = NMAXDS*NDIM*NBF
      NMIN  =  NOCS *NDIM*NBF
C
C   REPORT OF TOTAL MEMORY REQUIRED TO COMPLETE CALCULATION
C
      MNMEM = NEEDA + NEEDB + NEED + NMIN
      MXMEM = NEEDA + NEEDB + NEED + NMAX
      WRITE(IW,9010) MNMEM,MXMEM
C
      IF(NMIN .GT. LEFT) THEN
         WRITE(IW,9020) MNMEM,NGOTMX
         CALL ABRT
      ENDIF
C
C   CALCULATION OF THE NUMBER OF PASSES FOR DOUBLY OCCUPIED MOS
C
      LPASS = MIN(NMAXDS,LEFT/(NDIM*NBF))
      NPASS = (NMAXDS + LPASS - 1)/LPASS
      LPASS = (NMAXDS + NPASS - 1)/NPASS
C
C   THE LARGER REQUIREMENT WILL DICTATE THE SIZE OF X(LPQRJ)
C
      CALL VALFM(LOADFM)
      LWRK1   = 1      + LOADFM
      LWRK2   = LWRK1  + NBF3
      LPQRJ   = LWRK2  + NBF3
      LSINGS  = LPQRJ  + LPASS*NDIM*NBF
      LAST    = LSINGS + NSNGMX
      NEEDC   = LAST   - LOADFM - 1
      CALL GETFM(NEEDC)
C
      IMEM = NEEDA + NEEDB + NEEDC
      WRITE(IW,9030) IMEM
C
C   CALL OF MAIN DRIVING PROGRAM THAT CALL TRANSFORMATION ROUTINES
C   AND ENERGY EVALUATION ROUTINES
C
      IF(EXETYP.EQ.CHECK) GOTO 1000
C
      CALL ZAPTS(NBF,NDIM,NOCD,NOCS,NVIR,LPASS,NPASS,NINTMX,IJK,
     *           EZAPT,E1,E2,E3,E4,E5,E6,E7,
     *           MAXG,NSH2,X(LGHND),X(LXINTS),X(LDDIJ),
     *           X(LIX),X(LXX),X(IENG),X(IVEC),X(IIRP),
     *           X(LWRK1),X(LWRK2),X(LPQRJ),X(LSINGS))
C
C   PRINTING ENERGY TERM BY TERM
C
      WRITE(IW,9041) 1,E1
      WRITE(IW,9042) 2,E2
      WRITE(IW,9043) 3,E3
      WRITE(IW,9044) 4,E4
      WRITE(IW,9045) 5,E5
      WRITE(IW,9046) 6,E6
      WRITE(IW,9047) 7,E7
      WRITE(IW,9049)
      WRITE(IW,9050) EZAPT
C
C   THE TOTAL ENERGY IS (EHF + EN + EZAPT)
C                          \   /
C                       (  ETOT   + EZAPT)
C
      E = ETOT + EZAPT
      EMP2 = E
C
      WRITE(IW,9060)
      WRITE(IW,9070) ETOT
      WRITE(IW,9080) EZAPT
      WRITE(IW,9090)
      WRITE(IW,9100) E
C
 1000 CONTINUE
C
      CALL RETFM(NEEDC)
      CALL RETFM(NEEDB)
      CALL RETFM(NEEDA)
C
      NT = NTSAVE
      IF(NOSYMT.EQ.1) CALL SYMON
      RETURN
C
 9000 FORMAT(/1X,31('-'),5X,29(1H-)/
     *       1X,'2ND-ORDER ZAPT SINGLE POINT MP2',5X,
     *          'PROGRAM WRITTEN BY R. L. BELL'/
     *       1X,31('-'),5X,29(1H-)/
     *       1X,'NUMBER OF CORE MOS=',I4,/
     *       1X,'NUMBER OF DOUBLY OCCUPIED MOS=',I5,/
     *       1X,'NUMBER OF SINGLY OCCUPIED MOS=',I5,/
     *       1X,'NUMBER OF VIRTUAL MOS=',I5)
 9002 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-7 FDIFF=.FALSE.'/
     *        1X,' $MP2    CUTOFF=1D-10 (OR 11)'/)
 9004 FORMAT(/1X,'THIS IS A DIRECT CALCULATION')
 9005 FORMAT(/1X,'THIS IS A CONVENTIONAL CALCULATION')
 9010 FORMAT(/1X,'MEMORY REQUIREMENTS FOR ZAPT TRANSFORMATIONS'/
     *        1X,'  MINIMUM=',I15,' WORDS FOR 1 MOLECULAR ORBITAL',
     *           ' PER PASS'/
     *        1X,'  MAXIMUM=',I15,' WORDS FOR MAKING ONLY 1 INTEGRAL',
     *           ' PASS'/)
 9020 FORMAT(/1X,'THERE IS INSUFFICIENT MEMORY TO RUN THE SEGMENTED',
     *       1X,'INTEGRAL TRANSFORMATION.'/
     *       1X,'REQUIRED MEMORY=',2I15,'WORDS',/
     *       1X,'AVAILABLE MEMORY=',2I15,' WORDS')
 9030 FORMAT(1X,'  TOTAL MEMORY USED = ',I15/)
 9041 FORMAT(8X,'E',I1,' = ',F13.10,3X,'CLOSED SHELL-LIKE TERM')
 9042 FORMAT(8X,'E',I1,' = ',F13.10,3X,'SINGLY UNOCCUPIED')
 9043 FORMAT(8X,'E',I1,' = ',F13.10,3X,'2 SINGLY OCCUPIED')
 9044 FORMAT(8X,'E',I1,' = ',F13.10,3X,'SINGLY UNOCCUPIED/OCCUPIED')
 9045 FORMAT(8X,'E',I1,' = ',F13.10,3X,'"FOCK MATRIX CONTRIBUTION"')
 9046 FORMAT(8X,'E',I1,' = ',F13.10,3X,'SINGLY OCCUPIED')
 9047 FORMAT(8X,'E',I1,' = ',F13.10,3X,'2 SINGLY UNOCCUPIED')
 9049 FORMAT(3X,23('-'))
 9050 FORMAT(3X,'E(ZAPT) = ',F13.10/)
 9060 FORMAT(1X,'RESULTS OF 2ND-ORDER ZAPT CORRECTION')
 9070 FORMAT(1X,10X,'E(HF)   = ',F20.10)
 9080 FORMAT(1X,10X,'E(ZAPT) = ',F20.10)
 9090 FORMAT(1X,5X,35(1H-))
 9100 FORMAT(1X,10X,'E(MP2)  = ',F20.10/)
      END
C*MODULE MP2     *DECK ZAPTS
      SUBROUTINE ZAPTS(NBF,NDIM,NOCD,NOCS,NVIR,LPASS,NPASS,NINTMX,IJK,
     *                 EZAPT,E1,E2,E3,E4,E5,E6,E7,
     *                 MAXG,NSH2,GHONDO,XINTS,DDIJ,
     *                 IX,XX,E,C,MOSIRP,X,Y,XPQRJ,XSINGS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION E(*),C(NUM,*),X(*),Y(*),XPQRJ(*)
      DIMENSION XSINGS(*),IX(NINTMX),XX(NINTMX),MOSIRP(*)
      DIMENSION GHONDO(MAXG),XINTS(NSH2),DDIJ(*)
C
      COMMON /IOFILE/ IR,IW,IP,IK,IPK,IDAF,NAV,IODA(950)
      COMMON /DIRMEM/ IPQKL,IVEC,IDEN,IFCK,NUM,NOCC,NNNDIM,MINPQ,MAXPQ
C
      PARAMETER (ZERO = 0.0D+00)
C
      E1 = ZERO
      E2 = ZERO
      E3 = ZERO
      E4 = ZERO
      E5 = ZERO
      E6 = ZERO
      E7 = ZERO
      J0 = 1
      WRITE(IW,8000)
      CALL TSECND(TIM1)
C
C     ----- CALCULATE THE ALL SINGLES TEIS -----
C
      CALL SINGS(NINTMX,NBF,NDIM,IJK,NOCD,NOCS,
     *           LPASS,MAXG,NSH2,J0,IX,XX,GHONDO,
     *           XINTS,DDIJ,C,X,Y,XPQRJ,XSINGS,MOSIRP)
C
      CALL TSECND(TIM2)
      TIME = TIM2 - TIM1
      WRITE(IW,8001) TIME
C
C     ----- LOOP OVER NUMBER OF PASSES FOR THE SINGLY OCCUPIED
C           MOS AND EVALUATION OF THE ASSOCIATED ENERGY TERM
C
C     THE ZAPT CALCULATION REQUIRES THE EVALUATION OF SEVEN TERMS
C
C     E(MP2) = E1 + E2 + E3 + E4 + E5 + E6 + E7
C
      WRITE(IW,8005)
      CALL TSECND(TIM1)
      CALL MP2ZT7(NBF,NOCS,NDIM,NVIR,NOCD,
     *            J0,LPASS,C,X,Y,XPQRJ,
     *            XSINGS,E,MOSIRP,E7)
C
      CALL TSECND(TIM2)
      TIME = TIM2 - TIM1
      WRITE(IW,8006) TIME
C
      WRITE(IW,9002) LPASS,NPASS
C
      J0 = 1
      CALL TSECND(TIM1)
C
C     ----- LOOP OVER NUMBER OF PASSES FOR THE SINGLY OCCUPIED
C           MOS AND ENERGY EVALUATIONS
C
C     ----- FOR ALL  J = J0, ..., J0+NOCC-1 -----
C
      DO 200 IPASS = 1, NPASS
         NOCC = MIN(NOCD,J0 + LPASS - 1) - J0 + 1
C
C     THE ZAPT CALCULATION REQUIRES THE EVALUATION OF SEVEN TERMS
C
C     E(MP2) = E1 + E2 + E3 + E4 + E5 + E6 + E7
C
         CALL MP2ZRT(NINTMX,NBF,NDIM,NSH2,MAXG,IJK,
     *               LPASS,NOCC,J0,NOCD,NOCS,NVIR,
     *               XPQRJ,IX,XX,GHONDO,XINTS,DDIJ,
     *               E1,E2,E3,E4,E5,E6,E,C,X,Y,MOSIRP,XSINGS)
C
         CALL TSECND(TIM2)
         TIME = TIM2-TIM1
         TIM1 = TIM2
         WRITE(IW,9021) IPASS,TIME
         CALL FLSHBF(IW)
         J0 = J0 + NOCC
  200 CONTINUE
C
      EZAPT = E1 + E2 + E3 + E4 + E5 + E6 + E7
      RETURN
C
 8000 FORMAT(1X,'START TRANSFORMATION OF ALL-SINGLES INTEGRALS')
 8001 FORMAT(5X,'TIME FOR ALL-SINGLES TRANSFORMATION TOOK',
     *       F12.2,' SECONDS.')
 8005 FORMAT(/1X,'START EVALUATION OF TERM 7 INTEGRALS AND ENERGY')
 8006 FORMAT(5X,'TIME FOR TERM 7 TOOK',F12.2,' SECONDS.'/)
 9002 FORMAT(1X,'START OF PASSES OVER DOUBLY OCCUPIED MOS',/
     *       1X,'   NUMBER OF MOS/PASS = ',I4,/
     *       1X,'   NUMBER OF PASSES   = ',I4)
 9021 FORMAT(1X,'CLOSED-SHELL PASS #',I4,' TOOK',F12.2,' SECONDS.'/)
      END
C*MODULE MP2     *DECK SINGS
      SUBROUTINE SINGS(NINTMX,NBF,NDIM,IJK,NOCD,NOCS,
     *                 LPASS,MAXG,NSH2,J0,IX,XX,GHONDO,
     *                 XINTS,DDIJ,C,X,Y,XPQRJ,XSINGS,MOSIRP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION C(NBF,*),X(*),Y(*),XPQRJ(*),MOSIRP(*)
      DIMENSION XSINGS(*),IX(*),XX(*)
      DIMENSION GHONDO(MAXG),XINTS(NSH2),DDIJ(*)
C
C     ----- THIS IS THE START OF THE FORMATION OF (MY,MPQ,MR)
C            OR (PQ|RY) INTEGRALS
C
      CALL MP2ZJ(NINTMX,NBF,NOCS,IJK,NDIM,LPASS,NOCD,
     *           C(1,J0 + NOCD),XPQRJ,IX,XX,GHONDO,
     *           XINTS,DDIJ,MAXG,NSH2)
C
C     ----- FORM (WZ|RY) FOR ALL SINGLY OCCUPIED MOS FROM
C           (PQ|RJ) AND STORED IN XSINGS
C
      CALL MP2Z23(NBF,NDIM,NOCS,NOCS,NOCS,NBF,NBF,NOCS,
     *            NOCS,NOCS,NOCD,NOCD,0,NOCS,NOCS,NOCS,LPASS,
     *            C,X,Y,XPQRJ,XSINGS)
C
C     ----- COMPLETE BY FORMING (WZ|XY) FROM (WZ|RY) - WILL BE
C           STORED IN XSINGS
C
      CALL MP2Z4(J0,NBF,NOCS,NOCS,NOCS,NBF,NOCS,NOCS,NOCS,NOCS,
     *           NOCD,0,NOCS,NOCS,NOCD,0,NOCD,0,
     *           NOCD,0,NOCD,NOCD,0,0,
     *           C,X,Y,XSINGS,MOSIRP)
      RETURN
      END
C*MODULE MP2     *DECK MP2ZT7
      SUBROUTINE MP2ZT7(NBF,NOCS,NDIM,NVIR,NOCD,
     *                  J0,LPASS,C,X,Y,XPQRJ,
     *                  XSINGS,E,MOSIRP,E7)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION C(NBF,*),X(*),Y(*),XPQRJ(*),MOSIRP(*)
      DIMENSION XSINGS(*),E(*)
C
C     ----- FORM (AX|RY) FOR ALL DOUBLY AND SINGLY OCCUPIED
C           MOS - FORMED FROM (PQ|RJ)
C
      CALL MP2Z23(NBF,NDIM,LPASS,NDIM,1,NBF,NBF,NOCS,
     *            NVIR,NOCS,NOCD,NOCD,NOCS,NOCS,NVIR,NOCS,LPASS,
     *            C,X,Y,XPQRJ,XPQRJ)
C
C     ----- FORM (AX|BY) FOR ALL DOUBLY AND SINGLY OCCUPIED
C           MOS - FORMED FROM (AX|RY)
C
      CALL MP2Z4(J0,NBF,LPASS,NDIM,1,NBF,NOCS,NVIR,NOCS,NVIR,
     *           NOCD,NOCS,NVIR,NOCS,NOCD,NOCS,NOCD,0,
     *           NOCS,NOCD,NOCD,NOCD,NOCS,NOCS+NOCD,
     *           C,X,Y,XPQRJ,MOSIRP)
C
C     EVALUATION OF THE ENERGY
C
      CALL MP2ZE2(J0,NVIR,NOCS,NVIR,NOCS,NOCS,NOCD,NOCD,NOCD,
     *            LPASS,NDIM,NBF,NOCS,NOCS*NOCS,NBF,NOCS,
     *            E,XPQRJ,XSINGS,E7,1)
C
      RETURN
      END
C*MODULE MP2     *DECK MP2ZRT
      SUBROUTINE MP2ZRT(NINTMX,NBF,NDIM,NSH2,MAXG,IJK,
     *                  LPASS,NOCC,J0,NOCD,NOCS,NVIR,
     *                  XPQRJ,IX,XX,GHONDO,XINTS,DDIJ,
     *                  E1,E2,E3,E4,E5,E6,E,
     *                  C,X,Y,MOSIRP,XSINGS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION XPQRJ(*),IX(*),XX(*),GHONDO(*),XINTS(*),DDIJ(*)
      DIMENSION E(*),C(NBF,*),X(*),Y(*),MOSIRP(*),XSINGS(*)
C
      CALL MP2ZJ(NINTMX,NBF,NOCC,IJK,NDIM,LPASS,J0-1,
     *           C(1,J0),XPQRJ,IX,XX,GHONDO,
     *           XINTS,DDIJ,MAXG,NSH2)
C
C     ----- FORM ((NOCS+NVIR)(NOCD+NOCS)|RJ) FOR ALL DOUBLY
C           OCCUPIED AND VIRTUAL MOS -----
C
      CALL MP2Z23(NBF,NDIM,LPASS,NDIM,1,NBF,NBF,NOCC,
     *            NOCS+NVIR,NOCD+NOCS,0,NOCD,0,NOCD+NOCS,NOCS+NVIR,
     *            NOCD+NOCS,LPASS,
     *            C,X,Y,XPQRJ,XPQRJ)
C
C     ----- FORM (AI|BJ) FOR ALL VIRTUAL MOS
C
      CALL MP2Z4(J0,NBF,LPASS,NDIM,1,NBF,NOCC,NOCS+NVIR,
     *           NOCD+NOCS,NOCS+NVIR,
     *           NOCD,0,NOCS+NVIR,NOCD,NOCD,0,0,0,
     *           NOCD,0,0,NOCD,0,NOCD,
     *           C,X,Y,XPQRJ,MOSIRP)
C
C     ----- EVALUATION OF ENERGY FOR FIRST TERM ENERGY --> E1
C
      CALL MP2ZE(E,XPQRJ,E1,J0,NOCD,NVIR,NOCC,NDIM,
     *           NOCD,NOCS,LPASS,NBF,NOCS,NOCD+NOCS)
C
C     ----- EVALUATION OF ENERGY FOR SECOND TERM ENERGY --> E2
C
      CALL MP2ZE1(J0,NOCS,NOCD,NVIR,NOCC,0,NOCD,NOCS,NOCD,0,0,
     *            LPASS,NDIM,NBF,NOCS,NOCS*NOCS,NBF,
     *            NOCS,E,XPQRJ,XSINGS,E2)
C
C     ----- EVALUATION OF ENERGY FOR THIRD TERM ENERGY --> E3
C
      CALL MP2ZE2(J0,NOCS,NOCD,NOCS,NOCC,NOCD,0,0,0,
     *            LPASS,NDIM,NBF,NOCS,NOCS*NOCS,NBF,
     *            NOCS,E,XPQRJ,XSINGS,E3,0)
C
C     ----- EVALUATION OF ENERGY FOR FOURTH TERM ENERGY --> E4
C
      CALL MP2ZE3(J0,NVIR,NOCS,NOCS,NOCC,NOCD,NOCS,0,
     *            LPASS,NDIM,NBF,NOCS,NOCS*NOCS,NBF,
     *            NOCS,E,XPQRJ,XSINGS,E4)
C
C     ----- EVALUATION OF ENERGY FOR FIFTH TERM ENERGY --> E5
C
      CALL MP2ZE4(J0,NVIR,NOCS,NOCS,NOCC,NOCS,NOCD,LPASS,NDIM,NBF,
     *            E,XPQRJ,E5)
C
C     ----- EVALUATION OF ENERGY FOR SIXTH TERM ENERGY --> E6
C
      CALL MP2ZE1(J0,NVIR,NOCS,NVIR,NOCC,NOCD,NOCS,NOCD,NOCS,NOCD,1,
     *            LPASS,NDIM,NBF,NOCS,NOCS*NOCS,NBF,
     *            NOCS,E,XPQRJ,XSINGS,E6)
      RETURN
      END
C*MODULE MP2     *DECK MP2ZJ
      SUBROUTINE MP2ZJ(NINTMX,NBF,NOC,NFT8,NDIMM,LPSS,NSKIP,
     *                 C,XPQRJ,IX,XX,GHONDO,XINTS,DDIJ,MAXG,NSH2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,FDIFF,DIRTRF
C
      DIMENSION C(NBF,*),XPQRJ(LPSS,NDIMM,NBF),IX(NINTMX),XX(NINTMX)
      DIMENSION GHONDO(MAXG),XINTS(NSH2),DDIJ(*)
C
      COMMON /DIRCAS/ I2CASE
      COMMON /DIRMEM/ LPQRJ,IVEC,IDEN,IFCK,NUM,NOCC,NDIM,MINPQ,MAXPQ
      COMMON /DIRZPT/ LPASS,NJUMP
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
C   DISK BASED OR CONVENTIONAL TRANSFORMATION
C
      CALL VCLR(XPQRJ,1,LPSS*NDIM*NBF)
C
C     ----- DIRECT MP2 -----
C
      IF(DIRSCF) THEN
         NJUMP  = NSKIP
         I2CASE = 6
         NOCC   = NOC
         DIRTRF =.TRUE.
         CALL DIRJK(GHONDO,XINTS,DDIJ,XX,IX,MAXG,NSH2)
C
C     ----- DISK BASED -----
C
      ELSE
         CALL SEQREW(NFT8)
  10     CALL PREAD(NFT8,XX,IX,NXX,NINTMX)
         IF(NXX.EQ.0) RETURN
         NINT=IABS(NXX)
         IF(NINT.GT.NINTMX) THEN
            CALL ABRT
         END IF
C
C   ----- (PQ|RS) TO (PQ|RJ) TRANSFORMATION FOR ALL DOUBLY OCCUPIED
C         AND SINGLY OCCUPIED MOS
C
         CALL FRSTTR(XPQRJ,C,NDIMM,NBF,NOC,XX,IX,NXX,LPSS)
         IF(NXX.GT.0) GOTO 10
      ENDIF
C
      RETURN
      END
C*MODULE MP2     *DECK MP2Z23
C      CALL       MP2Z23(NBF,NDIM,LPASS,NDIM,1,NBF,NBF,NOCS,
C     *                  NVIR,NOCS,NOCD,NOCD,NOCS,NOCS,NVIR,NOCS,LPASS,
C     *                  C,X,Y,XPQRJ,XPQRJ)
      SUBROUTINE MP2Z23(NBF,NDIM,NPAR1,NPAR21,NPAR22,NPAR3,NR,N1,
     *                  N2,N3,NMO1,NMO21,NMO22,NVAR1,NVAR2,NVAR3,LPASS,
     *                  C,X,Y,XPQRJ,XTEMP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION C(NBF,*),XPQRJ(LPASS,NDIM,NBF),X(NBF,NBF),Y(NBF,NBF)
      DIMENSION XTEMP(NPAR1,NPAR21*NPAR22,NPAR3)
C
      DO 100 MR = 1, NR
      DO 120 M1 = 1, N1
         CALL VCLR(X,1,NBF*NBF)
         CALL VCLR(Y,1,NBF*NBF)
         MPQ = 0
         DO 130 MP = 1, NBF
            DO 140 MQ = 1, MP
               MPQ = MPQ + 1
               X(MP,MQ) = XPQRJ(M1,MPQ,MR)
               X(MQ,MP) = X(MP,MQ)
  140       CONTINUE
  130    CONTINUE
C
         CALL MRARBR(X,NBF,NBF,NBF,C(1,NMO1 + 1),NBF,NVAR1,Y,NBF)
         CALL MRTRBR(C(1,NMO21 + NMO22 + 1),NBF,NBF,NVAR2,Y,NBF,
     *               NVAR3,X,NBF)
         M23 = 0
         DO 150 M2 = 1, N2
            DO 160 M3 = 1, N3
               M23 = M23 + 1
               XTEMP(M1,M23,MR) = X(M2,M3)
  160       CONTINUE
  150    CONTINUE
C
  120 CONTINUE
  100 CONTINUE
C
      RETURN
      END
C*MODULE MP2     *DECK MP2Z4
      SUBROUTINE MP2Z4(J0,NBF,NPAR1,NPAR21,NPAR22,NPAR3,N1,  N2,
     *                 N3,       N4,
     *                 NMO11,NMO12,NVAR1,NVAR2,NVAR3,NVAR4,NVAR5,NVAR6,
     *                 NVAR7,NVAR8,NVAR9,NVAR10,NVAR11,NJUMP,
     *                 C,X,Y,XTEMP,MOSIRP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SYM2EI
C
      DIMENSION C(NBF,*),X(NBF,NBF),Y(NBF,NBF),MOSIRP(*)
      DIMENSION XTEMP(NPAR1,NPAR21*NPAR22,NPAR3)
C
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
C
      PARAMETER (ZERO = 0.0D+00)
C
C     ----- FORM (AI|BJ) FOR CURRENT BATCH OF J -----
C
      IF(NIRRED .EQ. 1) THEN
         M23 = 0
         DO 100 M2 = 1, N2
            DO 200 M3 = 1, N3
               M23 = M23 + 1
               DO 150 M1 = 1, N1
                  DO 160 MR = 1, NBF
                     X(MR,M1) = XTEMP(M1,M23,MR)
 160              CONTINUE
 150           CONTINUE
               CALL MRTRBR(C(1,NMO11 + NMO12 + 1),NBF,NBF,NVAR1,X,
     *                     NBF,NVAR2,Y,NBF)
               DO 250 M4 = 1, N4
                  DO 300 M1 = 1, N1
                     XTEMP(M1,M23,M4+NJUMP) = Y(M4,M1)
 300              CONTINUE
 250           CONTINUE
 200        CONTINUE
 100     CONTINUE
      ELSE
         M23 = 0
         DO 400 M2 = 1, N2
            M2SYM = MOSIRP(M2+NVAR3+NVAR4)
            DO 500 M3 = 1, N3
               M3SYM = MOSIRP(M3 + NVAR5 + NVAR6)
               M23 = M23 + 1
               DO 600 M1 = 1, N1
                  DO 700 MR = 1, NBF
                     X(MR,M1) = XTEMP(M1,M23,MR)
 700              CONTINUE
 600           CONTINUE
               DO 800 M1 = 1, N1
                  M1SYM = MOSIRP(M1 + NVAR9 + J0 - 1)
                  DO 900 M4 = 1, N4
                     M4SYM = MOSIRP(M4 + NVAR7 + NVAR8)
                     IF(SYM2EI(M4SYM,M1SYM,M2SYM,M3SYM)) THEN
                        XTEMP(M1,M23,M4+NJUMP) =
     *                     DDOT(NBF,C(1,M4+NVAR10+NVAR11),1,X(1,M1),1)
                     ELSE
                        XTEMP(M1,M23,M4+NJUMP) = ZERO
                     ENDIF
 900              CONTINUE
 800           CONTINUE
 500        CONTINUE
 400     CONTINUE
      ENDIF
C
      RETURN
      END
C*MODULE MP2     *DECK MP2ZE
      SUBROUTINE MP2ZE(E,AIBJ,E2,J0,NOCD,NVIR,NOCC,NPAR2,
     *                 NP1,NP2,NPAR1,NPAR3,NDIM1,NDIM2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
C
      DIMENSION AIBJ(NPAR1,NPAR2,NPAR3),E(*)
C
C     ----- FORM PARTIAL CONTRIBUTION TO THE E(2) ENERGY -----
C
      MAI = 0
      DO 25 MA = 1, NVIR
         DO 20 MI = 1, NOCD
            MAI = NDIM1*NDIM2 + MI + (MA-1)*(NP2 + NP1)
            DO 15 MB = 1, NVIR
               MBI = NDIM1*NDIM2 + MI + (MB-1)*(NP2 + NP1)
               DO 10 MJ = 1,NOCC
                  XAIBJ = AIBJ(MJ,MAI,MB+NP1+NP2)
                  IF(ABS(XAIBJ).LT.TOL) GOTO 10
                  XAJBI = AIBJ(MJ,MBI,MA+NP1+NP2)
                  DAIBJ = E(MA + NP1 + NP2) + E(MB + NP1 + NP2)
     *                    - E(MI)-E(MJ + J0 - 1)
                  E2 = E2 - XAIBJ*(XAIBJ + XAIBJ - XAJBI)/DAIBJ
   10          CONTINUE
   15       CONTINUE
   20    CONTINUE
   25 CONTINUE
C
      RETURN
      END
C*MODULE MP2     *DECK MP2ZE1
      SUBROUTINE MP2ZE1(J0,N2,N3,N4,N1,NVAR1,NVAR2,NVAR3,NVAR4,
     *                  NVAR5,IFLAG,
     *                  NPAR11,NPAR12,NPAR13,NPAR21,NPAR22,NPAR23,
     *                  NOCS,E,ARRAY1,ARRAY2,E2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
C
      DIMENSION ARRAY1(NPAR11,NPAR12,NPAR13)
      DIMENSION ARRAY2(NPAR21,NPAR22,NPAR23)
      DIMENSION E(*)
C
      PARAMETER(HALF = 0.50D+00)
C
C     ----- FORM PARTIAL CONTRIBUTION TO THE E(2) ENERGY -----
C
      DO 100 M2 = 1, N2
         DO 110 M3 = 1, N3
            M23 = (M2 - 1)*(N3 + N2) + M3
            IF(IFLAG .EQ. 1) THEN
               M23 = N3*(NVAR1+NVAR2)+M2*NVAR1+(M2-1)*N3+M3
            ENDIF
            DO 120 M4 = 1, N4
               M43 = (N2 + N3)*(N2 + M4 - 1) + M3
               IF(IFLAG .EQ. 1) THEN
                  M43 = N3*(NVAR1+NVAR2)+M4*NVAR1+(M4-1)*N3+M3
               ENDIF
               DO 130 M1 = 1, N1
                  MYX = 0
                  SUM = 0.00D+00
                  X2341 = ARRAY1(M1,M23,M4+NVAR3+NVAR4)
                  IF(ABS(X2341) .LT. TOL) GOTO 130
                  X2143 = ARRAY1(M1,M43,M2+NVAR4)
                  IF(IFLAG.EQ.1) X2143 = ARRAY1(M1,M43,M2+NVAR3+NVAR4)
                  D2341 = E(M2 + NVAR1 + NVAR2) +
     *                    E(M4 + NVAR3 + NVAR4) -
     *                    E(M3 + NVAR5) -
     *                    E(M1 + J0 - 1)
                  DO 140 MY = 1, NOCS
                     MYX   = NOCS * (MY - 1) + M2
                     XYXYX = ARRAY2(M2,MYX,MY)
                     IF(IFLAG .EQ. 1) THEN
                        MYX   = NOCS * (MY - 1) + M3
                        XYXYX = ARRAY2(M3,MYX,MY)
                     ENDIF
                     SUM   = SUM + XYXYX
  140             CONTINUE
                  SUM = HALF * SUM
                  E2 = E2 - (X2341*(2*X2341 - X2143))/(D2341 + SUM)
  130          CONTINUE
  120       CONTINUE
  110    CONTINUE
  100 CONTINUE
C
      RETURN
      END
C*MODULE MP2     *DECK MP2ZE2
      SUBROUTINE MP2ZE2(J0,N2,N3,N4,N1,NVAR1,NVAR2,NVAR3,NVAR4,
     *                  NPAR11,NPAR12,NPAR13,NPAR21,NPAR22,NPAR23,
     *                  NOCS,E,ARRAY1,ARRAY2,E2,IFLAG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
C
      DIMENSION ARRAY1(NPAR11,NPAR12,NPAR13)
      DIMENSION ARRAY2(NPAR21,NPAR22,NPAR23)
      DIMENSION E(*)
C
      PARAMETER(HALF = 0.50D+00, QUARTR = 0.25D+00)
C
C     ----- FORM PARTIAL CONTRIBUTION TO THE E(2) ENERGY -----
C
      DO 100 M2 = 1, N2
         DO 110 M3 = 1, N3
            M23 = (M2 - 1)*(N3 + N2) + M3
            IF(IFLAG .EQ. 1) M23 = (M2-1)*N3 + M3
            DO 120 M4 = 1, N4
               M43 = (M4 - 1)*(N3 + N2) + M3
               IF(IFLAG .EQ. 1) M43 = (M4-1)*N3 + M3
               DO 130 M1 = 1, N1
                  MZX = 0
                  MZY = 0
                  SUM = 0.00D+00
                  X2341 = ARRAY1(M1,M23,M4+N3)
                  X2143 = ARRAY1(M1,M43,M2+N3)
                  IF(IFLAG .EQ. 1) THEN
                     X2341 = ARRAY1(M1,M23,M4+NVAR2+NVAR1)
                     X2143 = ARRAY1(M1,M43,M2+NVAR2+NVAR1)
                  ENDIF
                  DIFF  = X2341 - X2143
                  IF(ABS(DIFF) .LT. TOL) GOTO 130
                  D2341 = E(M2 + NVAR1  + NVAR2) +
     *                    E(M4 + NVAR1  + NVAR2) -
     *                    E(M3 + NVAR3) -
     *                    E(M1 + NVAR4 + J0 - 1)
                  DO 140 MZ = 1, NOCS
                     MZX   = NOCS * (MZ - 1) + M2
                     MZY   = NOCS * (MZ - 1) + M4
                     XZXZX = ARRAY2(M2,MZX,MZ)
                     XZYZY = ARRAY2(M4,MZY,MZ)
                     IF(IFLAG .EQ. 1) THEN
                        MZX   = NOCS * (MZ - 1) + M3
                        MZY   = NOCS * (MZ - 1) + M1
                        XZXZX = ARRAY2(M3,MZX,MZ)
                        XZYZY = ARRAY2(M1,MZY,MZ)
                     ENDIF
                     SUM   = SUM + (XZXZX + XZYZY)
  140             CONTINUE
                  SUM = HALF * SUM
                  E2 = E2 - QUARTR*((DIFF*DIFF)/(D2341 + SUM))
  130          CONTINUE
  120       CONTINUE
  110    CONTINUE
  100 CONTINUE
C
      RETURN
      END
C*MODULE MP2     *DECK MP2ZE3
      SUBROUTINE MP2ZE3(J0,N2,N3,N4,N1,NVAR1,NVAR2,NVAR4,
     *                  NPAR11,NPAR12,NPAR13,NPAR21,NPAR22,NPAR23,
     *                  NOCS,E,ARRAY1,ARRAY2,E2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
C
      DIMENSION ARRAY1(NPAR11,NPAR12,NPAR13)
      DIMENSION ARRAY2(NPAR21,NPAR22,NPAR23)
      DIMENSION E(*)
C
      PARAMETER(HALF = 0.50D+00)
C
C     ----- FORM PARTIAL CONTRIBUTION TO THE E(2) ENERGY -----
C
      DO 100 M2 = 1, N2
         DO 110 M3 = 1, N3
            M23 = N3*(NVAR1+NVAR2)+M2*NVAR1+(M2-1)*NVAR2 + M3
            DO 120 M4 = 1, N4
               DO 130 M1 = 1, N1
                  MZX = 0
                  MZY = 0
                  SUM = 0.00D+00
                  X2341 = ARRAY1(M1,M23,M4+NVAR1)
                  IF(ABS(X2341) .LT. TOL) GOTO 130
                  D2341 = E(M2 + NVAR1  + NVAR2) +
     *                    E(M4 + NVAR1) -
     *                    E(M3 + NVAR1) -
     *                    E(M1 + NVAR4 + J0 - 1)
                  DO 140 MZ = 1, NOCS
                     MZX   = NOCS * (MZ - 1) + M3
                     MZY   = NOCS * (MZ - 1) + M4
                     XZXZX = ARRAY2(M3,MZX,MZ)
                     XZYZY = ARRAY2(M4,MZY,MZ)
                     SUM   = SUM + (XZXZX + XZYZY)
  140             CONTINUE
                  SUM = HALF * SUM
                  E2 = E2 - X2341**2/(D2341 + SUM)
  130          CONTINUE
  120       CONTINUE
  110    CONTINUE
  100 CONTINUE
C
      RETURN
      END
C*MODULE MP2     *DECK MP2ZE4
      SUBROUTINE MP2ZE4(J0,N2,N3,N4,N1,NVAR1,NVAR2,NPAR1,NPAR2,NPAR3,
     *                  E,ARRAY,E2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,
     *                MAXITC
C
      DIMENSION ARRAY(NPAR1,NPAR2,NPAR3),E(*)
C
      PARAMETER(HALF = 0.50D+00)
C
C     ----- FORM PARTIAL CONTRIBUTION TO THE E(2) ENERGY -----
C
      DO 100 M1 = 1, N1
         DO 110 M2 = 1, N2
            DO 120 M3 = 1, N3
               M23 = N3*(NVAR1+NVAR2)+M2*NVAR2+(M2-1)*NVAR1+M3
               DO 130 M4 = 1, N4
                  M43 = N3*(NVAR1+NVAR2)+M2*NVAR2+(M2-1)*NVAR1+M4
                  X2331 = ARRAY(M1,M23,M3+NVAR2)
                  X2441 = ARRAY(M1,M43,M4+NVAR2)
                  IF(ABS(X2331) .LT. TOL) GOTO 130
                  IF(ABS(X2441) .LT. TOL) GOTO 130
                  D2341 = E(M2 + NVAR1  + NVAR2) -
     *                    E(M1 + J0 - 1)
                  E2 = E2 - HALF*X2441*X2331/D2341
 130           CONTINUE
 120        CONTINUE
 110     CONTINUE
 100  CONTINUE
C
      RETURN
      END
