C  4 MAR 08 - RMO - IMPLEMENT SEMIDIRECT VVVV COMPUTATION (IKCUT INPUT)
C 25 JUN 07 - MWS - DRCCSD_DDI: KILL TRIPLES IF NOT ENOUGH WORK PER NODE
C 21 MAY 07 - MWS,HL - ORDER SMP CREATES TO MATCH DESTROYS, FIX RESTART
C 24 MAR 07 - MWS - CCSD_DDI_PROC,DRCCSD_DDI: BROADCAST E'S CORRECTLY
C 22 DEC 06 - MWS - USE IMPLICIT STATEMENTS TO COVER BLAS NAME HACK
C 19 NOV 06 - MWS - CCSD_VVVV: RESET DLB; DDCC_T_NODE: ZERO ENERGIES
C 22 SEP 06 - RMO,JLB - IMPLEMENT DISTRIBUTED DATA PARALLEL CCSD(T)
C
C*MODULE CCDDI   *DECK DRCCSD_DDI
      SUBROUTINE DRCCSD_DDI(NO,NU,OEH,OEP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXGSH=30)
C --------------------
C CALLING ARGUMENTS
C --------------------
      INTEGER NO,NU
      DOUBLE PRECISION OEH(NO),OEP(NU)
C
      INTEGER MBTOT(0:4)
C
C --------------------
C COMMON PARAMETERS
C --------------------
      INTEGER MXATM
      PARAMETER (MXATM=2000)
C
C --------------------
C COMMON BLOCK: CCPAR
C --------------------
      INTEGER          METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                 MXCCIT,MXRLEIT,MWRDCC,ICCCNV,ICCRST,IDSKCC
      DOUBLE PRECISION AMPTSH
      COMMON /CCPAR /  AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                 MXCCIT,MXRLEIT,MWRDCC,ICCCNV,ICCRST,IDSKCC
C
C --------------------
C COMMON BLOCK: RUNOPT
C --------------------
      INTEGER          NEVALS,NGLEVL,NHLEVL
      DOUBLE PRECISION RUNTYP,EXETYP,CHECK
      COMMON /RUNOPT/  RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
C --------------------
C COMMON BLOCK: INFOA
C --------------------
      INTEGER          NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,IAN(MXATM)
      DOUBLE PRECISION ZAN(MXATM),C(3,MXATM)
      COMMON /INFOA /  NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,ZAN,C,IAN
C
C --------------------
C COMMON BLOCK: FMCOM
C --------------------
      DOUBLE PRECISION X(1)
      COMMON /FMCOM /  X
C
      INTEGER         D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI
      INTEGER         D_VL,D_VL_IBT
      COMMON /CCDDI / D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI,
     *                D_VL,D_VL_IBT
C
C
      DOUBLE PRECISION ENRG,EREF,EMP2,ECCN,ETOT,ECORR,
     *                 DIAGS,AMPMX,XO1,XO2,
     *                 DIFMAX,DIFFENG
      LOGICAL          CNVR
      INTEGER          IAMPMX,ITER
      COMMON /CCENGY/ ENRG,EREF,EMP2,ECCN,ETOT(6),ECORR(6),
     *                DIAGS(3),AMPMX(5,2),IAMPMX(5,4,2),XO1,XO2,
     *                DIFMAX,DIFFENG,ITER,CNVR
C
      INTEGER ME,MASTER,NPROC,IBTYP,IPTIM
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C ---
C COMMON BLOCK FOR DISK FILES
C ---
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
      INTEGER         INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      INTEGER         NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
C
C ------------------------------------------------------
C DEFAULT ADDRESS FOR REFERENCING SHARED-MEMORY SEGMENTS
C ------------------------------------------------------
      CHARACTER*1 ADDR(1)
C
      INTEGER DDI_NP,DDI_ME,DDI_NN,DDI_MY
      INTEGER SMP_NP,SMP_ME
C
      INTEGER NO2,NO3,NO4,NU2,NU3,NOU,NOU2,NO3U,NO2U,NO2U2
      INTEGER NBF,NBSQ,NBTR,NOTR,NUTR
      INTEGER DISTRIB_MEM,SHARED_CCSD,SHARED_TRIP,SHARED_MEM,REP_MEM
      INTEGER D_O4,D_VM,D_O2,D_T2,D_RL,D_TEMP
      INTEGER LO2,LT2,LVM,LRL,LO4,LSHARED_TEMP
C
      INTEGER LT1,LO1,LFH,LFP,LFPH
      INTEGER LOADFM,LAST,NEED,NGOTMX
      INTEGER IFC,MET,MEMDDI,MEMINP
      DOUBLE PRECISION TMP
C
      DATA CHECK/8HCHECK   /
C
      MET = METHCC
      IFC = NCCFZC
C
      CALL DDI_SYNC(1234)
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_NNODE(DDI_NN,DDI_MY)
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
C
      IF(MASWRK) WRITE(6,9000)
C
C        TRIPLES MUST HAVE A LITTLE WORK FOR EVERY NODE TO DO.
C        MAKE SURE THAT A SMALL NUMBER OF CORRELATED ORBITALS
C        DOES NOT EXCEED THE NUMBER OF NODES WE HAVE.
C
      IF ((NO*(NO-1)*(NO-2))/6 .LT. DDI_NN   .AND.  METHCC.GT.2) THEN
         IF(MASWRK) WRITE(6,9400) NO,(NO*(NO-1)*(NO-2))/6,DDI_NN
         CALL ABRT
      END IF
C
C --------------------------------------------------------
C COMMON VARIABLE DEFINITIONS
C - NO   : NUMBER OF ACTIVE & OCCUPIED MOS
C - NU   : NUMBER OF ACTIVE & VIRTUAL MOS
C --------------------------------------------------------
C
      NO2   = NO*NO
      NO3   = NO*NO2
      NO4   = NO*NO3
      NU2   = NU*NU
      NU3   = NU*NU2
      NOU   = NO*NU
      NO3U  = NO3*NU
      NOU2  = NO*NU2
      NO2U  = NO2*NU
      NO2U2 = NOU*NOU
      NOTR  = (NO*NO+NO)/2
      NUTR  = (NU*NU+NU)/2
C
C          NUMBER OF BASIS FUNCTIONS FROM INFOA
      NBF   = NUM
      NBSQ  = NBF*NBF
      NBTR  = (NBSQ+NBF)/2
C
      NRESF=70
      NFRLE=71
      NT1=73
      NT2=74
C---  NT3=75
      NRESL = 8096
C
C     OPEN DISK FILES USED FOR CCSD(T)
C
      IF(MASWRK) THEN
         CALL CCOPEN(NRESF,((8+8/NWDVAR)*NRESL)/8,'CCREST')
         CALL CCOPEN(NFRLE,NOU+NO2U2,'CCDIIS')
         CALL CCOPEN(NT1,NOU        ,'CCT1AMP')
         CALL CCOPEN(NT2,NO2U2      ,'CCT2AMP')
C            NEXT ONE USED IN CHECK-SUM DEBUG ROUTINES ONLY.
C---     CALL CCOPEN(NT3,NU3        ,'CCT3AMP')
      END IF
C
C        TURN ON DDI ARRAY CREATION MESSAGES
C
      IFLAG=0
      IF(MASWRK) IFLAG=1
      CALL DDI_OUTPUT(IFLAG)
C
C                ---- ESTIMATE REPLICATED MEMORY -----
C
C          THIS ROUTINE ALLOCATES A VERY SMALL AMOUNT OF MEMORY,
C              WHICH IS HELD ONTO THROUGHOUT THE JOB.
C          NEXT, CCSD_FOCK ALLOCATES A SMALL AMOUNT (QUADRATIC),
C              WHICH IS IGNORED JUST BELOW, SINCE IT ISN'T CUBIC,
C              AND IT IS FREED UP BEFORE THE NEXT STEP'S CUBIC STUFF.
C          THEN, WE CALL EITHER PROCESS OR NODE-BASED DRIVERS, THE
C              MEMORY NEEDED BY PROCESS-NODE IS LARGER THAN NODE-BASED.
C          NO MATTER WHICH OF THESE TWO IS CALLED (PROCESS OR NODE),
C              THERE IS A CALL INSIDE EACH TO DO A 4 VIRTUAL TERM,
C                  WHICH HAS THREE MEMORY ALLOCATIONS IN IT, AND IT
C                  ALSO CALLS A QUARTET ROUTINE WITH A SMALL ALLOC.
C         FINALLY, THIS ROUTINE WAS GIVEN OCCUPIED AND VIRTUAL
C         ORBITAL ENERGIES, ALREADY DYNAMICALLY ALLOCATED (+NO+NU).
C
C         IMPOSE AN OPTIONAL USER LIMIT ON REPLICATED MEMORY,
C         NOTE THAT IN SPITE OF ITS NAME, -MWRDCC- IS IN WORDS.
C
      CALL GOTFM(NGOTMX)
      IF(MWRDCC.GT.0) NGOTMX = MIN(NGOTMX,MWRDCC)
      CALL SYSINP(MEMINP,MEMDDI)
C
      CALL VALFM(LOADFM)
      LO1  = LOADFM + 1
      LT1  = LO1    + NOU
      LFH  = LT1    + NOU
      LFP  = LFH    + NO2
      LFPH = LFP    + NU2
      LAST = LFPH   + NOU
      NEED = LAST - LOADFM - 1
C
C         NOW COMPUTE WHAT WE WILL NEED LATER,
C         SO THAT CHECK JOBS KNOW WHAT THEY ARE DOING.
C
C         THERE ARE 3 SEPARATE MEMORY ALLOCATIONS IN 4 VIRTUAL TERM,
C         BUT THE FIRST AND THE LAST ARE THE SAME (NOU2).
C
      CALL BASCHK(LMAX)
                    MXSHL =  4     ! L SHELLS HAVE  4 FUNCTIONS
      IF(LMAX.EQ.2) MXSHL =  6     ! D SHELLS HAVE  6 FUNCTIONS
      IF(LMAX.EQ.3) MXSHL = 10     ! F SHELLS HAVE 10 FUNCTIONS
      IF(LMAX.EQ.4) MXSHL = 15     ! G SHELLS HAVE 15 FUNCTIONS
      IF(LMAX.EQ.5) MXSHL = 21     ! H SHELLS HAVE 21 FUNCTIONS
      IF(LMAX.EQ.6) MXSHL = 28     ! I SHELLS HAVE 28 FUNCTIONS
      MXSHL2 = MXSHL *MXSHL
      MXSHL4 = MXSHL2*MXSHL2
      NOBF   = NO*NBF
      NUBF   = NU*NBF
      ND4VIR = MXSHL4 + 3*NBSQ + NUBF + MAX(NOBF,NUBF)*MXSHL2
     *                                + MAX(NO2 ,NU2 )*MXSHL2
      ND4VIR = MAX(NOU2,ND4VIR)
C
      NDQUAR = 49*MXGSH*MXGSH
C
C         THERE ARE TWO WAYS OF PROCESSING THE MO INTEGRAL TERMS:
C         PROCESSED-BASED MEMORY REQUIREMENT IS QUARTIC, OUCH.
C         NODE-BASED MEMORY IS CUBIC, AND OVERLAPS ITS MEMORY
C                               WITH THAT FOR THE 4 VIRT TERM.
C
      NDPROC = MAX(NU3+2*NOU2, NOU2+2*NO2U2+2*NOU2+10)
      NDPROC = NDPROC + ND4VIR    + NO2+NU2+NOU + NDQUAR + NEED + NO+NU
C
      NDNODE = MAX(NOU+NOU2, 3*NOU, NOU2+NUTR, NO2U)
      NDNODE = MAX(NDNODE,ND4VIR) + NO2+NU2+NOU + NDQUAR + NEED + NO+NU
      REP_MEM = MIN(NDPROC,NDNODE)   ! SMALLER IS USUALLY NDNODE.
C
      TMP = NDPROC
      MWPROC = INT(TMP/1.0D+06 + 1.0D+00)
      TMP = NDNODE
      MWNODE = INT(TMP/1.0D+06 + 1.0D+00)
C
      IF(MASWRK) WRITE(6,9010) NDPROC,NDNODE,REP_MEM
C
C                ---- ESTIMATE SHARED MEMORY -----
C     CCSD WILL BE FREED BEFORE (T) SHARED MEMORY IS ALLOCATED.
C     IT IS CONVENIENT TO USERS TO PRINT THE (T) REQUIREMENTS HERE.
C
      SHARED_CCSD = 3*NO2U2 + NO3U + NO4 + 2*NOU
      IF(MASWRK) WRITE(6,9020) SHARED_CCSD
      IF(METHCC.GT.2) THEN
         SHARED_TRIP = 2 * NU3 + 2 * (NO2U2+NOU) + NO4
         IF(MASWRK) WRITE(6,9030) SHARED_TRIP
      ELSE
         SHARED_TRIP = 0
      END IF
      SHARED_MEM = MAX(SHARED_CCSD,SHARED_TRIP)
C
C                ---- ESTIMATE DISTRIBUTED MEMORY -----
C
C          THE INTEGRAL TRANSFORMATION WILL HAVE TIED UP THIS AMOUNT,
      TMP = NBTR*NOU + NOTR*NBSQ + NOTR*NOU + NOTR*NBTR + NOTR*NOTR
C          THE 7 ARRAYS CREATED JUST BELOW ADD THIS,
      TMP = TMP + 7*NO2U2
C          AND LATER, CCSD_VVVV ALLOCATES ONE MORE (ON EVERY ITERATION)
      TMP = TMP + NBSQ*NOTR
      DISTRIB_MEM = INT(TMP/1.0D+06 + 1.0D+00)
C
      IF(MASWRK) WRITE(6,9040) DISTRIB_MEM
      IF(MASWRK) WRITE(6,9050) MWPROC,MWNODE,DISTRIB_MEM
C
      IF(EXETYP.NE.CHECK) THEN
         INHOMO = 0
         IF(DDI_NP/DDI_NN .NE. SMP_NP) INHOMO=1
         CALL DDI_GSUMI(7088,INHOMO,1)
         IF(MASWRK  .AND.  INHOMO.NE.0) WRITE(6,9060)
      END IF
C
C        ESTIMATE -NODE- MEMORY IN MBYTES, WORKING IN UNITS OF WORDS
C
      WREP = MWNODE * 1.0D+06
      WSHR = SHARED_MEM
      WDDI = DISTRIB_MEM * 1.0D+06
C
      IF(EXETYP.EQ.CHECK) THEN
         IF(MASWRK) WRITE(6,9070) MWNODE,DISTRIB_MEM,SHARED_MEM
         IF(MASWRK) WRITE(6,9080) (2**JPW,JPW=0,4)
         DO IPOW=0,7
            NCPU= 2**IPOW
            DO JPOW=0,MIN(4,IPOW)
               NWAY=MIN(2**JPOW,NCPU)
               WTOT = NWAY*WREP + WSHR + NWAY*(WDDI/NCPU)
               TOTMB = (8.0D+00*WTOT)/(1024.0D+00*1024.0D+00)
               MBTOT(JPOW) = INT(TOTMB + 1.0D+00)
            ENDDO
            IF(MASWRK) WRITE(6,9090) NCPU,
     *                               (MBTOT(JPOW),JPOW=0,MIN(4,IPOW))
         ENDDO
         IF(MASWRK) WRITE(6,9095)
      ELSE
         NWAY = DDI_NP/DDI_NN
         WTOT = NWAY*WREP + WSHR + NWAY*(WDDI/DDI_NP)
         TOTMB = (8.0D+00*WTOT)/(1024.0D+00*1024.0D+00)
         IF(MASWRK) WRITE(6,9100) DDI_NN,NWAY,
     *                            (MEMINP-1)/1000000+1,MEMDDI,
     *                            MWNODE,DISTRIB_MEM,
     *                            INT(TOTMB+1.0D+00)
      END IF
C
C         VERIFY ENOUGH -MWORDS- (OR -NWORD- IN $CCINP) WAS GIVEN
C
      NERR=0
      NDMIN = MIN(NDPROC,NDNODE)
      IF(NDMIN.GT.NGOTMX) THEN
         IF(MASWRK) WRITE(6,9110) NDMIN,NGOTMX
         NERR=NERR+1
      END IF
C
C         VERIFY ENOUGH -MEMDDI- WAS GIVEN
C
      IF(DISTRIB_MEM.LE.MEMDDI) THEN
         IF(EXETYP.EQ.CHECK  .AND.  MASWRK) WRITE(6,9120)
      ELSE
         IF(MASWRK) WRITE(6,9130) MEMDDI,DISTRIB_MEM
         NERR=NERR+1
      END IF
C
C         ...IF NOT, PULL THE PLUG
C
      IF(NERR.GT.0) CALL ABRT
C
C        ----- ALLOCATE THE REPLICATED MEMORY -----
C        THIS IS ONLY A LITTLE BIT, JUST WHAT WE NEED RIGHT NOW.
C
      CALL GETFM(NEED)
C
C        ----- ALLOCATE THE SHARED MEMORY -----
C        THIS IS ALL OF OF IT, FOR THE WHOLE CCSD STEP.
C        THE ARRAYS NAMED D_T2, D_O2, AND D_VM ARE KEPT IN THE (T),
C        THE REST (AND A D_TEMP MADE BELOW) ARE DESTROYED AFTER CCSD.
C
C        THIS MEMORY CLASS IS A HEAP TYPE, SO NO ATTEMPT IS MADE
C        TO MATCH THE ORDER OF DESTROYS TO REVERSE THE CREATES.
C          (NOT TRUE ACTUALLY, WE HAVE CHANGED THE ORDER TO MATCH NOW,
C           WHICH IS PROBABLY JUST SUPERSTITIOUS)
C
      CALL DDI_SMP_CREATE(NO3U, D_VM)
      CALL DDI_SMP_CREATE(NO2U2+NOU,D_O2)
      CALL DDI_SMP_CREATE(NO2U2+NOU,D_T2)
      CALL DDI_SMP_CREATE(NO4,  D_O4)
      CALL DDI_SMP_CREATE(NO2U2,D_RL)
C              DETERMINE OFFSETS FOR SHARED MEMORY ARRAYS
      CALL DDI_SMP_OFFSET(D_O4,ADDR,LO4)
      CALL DDI_SMP_OFFSET(D_VM,ADDR,LVM)
      CALL DDI_SMP_OFFSET(D_O2,ADDR,LO2)
      CALL DDI_SMP_OFFSET(D_T2,ADDR,LT2)
      CALL DDI_SMP_OFFSET(D_RL,ADDR,LRL)
C
      LO4=LO4+1
      LVM=LVM+1
      LO2=LO2+1
      LT2=LT2+1
      LRL=LRL+1
C
      CALL DDI_SMP_SYNC()
C
C        ----- ALLOCATE THE DISTRIBUTED MEMORY -----
C        THIS IS MOST OF IT, FOR THE WHOLE CCSD STEP, EXCEPT
C        ONE MORE ARRAY IS CREATED EACH ITERATION, IN CCSD_VVVV.
C        NOTE: ARRAYS FOR TRANSFORMED INTEGRALS ALREADY EXIST.
C
      IF(EXETYP.NE.CHECK) THEN
         CALL DDI_CREATE(NOU,NOU,D_VR)
         CALL DDI_CREATE(NOU,NOU,D_VL)
         CALL DDI_CREATE(NOU,NOU,D_VL_IBT)
         CALL DDI_CREATE(NOU,NOU,D_VR_IBT)
         CALL DDI_CREATE(NOU,NOU,D_VR_SYM)
         CALL DDI_CREATE(NU2,NO2,D_VR_BIT)
         CALL DDI_CREATE(NU2,NO2,D_VR_BI)
      END IF
C
C        WHEW, AT LAST, THAT IS THE END OF THE MEMORY COMPUTATIONS.
C
C            --------------------------------------------- !
C            READ IN INTEGRALS AND REORDER FOR USE IN CCSD
C            --------------------------------------------- !
C
      IF(EXETYP.NE.CHECK) THEN
C
      IF(MASWRK) THEN
         WRITE(6,9210)
         CALL FLSHBF(6)
C
         CALL CCSD_RDO4(NO,ADDR(LO4),ADDR(LRL))
C
         CALL CCSD_RDVL(NO,NU,ADDR(LO2),ADDR(LRL))
         CALL CCSD_MKVL(NO,NU,ADDR(LO2),ADDR(LRL))
C
         CALL CCSD_RDVR(NO,NU,ADDR(LO2),ADDR(LRL))
         CALL CCSD_MKVR(NO,NU,ADDR(LO2),ADDR(LT2))
         CALL CCSD_MKVR_PERMUTED(NO,NU,ADDR(LO2),ADDR(LT2))
      END IF
C
C BROADCASTING THE [OO|OO] INTEGRAL CLASS TO EACH NODE
C
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_BCAST(119,'F',ADDR(LO4),NO4,0)
      END IF
C
C ----------------------------------------------------------- !
C SET UP ONE ELECTRON CONTRIBUTION USING FOCK MATRIX ELEMENTS
C ----------------------------------------------------------- !
      CALL CCSD_FOCK(NO,NU,NBF,NCCFZC,X(LFH),X(LFP),X(LFPH),OEH,OEP)
C
C ---------------------------------------------------------- !
C INITIAL GUESS FOR T1 AMPS
C ---------------------------------------------------------- !
      CALL ZEROMA(X(LO1),1,NOU)
C
C ---------------------------------------------------------- !
C CALCULATE MP2 ENERGY; USE MP2 AMPS AS INITIAL GUESS FOR T2 !
C ---------------------------------------------------------- !
      CALL CCSD_MP2(NO,NU,ADDR(LO2),ADDR(LT2),OEH,OEP,EMP2)
C
C --------------------------------------------------- !
C DISTRIBUTE INITIAL GUESS / MP2 AMPLITUDES
C --------------------------------------------------- !
      CALL DDI_SYNC(1234)
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_BCAST(100,'F',ADDR(LO2),NO2U2,0)
      CALL DDI_SYNC(1234)
C
C ------------------------------------------------- !
C RUN PARALLEL CCSD
C ------------------------------------------------- !
C
      END IF
C
C     REPLICATED MEMORY REQUIREMENT SAME AS IN CCSD_DDI   (??)
C
C THIS OVERWRITES REP_MEM AND IS WRONG
C     REP_MEM = NO2 + NU2 + NOU
C     REP_MEM = REP_MEM + MAX(NU3+2*NOU2,NOU2+2*NO2U2+2*NOU2+10)
C
      CALL GOTFM(NGOTMX)
C
C
C IF THIS GOTO LINE IS INVOKED WE GO TO THE NODE BASED CCSD DUE TO THE
C THE MEMORY REQUIREMENT
C
      IF(NDPROC.GT.NGOTMX) GOTO 2950
C
      CALL DDI_TIMER_RESET()
C
C PROCESS BASED CCSD ITERATIONS
C
      CALL CCSD_DDI_PROC(NO,NU,EMP2,
     *                X(LO1),X(LT1),X(LFH),X(LFP),X(LFPH),
     *                ADDR(LO4),ADDR(LVM),ADDR(LO2),ADDR(LT2),ADDR(LRL),
     *                OEH,OEP,IFC)
C      CALL DDI_TIMER_OUTPUT()
      GOTO 2951
C
C NODE BASED CCSD ITERATIONS
C
 2950 CONTINUE
      CALL DDI_TIMER_RESET()
C
      CALL DDI_SMP_CREATE(MAX(NU3+2*NOU2,NOU2 + NO2U2 ), D_TEMP)
      CALL DDI_SMP_OFFSET(D_TEMP,ADDR,LSHARED_TEMP)
      LSHARED_TEMP = LSHARED_TEMP + 1
C
C
C NODE BASED CCSD ITERATIONS WHICH USE MUCH LESS REPLICATED MEMORY
C
C
      CALL CCSD_DDI_NODE(NO,NU,EMP2,
     *                X(LO1),X(LT1),X(LFH),X(LFP),X(LFPH),
     *                ADDR(LO4),ADDR(LVM),ADDR(LO2),ADDR(LT2),ADDR(LRL),
     *                OEH,OEP,IFC,ADDR(LSHARED_TEMP))
      CALL DDI_SMP_DESTROY(D_TEMP)
C      CALL DDI_TIMER_OUTPUT()
 2951 CONTINUE
C
      IF(MASWRK) THEN
      CALL DRPRINT(3)
      WRITE(6,9220)
      CALL TIMIT(1)
      END IF
      IF(.NOT.CNVR) THEN
        WRITE(6,*) 'AMPLITUDE ITERATIONS DID NOT CONVERGE'
        CALL ABRT
      END IF
C
C DESTROY SHARED-MEMORY ARRAYS NOT USED IN (T)
C
      CALL DDI_SYNC(123)
      CALL DDI_SMP_DESTROY(D_RL)
      CALL DDI_SMP_DESTROY(D_O4)
      CALL DDI_SYNC(124)
C
C ------ DRIVER FOR THE (T) ROUTINES -----
C
      IF(MET.EQ.3) THEN
C
      CALL DDI_TIMER_RESET()
      CALL DDCC_T_DRIVER(NO,NU,ADDR(LVM),ADDR(LT2),ADDR(LO2),OEH,OEP)
C      CALL DDI_TIMER_OUTPUT()
C
      CALL DDI_TIMER_RESET()
C
      IF(MASWRK) THEN
C---      CALL DDCC_T_DRSUMA(NO,NU,ADDR(LT2),ADDR(LO2),OEH,OEP)
      CALL DDCC_T_DRSUMA
      END IF
C
C      CALL DDI_TIMER_OUTPUT()
C
      END IF
C
C           DRPRINT IS WHERE THE (T) ENERGY IS ADDED TO THE CCSD,
C           MAKE SURE ALL NODES GET THE SUM OF THESE TWO: -ENRG-
C
      IF(MASWRK) THEN
        CALL DRPRINT(4)
        IF(METHCC.GE.3) WRITE(6,9230)
        IF(METHCC.GE.3) CALL TIMIT(1)
      END IF
      CALL DDI_BCAST(125,'F',ENRG,1,0)
C
C ------------------------------------------------- !
C DESTROY SHARED-MEMORY ARRAYS
C ------------------------------------------------- !
C
      CALL DDI_SMP_DESTROY(D_T2)
      CALL DDI_SMP_DESTROY(D_O2)
      CALL DDI_SMP_DESTROY(D_VM)
C
C ------------------------------------------------- !
C RETURN REPLICATED MEMORY
C ------------------------------------------------- !
      CALL RETFM(NEED)
C
C ------------------------------------------------- !
C DESTROY DISTRIBUTED ARRAYS
C ------------------------------------------------- !
C
      IF(EXETYP.NE.CHECK) THEN
         CALL DDI_DESTROY(D_VR_BI)
         CALL DDI_DESTROY(D_VR_BIT)
         CALL DDI_DESTROY(D_VR_SYM)
         CALL DDI_DESTROY(D_VR_IBT)
         CALL DDI_DESTROY(D_VL_IBT)
         CALL DDI_DESTROY(D_VL)
         CALL DDI_DESTROY(D_VR)
         CALL CCSD_CLEAN_INTS()
      END IF
      RETURN
C
 9000 FORMAT(/1X,'RUNNING THE DISTRIBUTED DATA, PARALLEL CCSD/CCSD(T)',
     *           ' PROGRAM...'//
     *        1X,'PARALLEL CODE WRITTEN BY RYAN M. OLSON AND',
     *           ' JONATHAN L. BENTZ,'/
     *        1X,'BASED ON SERIAL CODE OF P.PIECUCH, S.A.KUCHARSKI,',
     *           ' K.KOWALSKI, M.MUSIAL'/)
 9010 FORMAT(1X,'1A.  REPLICATED MEMORY REQUIRED FOR PROCESS-BASED',
     *          ' CCSD IS',I13,' WORDS.'/
     *       1X,'1B.  REPLICATED MEMORY REQUIRED FOR    NODE-BASED',
     *          ' CCSD IS',I13,' WORDS.'/
     *       1X,'THIS RUN WILL USE',I13,' WORDS OF REPLICATED MEMORY.')
 9020 FORMAT(1X,'2.       SHARED MEMORY REQUIRED FOR THE CCSD ITERS IS',
     *           4X,I13,' WORDS.')
 9030 FORMAT(1X,'         SHARED MEMORY FOR THE (T) CORRECTION WILL',
     *          ' BE    ',I13,' WORDS.')
 9040 FORMAT(1X,'3.  DISTRIBUTED MEMORY FOR THIS JOB IS MEMDDI=',
     *          I8,' MWORDS.')
 9050 FORMAT(/1X,'EXPLANATION (WHAT TO PUT IN $SYSTEM INPUT):'/
     *       1X,'1. THE PROCESS-BASED PARALLEL CCSD WILL BE CHOSEN',
     *          ' IF MWORDS=',I8,','/
     *       1X,'   OTHERWISE, ENTER MWORDS=',I8,' TO RUN THE NODE-',
     *          'BASED PARALLEL CCSD.'/
     *       1X,'   IT IS ALLOCATED BY EVERY COMPUTE PROCESS, SO THE',
     *          ' SECOND, SMALLER VALUE'/
     *       1X,'   IS UNDOUBTEDLY THE WISER CHOICE.'/
     *       1X,'2. THIS MEMORY CLASS PRESENTLY HAS NO INPUT KEYWORD.'/
     *       1X,'   IT IS ALLOCATED ONCE PER NODE, OUT OF THE',
     *          ' OPERATING SYSTEM''S SYSV MEMORY.'/
     *       1X,'3. THIS VALUE INCLUDES THE INTEGRAL TRANSFORMATION''S',
     *          ' DISTRIBUTED MEMORY,'/
     *       1X,'   SO MEMDDI=',I7,' SHOULD BE ENOUGH FOR THE',
     *          ' ENTIRE JOB.'/
     *       1X,'   IT IS ALLOCATED ONLY ONCE, FOR THE WHOLE RUN,',
     *          ' SPREAD ACROSS ALL NODES.'/)
 9060 FORMAT(/1X,'**** WARNING ****  THIS JOB IS NOT RUNNING IN A',
     *            ' HOMOGENEOUS SMP CLUSTER!'/
     *       20X,'MEMORY PROBLEMS AT RUNTIME MAY ENSUE AS A RESULT.'//)
 9070 FORMAT(1X,'TAKING REPLICATED MWORDS=',I8,' AND DISTRIBUTED',
     *         ' MEMDDI=',I8,' MWORDS,'/
     *       1X,'AND THE ADDITIONAL SHARED MEMORY OF',I13,' WORDS,'/
     *       1X,'THE MEMORY REQUIREMENTS ON VARIOUS HOMOGENOUS SMP',
     *          ' CLUSTERS WOULD BE:')
 9080 FORMAT(1X,'# CPU    VS.',4X,I2,4('-',7X,I2),'-WAY SMP SIZE')
 9090 FORMAT(1X,I4,4X,4I10,:,I10,' MBYTES/NODE')
 9095 FORMAT(1X,'PLEASE CHANGE YOUR INPUT''S TWO MEMORY KEYWORDS TO',
     *          ' MATCH THE TWO VALUES'/
     *       1X,'SHOWN AT THE TOP OF THIS TABLE TO MINIMIZE THE',
     *          ' MEMORY REQUIREMENT.'/
     *       1X,'OBVIOUSLY, THE NUMBER OF NODES TO RUN ON IS',
     *          ' (# CPUS/SMP SIZE).'/)
 9100 FORMAT(1X,'THIS JOB IS USING',I4,' NODES, WITH',I3,
     *          ' PROCESSES/NODE,'/
     *       1X,'USING INPUT MEMORY VALUES MWORDS=',I8,
     *          ' AND MEMDDI=',I8/
     *       1X,'MOST EFFICIENT VALUES ARE MWORDS=',I8,
     *          ' AND MEMDDI=',I8/
     *       1X,'THE INPUT VALUES MEANS EACH SMP NODE WILL ALLOCATE',
     *          I8,' MBYTES OF MEMORY.'/)
 9110 FORMAT(1X,'ERROR: NOT ENOUGH REPLICATED MEMORY FOR PARALLEL',
     *          ' CCSD,'/
     *       1X,'NEED=',I13,' AVAILABLE=',I13/
     *       1X,'PLEASE INCREASE -MWORDS- IN $SYSTEM APPROPRIATELY')
 9120 FORMAT(/6X,'CHECK RUN SHOWS SUFFICIENT DISTRIBUTED MEMORY',
     *           ' EXISTS.')
 9130 FORMAT(//6X,'*** INSUFFICIENT DISTRIBUTED MEMORY REQUESTED ***'/
     *         6X,'INPUT VALUE FOR MEMDDI= ',1I10,' REQUIRED= ',1I10//)
 9210 FORMAT(1X,'INITIALIZING INTEGRALS FOR CCSD')
 9220 FORMAT(1X,'....... DONE WITH CC AMPLITUDE ITERATIONS .......')
 9230 FORMAT(1X,'..... DONE WITH CC NON-ITERATIVE TRIPLES CORRECTIONS',
     *          ' .....')
 9400 FORMAT(1X,'ERROR: TOO LITTLE WORK FOR TOO MANY NODES.'//
     *       1X,'TRIPLES IN CCSD(T) ARE REQUESTED, FOR NO=',I4,
     *          ' CORRELATED ORBITALS'/
     *       1X,'WORK TASKS ARE GIVEN BY NO*(NO-1)*(NO-2)/6',19X,'=',I5/
     *       1X,'THIS MAY NOT BE SMALLER THAN THE NUMBER OF NODES',
     *          ' (NOT CPUS!) =',I5//)
      END
C
C*MODULE CCDDI   *DECK CCSD_MKVL
C
C ROUTINE TO REARRANGE THE VL CLASS OF INTEGRALS TO AN ORDER WE NEED
C THEN THEY ARE PUT INTO DISTRIBUTED MEMORY
C
      SUBROUTINE CCSD_MKVL(NO,NU,O2,TI)
      IMPLICIT NONE
      INTEGER NO,NU
      DOUBLE PRECISION O2(1),TI(1)
C
      INTEGER         D_VR,D_VR_IBT,D_VRSYM,D_VR_BIT,D_VR_BI
      INTEGER         D_VL,D_VL_IBT
      COMMON /CCDDI / D_VR,D_VR_IBT,D_VRSYM,D_VR_BIT,D_VR_BI,
     *                D_VL,D_VL_IBT
C
      INTEGER NOU
C
      NOU = NO*NU
C
      CALL DDI_PUT(D_VL,1,NOU,1,NOU,O2)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL DDI_PUT(D_VL_IBT,1,NOU,1,NOU,O2)
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_MKVR
C
C ROUTINE TO REARRANGE THE VR CLASS OF INTEGRALS TO AN ORDER WE NEED
C THEN THEY ARE PUT INTO DISTRIBUTED MEMORY
C
      SUBROUTINE CCSD_MKVR(NO,NU,O2,T2)
      IMPLICIT NONE
      INTEGER NO,NU
      DOUBLE PRECISION O2(1),T2(1)
C
      INTEGER         D_VR,D_VR_IBT,D_VRSYM,D_VR_BIT,D_VR_BI
      INTEGER         D_VL,D_VL_IBT
      COMMON /CCDDI / D_VR,D_VR_IBT,D_VRSYM,D_VR_BIT,D_VR_BI,
     *                D_VL,D_VL_IBT
C
      INTEGER NU2,NO2U2
C
      NU2 = NU*NU
      NO2U2 = NO*NO*NU2
C
      CALL DCOPY(NO2U2,O2,1,T2,1)
      CALL DDI_PUT(D_VR,1,NO*NU,1,NO*NU,O2)
C
      RETURN
      END
C*MODULE CCDDI   *DECK CCSD_MVVR_PERMUTED
C
C ROUTINE TO REARRANGE THE VR CLASS OF INTEGRALS TO PERMUTED
C ORDERS WE NEED THEN THEY ARE PUT INTO DISTRIBUTED MEMORY
C
      SUBROUTINE CCSD_MKVR_PERMUTED(NO,NU,O2,T2)
      IMPLICIT NONE
      INTEGER NO,NU,NOU,NO2,NU2
C
C -
C ON ENTRY, O2 AND T2 ARE VR(I,A,B,J), THE RESULT OF CCSD_MKVR
C -
C
      DOUBLE PRECISION O2(1),T2(1)
C
      INTEGER         D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI
      INTEGER         D_VL,D_VL_IBT
      COMMON /CCDDI / D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI,
     *                D_VL,D_VL_IBT
C
      NOU = NO*NU
      NO2 = NO*NO
      NU2 = NU*NU
C
C
C -
C  CREATING VR(I,A|B,J) AND THEN SYMT21
C -
C
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      CALL DDI_PUT(D_VR_SYM,1,NOU,1,NOU,O2)
C
C -
C  CREATING VR(AT,I|BT,J)
C -
C
      CALL INSITU(NO,NU,NU,NO,O2,T2,12)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL DDI_PUT(D_VR_IBT,1,NOU,1,NOU,T2)
C
C -
C  CREATING VR(A,B|I,J)
C -
C
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL INSITU(NU,NO,NU,NO,O2,T2,23)
      CALL DDI_PUT(D_VR_BI,1,NU2,1,NO2,T2)
C
C -
C  CREATING VR(A,B|IT,JT)
C -
C
      CALL TRANMD(T2,NU,NU,NO,NO,34)
      CALL DDI_PUT(D_VR_BIT,1,NU2,1,NO2,T2)
C
C -
C SET T2 AND O2 BACK TO THE ORIGINAL VR(I,A,B,J)
C FOR CORRECT CALCULATION OF MP2 GUESS
C -
C
      CALL TRANMD(T2,NU,NU,NO,NO,34)
      CALL INSITU(NU,NU,NO,NO,O2,T2,13)
      CALL INSITU(NO,NU,NU,NO,O2,T2,23)
      CALL DCOPY(NOU*NOU,T2,1,O2,1)
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_RDO4
C
C ROUTINE TO READ THE O4 INTEGRAL CLASS INTO SMP SHARED MEMORY
C
      SUBROUTINE CCSD_RDO4(NO,O4,TMP)
      IMPLICIT NONE
C
      INTEGER NO
      DOUBLE PRECISION O4(NO,NO,NO,NO),TMP(*)
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C
      INTEGER NO4,NOTR
      INTEGER I,J,K,L,IMO,JMO,KMO,LMO,ICNTR
      DOUBLE PRECISION VAL
C
      NO4  = NO*NO*NO*NO
      NOTR = NO*(NO+1)/2
C
C
      CALL ZEROMA(O4,1,NO4)
      CALL DDI_GET(D_OOOO,1,NOTR,1,NOTR,TMP)
C
      ICNTR = 1
      DO IMO = 1,NO
      DO JMO = 1,IMO
        DO KMO = 1,NO
        DO LMO = 1,KMO
C
           VAL = TMP(ICNTR)
            IF(ABS(VAL).LT.1.0D-10) VAL = 0.0D+00
C
           I = IMO
           J = JMO
           K = KMO
           L = LMO
C
           IF(I.GT.0 .AND. J.GT.0 .AND. K.GT.0 .AND. L.GT.0) THEN
C
              O4(I,K,J,L) = VAL   ! MULLIKEN INT [I J | K L]
              O4(I,L,J,K) = VAL   ! MULLIKEN INT [I J | L K]
              O4(J,K,I,L) = VAL   ! MULLIKEN INT [J I | K L]
              O4(J,L,I,K) = VAL   ! MULLIKEN INT [J I | L K]
C
           END IF
C
           ICNTR = ICNTR + 1
C
        END DO
        END DO
      END DO
      END DO
C
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_RDVM
C
C ROUTINE TO READ THE VM INTEGRAL CLASS INTO SMP SHARED MEMORY
C
      SUBROUTINE CCSD_RDVM(NO,NU,VM,TMP)
      IMPLICIT NONE
C
      INTEGER NO,NU
      DOUBLE PRECISION VM(NO,NO,NO,NU),TMP(1)
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C
      INTEGER ICNTR,I,J,K,L,NO2,NO3,NOTR
      INTEGER IMO,JMO,KMO,LMO,DDI_NP,DDI_ME
      DOUBLE PRECISION VAL
C
      NO2 = NO*NO
      NO3 = NO*NO2
      NOTR = NO*(NO+1)/2
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_DISTRIB(D_VOOO,DDI_ME,I,J,K,L)
C
      CALL ZEROMA(VM,1,NO3*NU)
C
      CALL DDI_GET(D_VOOO,1,NU,1,NOTR*NO,TMP)
C
      ICNTR = 0
      DO I = 1,NO
      DO J = 1,I
         DO K = 1,NO
         DO L = 1,NU
C
            ICNTR = ICNTR + 1
            VAL = TMP(ICNTR)
            IF(ABS(VAL).LT.1.0D-10) VAL = 0.0D+00
C
            IMO = I
            JMO = J
            KMO = K
            LMO = L
C
            IF(IMO.GT.0 .AND. JMO.GT.0 .AND. KMO.GT.0) THEN
               VM(IMO,JMO,KMO,LMO) = VAL
               VM(JMO,IMO,KMO,LMO) = VAL
            END IF
         END DO
         END DO
      END DO
      END DO
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_RDVR
C
C ROUTINE TO READ THE VR INTEGRAL CLASS INTO SMP SHARED MEMORY
C
      SUBROUTINE CCSD_RDVR(NO,NU,VR,TMP)
      IMPLICIT NONE
C
      INTEGER NO,NU
      DOUBLE PRECISION VR(NO,NU,NU,NO),TMP(*)
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C
      INTEGER I,J,NU2
      INTEGER ICNTR,ICOL,IMO,JMO,KMO,LMO
      INTEGER DDI_NP,DDI_ME,ILO,IHI,JLO,JHI
      DOUBLE PRECISION VAL
C
      NU2  = NU*NU
C
      CALL ZEROMA(VR,1,NO*NO*NU2)
      CALL ZEROMA(TMP,1,NO*NO*NU2)
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_DISTRIB(D_VOVO,DDI_ME,ILO,IHI,JLO,JHI)
C
      ICOL  = 0
      DO 1 I = 1,NO
      DO 1 J = 1,I
C
         ICOL = ICOL + 1
         IMO  = I
         JMO  = J
C
         IF(IMO.LT.1 .OR. JMO.LT.1) GOTO 1
C
         ICNTR = 0
         CALL DDI_GET(D_VOVO,1,NU2,ICOL,ICOL,TMP)
C
         DO KMO = 1,NU
         DO LMO = 1,NU
C
            ICNTR = ICNTR + 1
            VAL   = TMP(ICNTR)
            IF(ABS(VAL).LT.1.0D-10) VAL = 0.0D+00
C
            VR(IMO,LMO,KMO,JMO) = VAL
            VR(JMO,KMO,LMO,IMO) = VAL
         END DO
         END DO
    1 CONTINUE
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCRDVL
C
C ROUTINE TO READ THE VL INTEGRAL CLASS INTO SMP SHARED MEMORY
C
      SUBROUTINE CCSD_RDVL(NO,NU,VL,TMP)
      IMPLICIT NONE
C
      INTEGER NO,NU
      DOUBLE PRECISION VL(NO,NU,NU,NO),TMP(1)
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C
      INTEGER I,J,K,L,NOTR,NUTR,NO2,NU2,NO2U2
      INTEGER IMO,JMO,KMO,LMO,ICNTR
      DOUBLE PRECISION VAL
C
      NO2  = NO*NO
      NU2  = NU*NU
      NO2U2= NO2*NU2
      NOTR = NO*(NO+1)/2
      NUTR = NU*(NU+1)/2
C
      CALL DDI_GET(D_VVOO,1,NUTR,1,NOTR,TMP)
C
      ICNTR = 0
      CALL ZEROMA(VL,1,NO2U2)
C
      DO I = 1,NO
      DO J = 1,I
C
         DO K = 1,NU
         DO L = 1,K
C
            ICNTR = ICNTR + 1
            VAL   = TMP(ICNTR)
            IF(ABS(VAL).LT.1.0D-10) VAL = 0.0D+00
C
            IMO = I
            JMO = J
            KMO = K
            LMO = L
C
            IF(IMO.GT.0 .AND. JMO.GT.0) THEN
               VL(IMO,KMO,LMO,JMO) = VAL
               VL(IMO,LMO,KMO,JMO) = VAL
               VL(JMO,KMO,LMO,IMO) = VAL
               VL(JMO,LMO,KMO,IMO) = VAL
            END IF
C
         END DO
         END DO
      END DO
      END DO
C
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_CLEAN_INTS
C
C ROUTINE TO DESTROY DISTRIBUTED ARRAYS USED IN CCSD(T)
C
      SUBROUTINE CCSD_CLEAN_INTS()
      IMPLICIT NONE
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C
      IF(NDVVOO) CALL DDI_DESTROY(D_VVOO)
      IF(NDOOOO) CALL DDI_DESTROY(D_OOOO)
      IF(NDVOOO) CALL DDI_DESTROY(D_VOOO)
      IF(NDVOVO) CALL DDI_DESTROY(D_VOVO)
      IF(NDVVVO) CALL DDI_DESTROY(D_VVVO)
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_VVVV
C ------------------------------
C AO DRIVEN [VV|VV] TERM IN CCSD
C ------------------------------
      SUBROUTINE CCSD_VVVV(NO,NU,O1,O2,T2,ITER)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C --------------------
C CALLING ARGUMENTS
C --------------------
      INTEGER NO,NU,NBF,ITER
      DOUBLE PRECISION O1(*),O2(*),T2(*)
C
C --------------------
C CONSTANT PARAMETERS
C --------------------
      INTEGER MXATM,MXSH,MXGTOT
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      DOUBLE PRECISION ZERO,HALF,TWO
      PARAMETER(ZERO=0.0D+00, HALF=0.5D+00, TWO=2.0D+00)
C
C --------------------
C COMMON BLOCK: CCPAR
C --------------------
      INTEGER          METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                 MXCCIT,MXRLEIT,MWRDCC,ICCCNV,ICCRST,IDSKCC
      DOUBLE PRECISION AMPTSH
      COMMON /CCPAR /  AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                 MXCCIT,MXRLEIT,MWRDCC,ICCCNV,ICCRST,IDSKCC
C
C --------------------
C COMMON BLOCK: FMCOM
C --------------------
      DOUBLE PRECISION X(1)
      COMMON /FMCOM /  X
C
C --------------------
C COMMON BLOCK: INFOA
C --------------------
      INTEGER          NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,IAN(MXATM)
      DOUBLE PRECISION ZAN(MXATM),C(3,MXATM)
      COMMON /INFOA /  NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,ZAN,C,IAN
C
C --------------------
C COMMON BLOCK: IOFILE
C --------------------
      INTEGER IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA
C
C --------------------
C COMMON BLOCK: SHLEXC
C --------------------
      INTEGER NORGSH(3),NORGSP(3),IEXCH,NANGM,NGTH(4)
      COMMON /SHLEXC/ NORGSH,NORGSP,IEXCH,NANGM,NGTH
C
C --------------------
C COMMON BLOCK: NSHEL
C --------------------
      DOUBLE PRECISION EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                 CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT)
      INTEGER          KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                 KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /NSHEL /  EX,CS,CP,CD,CF,CG,CH,CI,
     *                 KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,NSHELL
C
C --------------------
C COMMON BLOCK: OUTPUT
C --------------------
      INTEGER NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
C
C --------------------
C COMMON BLOCK: PAR
C --------------------
      INTEGER ME,MASTER,NPROC,IBTYP,IPTIM
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C --------------------
C COMMON BLOCK: CCIKCT
C --------------------
      INTEGER IKCUT
      COMMON /CCIKCT/ IKCUT
C
C -------------------
C LOCAL VARIABLES
C -------------------
C
      INTEGER DDI_NP,DDI_ME
      INTEGER SMP_NP,SMP_ME
      INTEGER NOU,NO2,NU2,NO2U2,NBSQ,IUST,NUBF,NOBF,NROWS,IOST
      INTEGER NOTR
      INTEGER ICNTR,MYWRK
      INTEGER LOADFM,LAST,NEED
      INTEGER LCMO,LCMOT,LAO1,LTMP,LTRAN1,LDUM1,LDUM2,LTRAN2
      INTEGER LMAX,MXSHL,MXSHL2,MXSHL3,MXSHL4
      INTEGER ISH,JSH,KSH,LSH
      INTEGER I
      INTEGER LENI,LENK,LENIK,D_VVVV2
      INTEGER IBLK,IOFF,NCOL_USED,REMAINING,INFO(2,15*15)
      INTEGER LENIK_CUTOFF
C
      LOGICAL DEBUG
      LOGICAL USE_DLB
C
      INTEGER NTIMERS
      PARAMETER(NTIMERS=5)
C
      DOUBLE PRECISION CUTOFF
      DOUBLE PRECISION TIMERS(NTIMERS)
      DOUBLE PRECISION TSEC_START,TSEC_TRAN1,TSEC_TRAN2,TSEC_TRAN34
      DOUBLE PRECISION TOTAL_TRAN1,TOTAL_TRAN2,TOTAL_TRAN34
C
C -------------------------------------------------------------
C ASSUMPTIONS / DEFINITIONS
C =========================
C CALCULATING MULLIKEN TYPE AO INTEGRALS [I,J|K,L],
C HOWEVER, THE FORMAL SUMATIONS REQUIRE THE USE OF <I,J|K,L>
C INTEGRALS, THIS IS ACCOUNTED FOR IN CCSD_SUMAO.
C THE OCCUPPIED INDICIES OF O2 ARE REPRESENTED AS IOCC AND JOCC
C THE VIRTUAL INDICIES OF O2 ARE REPRESENTED AS A AND B
C -------------------------------------------------------------
C
C ---------------------------
C DETERMINE PROCESS IDENTITY
C ---------------------------
C
      DEBUG   = .FALSE.
      USE_DLB = .FALSE.
      LENIK_CUTOFF = IKCUT
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
C
      CALL DDI_SYNC(1234)
C
      IF(DEBUG.AND.MASWRK) THEN
         WRITE(6,*) 'CCSD_VVVV: BEGIN'
         CALL FLSHBF(6)
      END IF
C
C ------------------------------
C DETERMINE IMPORTANT QUANTITIES
C ------------------------------
      NBF    = NUM
      NOU    = NO*NU
      NO2    = NO*NO
      NU2    = NU*NU
      NO2U2  = NO2*NU2
      NOBF   = NO*NBF
      NUBF   = NU*NBF
      NBSQ   = NBF*NBF
      NOTR   = (NO2 + NO) / 2
      IOST   = NCCFZC + 1
C         STARTING VIRTUAL INDEX IN THE LIST OF ALL MOS
      IUST   = NO + NCCFZC + 1
C
      CUTOFF = 1.0D+00/(10.0D+00**ICUT) ! AO INTEGRAL CUTOFF
C
C -------------------------------------------------------------
C DETERMINE THE SIZE OF THE BUFFER NEEDED TO STORE AO INTEGRALS
C -------------------------------------------------------------
C        GET THE MAXIMUM L (TRUE ANG. MOM.) OF ANY FN IN THE BASIS SET
      CALL BASCHK(LMAX)
                    MXSHL =  4     ! L SHELLS HAVE  4 FUNCTIONS
      IF(LMAX.EQ.2) MXSHL =  6     ! D SHELLS HAVE  6 FUNCTIONS
      IF(LMAX.EQ.3) MXSHL = 10     ! F SHELLS HAVE 10 FUNCTIONS
      IF(LMAX.EQ.4) MXSHL = 15     ! G SHELLS HAVE 15 FUNCTIONS
      IF(LMAX.EQ.5) MXSHL = 21     ! H SHELLS HAVE 21 FUNCTIONS
      IF(LMAX.EQ.6) MXSHL = 28     ! I SHELLS HAVE 28 FUNCTIONS
C
      NGTH(4) = 1
      NGTH(3) = NGTH(4) * MXSHL
      NGTH(2) = NGTH(3) * MXSHL
      NGTH(1) = NGTH(2) * MXSHL
      IF(NOPK.EQ.0) THEN
         NORGSH(1) = 0
         NORGSH(2) = NORGSH(1) + MXSHL**4
         NORGSH(3) = NORGSH(2) + MXSHL**4
         NORGSP(1) = 0
         NORGSP(2) = 256
         NORGSP(3) = 512
         IEXCH     = 1
      ELSE
         DO I=1,3
            NORGSH(I) = 0
            NORGSP(I) = 0
         ENDDO
      END IF
C
      IF(DEBUG.AND.MASWRK) THEN
         WRITE(6,*) 'CCSD_VVVV: MXSHL=',MXSHL
         CALL FLSHBF(6)
      END IF
C
      MXSHL2 = MXSHL*MXSHL
      MXSHL3 = MXSHL*MXSHL2
      MXSHL4 = MXSHL*MXSHL3
C
C ----------------------------------------------------------------------
C RE-ORDER AMPLITUDES : INPUT ASSUMED TO BE SIMILAR TO O2 FROM CCSD_MP2
C ---------------------------------------------------------------------
      IF(DEBUG.AND.MASWRK) THEN
         WRITE(6,*) 'CCSD_VVVV: RE-ORDER O2'
         CALL FLSHBF(6)
      END IF
C
C     N.B.: IF YOU CHANGE THIS, YOU MUST ALSO CHANGE THE "CHECK" MEMORY.
C
      CALL VALFM(LOADFM)
      LTMP = LOADFM + 1
      LAST = LTMP   + NO*NU*NU
      NEED = LAST - LOADFM -1
      CALL GETFM(NEED)
C
      CALL ADT12_6_SMP(1,NO,NU,O1,O2)            ! ADDS O1 INTO O2
      CALL TRANSQ_SMP(O2,NOU)                    ! (I,A,B,J) ->(B,J,I,A)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),O2,12) ! (B,J,I,A) ->(J,B,I,A)
      CALL INSITU_SMP(NO,NU,NO,NU,X(LTMP),O2,23) ! (J,B,I,A) ->(J,I,B,A)
      CALL TRANMD_SMP(O2,NO,NO,NU,NU,12)         ! (J,I) -> (J,I)T
      CALL DSCAL_SMP(NO2U2,HALF,O2,1)            ! SCALE O2 BY HALF
      CALL ZEROMA_SMP(T2,1,NO2U2)
      CALL DDI_SMP_SYNC()
C
      CALL RETFM(NEED)
C
      IF(DEBUG.AND.MASWRK) THEN
         WRITE(6,*) 'CCSD_VVVV: RE-ORDERING COMPLETE'
C        CALL WO2AMPS(NO,NO,NU,NU,O2)
         CALL FLSHBF(6)
      END IF
C
C --------------------------
C ALLOCATE REPLICATED MEMORY
C --------------------------
C     N.B.: IF YOU CHANGE THIS, YOU MUST ALSO CHANGE THE "CHECK" MEMORY.
C
      CALL VALFM(LOADFM)
      LAO1   = LOADFM + 1
      LCMO   = LAO1   + MXSHL4
      LCMOT  = LCMO   + NBSQ
      LTRAN1 = LCMOT  + NUBF
      LTRAN2 = LTRAN1 + MAX(NOBF,NUBF)*MXSHL2
      LDUM1  = LTRAN2 + MAX(NO2,NU2)*MXSHL2
      LDUM2  = LDUM1  + NBSQ
      LAST   = LDUM2  + NBSQ
      NEED   = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C ---------------------------
C GET MO COEFFICIENTS
C ---------------------------
C          GETS ALL MO COEF.
      CALL DAREAD(IDAF,IODA,X(LDUM1),NBSQ,15,0)
C          COPY THE OCC MO COEFFS.
      CALL DCOPY(NO*NBF,X(LDUM1+NBF*(IOST-1)),1,X(LDUM2),1)
C          COPY THE VIRTUAL MO COEFFS.
      CALL DCOPY(NU*NBF,X(LDUM1+NBF*(IUST-1)),1,X(LCMO),1)
C          TRANSPOSE OF CMO --> CMOT
      CALL TRPOSE(X(LCMO),X(LCMOT),NBF,NU,0)
C
C --------------------------------
C RESET INTEGRAL SYMMETRY SCALAR
C --------------------------------
      CALL SETQ4(1.0D+00)
C
C --------------------------------
C CREATE DISTRIBUTED ARRAY
C --------------------------------
      CALL DDI_CREATE(NBSQ,NOTR,D_VVVV2)
C
C ---------------------
C INITIALIZE CPU TIMERS
C ---------------------
      TOTAL_TRAN1    = ZERO
      TOTAL_TRAN2    = ZERO
      TOTAL_TRAN34   = ZERO
C
      DO ISH = 1,NTIMERS
         TIMERS(ISH) = ZERO
      END DO
C
C ----------------------------------------------------------------
C PROCESS STORED HALF TRANSFORMED INTEGRALS FROM A SEMI-DIRECT RUN
C ----------------------------------------------------------------
C        DON'T OPEN THE DISK FILE IF WE NEVER USE IT.
      IF(LENIK_CUTOFF.EQ.101) GO TO 50
C
      NFT80 = 80
      IF(ITER.EQ.1) THEN
         DSKWRK=.TRUE.
         CALL SEQOPN(NFT80,'CCVVVV','UNKNOWN',.FALSE.,'UNFORMATTED')
         CALL SEQREW(NFT80)
         DSKWRK=.FALSE.
      ELSE
         DSKWRK=.TRUE.
         CALL SEQREW(NFT80)
         DSKWRK=.FALSE.
         CALL CCSD_PROCESS_TRAN2(NO,NU,D_VVVV2,O2,X(LTRAN1),X(LTRAN2),
     &                           MAX(NOBF,NUBF)*MXSHL2,NFT80,TIMERS)
      END IF
C
   50 CONTINUE
C
C ---------------------
C INITIALIZE BLOCK INFO
C ---------------------
      INFO(1,1) = 0
      IBLK      = 0
      IOFF      = 0
      NCOL_USED = 0
      REMAINING = MXSHL2
      CALL DCOPY(MAX(NOBF,NUBF)*MXSHL2,0.0D+00,0,X(LTRAN1),1)
C
C --------------------------------
C INITIALIZE LOAD BALANCE COUNTERS
C --------------------------------
      ICNTR  = -1
      IF(USE_DLB) CALL DDI_DLBRESET()
      IF(USE_DLB) CALL DDI_DLBNEXT(MYWRK)
C
C ----------------------------------------------------------------
C START THE DIRECT VVVV CALCULATION
C ----------------------------------------------------------------
      DO 10 ISH = 1,NSHELL
      DO 10 KSH = 1,ISH
C
C    --------------------
C    SEMI-DIRECT CRITERIA
C    --------------------
         LENI  = KMAX(ISH) - KMIN(ISH) + 1
         LENK  = KMAX(KSH) - KMIN(KSH) + 1
         IF(ITER.GT.1 .AND. LENI+LENK .GT. LENIK_CUTOFF) GOTO 10
C
C    -------------
C    LOAD BALANCER
C    -------------
         ICNTR = ICNTR + 1
         IF(USE_DLB) THEN
            IF(ICNTR.NE.MYWRK) GOTO 10
         ELSE
            IF(MOD(ICNTR,DDI_NP).NE.DDI_ME) GOTO 10
         END IF
C
         LENIK = LENI*LENK
         NROWS = LENIK
         IF(ISH.NE.KSH) NROWS = NROWS + NROWS
C
C ---------------------------------------------------------------------
C WE ARE USING A BUFFERED SET OF HALF-TRANSFORMED INTEGRALS TO IMPROVE
C THE PERFORMANCE OF THE CONTRACTION BETWEEN THE AMPLITUDES AND THE 1/2
C TRANSFORMED INTEGRALS.  AT THIS POINT, WE CHECK TO SEE IF OUR BUFFER
C CAN HOLD THE NEXT SET OF INTEGRALS.  IF SO, THE 1/2 TRANSFORMED INTS
C ARE CALCULATED AND STORED.  IF THE BUFFER CAN NOT HOLD THE NEXT SET
C OF 1/2 TRANS. INTS, THEN WE FLUSH THE BUFFER BY CONTRACTING THE AMPS
C WITH THE INTEGRALS AND STORE THE PRODUCT IN DISTRIBUTED MEMORY.
C ---------------------------------------------------------------------
         IF(REMAINING.LT.LENIK) THEN
            CALL CCSD_O2XVVNN(NO,NU,D_VVVV2,IBLK,INFO,
     &                        TIMERS,O2,X(LTRAN1),X(LTRAN2))
C       ----------------
C       RESET INFO BLOCS
C       ----------------
            IBLK      = 0
            IOFF      = 0
            NCOL_USED = 0
            REMAINING = MXSHL2
            CALL DCOPY(MAX(NOBF,NUBF)*MXSHL2,0.0D+00,0,X(LTRAN1),1)
         END IF
C
C    ---------------
C    START CPU TIMER
C    ---------------
         CALL TSECND(TSEC_START)
C
C    -----------------
C    DETERMINE OFFSETS
C    -----------------
         IOFF = NU2*NCOL_USED
C
C    ----------------------
C    ZERO OUT WORKING SPACE
C    ----------------------
         CALL DCOPY(MAX(NOBF,NUBF)*LENIK,0.0D+00,0,X(LTRAN1+IOFF),1)
C
C    ---------------
C    SAVE BLOCK INFO
C    ---------------
         IBLK         = IBLK + 1
         INFO(1,IBLK) = ISH
         INFO(2,IBLK) = KSH
C
         NCOL_USED = NCOL_USED + LENIK
         REMAINING = REMAINING - LENIK
C
         DO JSH = 1,NSHELL
         DO LSH = 1,NSHELL
C
            CALL CCSD_SHELLQUART(ISH,JSH,KSH,LSH,MXSHL,NBF,
     &                           X(LAO1),CUTOFF,
     &                           NU,LENI,LENK,X(LCMOT),X(LTRAN1+IOFF))
C
         END DO
         END DO
C
         CALL TSECND(TSEC_TRAN1)
         TOTAL_TRAN1 = TOTAL_TRAN1 + (TSEC_TRAN1-TSEC_START)
         TIMERS(1) = TIMERS(1) + (TSEC_TRAN1-TSEC_START)
C
         IF(DEBUG.AND.MASWRK) THEN
            WRITE(6,*) 'CCSD_TRAN1 FOR I/K=',ISH,KSH
            CALL FLSHBF(6)
         END IF
C
         CALL CCSD_TRAN2(LENI,LENK,NU,NBF,X(LCMO),X(LTRAN1+IOFF),
     &                   X(LTRAN2))
C
C    THE SEMI-DIRECT VVVV TERM IS AN OPTION IF THE COMPUTER AS A
C    REASONABLE AMOUNT OF LOCAL SCRATCH DISK.  THE SEMI-DIRECT
C    METHOD SELECTIVELY STORES THE SET OF HALF TRANSFORMED INTEGRALS
C    THAT ARE THE MOST EXPEN- SIVE TO CALCULATE.  THE SELECTION
C    CRITERIA IS THAT LENI+LENK IS GREATER THAN THE LENIK_CUTOFF,
C    WHICH IS USER DEFINABLE.
C
         IF(LENI+LENK .GT. LENIK_CUTOFF .AND. ITER.EQ.1) THEN
         IF(DEBUG.AND.MASWRK) THEN
            WRITE(6,*) 'CCSD_STORE_TRAN2 FOR I/K=',ISH,KSH
            CALL FLSHBF(6)
         END IF
            CALL CCSD_STORE_TRAN2(ISH,KSH,LENI,LENK,NU,
     *                            X(LTRAN1+IOFF),NFT80)
         END IF
C
C
         CALL TSECND(TSEC_TRAN2)
         TOTAL_TRAN2 = TOTAL_TRAN2 + (TSEC_TRAN2-TSEC_TRAN1)
         TIMERS(2) = TIMERS(2) + (TSEC_TRAN2-TSEC_TRAN1)
C
         IF(DEBUG.AND.MASWRK) THEN
            WRITE(6,*) 'CCSD_TRAN2 FOR I/K=',ISH,KSH
            CALL FLSHBF(6)
         END IF
C
         IF(USE_DLB) CALL DDI_DLBNEXT(MYWRK)
C
   10  CONTINUE
C
C --------------------------------------
C COMPLETE THE LAST BUFFERED WORK PACKET
C --------------------------------------
      IF(IBLK.NE.0) THEN
          CALL CCSD_O2XVVNN(NO,NU,D_VVVV2,IBLK,INFO,
     &                      TIMERS,O2,X(LTRAN1),X(LTRAN2))
      END IF
C
      IF(DEBUG.AND.MASWRK) THEN
         WRITE(6,*) 'CCSD_VVVV: FINISHED WITH AO INTEGRAL CONTRACTION'
         CALL FLSHBF(6)
      END IF
C
      CALL DDI_SYNC(6548)
C
      IF(USE_DLB) CALL DDI_DLBRESET()
C
      CALL TSECND(TSEC_START)
      CALL DDI_SMP_SYNC()
      CALL TRAN34_TEST(NO,NU,NBF,D_VVVV2,X(LCMO),X(LDUM1),X(LDUM2),T2)
      CALL DDI_SMP_SYNC()
      CALL TSECND(TSEC_TRAN34)
      TOTAL_TRAN34 = TSEC_TRAN34 - TSEC_START
      TIMERS(5) = TIMERS(5) + TOTAL_TRAN34
C
C -----------------------------------
C RETURN REPLICIATED MEMORY (PROCESS)
C -----------------------------------
      CALL RETFM(NEED)
C
      IF(DEBUG) THEN
        CALL DDI_SYNC(5000)
        IF(MASWRK) THEN
          WRITE(6,*) 'CCSD_VVVV: FINAL VVVV CONTRIBUTION TO T2 AMPS'
          CALL FLSHBF(6)
        END IF
        CALL DDI_SYNC(5001)
      END IF
C
C --------------------------------------------------------------------
C RETURN AMPLITUDES (O2) AND PARTIAL CONTRIBUTIONS (T2) TO ORIG. STATE
C --------------------------------------------------------------------
C     N.B.: IF YOU CHANGE THIS, YOU MUST ALSO CHANGE THE "CHECK" MEMORY.
C
      CALL VALFM(LOADFM)
      LTMP = LOADFM + 1
      LAST = LTMP   + NO*NU*NU
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C
C
C          SCALES O2 BACK TO ORIGINAL VALUES
      CALL DSCAL_SMP(NO2U2,TWO,O2,1)
      CALL TRANMD_SMP(O2,NO,NO,NU,NU,12)         ! (J,I)T    ->(J,I)
      CALL INSITU_SMP(NO,NO,NU,NU,X(LTMP),O2,23) ! (J,I,B,A) ->(J,B,I,A)
      CALL INSITU_SMP(NO,NU,NO,NU,X(LTMP),O2,12) ! (J,B,I,A) ->(B,J,I,A)
C          NOW, BACK TO ORIGINAL ORDER
      CALL TRANSQ_SMP(O2,NOU)                    ! (B,J,I,A) ->(I,A,B,J)
      CALL ADT12_6_SMP(2,NO,NU,O1,O2)            ! SUBTRACT O1 OUT OF O2
C
      CALL INSITU_SMP(NO,NO,NU,NU,X(LTMP),T2,13) ! (I,J,B,A) ->(B,J,I,A)
      CALL TRANSQ_SMP(T2,NOU)                    ! (B,J,I,A) ->(I,A,B,J)
C
      CALL DDI_SMP_SYNC()
      CALL RETFM(NEED)
C
C
C
      CALL DDI_SYNC(5673)
C
      CALL DDI_DESTROY(D_VVVV2)
C
      IF(DEBUG.AND.MASWRK) THEN
        WRITE(6,*) 'CCSD_VVVV: FINISHED'
        CALL FLSHBF(6)
      END IF
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_O2XVVNN
      SUBROUTINE CCSD_O2XVVNN(NO,NU,D_NNOO,NBLK,INFO,
     &                        TIMERS,O2,TRAN1,TRAN2)
      IMPLICIT NONE
C
C -----------------
C CALLING ARGUMENTS
C -----------------
      INTEGER NO,NU,D_NNOO,NBLK,INFO(2,*)
      DOUBLE PRECISION O2(*),TRAN1(*),TRAN2(*),TIMERS(5)
C
C -------------------
C CONSTANT PARAMETERS
C -------------------
      DOUBLE PRECISION ZERO,ONE
      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00)
C
      INTEGER MXSH,MXGTOT
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
C --------------------
C COMMON BLOCK: NSHEL
C --------------------
      DOUBLE PRECISION EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                 CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT)
      INTEGER          KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                 KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /NSHEL /  EX,CS,CP,CD,CF,CG,CH,CI,
     *                 KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,NSHELL
C
C ---------------
C LOCAL VARIABLES
C ---------------
      INTEGER NO2,NU2
      INTEGER IBLK,IOFF,ISH,KSH,LENI,LENK,LENIK,NROWS,NCOLS
      DOUBLE PRECISION TSEC_START,TSEC_CONTRACT,TSEC_PUT
C
C --------------------------
C INITIALIZE LOCAL VARIABLES
C --------------------------
      NO2 = NO*NO
      NU2 = NU*NU
C
      IOFF  = 0
      NCOLS = 0
C
C ---------------
C START CPU TIMER
C ---------------
      CALL TSECND(TSEC_START)
C
C ---------------------------------------
C COUNT THE NUMBER OF AO INTEGRAL COLUMNS
C ---------------------------------------
      DO IBLK = 1,NBLK
         ISH   = INFO(1,IBLK)
         KSH   = INFO(2,IBLK)
         LENI  = KMAX(ISH) - KMIN(ISH) + 1
         LENK  = KMAX(KSH) - KMIN(KSH) + 1
         LENIK = LENI*LENK
         NCOLS = NCOLS + LENIK
C
C        WRITE(6,*) 'FROM CCSD_O2X'
C        WRITE(6,*) 'BLOCK ',IBLK
C        WRITE(6,*) 'I/KSH ',ISH,KSH
C        WRITE(6,*) 'LENI/K ',LENI,LENK,LENIK
C        CALL FLSHBF(6)
      END DO
C
C
C -----------------------------------------------
C CONTRACT O2 AMPS WITH 1/2 TRANSFORMED INTEGRALS
C -----------------------------------------------
      CALL DGEMM('N','N',NO2,NCOLS,NU2,ONE,O2,NO2,TRAN1,NU2,
     &           ZERO,TRAN2,NO2)
C
C
      CALL TSECND(TSEC_CONTRACT)
      TIMERS(3) = TIMERS(3) + (TSEC_CONTRACT-TSEC_START)
C
C --------------------------------------------
C DISTRIBUTE THE PRODUCT TO DISTRIBUTED MEMORY
C --------------------------------------------
      DO IBLK = 1,NBLK
         ISH   = INFO(1,IBLK)
         KSH   = INFO(2,IBLK)
         LENI  = KMAX(ISH) - KMIN(ISH) + 1
         LENK  = KMAX(KSH) - KMIN(KSH) + 1
         LENIK = LENI*LENK
         NROWS = LENIK
         IF(ISH.NE.KSH) NROWS = NROWS + NROWS
C
         CALL PUT_TEST(D_NNOO,ISH,KSH,LENI,LENK,NO,TRAN2(IOFF+1),TRAN1,
     &                     NROWS)
C
         IOFF = IOFF + NO2*LENIK
      END DO
C
      CALL TSECND(TSEC_PUT)
      TIMERS(4) = TIMERS(4) + (TSEC_PUT-TSEC_CONTRACT)
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK PUT_TEST
      SUBROUTINE PUT_TEST(D_VVVV,ISH,KSH,LENI,LENK,NO,TRAN,TMP,
     &                    NROWS)
      IMPLICIT NONE
C
      INTEGER D_VVVV,ISH,KSH,LENI,LENK,NO,NROWS
      DOUBLE PRECISION TRAN(NO,NO,LENI,LENK)
      DOUBLE PRECISION TMP(NROWS,*)
C
C --------------------
C CONSTANT PARAMETERS
C --------------------
      INTEGER MXSH,MXGTOT
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
C --------------------
C COMMON BLOCK: NSHEL
C --------------------
      DOUBLE PRECISION EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                 CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT)
      INTEGER          KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                 KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /NSHEL /  EX,CS,CP,CD,CF,CG,CH,CI,
     *                 KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,NSHELL
C
      INTEGER I,K,A,B,ILO,IHI,IAB,LEN
      INTEGER ROW,NCOL
C
      ILO = 0
      IHI = 0
      NCOL = NO*NO + NO
      NCOL = NCOL / 2
C
      DO I = 1,ISH
      DO K = 1,I
C
         LEN = (KMAX(I)-KMIN(I)+1)*(KMAX(K)-KMIN(K)+1)
         IF(I.NE.K) LEN = LEN + LEN
C
         ILO = IHI + 1
         IHI = ILO + LEN - 1
C
         IF(I.EQ.ISH .AND. K.EQ.KSH) GOTO 1
C
      END DO
      END DO
C
   1  CONTINUE
C
      ROW  = 0
      DO I = 1,LENI
      DO K = 1,LENK
C
         ROW = ROW + 1
C
         IAB = 0
         DO A = 1,NO
         DO B = 1,A
C
            IAB = IAB + 1
            TMP(ROW,IAB) = TRAN(B,A,I,K)
C
         END DO
         END DO
C
      END DO
      END DO
C
      IF(ISH.EQ.KSH) THEN
         CALL DDI_PUT(D_VVVV,ILO,IHI,1,NCOL,TMP)
         RETURN
      END IF
C
      DO I = 1,LENI
      DO K = 1,LENK
C
         ROW = ROW + 1
C
         IAB = 0
         DO A = 1,NO
         DO B = 1,A
C
            IAB = IAB + 1
            TMP(ROW,IAB) = TRAN(A,B,I,K)
C
         END DO
         END DO
C
      END DO
      END DO
C
      CALL DDI_PUT(D_VVVV,ILO,IHI,1,NCOL,TMP)
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK ADT12_6_SMP
      SUBROUTINE ADT12_6_SMP(IGOTO,NO,NU,T1,T2)
      IMPLICIT NONE
      INTEGER IGOTO,NO,NU
      DOUBLE PRECISION T1(NO,NU),T2(NO,NU,NU,NO)
C
      INTEGER J,B,NOU
      INTEGER SMP_NP,SMP_ME
      DOUBLE PRECISION SCL,ONEM
      PARAMETER(ONEM=-1.0D+00)
C
      NOU  = NO*NU
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DO 1 J=1,NO
         IF(MOD(J,SMP_NP).NE.SMP_ME) GOTO 1
      DO B=1,NU
         SCL = T1(J,B)
         IF(IGOTO.EQ.2) SCL = SCL*ONEM
         CALL DAXPY(NOU,SCL,T1,1,T2(1,1,B,J),1)
      END DO
    1 CONTINUE
C
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK ADT12_3_SMP
      SUBROUTINE ADT12_3_SMP(IGOTO,NO,NU,T1,T2)
      IMPLICIT NONE
      INTEGER IGOTO,NO,NU
      DOUBLE PRECISION T1(1),T2(1)
      INTEGER A,B,J
      INTEGER NO2U,NO2
      INTEGER I1B,I1A,I2B,I2BA,I2BAJ
      DOUBLE PRECISION T1_JB
C
      INTEGER SMP_NP,SMP_ME
C
      DOUBLE PRECISION ONEM
      PARAMETER(ONEM=-1.0D+00)
C
      NO2  = NO*NO
      NO2U = NO2*NU
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DO 1 B=1,NU
         IF(MOD(B,SMP_NP).NE.SMP_ME) GOTO 1
         I1B = (B-1)*NO
         I2B = (B-1)*NO2U
      DO 10 A=1,NU
         I1A  = (A-1)*NO + 1
         I2BA = I2B + (A-1)*NO2
      DO 10 J=1,NO
         T1_JB = T1(I1B+J)
         I2BAJ = I2BA + (J-1)*NO + 1
C
         IF(IGOTO.EQ.2) T1_JB = ONEM*T1_JB
         CALL DAXPY(NO,T1_JB,T1(I1A),1,T2(I2BAJ),1)
C
 10   CONTINUE
  1   CONTINUE
C
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK ADT12_2_SMP
      SUBROUTINE ADT12_2_SMP(IGOTO,NO,NU,T1,T2)
      IMPLICIT NONE
      INTEGER IGOTO,NO,NU
      DOUBLE PRECISION T1(1),T2(1)
C
      INTEGER A,B,J
      INTEGER NO2,NO2U
      INTEGER I1A,I2A,I1B,I2AB,I2ABJ
      DOUBLE PRECISION T1_JB
C
      INTEGER SMP_NP,SMP_ME
C
      DOUBLE PRECISION ONEM
      PARAMETER(ONEM=-1.0D+00)
C
      NO2  = NO*NO
      NO2U = NO2*NU
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DO 1 A=1,NU
         IF(MOD(A,SMP_NP).NE.SMP_ME) GOTO 1
         I1A = (A-1)*NO + 1
         I2A = (A-1)*NO2U + 1
      DO 10 B=1,NU
         I1B  = (B-1)*NO
         I2AB = I2A + (B-1)*NO2
      DO 10 J=1,NO
         T1_JB = T1(I1B+J)
         I2ABJ = I2AB + (J-1)*NO
C
         IF(IGOTO.EQ.2) T1_JB = ONEM*T1_JB
         CALL DAXPY(NO,T1_JB,T1(I1A),1,T2(I2ABJ),1)
C
 10   CONTINUE
  1   CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK ADT12_4_SMP
      SUBROUTINE ADT12_4_SMP(IGOTO,NO,NU,T1,T2)
      IMPLICIT NONE
      INTEGER IGOTO,NO,NU
      DOUBLE PRECISION T1(1),T2(1)
C
      INTEGER B,I,J
      INTEGER NOU,NOU2
      INTEGER I2I,I1B,I2IB,I2IBJ
      INTEGER SMP_NP,SMP_ME
      DOUBLE PRECISION T1_JB
C
      DOUBLE PRECISION ONEM
      PARAMETER(ONEM=-1.0D+00)
C
      NOU  = NO*NU
      NOU2 = NOU*NU
C
C     ICNTR = 0
C     CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NIB,SIB)
C     EIB = SIB + NIB - 1
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DO 1 I=1,NO
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 1
         I2I = (I-1)*NOU2 + 1
      DO 10 B=1,NU
C        ICNTR = ICNTR + 1
C        IF(ICNTR.LT.SIB .OR. ICNTR.GT.EIB) GOTO 1
         I1B  = (B-1)*NO
         I2IB = I2I + (B-1)*NOU
      DO 10 J=1,NO
         T1_JB = T1(I1B+J)
         I2IBJ = I2IB + (J-1)*NU
C
         IF(IGOTO.EQ.2) T1_JB = T1_JB*ONEM
         CALL DAXPY(NU,T1_JB,T1(I),NO,T2(I2IBJ),1)
C
 10   CONTINUE
  1   CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK ADT12_5_SMP
      SUBROUTINE ADT12_5_SMP(IGOTO,NO,NU,T1,T2)
      IMPLICIT NONE
      INTEGER IGOTO,NO,NU
      DOUBLE PRECISION T1(1),T2(1)
C
      INTEGER A,I,J
      INTEGER I2J,I1A,I2JA,I2JAI,NOU2,NOU
      INTEGER SMP_NP,SMP_ME
C
      DOUBLE PRECISION T1_IA,ONEM
      PARAMETER(ONEM=-1.0D+00)
C
      NOU  = NO*NU
      NOU2 = NOU*NU
C
C     ICNTR = 0
C     CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NJA,SJA)
C     EJA = SJA + NJA - 1
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DO 1 J=1,NO
         IF(MOD(J,SMP_NP).NE.SMP_ME) GOTO 1
         I2J = (J-1)*NOU2 + 1
      DO 10 A=1,NU
C        ICNTR = ICNTR + 1
C        IF(ICNTR.LT.SJA .OR. ICNTR.GT.EJA) GOTO 1
         I1A  = (A-1)*NO
         I2JA = I2J + (A-1)*NOU
      DO 10 I=1,NO
         I2JAI = I2JA + (I-1)*NU
         T1_IA = T1(I1A+I)
C
         IF(IGOTO.EQ.2) T1_IA = T1_IA*ONEM
         CALL DAXPY(NU,T1_IA,T1(J),NO,T2(I2JAI),1)
C
 10   CONTINUE
  1   CONTINUE
C
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK DIV_EVEN
      SUBROUTINE DIV_EVEN(N,NP,ME,NR,SR)
      IMPLICIT NONE
      INTEGER N,NP,ME,NR,SR
      INTEGER NE
C
      NR = N / NP
      NE = MOD(N,NP)
C
      IF(ME.LT.NE) THEN
         NR = NR + 1
         SR = NR*ME + 1
      ELSE
         SR = (NR+1)*NE + NR*(ME-NE) + 1
      END IF
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK ZEROMA_SMP
C  ROUTINE TO ZERO OUT A SHARED MEMORY ARRAY BY BREAKING THE
C  ARRAY INTO EQUAL SIZED PIECES
      SUBROUTINE ZEROMA_SMP(WORK,NF,NL)
      IMPLICIT NONE
      INTEGER SMP_NP,SMP_ME,SR,NR,NF,NL,N
      DOUBLE PRECISION WORK(*),ZERO
      PARAMETER(ZERO=0.0D+00)
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      N = NL - NF + 1
      CALL DIV_EVEN(N,SMP_NP,SMP_ME,NR,SR)
      CALL DCOPY(NR,ZERO,0,WORK(SR+NF-1),1)
      CALL DDI_SMP_SYNC()
C
      END
C
C*MODULE CCDDI   *DECK VECCOP_SMP
C COPIES A SHARED MEMORY ARRAY BY BREAKING THE ARRAY INTO
C EQUAL SIZE PIECES
      SUBROUTINE VECCOP_SMP(N,A,B)
      IMPLICIT NONE
      INTEGER SMP_NP,SMP_ME,SR,NR,N
      DOUBLE PRECISION A(*),B(*)
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      CALL DIV_EVEN(N,SMP_NP,SMP_ME,NR,SR)
      CALL DCOPY(NR,B(SR),1,A(SR),1)
      CALL DDI_SMP_SYNC()
C
      END
C
C*MODULE CCDDI   *DECK SETQ4
      SUBROUTINE SETQ4(Q4)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
C
      QQ4 = Q4
      RETURN
      END
C
C*MODULE CCDDI   *DECK TRANMD_SMP
      SUBROUTINE TRANMD_SMP(A,N1,N2,N3,N4,IJ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(1)
C
      INTEGER SMP_NP,SMP_ME
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      N12=N1*N2
      N123=N12*N3
      IF(IJ.EQ.12) GO TO 12
      IF(IJ.EQ.13) GO TO 13
      IF(IJ.EQ.14) GO TO 14
      IF(IJ.EQ.23) GO TO 23
      IF(IJ.EQ.24) GO TO 24
      IF(IJ.EQ.34) GO TO 34
      IF(IJ.EQ.231) GO TO 231
      IF(IJ.EQ.312) GO TO 312
      IF(IJ.EQ.341) GO TO 341
      IF(IJ.EQ.413) GO TO 413
      IF(IJ.EQ.1234) GO TO 1234
      GOTO 100
   12 CONTINUE
      DO 11 L=1,N4
C         IF(MOD(L,SMP_NP).NE.SMP_ME) GOTO 11
         N123L=N123*(L-1)
      DO 9 K=1,N3
         IF(MOD(K,SMP_NP).NE.SMP_ME) GOTO 9
         N12K=(K-1)*N12+N123L
      DO 10 I=1,N1
         N1I=(I-1)*N1
      DO 10 J=1,I
         IJKL=N12K+(J-1)*N1+I
         JIKL=N12K+N1I+J
      X=A(IJKL)
      A(IJKL)=A(JIKL)
      A(JIKL)=X
   10 CONTINUE
    9 CONTINUE
   11 CONTINUE
      GO TO 100
   13 CONTINUE
      DO 22 L=1,N4
C         IF(MOD(L,SMP_NP).NE.SMP_ME) GOTO 21
         N123L=N123*(L-1)
      DO 21 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 21
         N12I=N123L+N12*(I-1)
      DO 20 J=1,N2
         N1J=N1*(J-1)
      DO 20 K=1,I
         IJKL=N123L+(K-1)*N12+N1J+I
         KJIL=N12I+N1J+K
      X=A(IJKL)
      A(IJKL)=A(KJIL)
      A(KJIL)=X
   20 CONTINUE
   21 CONTINUE
   22 CONTINUE
      GO TO 100
   14 CONTINUE
      DO 26 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 26
         N123I=N123*(I-1)
      DO 25 J=1,N2
         N1J=N1*(J-1)
      DO 25 K=1,N3
         N12K=N12*(K-1)+N1J
      DO 25 L=1,I
         IJKL=(L-1)*N123+N12K+I
         LJKI=N123I     +N12K+L
      X=A(IJKL)
      A(IJKL)=A(LJKI)
      A(LJKI)= X
   25 CONTINUE
   26 CONTINUE
      GO TO 100
   23 CONTINUE
      DO 31 J=1,N2
         IF(MOD(J,SMP_NP).NE.SMP_ME) GOTO 31
         J1=J-1
         N1J=N1*J1
         N12J=N12*J1
      DO 30 K=1,J
         K1=K-1
         N1K=N1*K1
         N12K=N12*K1
      DO 30 L=1,N4
         N123L=N123*(L-1)
      DO 30 I=1,N1
         N123LI=N123L+I
         IJKL=N123LI+N12K+N1J
         IKJL=N123LI+N12J+N1K
      X=A(IJKL)
      A(IJKL)=A(IKJL)
      A(IKJL)=X
   30 CONTINUE
   31 CONTINUE
      GO TO 100
   24 CONTINUE
      DO 41 J=1,N2
         IF(MOD(J,SMP_NP).NE.SMP_ME) GOTO 41
         J1=J-1
         N123J=N123*J1
         N1J  =N1*J1
      DO 40 L=1,J
         L1=L-1
         N123L=N123*L1
         N1L=N1*L1
      DO 40 K=1,N3
         N12K=N12*(K-1)
      DO 40 I=1,N1
         N12KI=N12K+I
         IJKL=N123L+N12KI+N1J
         ILKJ=N123J+N12KI+N1L
      X=A(IJKL)
      A(IJKL)=A(ILKJ)
      A(ILKJ)=X
   40 CONTINUE
   41 CONTINUE
      GO TO 100
   34 CONTINUE
      DO 51 K=1,N3
         IF(MOD(K,SMP_NP).NE.SMP_ME) GOTO 51
         K1=K-1
         N12K=N12*K1
         N123K=N123*K1
      DO 50 L=1,K
         L1=L-1
         N12L=N12*L1
         N123L=N123*L1
      DO 50 J=1,N2
         J1=J-1
         N1J=N1*(J-1)
      DO 50 I=1,N1
         N1JI=N1J+I
         IJKL=N123L+N12K+N1JI
         IJLK=N123K+N12L+N1JI
      X=A(IJKL)
      A(IJKL)=A(IJLK)
      A(IJLK)=X
   50 CONTINUE
   51 CONTINUE
      GO TO 100
 231  CONTINUE
      DO 61 L=1,N4
         IF(MOD(L,SMP_NP).NE.SMP_ME) GOTO 61
         N123L=N123*(L-1)
      DO 60 J=1,N1
         J1=J-1
         N12J=N12*J1
         N1J=N1*J1
      DO 60 K=1,J
         N12JK=N12J+K
         K1=K-1
         N12K=N12*K1
         N1K=N1*K1
      DO 60 I=1,K
         I1=I-1
         IJKL=N123L+N12K+N1J+I
         JKIL=N123L+I1*N12+N1K+J
         KIJL=N123L+N12JK +I1*N1
      X=A(IJKL)
      A(IJKL)=A(JKIL)
      A(JKIL)=A(KIJL)
      A(KIJL)=X
      IF(J.EQ.K.OR.K.EQ.I) GOTO 60
         JIKL=N123L+N12K  +N1*I1+J
         IKJL=N123L+N12J  +N1K  +I
         KJIL=N123L+N12*I1+N1J  +K
      X=A(JIKL)
      A(JIKL)=A(IKJL)
      A(IKJL)=A(KJIL)
      A(KJIL)=X
 60   CONTINUE
 61   CONTINUE
      GOTO 100
 312  CONTINUE
      DO 71 L=1,N4
         IF(MOD(L,SMP_NP).NE.SMP_ME) GOTO 71
         N123L=N123*(L-1)
      DO 70 I=1,N1
         I1=I-1
         N1I=N1*I1
         N12I=N12*I1
      DO 70 J=1,I
         J1=J-1
         N1J =N1*J1
         N12J=N12*J1
      DO 70 K=1,J
         K1=K-1
         N1K=N1*K1
         N12K=N12*K1
         IJKL=N123L+N12K+N1J+I
         JKIL=N123L+N12I+N1K+J
         KIJL=N123L+N12J+N1I+K
      X=A(JKIL)
      A(JKIL)=A(IJKL)
      A(IJKL)=A(KIJL)
      A(KIJL)=X
      IF (I.EQ.J.OR.J.EQ.K) GOTO 70
         IKJL=N123L+N12J+N1K+I
         JIKL=N123L+N12K+N1I+J
         KJIL=N123L+N12I+N1J+K
      X=A(IKJL)
      A(IKJL)=A(JIKL)
      A(JIKL)=A(KJIL)
      A(KJIL)=X
 70   CONTINUE
 71   CONTINUE
      GOTO 100
 341  CONTINUE
      DO 81 L=1,N2
         IF(MOD(L,SMP_NP).NE.SMP_ME) GOTO 81
      DO 80 J=1,N1
      DO 80 K=1,J
      DO 80 I=1,K
         ILJK=(K-1)*N123+(J-1)*N12+(L-1)*N1+I
         JLKI=(I-1)*N123+(K-1)*N12+(L-1)*N1+J
         KLIJ=(J-1)*N123+(I-1)*N12+(L-1)*N1+K
      X=A(ILJK)
      A(ILJK)=A(JLKI)
      A(JLKI)=A(KLIJ)
      A(KLIJ)=X
      IF(J.EQ.K.OR.K.EQ.I) GOTO 80
         ILKJ=(J-1)*N123+(K-1)*N12+(L-1)*N1+I
         JLIK=(K-1)*N123+(I-1)*N12+(L-1)*N1+J
         KLJI=(I-1)*N123+(J-1)*N12+(L-1)*N1+K
      X=A(JLIK)
      A(JLIK)=A(ILKJ)
      A(ILKJ)=A(KLJI)
      A(KLJI)=X
 80   CONTINUE
 81   CONTINUE
      GOTO 100
 413  CONTINUE
      DO 91 L=1,N2
         IF(MOD(L,SMP_NP).NE.SMP_ME) GOTO 91
      DO 90 I=1,N1
      DO 90 J=1,I
      DO 90 K=1,J
         JLKI=(I-1)*N123+(K-1)*N12+(L-1)*N1+J
         ILJK=(K-1)*N123+(J-1)*N12+(L-1)*N1+I
         KLIJ=(J-1)*N123+(I-1)*N12+(L-1)*N1+K
      X=A(JLKI)
      A(JLKI)=A(ILJK)
      A(ILJK)=A(KLIJ)
      A(KLIJ)=X
      IF (I.EQ.J.OR.J.EQ.K) GOTO 90
         ILKJ=(J-1)*N123+(K-1)*N12+(L-1)*N1+I
         JLIK=(K-1)*N123+(I-1)*N12+(L-1)*N1+J
         KLJI=(I-1)*N123+(J-1)*N12+(L-1)*N1+K
      X=A(ILKJ)
      A(ILKJ)=A(JLIK)
      A(JLIK)=A(KLJI)
      A(KLJI)=X
 90   CONTINUE
 91   CONTINUE
      GO TO 100
 1234 CONTINUE
C--      WRITE(6,76) A
C-- 76   FORMAT(4F15.10)
      DO 96 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 96
      DO 95 J=1,N2
      DO 95 K=1,J
      DO 95 L=1,I
         IJKL=(L-1)*N123+(K-1)*N12+(J-1)*N1+I
         LKJI=(I-1)*N123+(J-1)*N12+(K-1)*N1+L
      X=A(IJKL)
      A(IJKL)=A(LKJI)
      A(LKJI)=X
      IF (I.EQ.L.OR.K.EQ.J) GOTO 95
         LJKI=(I-1)*N123+(K-1)*N12+(J-1)*N1+L
         IKJL=(L-1)*N123+(J-1)*N12+(K-1)*N1+I
      X=A(LJKI)
      A(LJKI)=A(IKJL)
      A(IKJL)=X
 95   CONTINUE
 96   CONTINUE
 100  CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK SYMT21_SMP
      SUBROUTINE SYMT21_SMP(A,N1,N2,N3,N4,IJ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N1,N2,N3,N4)
      DATA TWO/2.0D+00/
C
      INTEGER SMP_NP,SMP_ME
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      IF(IJ.EQ.23) GOTO 23
      IF(IJ.EQ.14) GOTO 14
      IF(IJ.EQ.12) GOTO 12
      IF(IJ.EQ.34) GOTO 34
      IF(IJ.EQ.13) GOTO 13
C
 23   CONTINUE
      DO 100 J=1,N2
         IF(MOD(J,SMP_NP).NE.SMP_ME) GOTO 100
      DO 10 K=1,J
      DO 10 L=1,N4
      DO 10 I=1,N1
      X=A(I,J,K,L)
      Y=A(I,K,J,L)
      A(I,J,K,L)=TWO*X-Y
      A(I,K,J,L)=TWO*Y-X
   10 CONTINUE
  100 CONTINUE
      GOTO 1000
C
 14   CONTINUE
      DO 110 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 110
      DO 11 J=1,N2
      DO 11 K=1,N3
      DO 11 L=1,I
      X=A(I,J,K,L)
      Y=A(L,J,K,I)
      A(I,J,K,L)=TWO*X-Y
      A(L,J,K,I)=TWO*Y-X
   11 CONTINUE
  110 CONTINUE
      GOTO 1000
C
 12   CONTINUE
      DO 1120 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 1120
      DO 112 J=1,I
      DO 112 K=1,N3
      DO 112 L=1,N4
      X=A(I,J,K,L)
      Y=A(J,I,K,L)
      A(I,J,K,L)=TWO*X-Y
      A(J,I,K,L)=TWO*Y-X
  112 CONTINUE
 1120 CONTINUE
      GOTO 1000
C
 13   CONTINUE
      DO 1130 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 1130
      DO 113 J=1,N2
      DO 113 K=1,I
      DO 113 L=1,N4
      X=A(I,J,K,L)
      Y=A(K,J,I,L)
      A(I,J,K,L)=TWO*X-Y
      A(K,J,I,L)=TWO*Y-X
  113 CONTINUE
 1130 CONTINUE
      GOTO 1000
C
 34   CONTINUE
      DO 1340 K=1,N3
         IF(MOD(K,SMP_NP).NE.SMP_ME) GOTO 1340
      DO 134 L=1,K
      DO 134 I=1,N1
      DO 134 J=1,N2
      X=A(I,J,K,L)
      Y=A(I,J,L,K)
      A(I,J,K,L)=TWO*X-Y
      A(I,J,L,K)=TWO*Y-X
  134 CONTINUE
 1340 CONTINUE
C
 1000 CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK DESM21_SMP
      SUBROUTINE DESM21_SMP(A,N1,N2,N3,N4,IJ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N1,N2,N3,N4)
      PARAMETER (ONE=1.0D+00, THREE=3.0D+00, THIRD=ONE/THREE,
     *           HALF=0.5D+00)
C
      INTEGER SMP_NP,SMP_ME
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      IF(IJ.EQ.23) GOTO 23
      IF(IJ.EQ.14) GOTO 14
      IF(IJ.EQ.12) GOTO 12
      IF(IJ.EQ.13) GOTO 13
      IF(IJ.EQ.34) GOTO 34
C
 23   CONTINUE
      DO 100 J=1,N2
         IF(MOD(J,SMP_NP).NE.SMP_ME) GOTO 100
      DO 10 K=1,J
      DO 10 L=1,N4
      DO 10 I=1,N1
      A1=A(I,J,K,L)
      A2=A(I,K,J,L)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(I,K,J,L)=(X-Y)*HALF
   10 CONTINUE
  100 CONTINUE
      GOTO 1000
C
 14   CONTINUE
      DO 1010 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 1010
      DO 101 J=1,N2
      DO 101 K=1,N3
      DO 101 L=1,I
      A1=A(I,J,K,L)
      A2=A(L,J,K,I)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(L,J,K,I)=(X-Y)*HALF
  101 CONTINUE
 1010 CONTINUE
      GOTO 1000
C
 34   CONTINUE
      DO 102 K=1,N3
         IF(MOD(K,SMP_NP).NE.SMP_ME) GOTO 1020
      DO 102 L=1,K
      DO 102 I=1,N1
      DO 102 J=1,N2
      A1=A(I,J,K,L)
      A2=A(I,J,L,K)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(I,J,L,K)=(X-Y)*HALF
  102 CONTINUE
 1020 CONTINUE
      GOTO 1000
C
 12   CONTINUE
      DO 1030 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 1030
      DO 103 J=1,I
      DO 103 K=1,N3
      DO 103 L=1,N4
      A1=A(I,J,K,L)
      A2=A(J,I,K,L)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(J,I,K,L)=(X-Y)*HALF
  103 CONTINUE
 1030 CONTINUE
      GOTO 1000
C
 13   CONTINUE
      DO 1130 I=1,N1
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 1130
      DO 113 J=1,N2
      DO 113 K=1,I
      DO 113 L=1,N4
      A1=A(I,J,K,L)
      A2=A(K,J,I,L)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(K,J,I,L)=(X-Y)*HALF
  113 CONTINUE
 1130 CONTINUE
      GOTO 1000
C
 1000 CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK TRANSQ_SMP
      SUBROUTINE TRANSQ_SMP(A,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N,N)
C
      INTEGER SMP_NP,SMP_ME
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DO 10 I=1,N
         IF(MOD(I,SMP_NP).NE.SMP_ME) GOTO 10
         DO J=1,I
            X=A(I,J)
            A(I,J)=A(J,I)
            A(J,I)=X
         END DO
   10 CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK INSITU_SMP
      SUBROUTINE INSITU_SMP(N1,N2,N3,N4,TI,O2,IC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(N1,N2,N3),O2(N1,N2,N3,N4)
C
      INTEGER SMP_NP,SMP_ME
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
C
      DO 10 I=1,N4
      IF (MOD(I,SMP_NP).NE.SMP_ME) GOTO 10
      IF (IC.EQ.12) GOTO 12
      IF (IC.EQ.23) GOTO 23
      GOTO 13
 12   CALL INSI12(N1,N2,N3,TI,O2(1,1,1,I))
      GOTO 10
 23   CALL INSI23(N1,N2,N3,TI,O2(1,1,1,I))
      GOTO 10
 13   CALL INSI13(N1,N2,N3,TI,O2(1,1,1,I))
 10   CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C---C*MODULE CCDDI   *DECK CHKSUM_T1
C---      SUBROUTINE CHKSUM_T1(N,NO,NU,T1)
C---      IMPLICIT NONE
C---      INTEGER N,NO,NU
C---      DOUBLE PRECISION T1(1)
C---
C---      DOUBLE PRECISION X(1)
C---      COMMON /FMCOM /  X
C---
C---      INTEGER MYTYP
C---      COMMON /RMOTMP/ MYTYP
C---
C---      INTEGER I,NOU
C---      INTEGER DDI_NP,DDI_ME
C---      INTEGER LOADFM,LCOR,LTMP,LAST,NEED
C---
C---      DOUBLE PRECISION DDOT,ONEM,SUM2,Y
C---      PARAMETER(ONEM=-1.0D+00)
C---
C---      IF(MYTYP.EQ.3) RETURN
C---
C---      NOU = NO*NU
C---
C---      CALL DDI_NPROC(DDI_NP,DDI_ME)
C---
C---      CALL VALFM(LOADFM)
C---      LTMP = LOADFM + 1
C---      LCOR = LTMP   + NOU
C---      LAST = LCOR   + NOU
C---      NEED = LAST - LOADFM - 1
C---      CALL GETFM(NEED)
C---
C---      CALL DCOPY(NOU,T1,1,X(LTMP),1)
C---      CALL DDI_GSUMF(1234,X(LTMP),NOU)
C---
C---      IF(DDI_ME.NE.0) RETURN
C---
C---      CALL RO1(N,NO,NU,X(LCOR))
C---
C---      SUM2 = 0.0D+00
C---      DO I=0,NOU-1
C---        Y = ABS(X(LTMP+I)) - ABS(X(LCOR+I))
C---!        Y = (X(LTMP+I)) - (X(LCOR+I))
C---        SUM2 = SUM2 + Y*Y
C---C
C---!        IF(Y.GT.1.0D-06) WRITE(6,*)'T1',N,I+1,X(LTMP+I),X(LCOR+I)
C---!        WRITE(6,10) T1(I),X(LTMP+I),X(LCOR+I),Y,SUM2
C---C     10 FORMAT(1X,5E16.7)
C---C
C---      END DO
C---
C---      CALL DAXPY(NOU,ONEM,X(LTMP),1,X(LCOR),1)
C---      SUM2 = DDOT(NOU,X(LCOR),1,X(LCOR),1)
C---
C---      IF(SUM2.GT.1.0D-6) THEN
C---         WRITE(6,*) 'FATAL ERROR IN CHKSUM_T1 #',N,SUM2
C---         CALL FLSHBF(6)
C---!         CALL ABRT
C---      END IF
C---
C---      CALL RETFM(NEED)
C---
C---      WRITE(6,*) 'SUCCESS CHKSUM_T1 #',N,SUM2
C---      CALL FLSHBF(6)
C---
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK CHKSUM_T2
C---      SUBROUTINE CHKSUM_T2(N,NO,NU,T2)
C---      IMPLICIT NONE
C---      INTEGER N,NO,NU
C---      DOUBLE PRECISION T2(1)
C---
C---      DOUBLE PRECISION X(1)
C---      COMMON /FMCOM /  X
C---
C---      INTEGER MYTYP
C---      COMMON /RMOTMP/  MYTYP
C---
C---      INTEGER NOU,NO2U2,I
C---      INTEGER DDI_NP,DDI_ME
C---      INTEGER LOADFM,LCOR,LTMP,LAST,NEED
C---
C---      DOUBLE PRECISION DDOT,ONEM,SUM2,Y
C---      PARAMETER(ONEM=-1.0D+00)
C---
C---      IF(MYTYP.EQ.3) RETURN
C---
C---      NOU   = NO*NU
C---      NO2U2 = NOU*NOU
C---
C---      CALL DDI_NPROC(DDI_NP,DDI_ME)
C---      IF(DDI_ME.NE.0) RETURN
C---
C---      CALL VALFM(LOADFM)
C---      LTMP = LOADFM + 1
C---      LCOR = LTMP   + NO2U2
C---      LAST = LCOR   + NO2U2
C---      NEED = LAST - LOADFM - 1
C---      CALL GETFM(NEED)
C---
C---      CALL DCOPY(NO2U2,T2,1,X(LTMP),1)
C---!      CALL DDI_GSUMF(1234,X(LTMP),NO2U2)
C---
C---      IF(DDI_ME.NE.0) RETURN
C---
C---      CALL RO2(N,NO,NU,X(LCOR))
C---      WRITE(6,*)'CHKSUM_T2 READING REC',N
C---
C---      SUM2 = 0.0D+00
C---      DO I=0,NO2U2-1
C---        Y = ABS(ABS(X(LTMP+I)) - ABS(X(LCOR+I)))
C---!        Y = (X(LTMP+I)) - (X(LCOR+I))
C---        SUM2 = SUM2 + Y*Y
C---C
C---!        IF(Y.GT.1.0D-10) WRITE(6,*)'T2',I+1,X(LTMP+I),X(LCOR+I)
C---!        WRITE(6,*)'T2',I+1,X(LTMP+I),X(LCOR+I)
C---!        WRITE(6,10) T2(I+1),X(LTMP+I),X(LCOR+I),Y,SUM2
C---C     10 FORMAT(1X,5E15.6)
C---C
C---      END DO
C---
C---      CALL DAXPY(NO2U2,ONEM,X(LTMP),1,X(LCOR),1)
C---      SUM2 = DDOT(NO2U2,X(LCOR),1,X(LCOR),1)
C---      IF(SUM2.GT.1.0D-6) THEN
C---         WRITE(6,*) 'FATAL ERROR IN CHKSUM_T2 #',N,SUM2
C---         CALL FLSHBF(6)
C---!         CALL ABRT
C---      END IF
C---
C---      CALL RETFM(NEED)
C---
C---      WRITE(6,*) 'SUCCESS CHKSUM_T2 #',N,SUM2
C---      CALL FLSHBF(6)
C---
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK WRITE_CHKSUM
C---      SUBROUTINE WRITE_CHKSUM(N,NO,NU,O1,O2,T1,T2)
C---      IMPLICIT NONE
C---      INTEGER N,NO,NU
C---      DOUBLE PRECISION O1(1),O2(1),T1(1),T2(1)
C---
C---      INTEGER M
C---
C---      M = 4*(N-1)
C---
C---      WRITE(6,*) 'WRITING CHKSUM #',N,M+10,M+11
C---      CALL FLSHBF(6)
C---
C---      CALL WO1(M+10,NO,NU,O1)
C---      CALL WO2(M+10,NO,NU,O2)
C---      CALL WO1(M+11,NO,NU,T1)
C---      CALL WO2(M+11,NO,NU,T2)
C---
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK CHECK_CHKSUM
C---      SUBROUTINE CHECK_CHKSUM(N,NO,NU,O1,O2,T1,T2,FHH,FPH,FPP)
C---      IMPLICIT NONE
C---
C---      INTEGER MYTYP,DDI_ME,DDI_NP
C---      COMMON /RMOTMP/ MYTYP
C---
C---      INTEGER N,NO,NU
C---      DOUBLE PRECISION O1(1),O2(1),T1(1),T2(1),FHH(1),FPH(1),FPP(1)
C---
C---      INTEGER M
C---
C---      MYTYP=3
C---      IF(MYTYP.EQ.3) RETURN
C---      WRITE(6,*) 'MYTYP=',MYTYP
C---
C---      CALL DDI_NPROC(DDI_NP,DDI_ME)
C---
C---      M = 4*(N-1)
C---
C---      IF(DDI_ME.EQ.0) THEN
C---      WRITE(6,*) 'VERIFYING CHKSUM    #',N,M+10,M+11,M+12,M+13
C---      CALL FLSHBF(6)
C---      ENDIF
C---      CALL CHKSUM_T1(M+10,NO,NU,O1)
C---      CALL CHKSUM_T2(M+10,NO,NU,O2)
C---      CALL CHKSUM_T1(M+11,NO,NU,T1)
C---      CALL CHKSUM_T2(M+11,NO,NU,T2)
C---!JLB
C---      CALL F_CHKSUM(M+12,NO,NU,FHH,FPP,FPH)
C---!JLB
C---
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK F_CHKSUM
C---      SUBROUTINE F_CHKSUM(N,NO,NU,FH,FP,FHP)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---
C---      COMMON /RMOTMP/ MYTYP
C---
C---      DIMENSION FH(1),FP(1),FHP(1)
C---      COMMON /FMCOM /  X(1)
C---      DOUBLE PRECISION ONEM,SUM2,Y
C---      INTEGER DDI_ME,DDI_NP,TFH,TFPH,TFP
C---      PARAMETER(ONEM=-1.0D+00)
C---C
C---      IF(MYTYP.EQ.3) RETURN
C---C
C---      NO2 = NO*NO
C---      NU2 = NU*NU
C---      NOU = NO*NU
C---C
C---      CALL VALFM(LOADFM)
C---      LFH  = LOADFM + 1
C---      LFPH = LFH    + NO2
C---      LFP  = LFPH   + NOU
C---      TFH = LFP    + NU2
C---      TFPH = TFH + NO2
C---      TFP = TFPH + NOU
C---      LAST = TFP + NU2
C---      NEED = LAST - LOADFM - 1
C---      CALL GETFM(NEED)
C---C
C---C---      CALL RF2(N,NO,NU,X(LFH),X(LFP),X(LFPH))
C---C
C---      CALL DDI_NPROC(DDI_NP,DDI_ME)
C---      IF(DDI_ME.EQ.0) THEN
C---      WRITE(6,*) 'VERIFYING FH,FP,FPH #',N
C---      CALL FLSHBF(6)
C---      ENDIF
C---
C---
C---      CALL DCOPY(NO2,FH,1,X(LFH),1)
C---      CALL DCOPY(NOU,FHP,1,X(LFPH),1)
C---      CALL DCOPY(NU2,FP,1,X(LFP),1)
C---
C---
C---      CALL DDI_GSUMF(1234,X(LFH),NO2)
C---      CALL DDI_GSUMF(1234,X(LFPH),NOU)
C---      CALL DDI_GSUMF(1234,X(LFP),NU2)
C---
C---      IF(DDI_ME.NE.0) RETURN
C---
C---      CALL RHH(N,NO,NU,X(TFH))
C---      CALL RPH(N+1,NO,NU,X(TFPH))
C---      CALL RPP(N,NO,NU,X(TFP))
C---!      CALL PRINTVEC(X(TFH),NO2,'TFHAFTERGETT')
C---!      CALL PRINTVEC(X(LFH),NO2,'LFHAFTERGETT')
C---
C---      SUM2 = 0.0D+00
C---      DO I=0,NO2-1
C---        Y = ABS(X(TFH+I)) - ABS(X(LFH+I))
C---        SUM2 = SUM2 + Y*Y
C---!        IF(Y.GT.1.0D-06) WRITE(6,*)'FH',I+1,X(TFH+I),X(LFH+I)
C---      END DO
C---
C---      CALL DAXPY(NO2,ONEM,X(TFH),1,X(LFH),1)
C---      SUM2 = DDOT(NO2,X(LFH),1,X(LFH),1)
C---      IF(SUM2.GT.1.0D-06) THEN
C---         WRITE(6,*) 'CHECK SUM ERROR FH #',N,SUM2
C---!         CALL ABRT
C---      END IF
C---         WRITE(6,*) 'CHECK SUM SUCCESS FH #',N,SUM2
C---C
C---!      DO I=1,NOU
C---!        WRITE(6,100) X(TFPH+I-1),X(LFPH+I-1)
C---!      END DO
C---!  100 FORMAT(2E15.8)
C---C
C---      CALL DAXPY(NOU,ONEM,X(TFPH),1,X(LFPH),1)
C---      SUM2 = DDOT(NOU,X(LFPH),1,X(LFPH),1)
C---      IF(SUM2.GT.1.0D-06) THEN
C---         WRITE(6,*) 'CHECK SUM ERROR FPH #',N,SUM2
C---!         CALL ABRT
C---      END IF
C---         WRITE(6,*) 'CHECK SUM SUCCESS FPH #',N,SUM2
C---
C---      SUM2 = 0.0D+00
C---      DO I=0,NU2-1
C---        Y = ABS(X(TFP+I)) - ABS(X(LFP+I))
C---        SUM2 = SUM2 + Y*Y
C---!        IF(Y.GT.1.0D-06) WRITE(6,*)'FP',I+1,X(TFP+I),X(LFP+I)
C---      END DO
C---
C---      CALL DAXPY(NU2,ONEM,X(TFP),1,X(LFP),1)
C---      SUM2 = DDOT(NU2,X(LFP),1,X(LFP),1)
C---      IF(SUM2.GT.1.0D-06) THEN
C---         WRITE(6,*) 'CHECK SUM ERROR FP #',N,SUM2
C---!         CALL ABRT
C---      END IF
C---         WRITE(6,*) 'CHECK SUM SUCCESS FP #',N,SUM2
C---
C---      CALL RETFM(NEED)
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK RF2
C---      SUBROUTINE RF2(N,NO,NU,FH,FP,FHP)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      COMMON /RMOTMP/ MYTYP
C---      DIMENSION FH(NO,NO),FP(NU,NU),FHP(NO,NU)
C---      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C---
C---      IF(MYTYP.EQ.3) RETURN
C---
C---      NLAST=5*NO+2*NU+20+3*(N-1)
C---      READ(INTG,REC=NLAST+1) FH
C---      READ(INTG,REC=NLAST+2) FP
C---      READ(INTG,REC=NLAST+3) FHP
C---
C---      RETURN
C---      END
C
C*MODULE CCDDI   *DECK MTRANS_SMP
      SUBROUTINE MTRANS_SMP(V,NU,ID)
      IMPLICIT NONE
      INTEGER NU,ID
      DOUBLE PRECISION V(NU,NU,NU,NU)
C
      INTEGER A,B,C,D,LC
      INTEGER SMP_NP,SMP_ME
      DOUBLE PRECISION X
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      IF(ID.EQ. 7) GOTO  7
      IF(ID.EQ.11) GOTO 11
      IF(ID.EQ.19) GOTO 19
      IF(ID.EQ.23) GOTO 23
C
    7 CONTINUE
      DO 701 D=1,NU
         IF(MOD(D,SMP_NP).NE.SMP_ME) GOTO 701
      DO 700 B=1,NU
      DO 700 C=1,B
      DO 700 A=1,NU
      X=V(A,B,C,D)
      V(A,B,C,D)=V(A,C,B,D)
      V(A,C,B,D)=X
  700 CONTINUE
  701 CONTINUE
      GO TO 1000
 11   CONTINUE
      DO 961 A=1,NU
         IF(MOD(A,SMP_NP).NE.SMP_ME) GOTO 961
      DO 960 B=1,NU
      DO 960 C=1,NU
      DO 960 D=1,A
      X=V(A,B,C,D)
      V(A,B,C,D)=V(D,B,C,A)
      V(D,B,C,A)=X
 960  CONTINUE
 961  CONTINUE
      GOTO 1000
 19   CONTINUE
      CALL MTRA1(V,NU)
      GOTO 1000
 23   CONTINUE
      DO 998 A=1,NU
         IF(MOD(A,SMP_NP).NE.SMP_ME) GOTO 998
      DO 997 B=1,A
      DO 997 D=1,A
      LC=B
      IF (A.EQ.B)LC=D
      DO 997 C=1,LC
      X=V(A,B,C,D)
      V(A,B,C,D)=V(C,A,D,B)
      V(C,A,D,B)=V(D,C,B,A)
      V(D,C,B,A)=V(B,D,A,C)
      V(B,D,A,C)=X
      IF (B.EQ.C.OR.A.EQ.B.AND.C.EQ.D.OR.A.EQ.D)GO TO 997
      X=V(A,C,B,D)
      V(A,C,B,D)=V(B,A,D,C)
      V(B,A,D,C)=V(D,B,C,A)
      V(D,B,C,A)=V(C,D,A,B)
      V(C,D,A,B)=X
 997  CONTINUE
 998  CONTINUE
      GO TO 1000
 1000 CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK DSCAL_SMP
      SUBROUTINE DSCAL_SMP(N,DA,DX,INCX)
      IMPLICIT NONE
C
      INTEGER N,INCX
      DOUBLE PRECISION DX(*),DA
C
      INTEGER NI,SI
      INTEGER SMP_NP,SMP_ME
C
C        DETERMINES SMP PROCESS IDENTITY
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
C DIVIDES N INTO SMP_NP EVEN PIECES, SUCH THAT
C NI AND SI ARE THE NUMBER OF VALUES AND THE
C STARTING INDEX FOR PROCESS SMP_ME.  THE VALUES
C ARE SCALED ACCORDING TO INCX TO GET THE ACTUAL
C STARTING INDEX; FINALLY THE DSCAL IS PERFORMED.
C
      CALL DIV_EVEN(N,SMP_NP,SMP_ME,NI,SI)
      SI = INCX*(SI-1) + 1
      IF(NI.GT.0) CALL DSCAL(NI,DA,DX(SI),INCX)
      CALL DDI_SMP_SYNC()
      RETURN
      END
C---C
C---C*MODULE CCDDI   *DECK WO2AMPS
C---      SUBROUTINE WO2AMPS(N1,N2,N3,N4,T2)
C---      IMPLICIT NONE
C---
C---      INTEGER N1,N2,N3,N4
C---      INTEGER DDI_NP,DDI_ME
C---      DOUBLE PRECISION T2(N1,N2,N3,N4)
C---
C---      INTEGER I,J,A,B
C---
C---      CALL DDI_NPROC(DDI_NP,DDI_ME)
C---
C---      DO A=1,N4
C---      DO B=1,N3
C---      DO J=1,N2
C---      DO I=1,N1
C---         IF(ABS(T2(I,J,B,A)).LT.1.0D-10) THEN
C---            WRITE(6,*) I,J,B,A,0.0D+00
C---         ELSE
C---            WRITE(6,*) I,J,B,A,T2(I,J,B,A)
C---         END IF
C---      END DO
C---      END DO
C---      END DO
C---      END DO
C---C
C---      RETURN
C---      END
C---C
C---C
C---C*MODULE CCDDI   *DECK WFHH
C---      SUBROUTINE WFHH(NR,NO,NU,O1)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      DIMENSION O1(NO,NO)
C---      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C---C
C---C---      WRITE(6,*)'NT1,NR',NT1,NR
C---C---      CALL PRINTVEC(O1,NO*NU,'INWRITECHECK')
C---C
C---      WRITE(NT1,REC=NR) O1
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK WFPH
C---      SUBROUTINE WFPH(NR,NO,NU,O1)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      DIMENSION O1(NO,NU)
C---      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C---C
C---C---      WRITE(6,*)'NT1,NR',NT1,NR
C---C---      CALL PRINTVEC(O1,NO*NU,'INWRITECHECK')
C---C
C---      WRITE(NT1,REC=NR) O1
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK WFPP
C---      SUBROUTINE WFPP(NR,NO,NU,O1)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      DIMENSION O1(NU,NU)
C---      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C---C
C---C---      WRITE(6,*)'NT1,NR',NT1,NR
C---C---      CALL PRINTVEC(O1,NO*NU,'INWRITECHECK')
C---C
C---      WRITE(NT2,REC=NR) O1
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK RHH
C---      SUBROUTINE RHH(NR,NO,NU,O1)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      DIMENSION O1(NO,NO)
C---      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C---C
C---      READ(NT1,REC=NR) O1
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK RPH
C---      SUBROUTINE RPH(NR,NO,NU,O1)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      DIMENSION O1(NO,NU)
C---      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C---C
C---      READ(NT1,REC=NR) O1
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK RPP
C---      SUBROUTINE RPP(NR,NO,NU,O1)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      DIMENSION O1(NU,NU)
C---      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C---C
C---      READ(NT2,REC=NR) O1
C---      RETURN
C---      END
C
C*MODULE CCDDI   *DECK DDCC_DRRLEN_BIG
      SUBROUTINE DDCC_DRRLEN_BIG(NO,NU,O2,T2,TEMP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O2(*),T2(*),TEMP(*)
      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
C
      NRLE0=MXRLE
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NOU2  = NO*NU2
      NO2U2 = NO2*NU2
C
      L1=NOU2
      L2=NO2U2+NOU
      IO1  = 1
      IO2  = IO1    + L1
      IO3  = IO2    + L2
      IO4  = IO3    + L2
      LAST = IO4    + NRLE0
C          SINCE THERE IS NO FORMAL MEMORY ALLOCATION, LAST IS UNUSED.
C          SO NEXT LINE IS SILLY, ITS JUST TO AVOID AN FTNCHEK MESSAGE
      IF(LAST.LT.0) WRITE(6,*) 'LAST=',LAST
C
C        O1=TI ARRAY,     O2      T2      CRLE
C      CALL DDCC_NEWRLE(NO,NU,O1(IO2),O1(IO3),O1(IO4))
      CALL DDCC_NEWRLE(NO,NU,O2,T2,TEMP)
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK DDCC_DRRLEN
      SUBROUTINE DDCC_DRRLEN(NO,NU,O1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(*)
      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
C
      NRLE0=MXRLE
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NOU2  = NO*NU2
      NO2U2 = NO2*NU2
C
      L1=NOU2
      L2=NO2U2+NOU
      IO1  = 1
      IO2  = IO1    + L1
      IO3  = IO2    + L2
      IO4  = IO3    + L2
      LAST = IO4    + NRLE0
C          SINCE THERE IS NO FORMAL MEMORY ALLOCATION, LAST IS UNUSED.
C          SO NEXT LINE IS SILLY, ITS JUST TO AVOID AN FTNCHEK MESSAGE
      IF(LAST.LT.0) WRITE(6,*) 'LAST=',LAST
C
C        O1=TI ARRAY,     O2      T2      CRLE
      CALL DDCC_NEWRLE(NO,NU,O1(IO2),O1(IO3),O1(IO4))
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK DDCC_NEWRLE
      SUBROUTINE DDCC_NEWRLE(NO,NU,O2,T2,CRLE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL CNVR
      DIMENSION T2(1),O2(1),CRLE(*)
      DIMENSION XR(1000)
C
      COMMON /CCENGY/ ENRG,EREF,EMP2,ECCN,ETOT(6),ECORR(6),
     *                DIAGS(3),AMPMX(5,2),IAMPMX(5,4,2),XO1,XO2,
     *                DIFMAX,DIFFENG,ITER,CNVR
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NO2U2 = NO2*NU2
C
      IF(ITRLE.EQ.1) THEN
         CALL ZEROMA(XR,1,1000)
         NRLE=1
         IRLE=1
      ENDIF
      LEN=NOU+NO2U2
      INOU=NOU+1
      IF(MET.LT.2) THEN
      INOU=1
      LEN=NO2U2
      ENDIF
      LENTOT=LEN
      IO=2*IRLE-1
      ID=2*IRLE
      IF(MET.GT.1) CALL RO1(1,NO,NU,O2)
      CALL RO2(1,NO,NU,O2(INOU))
      CALL WRRLE(NFRLE,IO,LEN,O2)
      IF(MET.GT.1) CALL RO1(2,NO,NU,T2)
      CALL RO2(2,NO,NU,T2(INOU))
      CALL VECSUB(T2,O2,LEN)
      DIFMAX=T2(IDAMAX(LEN,T2,1))
      CALL WRRLE(NFRLE,ID,LEN,T2)
      DO 10 I=1,NRLE
         ID=2*I
         CALL RDRLE(NFRLE,ID,LEN,O2)
         DO 11 J=1,I
            JD=2*J
            IJ=I+(J-1)*NRLE0
            JI=J+(I-1)*NRLE0
            CALL RDRLE(NFRLE,JD,LEN,T2)
            X=DDOT(LENTOT,O2,1,T2,1)
            XR(JI)=X
            XR(IJ)=X
 11      CONTINUE
 10   CONTINUE
      CALL DODIIS(XR,O2,CRLE,NRLE0,NRLE)
      CALL ZEROMA (O2,1,LENTOT)
      DO 20 I=1,NRLE
      ID=2*I
      FX=CRLE(I)
      CALL RDRLE(NFRLE,ID,LEN,T2)
      CALL DAXPY(LENTOT,FX,T2,1,O2,1)
 20   CONTINUE
      IF (NRLE.EQ.1) GOTO 90
      DO 30 I=1,NRLE
      FX=CRLE(I)
      IO=2*I-1
      CALL RDRLE(NFRLE,IO,LEN,T2)
      CALL DAXPY(LENTOT,FX,T2,1,O2,1)
 30   CONTINUE
      IF(MET.GT.1) CALL WO1(1,NO,NU,O2)
      CALL WO2(1,NO,NU,O2(INOU))
C     CALL DDI_SYNC(1234)
 90   CONTINUE
      NRLE=NRLE+1
      IF(NRLE.GT.NRLE0)NRLE=NRLE0
      IRLE =IRLE+1
      IF(IRLE.GT.NRLE)IRLE=1
      RETURN
      END
C
C*MODULE CCDDI   *DECK DDCC_DRREST
      SUBROUTINE DDCC_DRREST(IOPT,NO,NU,TREST,ITREST)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TREST(*),ITREST(*)
C        SIZE OF TREST IS NO2U2, ITREST IS NOU
C
      IF(IOPT.EQ.0) THEN
C NOT IMPLEMENTED YET.
C        CALL REARES(NO,NU,TREST,ITREST)
      ELSE
         CALL DDCC_WRIRES(NO,NU,TREST,ITREST)
      ENDIF
      RETURN
      END
C
C*MODULE CCDDI   *DECK DDCC_WRIRES
      SUBROUTINE DDCC_WRIRES(NO,NU,T,IT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T(*),IT(*)
      DIMENSION ISZ(3)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NOU   = NO*NU
      NO2U2 = NOU*NOU
C
      IAD=2
      CALL RO1(1,NO,NU,T)
      CALL STORE(NOU,NNN,T,IT)
      ISZ(1)=NNN
      IF(NNN.GT.0) THEN
         CALL VRIPAKRES(IAD,NNN,T,IT)
      ELSE
         IAD=IAD+1
      END IF
C
C
      CALL RO2(1,NO,NU,T)
      CALL STORE(NO2U2,NNN,T,IT)
      ISZ(2)=NNN
      CALL VRIPAKRES(IAD,NNN,T,IT)
C
C
      ISZ(3)=0
      WRITE(NRESF,REC=1) ISZ
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_SHELLQUART
C ------------------------------------------------------------------
C THIS IS A WRAPPER ROUTINE TO GET AROUND THE ORDER RESTRICTIONS OF
C SHELLQUART.  PASS IN ANY VALID VALUES FOR I-LSH, AND THIS ROUTINE
C DETERMINES THE PROPER ORDER FOR A CALL TO SHELLQUART AND THE RE-
C ORDERS THE INTEGRALS UNTIL A SQUARE MXSHL^4 ARRAY TO MATCH THE
C INPUT ORDERING.
C
C THIS ROUTINE SHOULD BE CALLED PAOAO FOR "PICK AN ORDER, ANY ORDER"
C ------------------------------------------------------------------
      SUBROUTINE CCSD_SHELLQUART(ISH,JSH,KSH,LSH,MXSHL,NBF,AO1,
     &                           CUTOFF,NU,LENI,LENK,CMOT,TRAN)
      IMPLICIT NONE
C
      INTEGER ISH,JSH,KSH,LSH,MXSHL,NU,NBF,LENI,LENK
      DOUBLE PRECISION AO1(MXSHL,MXSHL,MXSHL,MXSHL)
      DOUBLE PRECISION CMOT(NU,NBF)
      DOUBLE PRECISION TRAN(NU,LENI,LENK,NBF)
      DOUBLE PRECISION CUTOFF
C
C --------------------
C CONSTANT PARAMETERS
C --------------------
      INTEGER MXSH,MXGTOT
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
C --------------------
C COMMON BLOCK: NSHEL
C --------------------
      DOUBLE PRECISION EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                 CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT)
      INTEGER          KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                 KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /NSHEL /  EX,CS,CP,CD,CF,CG,CH,CI,
     *                 KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,NSHELL
C
      INTEGER I,J,K,L,TMP,II,JJ,KK,LL,IIJJ,KKLL
      INTEGER IISH,JJSH,KKSH,LLSH,SHL(4),IDX(4),IAO(4)
      INTEGER LENII,LENJJ,LENKK,LENLL,JJMAX,LLMAX
      INTEGER LOCJ,LOCL
C
      LOGICAL IIANDJJ,KKANDLL,SAME
C
      DOUBLE PRECISION VAL
C
C ----------------------
C SAVE ORIGINAL ORDERING
C ----------------------
      SHL(1) = ISH
      SHL(2) = JSH
      SHL(3) = KSH
      SHL(4) = LSH
      IDX(1) = 1
      IDX(2) = 2
      IDX(3) = 3
      IDX(4) = 4
C
C---      LOCI = KLOC(ISH) - 1
      LOCJ = KLOC(JSH) - 1
C---      LOCK = KLOC(KSH) - 1
      LOCL = KLOC(LSH) - 1
C
C -----------------------------------------
C DETERMINE OPTIMAL ORDERING FOR SHELLQUART
C -----------------------------------------
      IF(SHL(IDX(1)) .LT. SHL(IDX(2))) THEN
         IDX(1) = 2
         IDX(2) = 1
      END IF
C
      IF(SHL(IDX(3)) .LT. SHL(IDX(4))) THEN
         IDX(3) = 4
         IDX(4) = 3
      END IF
C
      IF((SHL(IDX(1)) .LT. SHL(IDX(3))) .OR.
     &   (SHL(IDX(1)) .EQ. SHL(IDX(3)) .AND.
     &    SHL(IDX(2)) .LT. SHL(IDX(4)))) THEN
         TMP    = IDX(1)
         IDX(1) = IDX(3)
         IDX(3) = TMP
C
         TMP    = IDX(2)
         IDX(2) = IDX(4)
         IDX(4) = TMP
      END IF
C
C ---------------------------
C THE SHELLQUART ORDERING
C ---------------------------
      IISH = SHL(IDX(1))
      JJSH = SHL(IDX(2))
      KKSH = SHL(IDX(3))
      LLSH = SHL(IDX(4))
C
      IIANDJJ = IISH.EQ.JJSH
      KKANDLL = KKSH.EQ.LLSH
      SAME    = IISH.EQ.KKSH .AND. JJSH.EQ.LLSH
C
      LENII = KMAX(IISH) - KMIN(IISH) + 1
      LENJJ = KMAX(JJSH) - KMIN(JJSH) + 1
      LENKK = KMAX(KKSH) - KMIN(KKSH) + 1
      LENLL = KMAX(LLSH) - KMIN(LLSH) + 1
C
      IIJJ  = 0
      KKLL  = 0
      JJMAX = LENJJ
      LLMAX = LENLL
C
C ------------------------------------------
C CALCULATE INTEGRALS IN SHELLQUART ORDERING
C ------------------------------------------
       CALL SHELLQUART_RMO(IISH,JJSH,KKSH,LLSH,AO1)
C
C       WRITE(6,*) 'CCSD_SHELLQUART'
C       WRITE(6,*) 'I,J,K,L:     ',ISH,JSH,KSH,LSH
C       WRITE(6,*) 'II,JJ,KK,LL: ',IISH,JJSH,KKSH,LLSH
C       WRITE(6,*) 'LENII,JJ,KK,LL: ',LENII,LENJJ,LENKK,LENLL
C       WRITE(6,*) 'IDX:            ',IDX(1),IDX(2),IDX(3),IDX(4)
C       WRITE(6,*) 'LSTRI/J/K/L:',LSTRI,LSTRJ,LSTRK,LSTRL
       CALL FLSHBF(6)
C
C       WRITE(6,*) 'UNEDITTED BLOCK OF AO VALUES'
C       CALL CCSD_PRINTAO(IISH,JJSH,KKSH,LLSH,MXSHL,AO1)
C
C --------------------------------
C EXPAND AOS INTO A COMPLETE BLOCK
C --------------------------------
      IF(IIANDJJ .OR. KKANDLL .OR. SAME) THEN
      DO II = 1,LENII
        IF(IISH.EQ.JJSH) JJMAX = II
C
        DO JJ = 1,JJMAX
          KKLL = 0
          IIJJ = IIJJ + 1
C
          DO KK = 1,LENKK
            IF(KKSH.EQ.LLSH) LLMAX = KK
C
            DO 4 LL = 1,LLMAX
              KKLL = KKLL + 1
              IF((IISH.EQ.KKSH.AND.JJSH.EQ.LLSH)
     *              .AND.  KKLL.GT.IIJJ) GOTO 4
C
              VAL = AO1(LL,KK,JJ,II)
C
              IF(IISH.EQ.JJSH) AO1(LL,KK,II,JJ) = VAL
              IF(KKSH.EQ.LLSH) AO1(KK,LL,JJ,II) = VAL
              IF(IISH.EQ.JJSH .AND. KKSH.EQ.LLSH) AO1(KK,LL,II,JJ)=VAL
              IF(IISH.EQ.KKSH .AND. JJSH.EQ.LLSH) THEN
                 AO1(JJ,II,LL,KK) = VAL
                 IF(IISH.EQ.JJSH) THEN
                    AO1(II,JJ,LL,KK) = VAL
                    AO1(JJ,II,KK,LL) = VAL
                    AO1(II,JJ,KK,LL) = VAL
                 END IF
              END IF
C
    4       CONTINUE
          END DO
        END DO
      END DO
      END IF
C
C ------------------------------------------------
C EXTRACT INTEGRALS FROM THE "BLOCKED" SET OF AOS.
C ------------------------------------------------
      DO II = 1,LENII
        IAO(IDX(1)) = II
C
        DO JJ = 1,LENJJ
          IAO(IDX(2)) = JJ
C
          DO KK = 1,LENKK
            IAO(IDX(3)) = KK
C
            DO 41 LL = 1,LENLL
              IAO(IDX(4)) = LL
C
              VAL = AO1(LL,KK,JJ,II)
              IF(ABS(VAL).LT.CUTOFF) GOTO 41
C
              I = IAO(1)
              J = IAO(2)
              K = IAO(3)
              L = IAO(4)
C
C              IF(ABS(VAL-NNNN(I+LOCI,J+LOCJ,K+LOCK,L+LOCL))
C     &          .GT.CUTOFF) THEN
C                WRITE(6,*) 'ERROR IN INTEGRAL VALUE ',I+LOCI,J+LOCJ,
C     &                      K+LOCK,L+LOCL,VAL,NNNN(I+LOCI,J+LOCJ,
C     &                      K+LOCK,L+LOCL),II,JJ,KK,LL
C                WRITE(6,*) 'SORTED AO-SHELL BLOCK (WRONG VALUES)'
C                CALL CCSD_PRINTAO(IISH,JJSH,KKSH,LLSH,MXSHL,AO1)
C
C                CALL DCOPY(MXSHL**4,0.0D+00,0,AO1,1)
C                WRITE(6,*) 'II/JJ/KK/LL ',IISH,JJSH,KKSH,LLSH
C                CALL SHELLQUART(IISH,JJSH,KKSH,LLSH,AO1)
C                CALL CCSD_PRINTAO(IISH,JJSH,KKSH,LLSH,MXSHL,AO1)
C                CALL ABRT
C              END IF
C              VAL = NNNN(I+LOCI,J+LOCJ,K+LOCK,L+LOCL)
C
              CALL DAXPY(NU,VAL,CMOT(1,J+LOCJ),1,TRAN(1,I,K,L+LOCL),1)
C
C THIS WAS USED WHEN WE ONLY WANTED TO COLLECT AO VALUES
C             TRAN(J+LOCJ,I,K,L+LOCL) = VAL
C
   41       CONTINUE
          END DO
        END DO
      END DO
C
      RETURN
      END
C---C
C---C*MODULE CCDDI   *DECK CCSD_PRINTAO
C---      SUBROUTINE CCSD_PRINTAO(ISH,JSH,KSH,LSH,MXSHL,AO)
C---      IMPLICIT NONE
C---
C---      INTEGER ISH,JSH,KSH,LSH,MXSHL
C---      DOUBLE PRECISION AO(*)
C---
C---! --------------------
C---! CONSTANT PARAMETERS
C---! --------------------
C---      INTEGER MXSH,MXGTOT
C---      PARAMETER (MXSH=5000, MXGTOT=20000)
C---
C---! --------------------
C---! COMMON BLOCK: NSHEL
C---! --------------------
C---      DOUBLE PRECISION EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
C---     *                 CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT)
C---      INTEGER        KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
C---     *                 KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
C---      COMMON /NSHEL /  EX,CS,CP,CD,CF,CG,CH,CI,
C---     *                 KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,NSHELL
C---
C---      INTEGER IISH,JJSH,KKSH,LLSH,LSTRI,LSTRJ,LSTRK,LSTRL
C---      COMMON /ERIOUT/ IISH,JJSH,KKSH,LLSH,LSTRI,LSTRJ,LSTRK,LSTRL
C---
C---      INTEGER IAO,JAO,KAO,LAO
C---      INTEGER I,J,K,L,IJN,KLN
C---      INTEGER MINI,MINJ,MINK,MINL
C---      INTEGER MAXI,MAXJ,MAXK,MAXL,JMAX,LMAX
C---      INTEGER LOCI,LOCJ,LOCK,LOCL
C---      INTEGER I_INDEX,IJ_INDEX,IJK_INDEX,IJKL_INDEX
C---
C---      LOGICAL IANDJ,KANDL,SAME
C---
C---      IANDJ = ISH.EQ.JSH
C---      KANDL = KSH.EQ.LSH
C---      SAME  = ISH.EQ.KSH.AND.JSH.EQ.LSH
C---
C---      MINI = KMIN(ISH)
C---      MINJ = KMIN(JSH)
C---      MINK = KMIN(KSH)
C---      MINL = KMIN(LSH)
C---      MAXI = KMAX(ISH)
C---      MAXJ = KMAX(JSH)
C---      MAXK = KMAX(KSH)
C---      MAXL = KMAX(LSH)
C---      LOCI = KLOC(ISH)-MINI
C---      LOCJ = KLOC(JSH)-MINJ
C---      LOCK = KLOC(KSH)-MINK
C---      LOCL = KLOC(LSH)-MINL
C---C
C---      IJN = 0
C---      JMAX = MAXJ
C---      DO 360 I = MINI,MAXI
C---         I_INDEX = (I-MINI)*LSTRI + 1
C---         IF (IANDJ) JMAX = I
C---         DO 340 J = MINJ,JMAX
C---            IJ_INDEX = (J-MINJ)*LSTRJ + I_INDEX
C---            IJN = IJN+1
C---            LMAX = MAXL
C---            KLN = 0
C---            DO 320 K =  MINK,MAXK
C---               IJK_INDEX = (K-MINK)*LSTRK + IJ_INDEX
C---               IF (KANDL) LMAX = K
C---               DO 300 L = MINL,LMAX
C---                  KLN = KLN+1
C---                  IF(SAME .AND. KLN.GT.IJN) GO TO 340
C---                  IJKL_INDEX = (L-MINL)*LSTRL + IJK_INDEX
C---
C---                  IAO = LOCI+I
C---                  JAO = LOCJ+J
C---                  KAO = LOCK+K
C---                  LAO = LOCL+L
C---
C---                  WRITE(6,10) IAO,JAO,KAO,LAO,AO(IJKL_INDEX)
C---
C--- 300           CONTINUE
C--- 320        CONTINUE
C--- 340     CONTINUE
C--- 360  CONTINUE
C---
C---
C---      RETURN
C---   10 FORMAT('AOS ',4I4,F15.8)
C---      END
C
C*MODULE CCDDI   *DECK SHELLQUART_RMO
      SUBROUTINE SHELLQUART_RMO(ISH,JSH,KSH,LSH,AOS)
      IMPLICIT NONE
C
      INTEGER ISH,JSH,KSH,LSH
      DOUBLE PRECISION AOS(*)
C
      DOUBLE PRECISION ZERO,ONE
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      INTEGER MXGSH,MXG2,MXSH,MXGTOT
      PARAMETER (MXGSH=30, MXG2=MXGSH*MXGSH, MXSH=5000, MXGTOT=20000)
C
C --------------------
C COMMON BLOCK: FMCOM
C --------------------
      DOUBLE PRECISION X(1)
      COMMON /FMCOM /  X
C
      INTEGER NORG
      DOUBLE PRECISION GPOPLE
      COMMON /GOUT  / GPOPLE(768),NORG
C
      LOGICAL IANDJ,KANDL,SAME
      COMMON /MISC  / IANDJ,KANDL,SAME
C
      INTEGER IPL,JPL,KPL,LPL,INEW,JNEW,KNEW,LNEW
      COMMON /SHLG70/ IPL,JPL,KPL,LPL,INEW,JNEW,KNEW,LNEW
C
      INTEGER LPOPI,LPOPJ,LPOPK,LPOPL
      COMMON /POPOUT/ LPOPI,LPOPJ,LPOPK,LPOPL
C
      INTEGER LEN1,LEN2,LEN3,LEN4
      COMMON /ERIDAT/ LEN1,LEN2,LEN3,LEN4
C
      INTEGER INW,JNW,KNW,LNW,LSTRI,LSTRJ,LSTRK,LSTRL
      COMMON /ERIOUT/ INW,JNW,KNW,LNW,LSTRI,LSTRJ,LSTRK,LSTRL
C
C --------------------
C COMMON BLOCK: NSHEL
C --------------------
      DOUBLE PRECISION EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                 CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT)
      INTEGER          KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                 KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /NSHEL /  EX,CS,CP,CD,CF,CG,CH,CI,
     *                 KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,NSHELL
C
C -----------------
C LOCAL VARIABLES
C -----------------
      INTEGER LOADFM,NEED,LDDIJ
      DOUBLE PRECISION Q4
C
      LOGICAL POPLE
      INTEGER LQSUM
      INTEGER I,J,K,L,II,IP,IJ,IJP,IJK,IJKP,IJKL,IJKLP
      INTEGER MINI,MAXI,MINJ,MAXJ,MINK,MAXK,MINL,MAXL
C
C ----------------------
C INITIALIZATION - START
C ----------------------
C
      IANDJ = .FALSE.
      KANDL = .FALSE.
      SAME  = .FALSE.
      Q4    = ONE
C
C ---------------------------------------------
C SETS THE VALUE OF Q4 IN COMMON BLOCK
C ---------------------------------------------
      CALL SETQ4(Q4)
C
C ------------------------------------
C MODIFYING SHLG70 COMMON BLOCK VALUES
C ------------------------------------
      POPLE = .TRUE.
      IF(KTYPE(ISH).GT.2) POPLE=.FALSE.
      IF(KTYPE(JSH).GT.2) POPLE=.FALSE.
      IF(KTYPE(KSH).GT.2) POPLE=.FALSE.
      IF(KTYPE(LSH).GT.2) POPLE=.FALSE.
      LQSUM = KTYPE(ISH) + KTYPE(JSH) + KTYPE(KSH) + KTYPE(LSH) - 4
C     POPLE = .FALSE.
C ----------------------
C INITIALIZATION - END
C ----------------------
C
C ---------------------------
C CALCULATE AO INTEGRALS
C ---------------------------
      IF(POPLE) THEN
        IPL = ISH
        JPL = JSH
        KPL = KSH
        LPL = LSH
        INW = ISH
        JNW = JSH
        KNW = KSH
        LNW = LSH
C
        MINI = KMIN(INW)
        MAXI = KMAX(INW)
        MINJ = KMIN(JNW)
        MAXJ = KMAX(JNW)
        MINK = KMIN(KNW)
        MAXK = KMAX(KNW)
        MINL = KMIN(LNW)
        MAXL = KMAX(LNW)
C
        CALL DCOPY(256,ZERO,0,GPOPLE,1)
        CALL GENR70(1,.FALSE.)
C
C ------------------------------------------------------------------
C RE-ORDER GPOPLE TO GHONDO ORDER: TAKEN FROM SHELLQUART (INT2A.SRC)
C ------------------------------------------------------------------
        II = 1
        DO I = MINI, MAXI
          IP = (I-1)*LPOPI + 1
          IJ  = II
          DO J = MINJ, MAXJ
            IJP = (J-1)*LPOPJ + IP
            IJK  = IJ
            DO K = MINK, MAXK
              IJKP = (K-1)*LPOPK + IJP
              IJKL  = IJK
              DO L = MINL, MAXL
                IJKLP = (L-1)*LPOPL + IJKP
                AOS(IJKL) = GPOPLE(IJKLP)
                IJKL = IJKL  + LEN1
              END DO
              IJK  = IJK  + LEN2
            END DO
            IJ  = IJ  + LEN3
          END DO
          II = II + LEN4
        END DO
        LSTRI = LEN4
        LSTRJ = LEN3
        LSTRK = LEN2
        LSTRL = LEN1
        RETURN
C
      ELSE
C
C ------------------------------
C CALCULATE AO INTEGRALS - HONDO
C ------------------------------
C     N.B.: IF YOU CHANGE THIS, YOU MUST ALSO CHANGE THE "CHECK" MEMORY.
C
        CALL VALFM(LOADFM)
        LDDIJ = LOADFM + 1
        NEED  = 49*MXG2
        CALL GETFM(NEED)
C
        KANDL = KSH.EQ.LSH
        CALL PARSHEL(1,ISH,JSH,ISH,JSH)
        CALL IJPRIM(X(LDDIJ))
        CALL PARSHEL(2,ISH,JSH,KSH,LSH)
        CALL ZQOUT(AOS)
        IF(LQSUM.EQ.0) THEN
           CALL S0000(AOS,X(LDDIJ))
        ELSE
           CALL GENRAL(AOS,X(LDDIJ))
        END IF
C
        CALL RETFM(NEED)
C
      END IF
C
      RETURN
      END
C
C
C
C*MODULE CCDDI   *DECK CCSD_MP2
      SUBROUTINE CCSD_MP2(NO,NU,O2,T2,OEH,OEP,EMP2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DEBUG
C
      INTEGER NO,NU
C ------------------------
C CALCULATES THE MP2 ENERGY
C ------------------------
C
C ------------------------------------------------------
C O2 AND T2 ARE USED FOR WORKSPACE BEFORE GETTING THEIR
C FINAL ASSIGNED VALUES
C ------------------------------------------------------
C
      DOUBLE PRECISION O2(1),T2(1),OEH(1),OEP(1),EMP2
C
      INTEGER DDI_NP,DDI_ME
C
      INTEGER NOU2,NO2U2
C
      DOUBLE PRECISION TWO,HALF
      PARAMETER(TWO=2.0D+00,HALF=0.5D+00)
C
C --------------------------------------------
C PROCESS IDENITIY
C --------------------------------------------
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      IF(DDI_ME.NE.0) RETURN
C
      DEBUG=.FALSE.
C
      IF(DEBUG) THEN
         WRITE(6,*) 'CCSD_MP2: ENTERING'
         CALL FLSHBF(6)
      END IF
C
C --------------------------------------------
C REPLICATED MEMORY NEEDED: NOU2
C --------------------------------------------
C
      NOU2  = NO*NU*NU
      NO2U2 = NO*NOU2
C
C --------------------------------------------
C CALCULATE MP2 ENERGY.  MP2 AMPS STORED IN O2
C MOST OF THE FOLLOWING IS TAKEN FROM ENERGYMM
C --------------------------------------------
C
      CALL ADDDEN(NO,NU,O2,OEH,OEP)
C
      CALL VECMUL(T2,NO2U2,TWO)
      EMP2 = DDOT(NO2U2,O2,1,T2,1)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL VECMUL(T2,NO2U2,HALF)
      EMP2 = EMP2 - DDOT(NO2U2,O2,1,T2,1)
C
      IF(DEBUG) THEN
         WRITE(6,297) EMP2
         WRITE(6,*) 'CCSD_MP2: FINISHED'
         CALL FLSHBF(6)
      END IF
      RETURN
  297 FORMAT('CCSD_MP2: E(MP2) =',F18.10)
      END
C---C
C---C*MODULE CCDDI   *DECK PRINTVEC
C---      SUBROUTINE PRINTVEC(A,LENGTH,LABEL)
C---      IMPLICIT NONE
C---      INTEGER LENGTH,I
C---      DOUBLE PRECISION A(LENGTH)
C---      CHARACTER*12 LABEL
C---! ------------------------------------------------
C---! TESTING ROUTINE TO PRINT OUT A VECTOR
C---! ------------------------------------------------
C---      WRITE(6,*) LABEL
C---
C---      DO I = 1, LENGTH
C---        WRITE(6,*)'PRINTVEC',I,A(I)
C---!        WRITE(6,*) A(I)
C---      END DO
C---        CALL FLSHBF(6)
C---
C---      RETURN
C---      END
C
C*MODULE CCDDI   *DECK CCSD_FOCK
      SUBROUTINE CCSD_FOCK(NO,NU,NBF,NFRZC,FHH,FPP,FPH,OEH,OEP)
      IMPLICIT NONE
C
      INTEGER NO,NU,NBF,NFRZC
      DOUBLE PRECISION OEH(*),OEP(*),FHH(*),FPP(*),FPH(*)
C
C --------------------
C COMMON BLOCK: FMCOM
C --------------------
      DOUBLE PRECISION X(1)
      COMMON /FMCOM /  X
C
      INTEGER L1,L2,L3,M1,M2
      INTEGER LOADFM,LAST,NEED
      INTEGER LFAO,LFMO,LVEC,LWRK
C
      L1 = NBF
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
      M1 = NO + NU
      M2 = (M1*M1+M1)/2
C
C ONE ELECTRON CONTRIBUTIONS TO THE ENERGY ARE MADE
C USING FOCK MATRIX ELEMENTS, IN THE MO BASIS.
C     N.B.: THIS IS NOT INCLUDED IN THE CHECK MEMORY, ITS TRIVIAL.
C
      CALL VALFM(LOADFM)
      LFAO  = LOADFM+1
      LFMO  = LFAO  + L2
      LVEC  = LFMO  + M2
      LWRK  = LVEC  + L3
      LAST  = LWRK  + L1
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C
C
C CCFOCK NEEDED TO BE MODIFIED BECAUSE THE ORIGINAL STORED THE
C FOCK ELEMENTS AS THE LAST RECORD IN THE INTEGRAL FILE
C NOW THE ELEMENTS ARE REPLICATED PER PROCESSOR
C
      CALL CCFOCK_DDI(X(LFAO),X(LFMO),X(LVEC),X(LWRK),FHH,FPP,
     *            FPH,OEH,OEP,L1,L2,M1,M2,NO,NU,NFRZC)
C
      CALL RETFM(NEED)
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCFOCK_DDI
      SUBROUTINE CCFOCK_DDI(FAO,FMO,VEC,WRK,FHH,FPP,FPH,
     *                  EH,EP,L1,L2,M1,M2,NO,NU,IFC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION FAO(L2),FMO(M2),VEC(L1,L1),FHH(NO,NO),FPP(NU,NU),
     *          FPH(NO,NU),EH(NO),EP(NU),WRK(L1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      PARAMETER (ZERO=0.0D+00)
C
C        READ RHF FOCK MATRIX AND ORBITALS
C
      CALL DAREAD(IDAF,IODA,FAO,L2,14,0)
      CALL DAREAD(IDAF,IODA,VEC,L1*L1,15,0)
C
C        PERFORM A SIMILARITY TRANSFORMATION OVER ONLY THE
C        ORBITALS WHICH ARE TO BE INCLUDED IN THE CORRELATION.
C
      CALL TFTRI(FMO,FAO,VEC(1,IFC+1),WRK,M1,L1,L1)
C
C        FILL HOLE AND PARTICLE ORBITAL ENERGY ARRAY
C
      II = 0
      DO 101 I=1,NO+NU
         II = II+I
         IF(I.LE.NO) THEN
            EH(I) = FMO(II)
         ELSE
            EP(I-NO) = FMO(II)
         END IF
 101  CONTINUE
C
C        FILL HOLE/HOLE, PARTICLE/PARTICLE, AND HOLE/PARTICLE
C        BLOCKS OF THE FOCK MATRIX.  DIAGONALS ARE SET TO ZERO
C
      IJ = 0
      DO 103 I=1,NO
         DO 104 J=1,I
            IJ = IJ+1
            FHH(I,J)=FMO(IJ)
            FHH(J,I)=FMO(IJ)
 104     CONTINUE
         FHH(I,I)=ZERO
 103  CONTINUE
C
      DO 105 I=1,NU
         IROW = I+NO
         II = (IROW*IROW-IROW)/2
         DO 106 J=1,I
            JROW = J+NO
            IJ = II + JROW
            FPP(I,J)=FMO(IJ)
            FPP(J,I)=FMO(IJ)
 106     CONTINUE
         FPP(I,I)=ZERO
 105  CONTINUE
C
      DO 108 I=1,NU
         IROW = I+NO
         II = (IROW*IROW-IROW)/2
         DO 107 J=1,NO
            IJ = II + J
            FPH(J,I)=FMO(IJ)
 107     CONTINUE
 108  CONTINUE
      RETURN
      END
C
C
C*MODULE CCDDI   *DECK CCSD_TRAN2
      SUBROUTINE CCSD_TRAN2(LENI,LENK,NU,NBF,CMO,TRAN,TMP)
      IMPLICIT NONE
C
      INTEGER DDI_NP,DDI_ME
      INTEGER LENI,LENK,NU,NBF
      DOUBLE PRECISION CMO(NBF,NU)
      DOUBLE PRECISION TRAN(NU,NU,LENI,LENK)
      DOUBLE PRECISION TMP(NU,LENI,LENK,NU)
C
      DOUBLE PRECISION ZERO,ONE
      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00)
C
      INTEGER I,K,A,B
      INTEGER NUIK
C
      NUIK   = NU*LENI*LENK
      CALL DDI_NPROC(DDI_NP,DDI_ME)
C
      CALL DGEMM('N','N',NUIK,NU,NBF,ONE,TRAN,NUIK,CMO,NBF,
     &           ZERO,TMP,NUIK)
C
C
C SETTING UP THE INTEGRALS FOR CONTRACTION WITH THE AMPLITUDES
      DO K = 1,LENK
      DO I = 1,LENI
         DO A = 1,NU
            DO B = 1,NU
               TRAN(B,A,I,K) = TMP(B,I,K,A)
C              IF(ISH.EQ.KSH) TRAN(A,B,K,I) = TMP(B,A,I,K)
            END DO
         END DO
      END DO
      END DO
C
      RETURN
      END
C
C
C*MODULE CCDDI   *DECK TRAN34_TEST
      SUBROUTINE TRAN34_TEST(NCOLS,NU,NBF,D_VVVV,CMO,TMP1,TMP2,T2)
      IMPLICIT NONE
C
      INTEGER NU,NBF,D_VVVV,NCOLS
      DOUBLE PRECISION CMO(*),TMP1(*),TMP2(*)
      DOUBLE PRECISION T2(NCOLS,NCOLS,NU,NU)
C
C --------------------
C CONSTANT PARAMETERS
C --------------------
      INTEGER MXSH,MXGTOT
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      DOUBLE PRECISION ZERO,ONE
      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00)
C
C --------------------
C COMMON BLOCK: NSHEL
C --------------------
      DOUBLE PRECISION EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                 CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT)
      INTEGER          KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                 KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /NSHEL /  EX,CS,CP,CD,CF,CG,CH,CI,
     *                 KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,NSHELL
C
      INTEGER DDI_NP,DDI_ME
      INTEGER ILO,IHI,JLO,JHI
C
      INTEGER I,K,II,KK,IJ,IKN
      INTEGER IVIR,JVIR,NVIR
C
      INTEGER NBSQ
C
      NVIR = NU
      NBSQ = NBF*NBF
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_DISTRIB(D_VVVV,DDI_ME,ILO,IHI,JLO,JHI)
      CALL DDI_SYNC(5000)
C
      IJ = 0
      DO 1 IVIR = 1,NCOLS
      DO 1 JVIR = 1,IVIR
         IJ  = IJ + 1
C             SKIP WORK
         IF(IJ.LT.JLO .OR. IJ.GT.JHI .OR. JVIR.GT.IVIR) GOTO 1
C
C         WRITE(6,*) 'COLUMN #',IJ,DDI_ME
C         CALL FLSHBF(6)
C
C         DO KK = 1,NBF
C         DO II = 1,NBF
C            TMP2((KK-1)*NBF+II) = NVNV(II,KK,IVIR,JVIR)
C         END DO
C         END DO
C
C         CALL DDI_GET(D_VVVV,1,NBSQ,IJ,IJ,TMP1)
C         CALL DAXPY(NBSQ,-1.0D+00,TMP2,1,TMP1,1)
C         VAL = DDOT(NBSQ,TMP1,1,TMP1,1)
C         IF(VAL.GT.1.0D-06) THEN
C            WRITE(6,*) 'ERROR IN D_VVVV ',VAL
C            CALL ABRT
C         END IF
C
C LIKE THE FOLLOWING SECTION, TRAN2 DID NOT SCATTER THE [**|VO] INTS
C INTO THE VVVO ARRAY IN STRICT AO-ORDER, RATHER IT WAS SHELL-MAPPED
C
         CALL DDI_GET(D_VVVV,1,NBSQ,IJ,IJ,TMP1)
C
         IKN = 0
         DO 2 II = 1,NSHELL
         DO 2 KK = 1,II
C
            DO I = KLOC(II), KLOC(II) - KMIN(II) + KMAX(II)
            DO K = KLOC(KK), KLOC(KK) - KMIN(KK) + KMAX(KK)
C
               IKN = IKN + 1
               TMP2((I-1)*NBF+K) = TMP1(IKN)
C
            END DO
            END DO
C
            IF(II.EQ.KK) GOTO 2
C
            DO I = KLOC(II), KLOC(II) - KMIN(II) + KMAX(II)
            DO K = KLOC(KK), KLOC(KK) - KMIN(KK) + KMAX(KK)
C
               IKN = IKN + 1
               TMP2((K-1)*NBF+I) = TMP1(IKN)
C
            END DO
            END DO
C
    2     CONTINUE
C
C
C
C  THIRD QUARTER-TRANSFORMATION TO VIRTUAL INDICES
C
C
         CALL DGEMM('N','N',NBF,NVIR,NBF
     *,             ONE,TMP2,NBF
     *,             CMO,NBF
     *,             ZERO,TMP1,NBF)
C
C  FOURTH QUARTER-TRANSFORMATION TO VIR-VIR INDICES
C  (NOTE SPECIAL MULTIPLY ROUTINE THAT USES SYMMETRY)
C
C
         CALL ARBRCS('T','N',NVIR,NBF
     *,              ONE,CMO,NBF
     *,              TMP1,NBF
     *,              ZERO,TMP2,NBF)
C
C  PUT O2 X VVVV PARTIAL TERM BACK INTO THE ARRAY.
C
C
         IKN = 0
         DO I = 1,NU
         DO K = 1,NU
C           KSM = MOLABS(I)
C           LSM = MOLABS(J)
            IKN = IKN + 1
            TMP1(IKN) = TMP2( (I-1)*NBF + K )
C           IF(.NOT.SYM2EI(ISM,JSM,KSM,LSM)) TMP1(IJN) = ZERO
         END DO
         END DO
C        CALL DDI_PUT(D_VVVV,1,IKN,IJ,IJ,TMP1)
C
C
C  PUT THE TERMS FROM COLUMN IJ INTO THE T2 ARRAY IN PROPER ORDER ...
C               THIS IS NOT A CACHE-FRIENDLY PROCESS
C               AS TERMS WILL BE ALL OVER THE PLACE
C
         CALL CCSD_ACCT2(NCOLS,NU,IVIR,JVIR,TMP1,T2)
C
         IF(IVIR.EQ.JVIR) GOTO 1
C
C TESTING AND IDEA TO TAKE THE TRANSPOSE OF AN NBSQ COLUMN AN AND DO
C THE SECOND 1/2 TRANSFORMATION.
         CALL DDI_GET(D_VVVV,1,NBSQ,IJ,IJ,TMP1)
C
         IKN = 0
         DO 3 II = 1,NSHELL
         DO 3 KK = 1,II
C
            DO I = KLOC(II), KLOC(II) - KMIN(II) + KMAX(II)
            DO K = KLOC(KK), KLOC(KK) - KMIN(KK) + KMAX(KK)
C
               IKN = IKN + 1
               TMP2((I-1)*NBF+K) = TMP1(IKN)
C
            END DO
            END DO
C
            IF(II.EQ.KK) GOTO 3
C
            DO I = KLOC(II), KLOC(II) - KMIN(II) + KMAX(II)
            DO K = KLOC(KK), KLOC(KK) - KMIN(KK) + KMAX(KK)
C
               IKN = IKN + 1
               TMP2((K-1)*NBF+I) = TMP1(IKN)
C
            END DO
            END DO
C
    3    CONTINUE
C
         CALL TRPOSE(TMP2,TMP1,NBF,NBF,1)
C
C  THIRD QUARTER-TRANSFORMATION TO VIRTUAL INDICES
C
C
         CALL DGEMM('N','N',NBF,NVIR,NBF
     *,             ONE,TMP2,NBF
     *,             CMO,NBF
     *,             ZERO,TMP1,NBF)
C
C  FOURTH QUARTER-TRANSFORMATION TO VIR-VIR INDICES
C  (NOTE SPECIAL MULTIPLY ROUTINE THAT USES SYMMETRY)
C
C
         CALL ARBRCS('T','N',NVIR,NBF
     *,              ONE,CMO,NBF
     *,              TMP1,NBF
     *,              ZERO,TMP2,NBF)
C
         IKN = 0
         DO I = 1,NU
         DO K = 1,NU
C           KSM = MOLABS(I)
C           LSM = MOLABS(J)
            IKN = IKN + 1
            TMP1(IKN) = TMP2( (I-1)*NBF + K )
C           IF(.NOT.SYM2EI(ISM,JSM,KSM,LSM)) TMP1(IJN) = ZERO
         END DO
         END DO
C
C
C
          CALL CCSD_ACCT2(NCOLS,NU,JVIR,IVIR,TMP1,T2)
C
    1 CONTINUE
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_ACCT2
      SUBROUTINE CCSD_ACCT2(NO,NU,I,J,TMP,T2)
      IMPLICIT NONE
C
      INTEGER NO,NU,I,J
      DOUBLE PRECISION TMP(NU,NU)
      DOUBLE PRECISION T2(NO,NO,NU,NU)
C
      INTEGER A,B
C
      IF(I.GE.J) THEN
C
         DO A = 1,NU
         DO B = 1,A
C
            T2(I,J,A,B) = TMP(A,B)
            T2(J,I,B,A) = TMP(A,B)
C
         END DO
         END DO
C
      ELSE
C
         DO A = 1,NU
         DO B = 1,A
C
            T2(I,J,A,B) = TMP(B,A)
            T2(J,I,B,A) = TMP(B,A)
C
         END DO
         END DO
C
      END IF
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_DDI_PROC
      SUBROUTINE CCSD_DDI_PROC(NO,NU,MP2ENERGY,
     *                  O1,T1,FH,FP,FPH,        ! REPLICATED
     *                  O4,VM,O2,T2,RL,         ! SMP SHARED
     *                  OEH,OEP,IFC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER NO,NU,IFC,IFLAG
      DOUBLE PRECISION MP2ENERGY
      DOUBLE PRECISION O1(1),T1(1),FH(1),FP(1),FPH(1),
     *                 O4(1),VM(1),O2(1),T2(1),RL(1),OEH(1),OEP(1)
C
      DOUBLE PRECISION X(1)
      COMMON /FMCOM /  X
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C
C COMMON BLOCK FOR THE DISTRIBUTED ARRAYS WE CREATED FOR CCSD(T)
C
      INTEGER         D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI
      INTEGER         D_VL,D_VL_IBT
      COMMON /CCDDI / D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI,
     *                D_VL,D_VL_IBT
C
      COMMON /CCENGY/ ENRG,EREF,EMP2,ECCN,ETOT,ECORR,
     *                DIAGS,AMPMX,IAMPMX,XO1,XO2,
     *                DIFMAX,DIFFENG,ITER,CNVR
      DOUBLE PRECISION ENRG,EREF,EMP2,ECCN,ETOT(6),ECORR(6),
     *                DIAGS(3),AMPMX(5,2),XO1,XO2,
     *                DIFMAX,DIFFENG
      INTEGER         ITER,IAMPMX(5,4,2)
      LOGICAL         CNVR,LCCD,CCD
C
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      DOUBLE PRECISION TSH
      INTEGER         NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
C
      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
      INTEGER         MXRLE,NRLE0,NRLE,IRLE,ITRLE
C
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C
      DOUBLE PRECISION OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DOUBLE PRECISION RUNTYP,EXETYP,CHECK
      INTEGER NEVALS,NGLEVL,NHLEVL
C
      INTEGER ME,MASTER,NPROC,IBTYP,IPTIM
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DOUBLE PRECISION CPU, CPU0, CPUB, CPUAO, CPUMO, CPUI,
     *                 WALL,WALL0,WALLB,WALLAO,WALLMO,WALLI,TIM
      COMMON /TIMING/ CPU,WALL
C
C
C VARIABLES FOR MEMORY MANAGEMENT AND POINTERS FOR ARRAYS
C
      INTEGER LOADFM,LAST,NEED,LFH,LFP,LFPH,TOTAL_MEM
      INTEGER LVR,LVE,LTMP1,LTMP,LVL,LRL,LVM,LREST
C
C
C IDENTIFIERS FOR PARALLEL DDI STUFF
C
      INTEGER DDI_NP,DDI_ME,DDI_NN,DDI_MY,SMP_NP,SMP_ME
C
C
C VARIABLES FOR SIZES OF ARRAYS
C
      INTEGER NO2,NO3,NO4,NU2,NU3,NOU,NO2U,NOU2,NO2U2,NUTR,NO3U
C
C
C INTEGERS FOR DO LOOPS AND OFFSETS
C
      INTEGER I,J,ILO,IHI,JLO,JHI,IOFF,JOFF,JOF1,IOF1,ROW,COL,IOF2
      INTEGER NR,SR
C
C
C FLAG TO SET LOTS OF TIMERS TO BE PRINTED
C
      LOGICAL P_TIME
C
C
C VARIABLES USED DURING THE UPDATE OF THE AMPLITUDES
C
      DOUBLE PRECISION ZZ,ENRGOLD,TRESH
      DOUBLE PRECISION T1NORM,T2NORM
      INTEGER IMAX,III,IDMY,A,B,K,NGOTMX
C
      DOUBLE PRECISION ZERO,ONE,TWO,ONEM,HALF,TEN
      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00,ONEM=-1.0D+00)
      PARAMETER(HALF=0.5D+00,TEN=10.0D+00)
C
      DATA CHECK/8HCHECK   /
      DATA LCCD,CCD/2*.FALSE./
C
      IF(MASWRK) WRITE(6,*) 'RUNNING PROCESS-BASED CCSD ITERATIONS'
C
C NORMALLY SET TO FALSE, SET TO TRUE IF YOU WANT LOTS OF TIMINGS PRINTED
C
      P_TIME = .FALSE.
C
      NO2   = NO*NO
      NO3   = NO*NO2
      NO3U  = NO3*NU
      NO4   = NO*NO3
      NU2   = NU*NU
      NU3   = NU*NU2
      NOU   = NO*NU
      NO2U  = NO2*NU
      NOU2  = NO*NU2
      NO2U2 = NOU*NOU
      NUTR  = (NU2+NU)/2
C
      TRESH = TEN**(-ICONV)
      CNVR = .FALSE.
      LCCD = MET.EQ.0
      CCD = MET.EQ.1
C
C ------------------------------------------------------
C GET PROCESS AND NODE IDENTITY
C ------------------------------------------------------
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_NNODE(DDI_NN,DDI_MY)
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
C
C ------------------------------------------------------
C GET MEMORY FOR THE FH, FP, AND FPH WORKING ARRAYS
C THE FAST MEMORY WORKING ARRAYS ARE USED FOR ALL
C CALCULATIONS.  THE PARAMETERS PASSED IN ARE USED
C TO START THE WORKING COPIES PROPERLY EACH ITERATION
C ALSO GET MEMORY WHICH IS USED DURING THE ITERATION
C AS TEMPORARY STORAGE
C ------------------------------------------------------
C
      TOTAL_MEM = 0
      CALL GOTFM(NGOTMX)
C
C     N.B.: IF YOU CHANGE THIS, YOU MUST ALSO CHANGE THE "CHECK" MEMORY.
C
      CALL VALFM(LOADFM)
      LFH   = LOADFM + 1
      LFP   = LFH    + NO2
      LFPH  = LFP    + NU2
      LREST = LFPH   + NOU
      LAST  = LREST  + MAX(NU3+2*NOU2,NOU2+2*NO2U2+2*NOU2+10)
      NEED  = LAST - LOADFM - 1
C
      IF(NEED.GT.NGOTMX) THEN
        IF(MASWRK) THEN
          WRITE(6,91) NEED, NGOTMX
          CALL ABRT
        END IF
      END IF
      CALL GETFM(NEED)
C
      TOTAL_MEM = NEED
C
      IF(EXETYP.EQ.CHECK) CNVR=.TRUE.
      IF(EXETYP.EQ.CHECK) GO TO 2000
C
      IF(IREST.EQ.0.OR.MET.LT.2) THEN
        CALL ZEROMA(O1,1,NOU)
        IF(MASWRK) CALL WO1(1,NO,NU,O1)
        IF(MASWRK) CALL WO1(2,NO,NU,O1)
      END IF
C
      IF(IREST.EQ.0) THEN
         IF(MASWRK) CALL WO2(1,NO,NU,O2)
         EMP2 = MP2ENERGY
         ENRGOLD = EMP2
         ITER = 0
      END IF
      ITRLE = 0
C
 1000 CONTINUE
C
C        START CLOCKS.
C
C        WE WILL PRINT OUT ON THE FIRST ITERATION TIME SPENT EVALUATING
C        THE VVVV TERM, IN THE AO BASIS, FOR THAT IS VERY SCALABLE.
C
C        WE WILL PRINT OUT THE TIME SPENT DOING ALL OTHER TERMS, WHICH
C        INVOLVE MO BASIS INTEGRALS UP TO THE VVVO CLASS, WHICH ARE
C        NOT AS SCALABLE.  NOTE THAT THE MO BASIS WORK CONSISTS MAINLY
C        OF T1 RELATED TERMS UP TO TERM 18, AND AFTER THAT MAINLY T2,
C        WHICH IS OF COURSE THE MAJORITY OF THE MO BASIS TIME.
C
C        WE OMIT PRINTING THE BROADCAST TIME AT BEGINNING THE ITERATION,
C        BUT THAT IS INCLUDED IN THE TOTAL FOR THE ITERATION.
C
      CALL TSECND(TIM)
      CPU0  = CPU
      WALL0 = WALL
C
      IF(MASWRK) THEN
C---        WRITE(6,*) '...DONE WITH PROCESS-BASED CCSD ITERATION...'
C---        CALL TIMIT(1)
        CALL DCOPY(NO2,FH,1,X(LFH),1)
        CALL DCOPY(NU2,FP,1,X(LFP),1)
        CALL DCOPY(NOU,FPH,1,X(LFPH),1)
        CALL DCOPY(NOU,FPH,1,T1,1)
      ELSE
        CALL ZEROMA(X(LFH),1,NO2)
        CALL ZEROMA(X(LFP),1,NU2)
        CALL ZEROMA(X(LFPH),1,NOU)
        CALL ZEROMA(T1,1,NOU)
      END IF
C
      CALL ZEROMA_SMP(T2,1,NO2U2)
C
      ITER = ITER + 1
      ITRLE = ITRLE + 1
      IF(MASWRK) THEN
        IF(ITER.NE.1) CALL RO2(1,NO,NU,O2)
        CALL CCSD_RDVM(NO,NU,VM,RL)
        IF(ITER.NE.1) CALL RO1(1,NO,NU,O1)
      END IF
C
C  BROADCASTING THE STARTING VALUES OF SOME BUFFERS
C
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_BCAST(102,'F',O2,NO2U2,0)
        CALL DDI_MASTERS_BCAST(103,'F',VM,NO3U,0)
      END IF
C
      CALL DDI_SMP_SYNC()
C
      CALL DDI_BCAST(101,'F',O1,NOU,0)
C
      CALL DDI_SYNC(1234)
C
      CALL TSECND(TIM)
      CPUB  = CPU  - CPU0
      WALLB = WALL - WALL0
      CPU0  = CPU
      WALL0 = WALL
C
      CALL CCSD_VVVV(NO,NU,O1,O2,T2,ITER)
C
      CALL DDI_SYNC(2345)
C
      CALL TSECND(TIM)
      CPUAO  = CPU  - CPU0
      WALLAO = WALL - WALL0
      CPU0  = CPU
      WALL0 = WALL
C
C --------------------------------------------------------------------
C VR(I,A|B,J) X O1(NOU,1) += FPH(NOU,1)
C ACTUALLY CARRIED OUT USING A DAXPY CALL WHERE THE ITH COLUMN
C OF VR IS MULTIPLIED BY THE ITH ELEMENT OF O1 AND ACCUMULATED INTO
C FPH
C --------------------------------------------------------------------
      LVR  = LREST
      LAST = LVR + NOU
      NEED = LAST - LREST - 1
      CALL TRT1(NO,NU,X(LVR),O1)
C
C-----CALL CHECK_CHKSUM(1,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(1)
C
      CALL DDI_DISTRIB(D_VR,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
         CALL DDI_GET(D_VR_SYM,ILO,IHI,J,J,X(LVR))
         CALL DAXPY(NOU,O1(J),X(LVR),1,X(LFPH),1)
      END DO
C
C-----CALL CHECK_CHKSUM(2,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(2)
C
      CALL TRT1(NO,NU,X(LVR),X(LFPH))
C
      LVR  = -1
      LAST =  -1
      NEED = -1
C
C --------------------------------------------------------------
C VPP(C,B,A|I) X O1(NU,NO) += FP(NU2,1) : DGEMM = OU3, MEM = NU3
C --------------------------------------------------------------
      LVE = LREST
      LTMP1 = LVE + NU3
      LAST = LTMP1 + NU2
      NEED = LAST - LREST - 1
C
      CALL ZEROMA(X(LVE),1,NU3)
      CALL ZEROMA(X(LTMP1),1,NU2)
C
      CALL DDI_DISTRIB(D_VVVO,DDI_ME,ILO,IHI,JLO,JHI)
      CALL DIV_EVEN(NO,DDI_NP,DDI_ME,NR,SR)
C
C     J LOOP IS 0-BASED, NOT 1-BASED
C
      DO J = SR-1, SR+NR-2
        JOFF = NU*J + 1
        IOFF = 0
        DO I = J*NU, (J*NU+NU-1)
          CALL DDI_GET(D_VVVO,1,NUTR,I+1,I+1,X(LTMP1))
          CALL CPYTSQ(X(LTMP1),X(LVE+IOFF),NU,1)
          IOFF = IOFF + NU2
        ENDDO
        CALL SYMT21(X(LVE),NU,NU,NU,1,13)
        CALL DGEMM('N','N',NU2,1,NU,ONE,X(LVE),NU2,O1(JOFF),NU,
     *             ONE,X(LFP),NU2)
      ENDDO
C
      LVE = -1
      LTMP1 = -1
      LAST = -1
      NEED = - 1
C
C-----CALL CHECK_CHKSUM(3,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(3)
C
C -----------------------------------
C FPH X O1 += FP - OU2 ==> REPLICATED
C -----------------------------------
      CALL DGEMM('N','T',NU,NU,NO,ONEM,X(LFPH),NU,O1,NU,ONE,X(LFP),NU)
C
C-----CALL CHECK_CHKSUM(4,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(4)
C
C --------------------------------------------------------------------
C VR(AT,I,BT|J) X O2(J,B,I,A) += FP(NU,NU) : DGEMM = O2U3, MEM = 2*OU2
C --------------------------------------------------------------------
      LVR = LREST
      LTMP = LVR + NO2U2
      LAST = LTMP + NOU2
      NEED = LAST - LREST - 1
C
C
      CALL TRANSQ_SMP(O2,NOU)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),O2,12)
      CALL SYMT21_SMP(O2,NO,NU,NO,NU,13)
C
      CALL DDI_DISTRIB(D_VR_IBT,DDI_ME,ILO,IHI,JLO,JHI)
C
         JOFF = NO*(JLO-1) + 1
         NR = JHI-JLO + 1
         CALL DDI_GET(D_VR_IBT,ILO,IHI,JLO,JHI,X(LVR))
         CALL DGEMM('N','N',NU,NU,NO*NR,ONEM,X(LVR),NU,O2(JOFF),NO2U,
     *               ONE,X(LFP),NU)
C
C-----CALL CHECK_CHKSUM(5,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(5)
C
      CALL DESM21_SMP(O2,NO,NU,NO,NU,13)
      CALL INSITU_SMP(NO,NU,NO,NU,X(LTMP),O2,12)
      CALL TRANSQ_SMP(O2,NOU)
C
C
      LVR = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C
C ------------------------------------------------------------
C VM(I,J,K,A) X O1(NO,NU) += FH(NO2,1) : DGEMM = O3U, MEM = OU
C ------------------------------------------------------------
      LTMP = LREST
      LAST = LTMP + NOU
      NEED = LAST - LREST - 1
C
      CALL TRT1(NU,NO,X(LTMP),O1)
      CALL SYMT21_SMP(VM,NO,NO,NO,NU,13)
C
C
      DO 1 J = 1, NU
        IF(MOD(J,DDI_NP).NE.DDI_ME) GOTO 1
        IOF1 = NO*(J-1) + 1
        IOFF = NO3*(J-1) + 1
        CALL DGEMM('N','N',NO2,1,NO,ONE,VM(IOFF),NO2,O1(IOF1),NO,
     *             ONE,X(LFH),NO2)
    1 CONTINUE
C
C-----CALL CHECK_CHKSUM(6,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(6)
C
      CALL DESM21_SMP(VM,NO,NO,NO,NU,13)
      CALL TRANSQ(X(LFH),NO)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ------------------------------------------------------------------
C O2(I,A,B,J) X VR(A,B,IT,JT) += FH(NO,NO) : DGEMM = O2U3, MEM = OU2
C ------------------------------------------------------------------
      LVR = LREST
      LAST = LVR + NU2
      NEED = LAST - LREST - 1
C
      CALL SYMT21_SMP(O2,NO,NU,NU,NO,23)
C
      CALL DDI_DISTRIB(D_VR_BIT,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
         ROW = (J-1) / NO
         COL = MOD((J-1),NO)
C
         JOFF = COL*NOU2 + 1
         JOF1 = ROW*NO
C
         CALL DDI_GET(D_VR_BIT,ILO,IHI,J,J,X(LVR))
         CALL DGEMM('N','N',NO,1,NU2,ONE,O2(JOFF),NO,
     *               X(LVR),NU2,ONE,X(LFH+JOF1),NO)
C
      END DO
C
C-----CALL CHECK_CHKSUM(7,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(7)
C
      CALL DESM21_SMP(O2,NO,NU,NU,NO,23)
      LVR = -1
      LAST = -1
      NEED = -1
C
C -----------------------------------
C  O1 X FP += T1 - OV2 ==> REPLICATED
C -FH X O1 += T1 - O2V ==> REPLICATED
C -----------------------------------
      CALL DGEMM('N','N',NO,NU,NU,ONE,O1,NO,X(LFP),NU,ONE,T1,NO)
      CALL DGEMM('N','N',NO,NU,NO,ONEM,X(LFH),NO,O1,NO,ONE,T1,NO)
C
C-----CALL CHECK_CHKSUM(8,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(8)
C
C --------------------------------------------------
C O2 X FPH += T1 - O2V2 ==> REPLICATED AT THE MOMENT
C --------------------------------------------------
      CALL SYMT21_SMP(O2,NO,NU,NU,NO,14)
C           O(O2V2) BUST IT L8R
      CALL DGEMM('N','N',NOU,1,NOU,ONE,O2,NOU,X(LFPH),NOU,ONE,T1,NOU)
C
C-----CALL CHECK_CHKSUM(9,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(9)
C
      CALL DESM21_SMP(O2,NO,NU,NU,NO,14)
C
C ----------------------------------------------------------------
C VR(A,I,B|J) = 2*VR(A,I,B|J) - VL(A,I,B|J)
C O1(1,NOU) X VR(A,I,B|J) += T1(NU,NO) : DGEMM = O2U2, MEM = 3*OU2
C ----------------------------------------------------------------
C
      LVR = LREST
      LVL = LVR   + NOU
      LTMP = LVL   + NOU
      LAST = LTMP   + NOU
      NEED = LAST - LREST - 1
C
      CALL TRT1(NO,NU,X(LTMP),T1)
      CALL TRT1(NO,NU,X(LTMP),O1)
C
      CALL DDI_DISTRIB(D_VR,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
C
        CALL DDI_GET(D_VR,ILO,IHI,J,J,X(LVR))
        CALL INSITU(NO,NU,1,1,X(LTMP),X(LVR),12)
C
        CALL DDI_GET(D_VL,ILO,IHI,J,J,X(LVL))
        CALL INSITU(NO,NU,1,1,X(LTMP),X(LVL),12)
C
        CALL DSCAL(NOU,TWO,X(LVR),1)
        CALL DAXPY(NOU,ONEM,X(LVL),1,X(LVR),1)
C
        T1(J) = T1(J) + DDOT(NOU,O1,1,X(LVR),1)
C
      END DO
C
C-----CALL CHECK_CHKSUM(10,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(10)
C
      LVR = -1
      LVL = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------------------------------------------- 11
C VPP(AXB,C|I) X O2(BXA,I,J) += T1(NU,NO) : DGEMM = O2U3, MEM = NU3
C -----------------------------------------------------------------
      LVE = LREST
      LTMP1 = LVE + NOU2
      LAST = LTMP1   + NUTR
      NEED = LAST - LREST - 1
C
C             USE LVE AS TEMP ARRAY
      CALL INSITU_SMP(NO,NU,NU,NO,X(LVE),O2,13)
C             O2(B,A,I,J) W/ B,A MODIFIED
      CALL SYMT21_SMP(O2,NU,NU,NO,NO,12)
C
      CALL DDI_DISTRIB(D_VVVO,DDI_ME,ILO,IHI,JLO,JHI)
      DO J = JLO, JHI
        JOFF = NU*(J-1) + 1
        CALL DDI_GET(D_VVVO,1,NUTR,J,J,X(LTMP1))
        CALL CPYTSQ(X(LTMP1),X(LVE),NU,1)
        CALL DGEMM('N','N',NU,NO,NU,ONE,X(LVE),NU,O2(JOFF),NOU2,
     *             ONE,T1,NU)
      END DO
C
C-----CALL CHECK_CHKSUM(11,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(11)
C
      LVE = -1
      LTMP1 = -1
      LAST = -1
      NEED = -1
C
C
C -----------------------------------------------------------------12
C -VM(IXJ,K,A) X O2(I,J,BXA) += T1(NO,NU) : DGEMM = O3U2, MEM = OU2
C -----------------------------------------------------------------
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL TRT1(NU,NO,X(LTMP),T1)
C
C              O2(B,A,I,J) -> O2(I,A,B,J)
      CALL INSITU_SMP(NU,NU,NO,NO,X(LTMP),O2,13)
C              O2(I,A,B,J) -> O2(B,J,I,A)
      CALL TRANSQ_SMP(O2,NOU)
C              O2(B,J,I,A) -> O2(I,J,B,A)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),O2,13)
C
      DO 2 J = 1, NU
        IF(MOD(J,DDI_NP).NE.DDI_ME) GOTO 2
        IOF1 = NO*(J-1) + 1
        IOFF = NO2U*(J-1) + 1
        CALL DGEMM('N','N',NO,1,NO2U,ONEM,VM,NO,O2(IOFF),NO2U,
     *             ONE,T1(IOF1),NO)
    2 CONTINUE
C
C-----CALL CHECK_CHKSUM(12,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(12)
C
      CALL DESM21_SMP(O2,NO,NO,NU,NU,12)
      CALL INSITU_SMP(NO,NO,NU,NU,X(LTMP),O2,13)
      CALL TRANSQ_SMP(O2,NOU)
C
      CALL TRT1(NU,NO,X(LTMP),O1)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C -------------------------------------------
C MODIFY T1 WITH EH AND EP
C -------------------------------------------
      CALL DDI_GSUMF(202,T1,NOU)
      IF(MASWRK)    CALL ADDDEN1(NO,NU,T1,OEH,OEP)
      IF(ITER.LE.3) CALL ZEROMA(T1,1,NOU)
      IF(MASWRK)    CALL WO1(2,NO,NU,T1)
C
C ---------------------------------------
C O1 X FPH += FH : DGEMM = O2U, MEM = NO,
C   REPLICATED SINCE FPH IS PARTIAL
C ---------------------------------------
      LTMP = LREST
      LAST = LTMP   + NOU
      NEED = LAST - LREST - 1
C
      CALL TRT1(NU,NO,X(LTMP),X(LFPH))
C
      CALL DGEMM('N','T',NO,NO,NU,ONE,O1,NO,X(LFPH),NO,ONE,X(LFH),NO)
      IF(DDI_ME.NE.0) CALL DCOPY(NOU,ZERO,0,T1,1)
C
C-----CALL CHECK_CHKSUM(13,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(13)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C -------------------------------------------------------------- 14
C O2(I,A,B,J) X FH(NO,NO) += T2(NOU2,NO) : DGEMM = O3U2, MEM = 0
C --------------------------------------------------------------
C LAST TIME FH USED; SUM IT TO MAKE NEXT DGEMM FASTER
      CALL DDI_GSUMF(1234,X(LFH),NO2)
      CALL DDI_SMP_SYNC()
      CALL DIV_EVEN(NOU2,DDI_NP,DDI_ME,NR,SR)
      CALL DGEMM('N','T',NR,NO,NO,ONEM,O2(SR),NOU2,X(LFH),NO,
     *           ONE,T2(SR),NOU2)
C
C     JUST USED TO SET THE VALUES PROPERLY FOR THE CHECKSUM
      CALL DDI_SMP_SYNC()
      IF(DDI_ME.NE.0) CALL DCOPY(NO2,ZERO,0,X(LFH),1)
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(500,T2,NO2U2)
      CALL DDI_SMP_SYNC()
C      IF(DDI_ME.NE.0.AND.SMP_ME.EQ.0) CALL DCOPY(NO2U2,ZERO,0,T2,1)
      IF(DDI_MY.NE.0) CALL ZEROMA_SMP(T2,1,NO2U2)
C
C-----CALL CHECK_CHKSUM(14,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(14)
C
C ---------------------------------------------------------------- 15
C O2(B,J,I,A) X FP(NU,NU) += T2(B,J,I,A) : DGEMM = O2U3, MEM = O2U
C ----------------------------------------------------------------
      LTMP = LREST
      LAST = LTMP   + NO2U
      NEED = LAST - LREST - 1
C
      CALL TRANSQ_SMP(T2,NOU)                     ! (I,A,B,J)->(B,J,I,A)
      CALL TRANSQ_SMP(O2,NOU)                     ! (I,A,B,J)->(B,J,I,A)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),T2,12)  ! (B,J,I,A)->(J,B,I,A)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),O2,12)  ! (B,J,I,A)->(J,B,I,A)
C
C          LAST TIME FP USED; SUM IT TO AVOID REP. DGEMM
      CALL DDI_GSUMF(1234,X(LFP),NU2)
C
      CALL DDI_SMP_SYNC()
      CALL DIV_EVEN(NO2U,DDI_NP,DDI_ME,NR,SR)
      CALL DGEMM('N','N',NR,NU,NU,ONE,O2(SR),NO2U,X(LFP),NU,
     *           ONE,T2(SR),NO2U)
C
      CALL DDI_SMP_SYNC()
C USED FOR GETTING CORRECT CHECKSUMS
      IF(DDI_ME.NE.0) CALL DCOPY(NU2,ZERO,0,X(LFP),1)
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(500,T2,NO2U2)
      CALL DDI_SMP_SYNC()
C      IF(DDI_ME.NE.0.AND.SMP_ME.EQ.0) CALL DCOPY(NO2U2,ZERO,0,T2,1)
      IF(DDI_MY.NE.0) CALL ZEROMA_SMP(T2,1,NO2U2)
C
C-----CALL CHECK_CHKSUM(15,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(15)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------------------------------------------------
C O2(J,I,B,A) X VR(A,B,I,J) = O4_T(NO2,NO2) : DGEMM = O4U2, MEM = 2*NOU2
C ----------------------------------------------------------------------
      LVR = LREST
      LTMP = LVR   + NO2U2
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL DDI_SMP_SYNC()
      CALL ZEROMA_SMP(RL,1,NO2U2)
      CALL INSITU_SMP(NO,NU,NO,NU,X(LTMP),O2,23)
C
C
      IF(SMP_ME.EQ.0) CALL ADT12(1,NO,NU,O1,O2,3)
      CALL DDI_SMP_SYNC()
C
      CALL DDI_DISTRIB(D_VR_BI,DDI_ME,ILO,IHI,JLO,JHI)
C
      IOFF = NO2*(JLO-1) + 1
      NR = NO2*(JHI-JLO+1)
      CALL DCOPY(NR,O4(IOFF),1,RL(IOFF),1)
      CALL DDI_GET(D_VR_BI,ILO,IHI,JLO,JHI,X(LVR))
      CALL DGEMM('N','N',NO2,(JHI-JLO+1),NU2,ONE,O2,NO2,X(LVR),NU2,
     *           ONE,RL(IOFF),NO2)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(500,RL,NO4)
C
C-----CALL CHECK_CHKSUM(16,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(16)
C
      LVR = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C --------------------------------------
C TWEAK O4/RL AROUND
C --------------------------------------
      CALL MTRANS_SMP(RL,NO,11)
      CALL DSCAL_SMP(NO4,HALF,RL,1)
C
C --------------------------------------------------------------- ! 17
C VM(I,J,K,A) X O1(NU,NO) += O4_T(L,J,K,I) : DGEMM = O4U, MEM = 0 !
C O4_T IS NEEDED IN THE LHS OF THE NEXT O4U2 DGEMM, SO THIS MXM   !
C MUST BE REPLICATED PER NODE ==> A COMPLETE O4_T IS ON EACH NODE !
C --------------------------------------------------------------- !
      CALL DIV_EVEN(NO3,SMP_NP,SMP_ME,NR,SR)
      CALL DGEMM('N','T',NR,NO,NU,ONE,VM(SR),NO3,O1,NO,ONE,RL(SR),NO3)
C
      CALL DDI_SMP_SYNC()
C
      IF(SMP_ME.EQ.0) CALL SYMV1(RL,NO2)
C      CALL SYMV1_SMP(RL,NO2)
C      IF(SMP_ME.EQ.0) CALL MTRANS(RL,NO,23)
C      CALL DDI_SMP_SYNC()
C     MTRANS_SMP(..,..,23) DOESN'T WORK IN PARALLEL
      CALL MTRANS_SMP(RL,NO,23)
C
C-------------------------------------------------------------------- 18
C O4(NO2,NO2) X 1/2 O2(JT,IT,B,A) += T2(?,?,?,?) : DGEMM = O3U3,MEM=O2U
C--------------------------------------------------------------------
      LTMP = LREST
      LAST = LTMP + NOU2
      NEED = LAST - LREST
C
C
      CALL TRANMD_SMP(O2,NO,NO,NU,NU,12)
      CALL INSITU_SMP(NO,NU,NO,NU,X(LTMP),T2,12)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),T2,13)
      CALL DSCAL_SMP(NO2U2,HALF,O2,1)
C
      CALL DIV_EVEN(NO2,DDI_NP,DDI_ME,NR,SR)
      CALL DDI_SMP_SYNC()
      CALL DGEMM('N','N',NR,NU2,NO2,ONE,RL(SR),NO2,O2,NO2,
     *           ONE,T2(SR),NO2)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(500,T2,NO2U2)
      CALL DDI_SMP_SYNC()
      IF(DDI_MY.NE.0) CALL ZEROMA_SMP(T2,1,NO2U2)
      CALL DDI_SYNC(1234)
C
C-----CALL CHECK_CHKSUM(17,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(17)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ---------------
C VVVV TERMS
C ---------------
C  THIS IS WHERE THE VVVV TERM APPEARS IN THE ORIGINAL SERIAL CODE
C  THIS IS DEBUGGING CODE
C      CALL DDI_SMP_SYNC()
C      IF(MASWRK) THEN
C      DO I = 1, NU
C      CALL RO2(140+I,NO,NU,JONTEST)
C      CALL DGEMM('N','N',NO2,NU,NU2,ONE,O2,NO2,JONTEST,NU2,ONE,
C     &           T2( (I-1)*NO2U + 1 ),NO2)
C      ENDDO
C      ENDIF
C      CALL DDI_SMP_SYNC()
C      CALL CCSD_VVVV(NO,NU,O1,O2,T2,ITER)
CC
CC-----CALL CHECK_CHKSUM(18,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
C      IF(P_TIME) CALL PRINT_TIM(18)
C      IF(MASWRK) THEN
C        CALL TIMIT(1)
C        WRITE(6,*) 'CHKSUM 18'
C      END IF
C      CALL DDI_SMP_SYNC()
C
C
C ------------------------------------------------------
C -VR(AT,I,BT,J) X 1/2 O12(B,I,A,J) + VL(AT,I,BT,J) = RL
C       DGEMM = O3U3, MEM=2*NOU2
C ------------------------------------------------------
C
      LVR = LREST
      LTMP = LVR   + NO2U2
      LAST = LTMP   + NO2U2
      NEED = LAST - LREST - 1
C
      CALL DDI_SMP_SYNC()
      CALL DSCAL_SMP(NO2U2,TWO,O2,1)
      IF(SMP_ME.EQ.0) THEN
        IF(.NOT.CCD) CALL ADT12(2,NO,NU,O1,O2,2)
      END IF
C
      CALL INSITU_SMP(NO,NO,NU,NU,X(LTMP),O2,13)
      CALL TRANSQ_SMP(O2,NOU)
      CALL INSITU_SMP(NO,NU,NU,NO,X(LTMP),O2,12)
      CALL TRANMD_SMP(O2,NU,NO,NU,NO,24)
C
      CALL DSCAL_SMP(NO2U2,HALF,O2,1)
      IF(SMP_ME.EQ.0) THEN
        IF(.NOT.CCD) CALL ADT12(1,NO,NU,O1,O2,4)
      END IF
C
      CALL ZEROMA_SMP(RL,1,NO2U2)
C
      CALL ZEROMA(X(LTMP),1,NO2U2)
C
      CALL DDI_DISTRIB(D_VL_IBT,DDI_ME,ILO,IHI,JLO,JHI)
C
      JOFF = (JLO-1)*NOU
      CALL DDI_GET(D_VL_IBT,ILO,IHI,JLO,JHI,X(LTMP+JOFF))
      CALL DDI_DISTRIB(D_VR_IBT,DDI_ME,ILO,IHI,JLO,JHI)
C
      NR = JHI-JLO + 1
      CALL DDI_GET(D_VR_IBT,ILO,IHI,JLO,JHI,X(LVR))
      CALL DGEMM('N','N',NOU,NOU,NR,ONEM,X(LVR),NOU,O2(JLO),NOU,
     *           ONE,X(LTMP),NOU)
C
      CALL DDI_GSUMF(1234,X(LTMP),NO2U2)
      CALL DIV_EVEN(NO2U2,SMP_NP,SMP_ME,NR,SR)
      CALL DCOPY(NR,X(LTMP+SR-1),1,RL(SR),1)
C
C-----CALL CHECK_CHKSUM(19,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(19)
C
C MORE WORK HERE IF IN PARALLEL AND IF CCD
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
        IF(.NOT.CCD) CALL ADT12(2,NO,NU,O1,O2,4)
      END IF
      CALL DSCAL_SMP(NO2U2,TWO,O2,1)
C
      LVR = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ---------------------------------------------- 21
C O1 X VM += VL
C ----------------------------------------------
C
      LTMP = LREST
      LAST = LTMP + NOU2
      NEED = LAST - LREST
C
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,13)
      CALL INSITU_SMP(NU,NO,NU,NO,X(LTMP),RL,12)
      CALL TRANMD_SMP(RL,NO,NU,NU,NO,14)
      CALL TRANSQ_SMP(RL,NOU)
C
      CALL DIV_EVEN(NO2U,SMP_NP,SMP_ME,NR,SR)
      IOFF = (SR-1)*NO + 1
      JOFF = (SR-1)*NU + 1
      CALL DGEMM('T','N',NU,NR,NO,ONEM,O1,NO,VM(IOFF),NO,
     *           ONE,RL(JOFF),NU)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO2U2,ZERO,0,RL,1)
      END IF
C
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,13)
      CALL TRANSQ_SMP(RL,NOU)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C --------------------------------------------- 22
C O1 X VE(C,B,A,I) += VL
C ---------------------------------------------
      LVE = LREST
      LTMP = LVE   + NU3
      LAST = LTMP + NU2
      NEED = LAST - LREST - 1
C
C
      CALL DDI_DISTRIB(D_VVVO,DDI_ME,ILO,IHI,JLO,JHI)
      CALL DIV_EVEN(NO,DDI_NP,DDI_ME,NR,SR)
C
C     0-BASED DO LOOP INDEX
C   REQUIRED TO GET NU3 OF VVVO INTEGRALS BECAUSE OF THE TRANMD(13) CALL
C
      DO J = SR-1, SR+NR-2
        JOFF = J*NOU2 + 1
        IOFF = 0
        DO I = J*NU, (J*NU+NU-1)
          CALL DDI_GET(D_VVVO,1,NUTR,I+1,I+1,X(LTMP))
          CALL CPYTSQ(X(LTMP),X(LVE+IOFF),NU,1)
          IOFF = IOFF + NU2
        ENDDO
        CALL TRANMD(X(LVE),NU,NU,NU,1,13)
        CALL DGEMM('N','N',NO,NU2,NU,ONE,O1,NO,X(LVE),NU,
     *             ONE,RL(JOFF),NO)
      ENDDO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(300,RL,NO2U2)
C
C-----CALL CHECK_CHKSUM(20,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(20)
C
      LVE = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C -------------------------------- 23A & 23B
C O2 X VL += T2
C --------------------------------
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL INSITU_SMP(NO,NU,NU,NO,X(LTMP),RL,12) ! TRMD 26
      CALL TRANMD_SMP(RL,NU,NO,NU,NO,24)         ! TRMD 26
C
      CALL TRANMD_SMP(O2,NU,NO,NU,NO,24)         ! TRMD 27
      CALL INSITU_SMP(NU,NO,NU,NO,X(LTMP),O2,12) ! TRMD 27
      CALL TRANMD_SMP(O2,NO,NU,NU,NO,23)         ! TRMD 27
C
      CALL INSITU_SMP(NO,NO,NU,NU,X(LTMP),T2,13) ! TRMD 28
      CALL TRANSQ_SMP(T2,NOU)                    ! TRMD 28
      CALL TRANMD_SMP(T2,NO,NU,NU,NO,23)         ! TRMD 28
C
      CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NR,SR)
      IOFF = (SR-1)*NOU + 1
C
      CALL DGEMM('N','N',NOU,NR,NOU,ONEM,O2,NOU,RL(IOFF),NOU,
     &           ONE,T2(IOFF),NOU)
C
      CALL TRANMD_SMP(O2,NO,NU,NU,NO,23)
      CALL TRANMD_SMP(T2,NO,NU,NU,NO,23)
C
      CALL DGEMM('N','N',NOU,NR,NOU,ONEM,O2,NOU,RL(IOFF),NOU,
     &           ONE,T2(IOFF),NOU)
C
C-----CALL CHECK_CHKSUM(21,NO,NU,O1,RL,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(21)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C
C -------------------------------------- 24A AND 24B
C VR X O2 = VL
C --------------------------------------
      LVR = LREST
      LTMP = LVR   + NO2U2
      LTMP1= LTMP   + NO2U2
      LAST = LTMP1  + NOU2
      NEED = LAST - LREST -1
C
      CALL ZEROMA_SMP(RL,1,NO2U2)
C
      CALL INSITU_SMP(NO,NU,NU,NO,X(LTMP),O2,12)
      CALL DSCAL_SMP(NO2U2,HALF,O2,1)
C
      CALL DDI_DISTRIB(D_VR,DDI_ME,ILO,IHI,JLO,JHI)
C
      CALL DIV_EVEN(NO,DDI_NP,DDI_ME,NR,SR)
      CALL DCOPY(NO2U2,ZERO,0,X(LTMP),1)
C
C     0-BASED INDEX
C
      DO J = SR-1, SR+NR-2
        JOFF = J*NU + 1
        IOFF = 0
        DO I = J*NU, (J*NU+NU-1)
          CALL DDI_GET(D_VR,1,NOU,I+1,I+1,X(LVR+IOFF))
          IOFF = IOFF + NOU
        END DO
        CALL INSITU(NO,NU,NU,1,X(LTMP1),X(LVR),12)
        CALL SYMT21(X(LVR),NU,NO,NU,1,13)
        CALL DGEMM('N','N',NOU,NOU,NU,ONE,X(LVR),NOU,O2(JOFF),NOU,
     *             ONE,X(LTMP),NOU)
      END DO
C
      CALL DDI_GSUMF(201,X(LTMP),NO2U2)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DAXPY(NO2U2,ONE,X(LTMP),1,RL,1)
C
C-----CALL CHECK_CHKSUM(22,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(22)
C
      CALL TRANMD_SMP(O2,NU,NO,NU,NO,13)
      IF(SMP_ME.EQ.0) CALL ADT12(1,NO,NU,O1,O2,5)
      CALL DDI_SMP_SYNC()
C
      CALL DCOPY(NO2U2,ZERO,0,X(LTMP),1)
C
      NR = JHI-JLO + 1
      JOFF = 0
      DO J = JLO,JHI
        CALL DDI_GET(D_VR,ILO,IHI,J,J,X(LVR+JOFF))
        CALL INSITU(NO,NU,1,1,X(LTMP1),X(LVR+JOFF),12)
        JOFF = JOFF + NOU
      END DO
        CALL DGEMM('N','N',NOU,NOU,NR,ONEM,X(LVR),NOU,O2(JLO),NOU,
     *             ONE,X(LTMP),NOU)
C
      CALL DDI_GSUMF(201,X(LTMP),NO2U2)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DAXPY(NO2U2,ONE,X(LTMP),1,RL,1)
C
C-----CALL CHECK_CHKSUM(23,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(23)
C
      IF(SMP_ME.EQ.0) CALL ADT12(2,NO,NU,O1,O2,5)
      CALL DSCAL_SMP(NO2U2,TWO,O2,1)
C
      LVR = -1
      LTMP = -1
      LTMP1= -1
      LAST = -1
      NEED = -1
C
C ----------------------------- 25
C O1 X VE += VL
C -----------------------------
      LVE = LREST
      LTMP = LVE   + NU2
      LAST = LTMP + NUTR
      NEED = LAST - LREST - 1
C
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO2U2,ZERO,0,RL,1)
      END IF
      CALL TRANSQ_SMP(RL,NOU)
C                 LVE USED AS A TMP ARRAY
      CALL INSITU_SMP(NU,NO,NU,NO,X(LVE),RL,12)
      CALL DDI_DISTRIB(D_VVVO,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
        JOFF = NOU*(J-1) + 1
        CALL DDI_GET(D_VVVO,1,NUTR,J,J,X(LTMP))
        CALL CPYTSQ(X(LTMP),X(LVE),NU,1)
        CALL DGEMM('N','N',NO,NU,NU,ONE,O1,NO,X(LVE),NU,
     *             ONE,RL(JOFF),NO)
      END DO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(301,RL,NO2U2)
C
C-----CALL CHECK_CHKSUM(24,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(24)
C
      LVE = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------- 26
C O1 X VM += VL
C -----------------------------
C
       CALL TRANMD_SMP(RL,NO,NU,NU,NO,14)
       CALL TRANSQ_SMP(RL,NOU)
       CALL TRANMD_SMP(RL,NU,NO,NO,NU,14)
C
C     MAY NOT BE WORTH DISTRIBUTING THIS DGEMM SO WE'LL DO IT ON EACH
C     NODE WHEN REALLY THE MASTER IS THE ONLY IMPORTANT ONE
C     CALL DIV_EVEN(NO2U,DDI_NP,DDI_ME,NR,SR)
      CALL DIV_EVEN(NO2U,SMP_NP,SMP_ME,NR,SR)
      IOFF = (SR-1)*NO + 1
      JOFF = (SR-1)*NU + 1
      CALL DGEMM('T','N',NU,NR,NO,ONEM,O1,NO,VM(IOFF),NO,
     &           ONE,RL(JOFF),NU)
C
C-----CALL CHECK_CHKSUM(25,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(25)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
C        CALL DDI_MASTERS_GSUMF(505,RL,NO2U2)
        IF(DDI_ME.NE.0) CALL DCOPY(NO2U2,ZERO,0,RL,1)
      END IF
C -----------------------------
C VL = VL + VR
C -----------------------------
      LVR = LREST
      LTMP = LVR   + NOU
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL TRANSQ_SMP(RL,NOU)
      CALL INSITU_SMP(NO,NU,NU,NO,X(LTMP),RL,12)
C
      CALL DDI_DISTRIB(D_VR,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
        JOFF = (J-1)*NOU + 1
        CALL DDI_GET(D_VR,ILO,IHI,J,J,X(LVR))
        CALL INSITU(NO,NU,1,1,X(LTMP),X(LVR),12)
        CALL DAXPY(NOU,ONE,X(LVR),1,RL(JOFF),1)
      END DO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(505,RL,NO2U2)
C
C-----CALL CHECK_CHKSUM(26,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(26)
C
      LVR = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C
C ----------------------------- 28
C O2 X VL += T2
C -----------------------------
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL TRANMD_SMP(O2,NU,NO,NU,NO,13)
      CALL INSITU_SMP(NU,NO,NU,NO,X(LTMP),O2,12)
      CALL SYMT21_SMP(O2,NO,NU,NU,NO,23)
C
      CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NR,SR)
      IOFF = (SR-1)*NOU + 1
      CALL DGEMM('N','N',NOU,NR,NOU,ONE,O2,NOU,RL(IOFF),NOU,
     &           ONE,T2(IOFF),NOU)
C
C-----CALL CHECK_CHKSUM(27,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(27)
C
      CALL DESM21_SMP(O2,NO,NU,NU,NO,23)
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO2U2,ZERO,0,T2,1)
      END IF
      CALL DDI_SMP_SYNC()
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------- 29 30 31
C
C -----------------------------
      LVE = LREST
      LRL = LVE   + NU3
      LTMP = LRL   + NOU2
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL DDI_DISTRIB(D_VL,DDI_ME,ILO,IHI,JLO,JHI)
      CALL DIV_EVEN(NO,DDI_NP,DDI_ME,NR,SR)
C
C     0-BASED LOOP INDEX
      DO J = SR-1, SR+NR-2
        JOFF = NU*J + 1
        JOF1 = NOU2*J + 1
        IOFF = 0
        DO I = J*NU, (J*NU+NU-1)
          CALL DDI_GET(D_VVVO,1,NUTR,I+1,I+1,X(LRL))
          CALL CPYTSQ(X(LRL),X(LVE+IOFF),NU,1)
          IOFF = IOFF + NU2
        ENDDO
        CALL TRANMD(X(LVE),NU,NU,NU,1,13)
        CALL DDI_GET(D_VL,ILO,IHI,JOFF,JOFF+NU-1,X(LRL))
        CALL DGEMM('T','N',NU,NU2,NO,ONEM,O1,NO,X(LRL),NO,
     *             ONE,X(LVE),NU)
C
        CALL TRANMD(X(LVE),NU,NU,NU,1,13)
        CALL DDI_GET(D_VR_IBT,ILO,IHI,JOFF,JOFF+NU-1,X(LRL))
        CALL INSITU(NU,NO,NU,1,X(LTMP),X(LRL),13)
        CALL INSITU(NU,NO,NU,1,X(LTMP),X(LRL),12)
        CALL DGEMM('T','N',NU,NU2,NO,ONEM,O1,NO,X(LRL),NO,
     *             ONE,X(LVE),NU)
C
        CALL TRANMD(X(LVE),NU,NU,NU,1,12)
        CALL DGEMM('N','N',NO,NU2,NU,ONE,O1,NO,X(LVE),NU,
     *             ONE,T2(JOF1),NO)
      ENDDO
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(304,T2,NO2U2)
C
C-----CALL CHECK_CHKSUM(28,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(28)
C
      LVE = -1
      LRL = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------- 35 34 32 33
C
C -----------------------------
C
      LVE  = LREST
      LVM  = LVE   + NU3
      LAST = LVM   + NOU2
      NEED = LAST - LREST - 1
C
      CALL ZEROMA_SMP(RL,1,NO2U2)
      CALL ZEROMA(X(LVM),1,NOU2)
      CALL TRANSQ_SMP(T2,NOU)
      CALL INSITU_SMP(NO,NU,NU,NO,X(LVE),O2,12)
      CALL INSITU_SMP(NU,NO,NU,NO,X(LVE),O2,23)
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,312)
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO3U,ZERO,0,VM,1)
      END IF
C
      CALL DDI_SMP_SYNC()
C
      CALL DIV_EVEN(NO,DDI_NP,DDI_ME,NR,SR)
C
C     0-BASED LOOP INDEX
      DO J = SR-1, SR+NR-2
        JOFF = NU*J + 1
        IOFF = NOU2*J + 1
        IOF1 = 0
        DO I = J*NU, (J*NU+NU-1)
          CALL DDI_GET(D_VVVO,1,NUTR,I+1,I+1,X(LVM))
          CALL CPYTSQ(X(LVM),X(LVE+IOF1),NU,1)
          IOF1 = IOF1 + NU2
        END DO
        CALL DGEMM('N','N',NO,NU2,NU,ONE,O1,NO,X(LVE),NU,
     *             ZERO,RL(IOFF),NO)
        CALL TRANMD(X(LVE),NU,NU,NU,1,13)
        CALL DGEMM('T','N',NO2,NU,NU2,ONE,O2,NU2,X(LVE),NU2,
     *             ZERO,X(LVM),NO2)
C
C
        IOF1 = J*NO2 + 1
        IOF2 = LVM
        DO A = 1,NU
          CALL DAXPY(NO2,ONE,X(IOF2),1,VM(IOF1),1)
          IOF1 = IOF1 + NO3
          IOF2 = IOF2 + NO2
        END DO
      END DO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_GSUMF(305,RL,NO2U2)
        CALL DDI_MASTERS_GSUMF(306,VM,NO3U)
      END IF
C
      CALL TRANSQ_SMP(RL,NOU)
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,23)
C
C ------------------------
C O1 X RL += LVM
C ------------------------
C
      CALL DIV_EVEN(NO2U,SMP_NP,SMP_ME,NR,SR)
C
      IOF1 = (SR-1)*NU + 1
      IOF2 = (SR-1)*NO + 1
C GOOD PLACE FOR SHARED MEMORY DGEMM HERE
      CALL DGEMM('N','N',NO,NR,NU,ONE,O1,NO,RL(IOF1),NU,
     &           ONE,VM(IOF2),NO)
      LVE = -1
      LVM = -1
      LAST = -1
      NEED = -1
C
C ------------------------
C FINAL CONTRIBUTION TO T2
C ------------------------
C
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,12)
C
      CALL DGEMM('T','N',NU,NR,NO,ONEM,O1,NO,VM(IOF2),NO,
     &           ONE,T2(IOF1),NU)
C
C-----CALL CHECK_CHKSUM(29,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(29)
C
      CALL TRANSQ_SMP(T2,NOU)
C
      LTMP1 = LREST
      LAST = LTMP1 + NO2U2
      NEED = LAST - LREST - 1
C
      IF(SMP_ME.EQ.0) CALL SYMETR(T2,NO,NU)
C
      IF(SMP_ME.EQ.0) CALL DDI_GET(D_VR,1,NOU,1,NOU,O2)
      IF(SMP_ME.EQ.0) CALL VECADD(T2,O2,NO2U2)
      IF(SMP_ME.EQ.0) CALL ADDDEN(NO,NU,T2,OEH,OEP)
      IF(MASWRK)      CALL WO2(2,NO,NU,T2)
C SHOULD SAVE THE T2 AMPS HERE SOMEWHERE
      CALL VECCOP_SMP(NO2U2,O2,T2)
      IF(.NOT.LCCD.AND..NOT.CCD) THEN
        IF(SMP_ME.EQ.0) CALL ADT12(1,NO,NU,T1,T2,6)
      END IF
      ZZ = TWO*DDOT(NOU,T1,1,FPH,1)
      IF(SMP_ME.EQ.0) THEN
        CALL ENERGYMM_DDI(NO,NU,T2,RL,ENRG,D_VR)
      END IF
C
C-----CALL CHECK_CHKSUM(30,NO,NU,O1,O2,T1,T2,X(LFH),FPH,X(LFP))
      IF(P_TIME) CALL PRINT_TIM(30)
C
      ENRG=ENRG+ZZ
      DIFFENG=ENRG-ENRGOLD
C
      CALL DDI_BCAST(125,'F',ENRG,1,0)
      CALL DDI_BCAST(127,'F',DIFFENG,1,0)
C
      LTMP1 = LREST
      LAST = LTMP1 + NOU2 + (NO2U2+NOU) + (NO2U2+NOU) + 10
      NEED = LAST - LREST - 1
C
      CALL DDI_BCAST(122,'I',MXRLE,1,0)
      IF(MXRLE.GT.0) GO TO 717
C
 717  CONTINUE
C
C     FIX THIS CALL LATER!!  (EITHER JONATHAN OR RYAN WROTE THIS NOTE)
C     I THINK IT IS FOR RESTART, WHICH ISN'T IMPLEMENTED YET
C     IF(IREST.GT.0.AND.ITRLE.EQ.1) CALL DRCMP(NO,NU,O1)
C
C     MWS, 4/9/07:
C     INSTEAD, FOLLOWING HUI, LETS JUST SET DIFMAX TO SOMETHING
C     THAT WILL CAUSE US TO LOOK LIKE WE ARE UNCONVERGED.
C     THE REAL COMPUTATION OF DIFMAX IS IN DDCC_DRRLEN JUST BELOW.
C
      IF(IREST.GT.0  .AND.  ITRLE.EQ.1) DIFMAX = 1.0D+00
C
      CALL DDI_BCAST(123,'F',DIFMAX,1,0)
      CNVR = ABS(DIFMAX).LT.TRESH
      IF(MASWRK  .AND.CNVR.AND.ITER.GT.1) CALL DRPRINT(2)
C
      IF(.NOT.CNVR.OR.ITER.LT.2) THEN
C
      IF(MASWRK) THEN
         IF(.NOT.LCCD .AND. .NOT.CCD) CALL RO1(2,NO,NU,T1)
         IF(MXRLE.GT.0) CALL DDCC_DRRLEN(NO,NU,X(LTMP1))
         CALL DRPRINT(2)
      END IF
C
      IF(MASWRK.AND.ITRLE.EQ.1) THEN
        IF(.NOT.LCCD.AND..NOT.CCD) THEN
          CALL RO1(2,NO,NU,T1)
          CALL WO1(1,NO,NU,T1)
        END IF
        CALL RO2(2,NO,NU,T2)
        CALL WO2(1,NO,NU,T2)
      END IF
      ENRGOLD = ENRG
C
      CALL ZEROMA(X(LTMP1),1,2*NO2U2)
      IF(MASWRK) CALL DDCC_DRREST(1,NO,NU,X(LTMP1),X(LTMP1+NO2U2))
C
      CALL TSECND(TIM)
      CPUMO  = CPU  - CPU0
      WALLMO = WALL - WALL0
      CPU0  = CPU
      WALL0 = WALL
      CPUI  = CPUB + CPUAO + CPUMO
      WALLI = WALLB + WALLAO + WALLMO
C
      IF(MASWRK  .AND.  ITER.EQ.1)
     *  WRITE(6,9040) CPUI,CPUAO,CPUMO,WALLI,WALLAO,WALLMO
C
C        TURN OFF DDI ARRAY CREATION MESSAGES
C
      IFLAG=0
      CALL DDI_OUTPUT(IFLAG)
C
      IF(ITER.LT.MAXIT) GO TO 1000
      END IF
C     CONVERGENCE HAS BEEN ACHIEVED
C
C
C               READ CONVERGED AMPLITUDES FROM DISK.
C        THESE HAVE THE SHAPE T1(NO,NU) AND T2(NO,NU,NU,NO).
C        NOTE THAT THE SHAPE OF T2 AT THIS POINT DOES NOT MATCH
C        THE DIMENSION ABOVE, SO WE USE -VR- AS STORAGE OF T2.
C
      IF(MASWRK) THEN
      IF(MET.GE.2) THEN
        CALL RO1(1,NO,NU,T1)
        CALL RO2(2,NO,NU,RL)
C
C        COMPUTE THE T1 DIAGNOSTIC OF
C        T.J.LEE, P.R.TAYLOR  INT.J.QUANTUM CHEM. S23, 199-207(1989)
C
        T1NORM=DDOT(NOU  ,T1,1,T1,1)
        T2NORM=DDOT(NO2U2,RL,1,RL,1)
        DIAGS(1) = SQRT(T1NORM/(TWO*NO))
        DIAGS(2) = SQRT(T1NORM)
        DIAGS(3) = SQRT(T2NORM)
C
        DO III=1,5
           IMAX = IDAMAX(NOU,T1,1)
           A = (IMAX-1)/NO + 1
           I = IMAX - (A-1)*NO
            AMPMX(III,  1) = T1(IMAX)
           IAMPMX(III,1,1) = I + IFC
           IAMPMX(III,2,1) = A + IFC + NO
           T1(IMAX) = ZERO
C
           IMAX = IDAMAX(NO2U2,RL,1)
           J = (IMAX-1)/NOU2 + 1
           IDMY = IMAX - (J-1)*NOU2
           B = (IDMY-1)/NOU + 1
           IDMY = IDMY - (B-1)*NOU
           A = (IDMY-1)/NO + 1
           I = IDMY - (A-1)*NO
            AMPMX(III,  2) = RL(IMAX)
           RL(IMAX) = ZERO
C               T2(I,A,B,J) EQUALS T2(J,B,A,I)
           IMAX = J + (B-1)*NO + (A-1)*NOU + (I-1)*NOU2
           RL(IMAX) = ZERO
           IF(I.EQ.J  .AND.  A.GT.B) THEN
              K = B
              B = A
              A = K
           END IF
           IF(I.NE.J) THEN
              K = J
              J = I
              I = K
              K = B
              B = A
              A = K
           END IF
           IAMPMX(III,1,2) = I + IFC
           IAMPMX(III,2,2) = J + IFC
           IAMPMX(III,3,2) = A + IFC + NO
           IAMPMX(III,4,2) = B + IFC + NO
        ENDDO
      END IF
C
      IF(MET.GE.4) THEN
      CALL RO1(1,NO,NU,T1)
      CALL RO2(1,NO,NU,T2)
      CALL VECCOP(NO2U2,O2,T2)
      CALL ADT12(1,NO,NU,T1,T2,6)
      OSS=TWO*DDOT(NOU,T1,1,T1,1)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      ODS=ZERO
      ODD=DDOT(NO2U2,O2,1,T2,1)
      END IF
      ESD=ENRG
C
      END IF
C
 2000 CONTINUE
C
C
C
      CALL RETFM(TOTAL_MEM)
      RETURN
C
   91 FORMAT(1X,'INSUFFICIENT MEMORY FOR CCSD ITERATIONS'/
     *       1X,'REQUIRED:',I13,'     AVAILABLE:',I13)
 9040 FORMAT(/1X,'ITER  CPU TIME: TOTAL=',F8.1,
     *        '  FORMULAE IN AO,MO BASIS=',2F8.1/
     *        1X,'ITER WALL TIME: TOTAL=',F8.1,
     *        '  FORMULAE IN AO,MO BASIS=',2F8.1/
     *        1X,'IT IS BENEFICIAL TO ADD MORE PROCESSORS IF THE',
     *           ' SCALABLE AO CONTRIBUTION''S TIME'/
     *        1X,'IS CONSIDERABLY LARGER THAN THE LESS SCALABLE',
     *           ' MO CONTRIBUTION''S TIME.'/)
      END
C
C*MODULE CCDDI   *DECK CCSD_DDI_NODE
      SUBROUTINE CCSD_DDI_NODE(NO,NU,MP2ENERGY,
     *                  O1,T1,FH,FP,FPH,        ! REPLICATED
     *                  O4,VM,O2,T2,RL,         ! SMP SHARED
     *                  OEH,OEP,IFC,
     *                  SMP_TEMP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER NO,NU,IFC
      DOUBLE PRECISION MP2ENERGY
      DOUBLE PRECISION O1(1),T1(1),FH(1),FP(1),FPH(1),SMP_TEMP(*),
     *                 O4(1),VM(1),O2(1),T2(1),RL(1),OEH(1),OEP(1)
C
      DOUBLE PRECISION X(1)
      COMMON /FMCOM /  X
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C           COMMON BLOCK FOR THE DDI ARRAYS WE CREATE
C
      INTEGER         D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI
      INTEGER         D_VL,D_VL_IBT
      COMMON /CCDDI / D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI,
     *                D_VL,D_VL_IBT
C
      COMMON /CCENGY/ ENRG,EREF,EMP2,ECCN,ETOT,ECORR,
     *                DIAGS,AMPMX,IAMPMX,XO1,XO2,
     *                DIFMAX,DIFFENG,ITER,CNVR
C
      DOUBLE PRECISION ENRG,EREF,EMP2,ECCN,ETOT(6),ECORR(6),
     *                DIAGS(3),AMPMX(5,2),XO1,XO2,
     *                DIFMAX,DIFFENG
C
      INTEGER         ITER,IAMPMX(5,4,2)
      LOGICAL         CNVR,LCCD,CCD
C
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      DOUBLE PRECISION TSH
      INTEGER         NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
C
      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
      INTEGER         MXRLE,NRLE0,NRLE,IRLE,ITRLE
C
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      DOUBLE PRECISION OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DOUBLE PRECISION RUNTYP,EXETYP,CHECK
      INTEGER NEVALS,NGLEVL,NHLEVL
C
      INTEGER ME,MASTER,NPROC,IBTYP,IPTIM
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DOUBLE PRECISION CPU, CPU0, CPUB, CPUAO, CPUMO, CPUI,
     *                 WALL,WALL0,WALLB,WALLAO,WALLMO,WALLI,TIM
      COMMON /TIMING/ CPU,WALL
C
C  MEMORY MANAGEMENT AND POINTER VARIABLES
C
      INTEGER LOADFM,LAST,NEED,LFH,LFP,LFPH,TOTAL_MEM
      INTEGER LVR,LVE,LTMP1,LTMP,LVL,LRL,LVM,LREST,BUFSIZE
C
C
C  DDI IDENTIFIERS
C
      INTEGER DDI_NP,DDI_ME,DDI_NN,DDI_MY,SMP_NP,SMP_ME
C
C
C  INTEGRAL SIZES
C
      INTEGER NO2,NO3,NO4,NU2,NU3,NOU,NO2U,NOU2,NO2U2,NUTR,NO3U
C
C
C  LOOP VARIABLES AND POINTER OFFSETS
C
      INTEGER I,J,ILO,IHI,JLO,JHI,IOFF,JOFF,JOF1,IOF1,ROW,COL,IOF2
      INTEGER NR,SR,SMPOFF,RLOFF,SR1,NR1
C
      DOUBLE PRECISION ZERO,ONE,TWO,ONEM,HALF,TEN
      LOGICAL P_TIME
      DOUBLE PRECISION ZZ,ENRGOLD,TRESH
      DOUBLE PRECISION T1NORM,T2NORM
      INTEGER IMAX,III,IDMY,A,B,K,NGOTMX
      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00,ONEM=-1.0D+00)
      PARAMETER(HALF=0.5D+00,TEN=10.0D+00)
C
      DATA CHECK/8HCHECK   /
      DATA LCCD,CCD/2*.FALSE./
C
      IF(MASWRK) WRITE(6,*) 'RUNNING NODE-BASED CCSD ITERATIONS'
      P_TIME = .FALSE.
C
      NO2   = NO*NO
      NO3   = NO*NO2
      NO3U  = NO3*NU
      NO4   = NO*NO3
      NU2   = NU*NU
      NU3   = NU*NU2
      NOU   = NO*NU
      NO2U  = NO2*NU
      NOU2  = NO*NU2
      NO2U2 = NOU*NOU
      NUTR  = (NU2+NU)/2
C
      TRESH = TEN**(-ICONV)
      CNVR = .FALSE.
      LCCD = MET.EQ.0
      CCD = MET.EQ.1
C
C ------------------------------------------------------
C GET IDENTITY
C ------------------------------------------------------
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_NNODE(DDI_NN,DDI_MY)
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
C
C ------------------------------------------------------
C GET MEMORY FOR THE FH, FP, AND FPH WORKING ARRAYS
C THE FAST MEMORY WORKING ARRAYS ARE USED FOR ALL
C CALCULATIONS.  THE PARAMETERS PASSED IN ARE USED
C TO START THE WORKING COPIES PROPERLY EACH ITERATION
C THE LREST ALLOCATION IS FOR TEMPORARY MEMORY USED
C DURING THE ITERATIONS
C ------------------------------------------------------
C
      TOTAL_MEM = 0
      CALL GOTFM(NGOTMX)
C
C     N.B.: IF YOU CHANGE THIS, YOU MUST ALSO CHANGE THE "CHECK" MEMORY.
C
      CALL VALFM(LOADFM)
      LFH   = LOADFM + 1
      LFP   = LFH    + NO2
      LFPH  = LFP    + NU2
      LREST = LFPH   + NOU
      LAST  = LREST  + MAX(NOU+NOU2,3*NOU,NOU2+NUTR,NO2U)
      NEED = LAST - LOADFM - 1
C
      IF(NEED.GT.NGOTMX) THEN
        IF(MASWRK) THEN
          WRITE(6,99) NEED, NGOTMX
          CALL ABRT
        END IF
      END IF
C
      CALL GETFM(NEED)
C
      TOTAL_MEM = NEED
C
      IF(EXETYP.EQ.CHECK) CNVR=.TRUE.
      IF(EXETYP.EQ.CHECK) GO TO 2000
C
      IF(IREST.EQ.0.OR.MET.LT.2) THEN
        CALL ZEROMA(O1,1,NOU)
        IF(MASWRK) CALL WO1(1,NO,NU,O1)
        IF(MASWRK) CALL WO1(2,NO,NU,O1)
      END IF
C
      IF(IREST.EQ.0) THEN
      IF(MASWRK) CALL WO2(1,NO,NU,O2)
      EMP2 = MP2ENERGY
      ENRGOLD = EMP2
      ITER = 0
      END IF
      ITRLE = 0
C
 1000 CONTINUE
C
C         START CLOCKS.  SEE COMMENTS IN CCSD_DDI_PROC
C
      CALL TSECND(TIM)
      CPU0  = CPU
      WALL0 = WALL
C
      CALL ZEROMA_SMP(T2,1,NO2U2)
C
      ITER = ITER + 1
      ITRLE = ITRLE + 1
      IF(MASWRK) THEN
        IF(ITER.NE.1) CALL RO2(1,NO,NU,O2)
        CALL CCSD_RDVM(NO,NU,VM,RL)
        IF(ITER.NE.1) CALL RO1(1,NO,NU,O1)
      END IF
C
C  BROADCASTING THE STARTING VALUES OF SOME BUFFERS
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_BCAST(102,'F',O2,NO2U2,0)
        CALL DDI_MASTERS_BCAST(103,'F',VM,NO3U,0)
      END IF
C
      CALL DDI_SMP_SYNC()
C
      CALL DDI_BCAST(101,'F',O1,NOU,0)
C
      CALL DDI_SYNC(1234)
C
C        WE CAN RETURN ALMOST ALL OF THE MEMORY NOW, SO THAT THE
C        FOUR VIRTUAL TERM CAN REUSE IT.  AFTER THE FOUR VIRTUAL
C        TERM, GRAB THE MEMORY AGAIN FOR THIS ROUTINE'S PURPOSES.
C     N.B.: IF YOU CHANGE THIS, YOU MUST ALSO CHANGE THE "CHECK" MEMORY.
C
      CALL RETFM(TOTAL_MEM-NOU-NU2-NO2)
      CALL DDI_TIMER_RESET()
C
      CALL TSECND(TIM)
      CPUB  = CPU  - CPU0
      WALLB = WALL - WALL0
      CPU0  = CPU
      WALL0 = WALL
C
      CALL CCSD_VVVV(NO,NU,O1,O2,T2,ITER)
C
      CALL GETFM(TOTAL_MEM-NOU-NU2-NO2)
C      CALL DDI_TIMER_OUTPUT()
      CALL DDI_TIMER_RESET()
      CALL DDI_SYNC(2345)
C
      CALL TSECND(TIM)
      CPUAO  = CPU  - CPU0
      WALLAO = WALL - WALL0
      CPU0  = CPU
      WALL0 = WALL
C
      IF(MASWRK) THEN
C---        WRITE(6,*) '...DONE WITH NODE-BASED CCSD ITERATION...'
C---        CALL TIMIT(1)
        CALL DCOPY(NO2,FH,1,X(LFH),1)
        CALL DCOPY(NU2,FP,1,X(LFP),1)
        CALL DCOPY(NOU,FPH,1,X(LFPH),1)
        CALL DCOPY(NOU,FPH,1,T1,1)
      ELSE
        CALL ZEROMA(X(LFH),1,NO2)
        CALL ZEROMA(X(LFP),1,NU2)
        CALL ZEROMA(X(LFPH),1,NOU)
        CALL ZEROMA(T1,1,NOU)
      END IF
C
C --------------------------------------------------------------------
C VR(I,A|B,J) X O1(NOU,1) += FPH(NOU,1)
C ACTUALLY CARRIED OUT USING A DAXPY CALL WHERE THE ITH COLUMN
C OF VR IS MULTIPLIED BY THE ITH ELEMENT OF O1 AND ACCUMULATED INTO
C FPH
C --------------------------------------------------------------------
      LVR  = LREST
      LAST = LVR + NOU
      NEED = LAST - LREST - 1
C
      CALL TRT1(NO,NU,X(LVR),O1)
C
C-----CALL CHECK_CHKSUM(1,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(1)
C
      CALL DDI_DISTRIB(D_VR,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
         CALL DDI_GET(D_VR_SYM,ILO,IHI,J,J,X(LVR))
         CALL DAXPY(NOU,O1(J),X(LVR),1,X(LFPH),1)
      END DO
C
C-----CALL CHECK_CHKSUM(2,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(2)
C
      CALL TRT1(NO,NU,X(LVR),X(LFPH))
C
      LVR  = -1
      LAST =  -1
      NEED = -1
C
C --------------------------------------------------------------
C VPP(C,B,A|I) X O1(NU,NO) += FP(NU2,1) : DGEMM = OU3, MEM = NU3
C --------------------------------------------------------------
      LTMP1 = LREST
      LAST = LTMP1 + NU2
      NEED = LAST - LREST - 1
C
      CALL DIV_EVEN(NO,DDI_NN,DDI_MY,NR,SR)
C
C     J LOOP IS 0-BASED, NOT 1-BASED
      JLO = SR - 1
      JHI = SR + NR - 2
      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NR,SR)
C
      DO J = JLO, JHI
        JOFF = NU*J + 1
        IF(SMP_ME.EQ.0) THEN
          CALL DDCC_T_GETVE(NU,J+1,X(LTMP1),SMP_TEMP)
        END IF
        CALL SYMT21_SMP(SMP_TEMP,NU,NU,NU,1,13)
        CALL DGEMM('N','N',NR,1,NU,ONE,SMP_TEMP(SR),NU2,O1(JOFF),NOU,
     *             ONE,X(LFP+SR-1),NU2)
        CALL DDI_SMP_SYNC()
C
      ENDDO
C
      LVE = -1
      LTMP1 = -1
      LAST = -1
      NEED = - 1
C
C-----CALL CHECK_CHKSUM(3,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(3)
C
C -----------------------------------
C FPH X O1 += FP - OU2 ==> REPLICATED
C -----------------------------------
      CALL DGEMM('N','T',NU,NU,NO,ONEM,X(LFPH),NU,O1,NU,ONE,X(LFP),NU)
C
C-----CALL CHECK_CHKSUM(4,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(4)
C
C --------------------------------------------------------------------
C VR(AT,I,BT|J) X O2(J,B,I,A) += FP(NU,NU) : DGEMM = O2U3, MEM = 2*OU2
C --------------------------------------------------------------------
      LVR = LREST
      LTMP = LVR + NOU
      LAST = LTMP + NOU2
      NEED = LAST - LREST - 1
C
C
      CALL TRANSQ_SMP(O2,NOU)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),O2,12)
      CALL SYMT21_SMP(O2,NO,NU,NO,NU,13)
C
      CALL DDI_DISTRIB(D_VR_IBT,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
         JOFF = NO*(J-1) + 1
         CALL DDI_GET(D_VR_IBT,ILO,IHI,J,J,X(LVR))
         CALL DGEMM('N','N',NU,NU,NO,ONEM,X(LVR),NU,O2(JOFF),NO2U,
     *               ONE,X(LFP),NU)
      END DO
C
C-----CALL CHECK_CHKSUM(5,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(5)
C
      CALL DESM21_SMP(O2,NO,NU,NO,NU,13)
      CALL INSITU_SMP(NO,NU,NO,NU,X(LTMP),O2,12)
      CALL TRANSQ_SMP(O2,NOU)
C
      LVR = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C
C ------------------------------------------------------------
C VM(I,J,K,A) X O1(NO,NU) += FH(NO2,1) : DGEMM = O3U, MEM = OU
C ------------------------------------------------------------
      LTMP = LREST
      LAST = LTMP + NOU
      NEED = LAST - LREST - 1
C
      CALL TRT1(NU,NO,X(LTMP),O1)
      CALL SYMT21_SMP(VM,NO,NO,NO,NU,13)
C
C
      DO 1 J = 1, NU
        IF(MOD(J,DDI_NP).NE.DDI_ME) GOTO 1
        IOF1 = NO*(J-1) + 1
        IOFF = NO3*(J-1) + 1
        CALL DGEMM('N','N',NO2,1,NO,ONE,VM(IOFF),NO2,O1(IOF1),NO,
     *             ONE,X(LFH),NO2)
    1 CONTINUE
C
C-----CALL CHECK_CHKSUM(6,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(6)
C
      CALL DESM21_SMP(VM,NO,NO,NO,NU,13)
      CALL TRANSQ(X(LFH),NO)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ------------------------------------------------------------------
C O2(I,A,B,J) X VR(A,B,IT,JT) += FH(NO,NO) : DGEMM = O2U3, MEM = OU2
C ------------------------------------------------------------------
      LVR = LREST
      LAST = LVR + NU2
      NEED = LAST - LREST - 1
C
      CALL SYMT21_SMP(O2,NO,NU,NU,NO,23)
C
      CALL DDI_DISTRIB(D_VR_BIT,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
         ROW = (J-1) / NO
         COL = MOD((J-1),NO)
C
         JOFF = COL*NOU2 + 1
         JOF1 = ROW*NO
C
         CALL DDI_GET(D_VR_BIT,ILO,IHI,J,J,X(LVR))
         CALL DGEMM('N','N',NO,1,NU2,ONE,O2(JOFF),NO,
     *               X(LVR),NU2,ONE,X(LFH+JOF1),NO)
C
      END DO
C
C-----CALL CHECK_CHKSUM(7,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(7)
C
      CALL DESM21_SMP(O2,NO,NU,NU,NO,23)
C
      LVR = -1
      LAST = -1
      NEED = -1
C
C -----------------------------------
C  O1 X FP += T1 - OV2 ==> REPLICATED
C -FH X O1 += T1 - O2V ==> REPLICATED
C -----------------------------------
      CALL DGEMM('N','N',NO,NU,NU,ONE,O1,NO,X(LFP),NU,ONE,T1,NO)
      CALL DGEMM('N','N',NO,NU,NO,ONEM,X(LFH),NO,O1,NO,ONE,T1,NO)
C
C-----CALL CHECK_CHKSUM(8,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(8)
C
C --------------------------------------------------
C O2 X FPH += T1 - O2V2 ==> REPLICATED AT THE MOMENT
C --------------------------------------------------
      CALL SYMT21_SMP(O2,NO,NU,NU,NO,14)
C             O(O2V2) BUST IT L8R
      CALL DGEMM('N','N',NOU,1,NOU,ONE,O2,NOU,X(LFPH),NOU,ONE,T1,NOU)
C
C-----CALL CHECK_CHKSUM(9,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(9)
C
      CALL DESM21_SMP(O2,NO,NU,NU,NO,14)
C
C ----------------------------------------------------------------
C VR(A,I,B|J) = 2*VR(A,I,B|J) - VL(A,I,B|J)
C O1(1,NOU) X VR(A,I,B|J) += T1(NU,NO) : DGEMM = O2U2, MEM = 3*OU2
C ----------------------------------------------------------------
C
      LVR = LREST
      LVL = LVR   + NOU
      LTMP = LVL   + NOU
      LAST = LTMP   + NOU
      NEED = LAST - LREST - 1
C
      CALL TRT1(NO,NU,X(LTMP),T1)
      CALL TRT1(NO,NU,X(LTMP),O1)
C
      CALL DDI_DISTRIB(D_VR,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
C
        CALL DDI_GET(D_VR,ILO,IHI,J,J,X(LVR))
        CALL INSITU(NO,NU,1,1,X(LTMP),X(LVR),12)
C
        CALL DDI_GET(D_VL,ILO,IHI,J,J,X(LVL))
        CALL INSITU(NO,NU,1,1,X(LTMP),X(LVL),12)
C
        CALL DSCAL(NOU,TWO,X(LVR),1)
        CALL DAXPY(NOU,ONEM,X(LVL),1,X(LVR),1)
C
        T1(J) = T1(J) + DDOT(NOU,O1,1,X(LVR),1)
C
      END DO
C
C-----CALL CHECK_CHKSUM(10,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(10)
C
      LVR = -1
      LVL = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------------------------------------------- 11
C VPP(AXB,C|I) X O2(BXA,I,J) += T1(NU,NO) : DGEMM = O2U3, MEM = NU3
C -----------------------------------------------------------------
      LVE = LREST
      LTMP1 = LVE + NOU2
      LAST = LTMP1   + NUTR
      NEED = LAST - LREST - 1
C
C            USE LVE AS TEMP ARRAY
      CALL INSITU_SMP(NO,NU,NU,NO,X(LVE),O2,13)
C            O2(B,A,I,J) W/ B,A MODIFIED
      CALL SYMT21_SMP(O2,NU,NU,NO,NO,12)
C
      CALL DDI_DISTRIB(D_VVVO,DDI_ME,ILO,IHI,JLO,JHI)
      DO J = JLO, JHI
        JOFF = NU*(J-1) + 1
        CALL DDI_GET(D_VVVO,1,NUTR,J,J,X(LTMP1))
        CALL CPYTSQ(X(LTMP1),X(LVE),NU,1)
        CALL DGEMM('N','N',NU,NO,NU,ONE,X(LVE),NU,O2(JOFF),NOU2,
     *             ONE,T1,NU)
      END DO
C
C-----CALL CHECK_CHKSUM(11,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(11)
C
      LVE = -1
      LTMP1 = -1
      LAST = -1
      NEED = -1
C
C -----------------------------------------------------------------
C -VM(IXJ,K,A) X O2(I,J,BXA) += T1(NO,NU) : DGEMM = O3U2, MEM = OU2
C -----------------------------------------------------------------
C
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL TRT1(NU,NO,X(LTMP),T1)
C
C            O2(B,A,I,J) -> O2(I,A,B,J)
      CALL INSITU_SMP(NU,NU,NO,NO,X(LTMP),O2,13)
C            O2(I,A,B,J) -> O2(B,J,I,A)
      CALL TRANSQ_SMP(O2,NOU)
C            O2(B,J,I,A) -> O2(I,J,B,A)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),O2,13)
C
      DO 2 J = 1, NU
        IF(MOD(J,DDI_NP).NE.DDI_ME) GOTO 2
        IOF1 = NO*(J-1) + 1
        IOFF = NO2U*(J-1) + 1
        CALL DGEMM('N','N',NO,1,NO2U,ONEM,VM,NO,O2(IOFF),NO2U,
     *             ONE,T1(IOF1),NO)
    2 CONTINUE
C
C-----CALL CHECK_CHKSUM(12,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(12)
C
      CALL DESM21_SMP(O2,NO,NO,NU,NU,12)
      CALL INSITU_SMP(NO,NO,NU,NU,X(LTMP),O2,13)
      CALL TRANSQ_SMP(O2,NOU)
C
      CALL TRT1(NU,NO,X(LTMP),O1)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C -------------------------------------------
C MODIFY T1 WITH EH AND EP
C -------------------------------------------
      CALL DDI_GSUMF(202,T1,NOU)
      IF(MASWRK)    CALL ADDDEN1(NO,NU,T1,OEH,OEP)
      IF(ITER.LE.3) CALL ZEROMA(T1,1,NOU)
      IF(MASWRK)    CALL WO1(2,NO,NU,T1)
C
C ---------------------------------------
C O1 X FPH += FH : DGEMM = O2U, MEM = NO,
C    REPLICATED SINCE FPH IS PARTIAL
C ---------------------------------------
      LTMP = LREST
      LAST = LTMP   + NOU
      NEED = LAST - LREST - 1
C
      CALL TRT1(NU,NO,X(LTMP),X(LFPH))
C
      CALL DGEMM('N','T',NO,NO,NU,ONE,O1,NO,X(LFPH),NO,ONE,X(LFH),NO)
      IF(DDI_ME.NE.0) CALL DCOPY(NOU,ZERO,0,T1,1)
C
C-----CALL CHECK_CHKSUM(13,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(13)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C -------------------------------------------------------------- 14
C O2(I,A,B,J) X FH(NO,NO) += T2(NOU2,NO) : DGEMM = O3U2, MEM = 0
C --------------------------------------------------------------
C LAST TIME FH USED; SUM IT TO MAKE NEXT DGEMM FASTER
      CALL DDI_GSUMF(1234,X(LFH),NO2)
      CALL DDI_SMP_SYNC()
      CALL DIV_EVEN(NOU2,DDI_NP,DDI_ME,NR,SR)
      CALL DGEMM('N','T',NR,NO,NO,ONEM,O2(SR),NOU2,X(LFH),NO,
     *           ONE,T2(SR),NOU2)
C
C     JUST USED TO SET THE VALUES PROPERLY FOR THE CHECKSUM
      CALL DDI_SMP_SYNC()
C
      IF(DDI_ME.NE.0) CALL DCOPY(NO2,ZERO,0,X(LFH),1)
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(500,T2,NO2U2)
C
      CALL DDI_SMP_SYNC()
C      CALL DDI_TIMER_OUTPUT()
      CALL DDI_TIMER_RESET()
      IF(DDI_MY.NE.0) CALL ZEROMA_SMP(T2,1,NO2U2)
C
C-----CALL CHECK_CHKSUM(14,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(14)
C
C ---------------------------------------------------------------- 15
C O2(B,J,I,A) X FP(NU,NU) += T2(B,J,I,A) : DGEMM = O2U3, MEM = O2U
C ----------------------------------------------------------------
      LTMP = LREST
      LAST = LTMP   + NO2U
      NEED = LAST - LREST - 1
C
      CALL TRANSQ_SMP(T2,NOU)                     ! (I,A,B,J)->(B,J,I,A)
      CALL TRANSQ_SMP(O2,NOU)                     ! (I,A,B,J)->(B,J,I,A)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),T2,12)  ! (B,J,I,A)->(J,B,I,A)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),O2,12)  ! (B,J,I,A)->(J,B,I,A)
C
C         LAST TIME FP USED; SUM IT TO AVOID REP. DGEMM
C
      CALL DDI_GSUMF(1234,X(LFP),NU2)
      CALL DDI_SMP_SYNC()
      CALL DIV_EVEN(NO2U,DDI_NP,DDI_ME,NR,SR)
      CALL DGEMM('N','N',NR,NU,NU,ONE,O2(SR),NO2U,X(LFP),NU,
     *           ONE,T2(SR),NO2U)
C
      CALL DDI_SMP_SYNC()
C USED FOR GETTING CORRECT CHECKSUMS
      IF(DDI_ME.NE.0) CALL DCOPY(NU2,ZERO,0,X(LFP),1)
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(500,T2,NO2U2)
      CALL DDI_SMP_SYNC()
      IF(DDI_MY.NE.0) CALL ZEROMA_SMP(T2,1,NO2U2)
C
C-----CALL CHECK_CHKSUM(15,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(15)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ---------------------------------------------------------
C O2(J,I,B,A) X VR(A,B,I,J) = O4_T(NO2,NO2) : DGEMM = O4U2,
C ---------------------------------------------------------
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL DDI_SMP_SYNC()
      CALL ZEROMA_SMP(RL,1,NO2U2)
      CALL INSITU_SMP(NO,NU,NO,NU,X(LTMP),O2,23)
C
C     IF(SMP_ME.EQ.0) CALL ADT12(1,NO,NU,O1,O2,3)
      CALL ADT12_3_SMP(1,NO,NU,O1,O2)
      CALL DDI_SMP_SYNC()
C
      CALL DDI_NDISTRIB(D_VR_BI,DDI_MY,ILO,IHI,JLO,JHI)
C
      IOFF = NO2*(JLO-1) + 1
      NR = NO2*(JHI-JLO+1)
      IF(SMP_ME.EQ.0) THEN
        CALL DCOPY(NR,O4(IOFF),1,RL(IOFF),1)
        CALL DDI_GET(D_VR_BI,ILO,IHI,JLO,JHI,SMP_TEMP)
      END IF
      CALL DDI_SMP_SYNC()
      CALL DIV_EVEN(NO2,SMP_NP,SMP_ME,NR,SR)
      IOFF = IOFF + SR - 1
      CALL DGEMM('N','N',NR,(JHI-JLO+1),NU2,ONE,O2(SR),NO2,
     *     SMP_TEMP,NU2,ONE,RL(IOFF),NO2)
C
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(500,RL,NO4)
C
C-----CALL CHECK_CHKSUM(16,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(16)
C
      LVR = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C --------------------------------------
C TWEAK O4/RL AROUND
C --------------------------------------
      CALL MTRANS_SMP(RL,NO,11)
      CALL DSCAL_SMP(NO4,HALF,RL,1)
C
C --------------------------------------------------------------- ! 17
C VM(I,J,K,A) X O1(NU,NO) += O4_T(L,J,K,I) : DGEMM = O4U, MEM = 0 !
C O4_T IS NEEDED IN THE LHS OF THE NEXT O4U2 DGEMM, SO THIS MXM   !
C MUST BE REPLICATED PER NODE ==> A COMPLETE O4_T IS ON EACH NODE !
C --------------------------------------------------------------- !
      CALL DIV_EVEN(NO3,SMP_NP,SMP_ME,NR,SR)
      CALL DGEMM('N','T',NR,NO,NU,ONE,VM(SR),NO3,O1,NO,ONE,RL(SR),NO3)
C
      CALL DDI_SMP_SYNC()
C
      IF(SMP_ME.EQ.0) CALL SYMV1(RL,NO2)
      CALL MTRANS_SMP(RL,NO,23)
C
C-------------------------------------------------------------------- 18
C O4(NO2,NO2) X 1/2 O2(JT,IT,B,A) += T2(?,?,?,?) : DGEMM = O3U3,MEM=O2U
C--------------------------------------------------------------------
      LTMP = LREST
      LAST = LTMP + NOU2
      NEED = LAST - LREST
C
      CALL TRANMD_SMP(O2,NO,NO,NU,NU,12)
      CALL INSITU_SMP(NO,NU,NO,NU,X(LTMP),T2,12)
      CALL INSITU_SMP(NU,NO,NO,NU,X(LTMP),T2,13)
      CALL DSCAL_SMP(NO2U2,HALF,O2,1)
C
      CALL DIV_EVEN(NO2,DDI_NP,DDI_ME,NR,SR)
      CALL DDI_SMP_SYNC()
      CALL DGEMM('N','N',NR,NU2,NO2,ONE,RL(SR),NO2,O2,NO2,
     *           ONE,T2(SR),NO2)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(500,T2,NO2U2)
      CALL DDI_SMP_SYNC()
      IF(DDI_MY.NE.0) CALL ZEROMA_SMP(T2,1,NO2U2)
      CALL DDI_SYNC(1234)
C
C-----CALL CHECK_CHKSUM(17,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(17)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ---------------
C VVVV TERMS
C ---------------
C      CALL DDI_SMP_SYNC()
C      IF(MASWRK) THEN
C      DO I = 1, NU
C      CALL RO2(140+I,NO,NU,JONTEST)
C      CALL DGEMM('N','N',NO2,NU,NU2,ONE,O2,NO2,JONTEST,NU2,ONE,
C     &           T2( (I-1)*NO2U + 1 ),NO2)
C      ENDDO
C      ENDIF
C      CALL DDI_SMP_SYNC()
C      CALL CCSD_VVVV(NO,NU,O1,O2,T2,ITER)
CC
CC-----CALL CHECK_CHKSUM(18,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
C      IF(P_TIME) CALL PRINT_TIM(18)
C      IF(MASWRK) THEN
C        CALL TIMIT(1)
C        WRITE(6,*) 'CHKSUM 18'
C      END IF
C      GOTO 2000
C      CALL DDI_SMP_SYNC()
C
C
C ----------------------------------------------------------------------
C -VR(AT,I,BT,J) X 1/2 O12(B,I,A,J) + VL(AT,I,BT,J) = RL : DGEMM = O3U3,
C  REPLICATED = NOU2, SHARED MEM = NOU*BUFSIZE + NO2U2
C ----------------------------------------------------------------------
C
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      BUFSIZE = MIN(20,NU)
C
      CALL DDI_SMP_SYNC()
      CALL DSCAL_SMP(NO2U2,TWO,O2,1)
C      IF(SMP_ME.EQ.0) THEN
C        IF(.NOT.CCD) CALL ADT12(2,NO,NU,O1,O2,2)
C      END IF
      CALL ADT12_2_SMP(2,NO,NU,O1,O2)
C
      CALL INSITU_SMP(NO,NO,NU,NU,X(LTMP),O2,13)
      CALL TRANSQ_SMP(O2,NOU)
      CALL INSITU_SMP(NO,NU,NU,NO,X(LTMP),O2,12)
      CALL TRANMD_SMP(O2,NU,NO,NU,NO,24)
C
      CALL DSCAL_SMP(NO2U2,HALF,O2,1)
C     IF(SMP_ME.EQ.0) THEN
C       IF(.NOT.CCD) CALL ADT12(1,NO,NU,O1,O2,4)
C     END IF
      CALL ADT12_4_SMP(1,NO,NU,O1,O2)
C
      CALL ZEROMA_SMP(RL,1,NO2U2) ! MAKE SMP
      CALL ZEROMA_SMP(SMP_TEMP(NOU*BUFSIZE+1),1,NO2U2)
C
      CALL DDI_NDISTRIB(D_VL_IBT,DDI_MY,ILO,IHI,JLO,JHI)
C
      JOFF = (JLO-1)*NOU
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_GET(D_VL_IBT,ILO,IHI,JLO,JHI,
     *               SMP_TEMP(NOU*BUFSIZE+JOFF+1))
      END IF
      CALL DDI_NDISTRIB(D_VR_IBT,DDI_MY,ILO,IHI,JLO,JHI)
C
      JOFF = JHI-JLO + 1
C
      DO WHILE(JOFF.GT.0)
        NR1 = MIN(JOFF,BUFSIZE)
        IF(SMP_ME.EQ.0) THEN
          CALL DDI_GET(D_VR_IBT,ILO,IHI,JLO,JLO+NR1-1,SMP_TEMP)
        END IF
        CALL DDI_SMP_SYNC()
C
        CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NR,SR)
        SMPOFF = NOU*BUFSIZE + (SR-1)*NOU + 1
        IOF1 = JLO + (SR-1)*NOU
C
        CALL DGEMM('N','N',NOU,NR,NR1,ONEM,SMP_TEMP,NOU,
     *            O2(IOF1),NOU,ONE,
     *            SMP_TEMP(SMPOFF),NOU)
C
      CALL DDI_SMP_SYNC()
      JOFF = JOFF - NR1
      JLO = JLO + NR1
      END DO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_GSUMF(500,SMP_TEMP(NOU*BUFSIZE+1),NO2U2)
      END IF
      CALL DDI_SMP_SYNC()
      CALL DIV_EVEN(NO2U2,SMP_NP,SMP_ME,NR,SR)
      CALL DCOPY(NR,SMP_TEMP(NOU*BUFSIZE+SR),1,RL(SR),1)
C
C-----CALL CHECK_CHKSUM(19,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(19)
C
C MORE WORK HERE IF IN PARALLEL AND IF CCD
C
      CALL DDI_SMP_SYNC()
C     IF(SMP_ME.EQ.0) THEN
C       IF(.NOT.CCD) CALL ADT12(2,NO,NU,O1,O2,4)
C     END IF
      CALL ADT12_4_SMP(2,NO,NU,O1,O2)
C        CALL VECMUL(O2,NO2U2,TWO)
      CALL DSCAL_SMP(NO2U2,TWO,O2,1)
C
      LVR = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ---------------------------------------------- 21
C O1 X VM += VL
C ----------------------------------------------
C
      LTMP = LREST
      LAST = LTMP + NOU2
      NEED = LAST - LREST
C
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,13)
      CALL INSITU_SMP(NU,NO,NU,NO,X(LTMP),RL,12)
      CALL TRANMD_SMP(RL,NO,NU,NU,NO,14)
      CALL TRANSQ_SMP(RL,NOU)
C
      CALL DIV_EVEN(NO2U,SMP_NP,SMP_ME,NR,SR)
      IOFF = (SR-1)*NO + 1
      JOFF = (SR-1)*NU + 1
      CALL DGEMM('T','N',NU,NR,NO,ONEM,O1,NO,VM(IOFF),NO,
     *           ONE,RL(JOFF),NU)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO2U2,ZERO,0,RL,1)
      END IF
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,13)
      CALL TRANSQ_SMP(RL,NOU)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C --------------------------------------------- 22
C O1 X VE(C,B,A,I) += VL
C ---------------------------------------------
      LTMP = LREST
      LAST = LTMP + NU2
      NEED = LAST - LREST - 1
C
      CALL DDI_NDISTRIB(D_VVVO,DDI_MY,ILO,IHI,JLO,JHI)
      CALL DIV_EVEN(NO,DDI_NN,DDI_MY,NR,SR)
C     0-BASED DO LOOP INDEX
C   REQUIRED TO USE NU3 OF VVVO INTEGRALS BECAUSE OF THE TRANMD(13) CALL
      JLO = SR
      JHI = SR + NR - 1
      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NR,SR)
      DO J = JLO, JHI
        JOFF = (J-1)*NOU2 + 1
        IF(SMP_ME.EQ.0) THEN
          CALL DDCC_T_GETVE(NU,J,X(LTMP),SMP_TEMP)
        END IF
        SMPOFF = (SR-1)*NU + 1
        RLOFF = JOFF + (SR-1)*NO
        CALL TRANMD_SMP(SMP_TEMP,NU,NU,NU,1,13)
        CALL DGEMM('N','N',NO,NR,NU,ONE,O1,NO,SMP_TEMP(SMPOFF),NU,
     *             ONE,RL(RLOFF),NO)
        CALL DDI_SMP_SYNC()
      ENDDO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(300,RL,NO2U2)
C
C-----CALL CHECK_CHKSUM(20,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(20)
C
      LVE = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C -------------------------------- 23A & 23B
C O2 X VL += T2
C --------------------------------
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
C
      CALL INSITU_SMP(NO,NU,NU,NO,X(LTMP),RL,12) ! TRMD 26
      CALL TRANMD_SMP(RL,NU,NO,NU,NO,24)         ! TRMD 26
C
      CALL TRANMD_SMP(O2,NU,NO,NU,NO,24)         ! TRMD 27
      CALL INSITU_SMP(NU,NO,NU,NO,X(LTMP),O2,12) ! TRMD 27
      CALL TRANMD_SMP(O2,NO,NU,NU,NO,23)         ! TRMD 27
C
      CALL INSITU_SMP(NO,NO,NU,NU,X(LTMP),T2,13) ! TRMD 28
      CALL TRANSQ_SMP(T2,NOU)                    ! TRMD 28
      CALL TRANMD_SMP(T2,NO,NU,NU,NO,23)         ! TRMD 28
C
      CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NR,SR)
      IOFF = (SR-1)*NOU + 1
C
      CALL DGEMM('N','N',NOU,NR,NOU,ONEM,O2,NOU,RL(IOFF),NOU,
     &           ONE,T2(IOFF),NOU)
C
      CALL TRANMD_SMP(O2,NO,NU,NU,NO,23)
      CALL TRANMD_SMP(T2,NO,NU,NU,NO,23)
C
      CALL DGEMM('N','N',NOU,NR,NOU,ONEM,O2,NOU,RL(IOFF),NOU,
     &           ONE,T2(IOFF),NOU)
C
C-----CALL CHECK_CHKSUM(21,NO,NU,O1,RL,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(21)
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C
C -------------------------------------- 24A AND 24B
C VR X O2 = VL REPLICATED MEMORY=NOU2, SHARED MEMORY=NOU2+NO2U2
C --------------------------------------
      LTMP1 = LREST
      LAST = LTMP1  + NOU2
      NEED = LAST - LREST -1
C
C
C HAVE TO CHOOSE THE MIN IN CASE NU IS LESS THAN 20
C
C
      BUFSIZE = MIN(20,NU)
C
      CALL ZEROMA_SMP(RL,1,NO2U2)
C
      CALL INSITU_SMP(NO,NU,NU,NO,X(LTMP1),O2,12)
      CALL DSCAL_SMP(NO2U2,HALF,O2,1)
C
      CALL DIV_EVEN(NO,DDI_NN,DDI_MY,NR,SR)
      CALL ZEROMA_SMP(SMP_TEMP(NOU2+1),1,NO2U2)
C
C     0-BASED INDEX
      JLO = SR - 1
      JHI = SR + NR - 2
      CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NR,SR)
C
      DO J = JLO, JHI
        JOFF = J*NU + 1
        IOFF = 1
C
        IF(SMP_ME.EQ.0) THEN
          DO I = J*NU, (J*NU+NU-1)
            CALL DDI_GET(D_VR,1,NOU,I+1,I+1,SMP_TEMP(IOFF))
            IOFF = IOFF + NOU
          END DO
        END IF
C
        JOFF = JOFF + (SR-1)*NOU
        SMPOFF = NOU2 + 1 + (SR-1)*NOU
        CALL INSITU_SMP(NO,NU,NU,1,X(LTMP1),SMP_TEMP,12)
        CALL SYMT21_SMP(SMP_TEMP,NU,NO,NU,1,13)
        CALL DGEMM('N','N',NOU,NR,NU,ONE,SMP_TEMP,NOU,O2(JOFF),NOU,
     *             ONE,SMP_TEMP(SMPOFF),NOU)
        CALL DDI_SMP_SYNC()
      END DO
C
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_GSUMF(201,SMP_TEMP(NOU2+1),NO2U2)
        CALL DAXPY(NO2U2,ONE,SMP_TEMP(NOU2+1),1,RL,1)
      END IF
C
C-----CALL CHECK_CHKSUM(22,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(22)
C
      CALL TRANMD_SMP(O2,NU,NO,NU,NO,13)
C     IF(SMP_ME.EQ.0) CALL ADT12(1,NO,NU,O1,O2,5)
      CALL ADT12_5_SMP(1,NO,NU,O1,O2)
C      CALL DDI_SMP_SYNC()
C
      CALL ZEROMA_SMP(SMP_TEMP(NOU2+1),1,NO2U2)
C
      CALL DDI_NDISTRIB(D_VR,DDI_MY,ILO,IHI,JLO,JHI)
C
      IOFF = JHI-JLO + 1
C
      DO WHILE(IOFF.GT.0)
        NR = MIN(IOFF,BUFSIZE)
        IF(SMP_ME.EQ.0) THEN
          JOFF = 1
          DO J = JLO,JLO+NR-1
            CALL DDI_GET(D_VR,ILO,IHI,J,J,SMP_TEMP(JOFF))
            CALL INSITU(NO,NU,1,1,X(LTMP1),SMP_TEMP(JOFF),12)
            JOFF = JOFF + NOU
          END DO
        END IF
        CALL DDI_SMP_SYNC()
C
        CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NR1,SR1)
        SMPOFF = NOU2 + (SR1-1)*NOU + 1
        JOFF = JLO + (SR1-1)*NOU
        CALL DGEMM('N','N',NOU,NR1,NR,ONEM,SMP_TEMP,NOU,O2(JOFF),NOU,
     *             ONE,SMP_TEMP(SMPOFF),NOU)
        CALL DDI_SMP_SYNC()
        IOFF = IOFF - NR
        JLO = JLO + NR
      END DO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_GSUMF(201,SMP_TEMP(NOU2+1),NO2U2)
        CALL DAXPY(NO2U2,ONE,SMP_TEMP(NOU2+1),1,RL,1)
      END IF
C
      CALL DDI_SMP_SYNC()
C
C-----CALL CHECK_CHKSUM(23,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(23)
C
C     IF(SMP_ME.EQ.0) CALL ADT12(2,NO,NU,O1,O2,5)
      CALL ADT12_5_SMP(2,NO,NU,O1,O2)
      CALL DSCAL_SMP(NO2U2,TWO,O2,1)
C
      LVR = -1
      LTMP = -1
      LTMP1= -1
      LAST = -1
      NEED = -1
C
C ----------------------------- 25
C O1 X VE += VL
C -----------------------------
      LVE = LREST
      LTMP = LVE  + NOU2
      LAST = LTMP + NUTR
      NEED = LAST - LREST - 1
C
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO2U2,ZERO,0,RL,1)
      END IF
      CALL TRANSQ_SMP(RL,NOU)
C        LVE USED AS A TMP ARRAY
      CALL INSITU_SMP(NU,NO,NU,NO,X(LVE),RL,12)
C
      CALL DDI_DISTRIB(D_VVVO,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
        JOFF = NOU*(J-1) + 1
        CALL DDI_GET(D_VVVO,1,NUTR,J,J,X(LTMP))
        CALL CPYTSQ(X(LTMP),X(LVE),NU,1)
        CALL DGEMM('N','N',NO,NU,NU,ONE,O1,NO,X(LVE),NU,
     *             ONE,RL(JOFF),NO)
      END DO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(301,RL,NO2U2)
C
C-----CALL CHECK_CHKSUM(24,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(24)
C
      LVE = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------- 26
C O1 X VM += VL
C -----------------------------
C
       CALL TRANMD_SMP(RL,NO,NU,NU,NO,14)
       CALL TRANSQ_SMP(RL,NOU)
       CALL TRANMD_SMP(RL,NU,NO,NO,NU,14)
C
C     MAY NOT BE WORTH DISTRIBUTING THIS DGEMM SO WE'LL DO IT ON EACH
C     NODE WHEN REALLY THE MASTER IS THE ONLY IMPORTANT ONE
      CALL DIV_EVEN(NO2U,SMP_NP,SMP_ME,NR,SR)
      IOFF = (SR-1)*NO + 1
      JOFF = (SR-1)*NU + 1
      CALL DGEMM('T','N',NU,NR,NO,ONEM,O1,NO,VM(IOFF),NO,
     &           ONE,RL(JOFF),NU)
C
C-----CALL CHECK_CHKSUM(25,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(25)
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO2U2,ZERO,0,RL,1)
      END IF
C
C -----------------------------
C VL = VL + VR
C -----------------------------
      LVR = LREST
      LTMP = LVR   + NOU
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL TRANSQ_SMP(RL,NOU)
      CALL INSITU_SMP(NO,NU,NU,NO,X(LTMP),RL,12)
C
      CALL DDI_DISTRIB(D_VR,DDI_ME,ILO,IHI,JLO,JHI)
C
      DO J = JLO,JHI
        JOFF = (J-1)*NOU + 1
        CALL DDI_GET(D_VR,ILO,IHI,J,J,X(LVR))
        CALL INSITU(NO,NU,1,1,X(LTMP),X(LVR),12)
        CALL DAXPY(NOU,ONE,X(LVR),1,RL(JOFF),1)
      END DO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(505,RL,NO2U2)
C
C-----CALL CHECK_CHKSUM(26,NO,NU,O1,O2,T1,RL,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(26)
C
      LVR = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C
C ----------------------------- 28
C O2 X VL += T2
C -----------------------------
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL TRANMD_SMP(O2,NU,NO,NU,NO,13)
      CALL INSITU_SMP(NU,NO,NU,NO,X(LTMP),O2,12)
      CALL SYMT21_SMP(O2,NO,NU,NU,NO,23)
C
      CALL DIV_EVEN(NOU,SMP_NP,SMP_ME,NR,SR)
      IOFF = (SR-1)*NOU + 1
      CALL DGEMM('N','N',NOU,NR,NOU,ONE,O2,NOU,RL(IOFF),NOU,
     &           ONE,T2(IOFF),NOU)
C
C-----CALL CHECK_CHKSUM(27,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(27)
C
      CALL DESM21_SMP(O2,NO,NU,NU,NO,23)
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO2U2,ZERO,0,T2,1)
      END IF
      CALL DDI_SMP_SYNC()
C
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------- 29 30 31
C
C -----------------------------
      LTMP = LREST
      LAST = LTMP   + NOU2
      NEED = LAST - LREST - 1
C
      CALL DDI_NDISTRIB(D_VL,DDI_MY,ILO,IHI,JLO,JHI)
      CALL DIV_EVEN(NO,DDI_NN,DDI_MY,NR,SR)
C
C     0-BASED LOOP INDEX
      LRL = NU3 + 1
      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NR1,SR1)
C
      DO J = SR-1, SR+NR-2
        JOFF = NU*J + 1
        JOF1 = NOU2*J + 1
        IOFF = 1
C
        IF(SMP_ME.EQ.0) THEN
          DO I = J*NU, (J*NU+NU-1)
            CALL DDI_GET(D_VVVO,1,NUTR,I+1,I+1,SMP_TEMP(LRL))
            CALL CPYTSQ(SMP_TEMP(LRL),SMP_TEMP(IOFF),NU,1)
            IOFF = IOFF + NU2
          ENDDO
        END IF
        IOF1 = (SR1-1)*NO
        SMPOFF = (SR1-1)*NU + 1
C
        CALL TRANMD_SMP(SMP_TEMP,NU,NU,NU,1,13)
C
        IF(SMP_ME.EQ.0) THEN
          CALL DDI_GET(D_VL,ILO,IHI,JOFF,JOFF+NU-1,SMP_TEMP(LRL))
        END IF
C
        CALL DDI_SMP_SYNC()
        CALL DGEMM('T','N',NU,NR1,NO,ONEM,O1,NO,SMP_TEMP(LRL+IOF1),NO,
     *             ONE,SMP_TEMP(SMPOFF),NU)
C
        CALL TRANMD_SMP(SMP_TEMP,NU,NU,NU,1,13)
C
        IF(SMP_ME.EQ.0) THEN
          CALL DDI_GET(D_VR_IBT,ILO,IHI,JOFF,JOFF+NU-1,SMP_TEMP(LRL))
        END IF
C
        CALL INSITU_SMP(NU,NO,NU,1,X(LTMP),SMP_TEMP(LRL),13)
        CALL INSITU_SMP(NU,NO,NU,1,X(LTMP),SMP_TEMP(LRL),12)
        CALL DGEMM('T','N',NU,NR1,NO,ONEM,O1,NO,SMP_TEMP(LRL+IOF1),NO,
     *             ONE,SMP_TEMP(SMPOFF),NU)
C
        CALL TRANMD_SMP(SMP_TEMP,NU,NU,NU,1,12)
        CALL DGEMM('N','N',NO,NR1,NU,ONE,O1,NO,SMP_TEMP(SMPOFF),NU,
     *             ONE,T2(JOF1+IOF1),NO)
        CALL DDI_SMP_SYNC()
C
      ENDDO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_GSUMF(304,T2,NO2U2)
C
C-----CALL CHECK_CHKSUM(28,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(28)
C
      LVE = -1
      LRL = -1
      LTMP = -1
      LAST = -1
      NEED = -1
C
C ----------------------------- 35 34 32 33
C
C -----------------------------
C
      LVM = LREST
      LAST = LVM   + NOU2
      NEED = LAST - LREST - 1
C
      CALL DDI_SMP_SYNC()
C
      CALL ZEROMA_SMP(RL,1,NO2U2)
      CALL TRANSQ_SMP(T2,NOU)
      CALL INSITU_SMP(NO,NU,NU,NO,X(LVM),O2,12)
      CALL INSITU_SMP(NU,NO,NU,NO,X(LVM),O2,23)
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,312)
      IF(SMP_ME.EQ.0) THEN
        IF(DDI_ME.NE.0) CALL DCOPY(NO3U,ZERO,0,VM,1)
      END IF
C
      CALL DDI_SMP_SYNC()
C
      CALL DIV_EVEN(NO,DDI_NN,DDI_MY,NR,SR)
C
C     0-BASED LOOP INDEX
C      LVM = NU3 + 1
      JLO = SR - 1
      JHI = SR + NR - 2
      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NR,SR)
      CALL DIV_EVEN(NU,SMP_NP,SMP_ME,NR1,SR1)
      DO J = JLO, JHI
        IOFF = NOU2*J + 1
        IOF1 = 1
C
        IF(SMP_ME.EQ.0) THEN
          DO I = J*NU, (J*NU+NU-1)
            CALL DDI_GET(D_VVVO,1,NUTR,I+1,I+1,X(LVM))
            CALL CPYTSQ(X(LVM),SMP_TEMP(IOF1),NU,1)
            IOF1 = IOF1 + NU2
          END DO
        END IF
C
        CALL DDI_SMP_SYNC()
        IOFF = IOFF + (SR-1)*NO
        SMPOFF = (SR-1)*NU + 1
C
        CALL DGEMM('N','N',NO,NR,NU,ONE,O1,NO,SMP_TEMP(SMPOFF),NU,
     *             ZERO,RL(IOFF),NO)
        CALL TRANMD_SMP(SMP_TEMP,NU,NU,NU,1,13)
        SMPOFF = (SR1-1)*NU2 + 1
        JOFF = (SR1-1)*NO2
        CALL DCOPY(NOU2,ZERO,0,X(LVM),1)
        CALL DGEMM('T','N',NO2,NR1,NU2,ONE,O2,NU2,SMP_TEMP(SMPOFF),NU2,
     *             ZERO,X(LVM+JOFF),NO2)
C
        IF(SMP_NP.GT.1) CALL DDI_SMP_GSUMF(191,X(LVM),NO2U)
C
C
        IOF1 = J*NO2 + 1
        IOF2 = LVM
        DO A = 1,NU
          IF(MOD(A,SMP_NP).EQ.SMP_ME) THEN
            CALL DAXPY(NO2,ONE,X(IOF2),1,VM(IOF1),1)
          END IF
          IOF1 = IOF1 + NO3
          IOF2 = IOF2 + NO2
        END DO
      END DO
C
      CALL DDI_SMP_SYNC()
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_GSUMF(305,RL,NO2U2)
        CALL DDI_MASTERS_GSUMF(306,VM,NO3U)
      END IF
C      CALL DDI_TIMER_OUTPUT()
      CALL DDI_TIMER_RESET()
C
      CALL TRANSQ_SMP(RL,NOU)
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,23)
C
C ------------------------
C O1 X RL += LVM
C ------------------------
C
      CALL DIV_EVEN(NO2U,SMP_NP,SMP_ME,NR,SR)
      IOF1 = (SR-1)*NU + 1
      IOF2 = (SR-1)*NO + 1
C GOOD PLACE FOR SHARED MEMORY DGEMM HERE
      CALL DGEMM('N','N',NO,NR,NU,ONE,O1,NO,RL(IOF1),NU,
     &           ONE,VM(IOF2),NO)
C
      LVE = -1
      LVM = -1
      LAST = -1
      NEED = -1
C
C ------------------------
C FINAL CONTRIBUTION TO T2
C ------------------------
C
      CALL TRANMD_SMP(VM,NO,NO,NO,NU,12)
C
      CALL DGEMM('T','N',NU,NR,NO,ONEM,O1,NO,VM(IOF2),NO,
     &           ONE,T2(IOF1),NU)
C
C-----CALL CHECK_CHKSUM(29,NO,NU,O1,O2,T1,T2,X(LFH),X(LFPH),X(LFP))
      IF(P_TIME) CALL PRINT_TIM(29)
C
      CALL TRANSQ_SMP(T2,NOU)
C
C
      IF(SMP_ME.EQ.0) CALL SYMETR(T2,NO,NU)
C
      IF(DDI_MY.EQ.0) THEN
      IF(SMP_ME.EQ.0) CALL DDI_GET(D_VR,1,NOU,1,NOU,O2)
      IF(SMP_ME.EQ.0) CALL VECADD(T2,O2,NO2U2)
      IF(SMP_ME.EQ.0) CALL ADDDEN(NO,NU,T2,OEH,OEP)
      IF(MASWRK)      CALL WO2(2,NO,NU,T2)
C SHOULD SAVE THE T2 AMPS HERE SOMEWHERE
      CALL VECCOP_SMP(NO2U2,O2,T2)
      CALL DDI_SMP_SYNC()
C
C     IF(.NOT.LCCD.AND..NOT.CCD) THEN
C       IF(SMP_ME.EQ.0) CALL ADT12(1,NO,NU,T1,T2,6)
C     END IF
C
      CALL DDI_SMP_BCAST(1234,'F',T1,NOU,0)
      CALL ADT12_6_SMP(1,NO,NU,T1,T2)
      ZZ = TWO*DDOT(NOU,T1,1,FPH,1)
C
C     LTMP1 = LREST + 1
C     LAST  = LTMP1 + NOU2
C     NEED  = LAST - LREST - 1
C     CALL ENERGYMM_DDI_PAR(NO,NU,T2,X(LTMP),ENRG,D_VR)
C
      IF(MASWRK) THEN
        CALL ENERGYMM_DDI(NO,NU,T2,RL,ENRG,D_VR)
      END IF
      ENDIF
C
C-----CALL CHECK_CHKSUM(30,NO,NU,O1,O2,T1,T2,X(LFH),FPH,X(LFP))
      IF(P_TIME) CALL PRINT_TIM(30)
C
      ENRG=ENRG+ZZ
      DIFFENG=ENRG-ENRGOLD
C
      CALL DDI_BCAST(126,'F',ENRG,1,0)
      CALL DDI_BCAST(127,'F',DIFFENG,1,0)
C
      CALL DDI_BCAST(122,'I',MXRLE,1,0)
      IF(MXRLE.GT.0) GO TO 717
C
C
 717  CONTINUE
C
C     FIX THIS CALL LATER!!   (EITHER JONATHAN OR RYAN WROTE THIS NOTE)
C     I THINK IT IS FOR RESTART, WHICH ISN'T IMPLEMENTED YET
C     IF(IREST.GT.0.AND.ITRLE.EQ.1) CALL DRCMP(NO,NU,O1)
C
C     MWS, 4/9/07:
C     INSTEAD, FOLLOWING HUI, LETS JUST SET DIFMAX TO SOMETHING
C     THAT WILL CAUSE US TO LOOK LIKE WE ARE UNCONVERGED.
C     THE REAL COMPUTATION OF DIFMAX IS IN DDCC_DRRLEN_BIG JUST BELOW.
C
      IF(IREST.GT.0  .AND.  ITRLE.EQ.1) DIFMAX = 1.0D+00
C

      CALL DDI_BCAST(123,'F',DIFMAX,1,0)
      CNVR = ABS(DIFMAX).LT.TRESH
      IF(MASWRK.AND.CNVR.AND.ITER.GT.1) CALL DRPRINT(2)
C
      IF(.NOT.CNVR.OR.ITER.LT.2) THEN
      IF(MASWRK.AND..NOT.LCCD.AND..NOT.CCD) CALL RO1(2,NO,NU,T1)
C      IF(MASWRK.AND.MXRLE.GT.0) CALL DDCC_DRRLEN(NO,NU,SMP_TEMP)
      IF(MASWRK.AND.MXRLE.GT.0)
     *       CALL DDCC_DRRLEN_BIG(NO,NU,O2,T2,SMP_TEMP)
C
      IF(MASWRK) CALL DRPRINT(2)
C
      IF(MASWRK.AND.ITRLE.EQ.1) THEN
        IF(.NOT.LCCD.AND..NOT.CCD) THEN
          CALL RO1(2,NO,NU,T1)
          CALL WO1(1,NO,NU,T1)
        END IF
        CALL RO2(2,NO,NU,T2)
        CALL WO2(1,NO,NU,T2)
      END IF
      ENRGOLD = ENRG
C
C      IF(MASWRK) CALL ZEROMA(SMP_TEMP,1,2*NO2U2)
      CALL ZEROMA_SMP(SMP_TEMP,1,NO2U2+NOU)
C
      IF(MASWRK) CALL DDCC_DRREST(1,NO,NU,O2,T2)
C
      CALL TSECND(TIM)
      CPUMO  = CPU  - CPU0
      WALLMO = WALL - WALL0
      CPU0  = CPU
      WALL0 = WALL
      CPUI  = CPUB + CPUAO + CPUMO
      WALLI = WALLB + WALLAO + WALLMO
C
      IF(MASWRK  .AND.  ITER.EQ.1)
     *  WRITE(6,9040) CPUI,CPUAO,CPUMO,WALLI,WALLAO,WALLMO
C
C        TURN OFF DDI ARRAY CREATION MESSAGES
C
      IFLAG=0
      CALL DDI_OUTPUT(IFLAG)
C
      IF(ITER.LT.MAXIT) GO TO 1000
      END IF
C     CONVERGENCE HAS BEEN ACHIEVED
C
C
C               READ CONVERGED AMPLITUDES FROM DISK.
C        THESE HAVE THE SHAPE T1(NO,NU) AND T2(NO,NU,NU,NO).
C        NOTE THAT THE SHAPE OF T2 AT THIS POINT DOES NOT MATCH
C        THE DIMENSION ABOVE, SO WE USE -VR- AS STORAGE OF T2.
C
      IF(MASWRK) THEN
      IF(MET.GE.2) THEN
        CALL RO1(1,NO,NU,T1)
        CALL RO2(2,NO,NU,RL)
C
C        COMPUTE THE T1 DIAGNOSTIC OF
C        T.J.LEE, P.R.TAYLOR  INT.J.QUANTUM CHEM. S23, 199-207(1989)
C
        T1NORM=DDOT(NOU  ,T1,1,T1,1)
        T2NORM=DDOT(NO2U2,RL,1,RL,1)
        DIAGS(1) = SQRT(T1NORM/(TWO*NO))
        DIAGS(2) = SQRT(T1NORM)
        DIAGS(3) = SQRT(T2NORM)
C
        DO III=1,5
           IMAX = IDAMAX(NOU,T1,1)
           A = (IMAX-1)/NO + 1
           I = IMAX - (A-1)*NO
            AMPMX(III,  1) = T1(IMAX)
           IAMPMX(III,1,1) = I + IFC
           IAMPMX(III,2,1) = A + IFC + NO
           T1(IMAX) = ZERO
C
           IMAX = IDAMAX(NO2U2,RL,1)
           J = (IMAX-1)/NOU2 + 1
           IDMY = IMAX - (J-1)*NOU2
           B = (IDMY-1)/NOU + 1
           IDMY = IDMY - (B-1)*NOU
           A = (IDMY-1)/NO + 1
           I = IDMY - (A-1)*NO
            AMPMX(III,  2) = RL(IMAX)
           RL(IMAX) = ZERO
C               T2(I,A,B,J) EQUALS T2(J,B,A,I)
           IMAX = J + (B-1)*NO + (A-1)*NOU + (I-1)*NOU2
           RL(IMAX) = ZERO
           IF(I.EQ.J  .AND.  A.GT.B) THEN
              K = B
              B = A
              A = K
           END IF
           IF(I.NE.J) THEN
              K = J
              J = I
              I = K
              K = B
              B = A
              A = K
           END IF
           IAMPMX(III,1,2) = I + IFC
           IAMPMX(III,2,2) = J + IFC
           IAMPMX(III,3,2) = A + IFC + NO
           IAMPMX(III,4,2) = B + IFC + NO
        ENDDO
      END IF
C
      IF(MET.GE.4) THEN
      CALL RO1(1,NO,NU,T1)
      CALL RO2(1,NO,NU,T2)
      CALL VECCOP(NO2U2,O2,T2)
      CALL ADT12(1,NO,NU,T1,T2,6)
      OSS=TWO*DDOT(NOU,T1,1,T1,1)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      ODS=ZERO
      ODD=DDOT(NO2U2,O2,1,T2,1)
      END IF
      ESD=ENRG
C
      END IF
C
C
 2000 CONTINUE
C
      CALL RETFM(TOTAL_MEM)
C
      IF(MASWRK) THEN
         WRITE(6,*) 'LEAVING CCSD ITERATIONS'
         CALL FLSHBF(6)
      END IF
      RETURN
C
   99 FORMAT(1X,'INSUFFICIENT MEMORY FOR CCSD ITERATIONS'/
     *       1X,'REQUIRED:',I13,'     AVAILABLE:',I13)
 9040 FORMAT(/1X,'ITER  CPU TIME: TOTAL=',F8.1,
     *        '  TERMS IN AO BASIS=',F8.1,', MO BASIS=',F8.1/
     *        1X,'ITER WALL TIME: TOTAL=',F8.1,
     *        '  TERMS IN AO BASIS=',F8.1,', MO BASIS=',F8.1/
     *        1X,'IT IS USEFUL TO ADD MORE PROCESSORS IF THE',
     *           ' SCALABLE AO TERM''S TIME'/
     *        1X,'IS CONSIDERABLY LARGER THAN THE LESS SCALABLE',
     *           ' MO TERM''S TIME.'/)
      END
C
C*MODULE CCDDI   *DECK ENERGYMM_DDI
      SUBROUTINE ENERGYMM_DDI(NO,NU,O2,V,Y,D_VR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER NO,NU,NO2U2,D_VR,NOU
      DOUBLE PRECISION O2(1),V(1),Y,TWO,HALF
      PARAMETER(TWO=2.0D+00,HALF=0.5D+00)
C
C
      NOU = NO*NU
      NO2U2 = NO*NO*NU*NU
      CALL DDI_GET(D_VR,1,NOU,1,NOU,V)
      CALL VECMUL(V,NO2U2,TWO)
      Y=DDOT(NO2U2,O2,1,V,1)
      CALL TRANMD(V,NO,NU,NU,NO,23)
      CALL VECMUL(V,NO2U2,HALF)
      Y=Y-DDOT(NO2U2,O2,1,V,1)
      RETURN
      END
C---C
C---C*MODULE CCDDI   *DECK ENERGYMM_DDI_PAR
C---      SUBROUTINE ENERGYMM_DDI_PAR(NO,NU,O2,V,Y,D_VR)
C---      IMPLICIT NONE
C---      INTEGER NO,NU,NOU2,D_VR,NOU
C---      DOUBLE PRECISION O2(1),V(1),Y,TWO,HALF,ZERO,DDOT
C---      PARAMETER(TWO=2.0D+00,HALF=0.5D+00,ZERO=0.0D+00)
C---
C---      INTEGER DDI_NP,DDI_ME
C---      INTEGER ILO,IHI,JLO,JHI,JCOL_LO,JCOL_HI
C---      INTEGER I,IOFF
C---
C---      CALL DDI_NPROC(DDI_NP,DDI_ME)
C---      CALL DDI_DISTRIB(D_VR,DDI_ME,ILO,IHI,JLO,JHI)
C---
C---      NOU = NO*NU
C---      NOU2 = NOU*NU
C---
C---      Y = ZERO
C---
C---      DO 1 I = 1,NOU,NU
C---         IF(I.LT.JLO .OR. I.GT.JHI) GOTO 1
C---         JCOL_LO = I
C---         JCOL_HI = I + NU - 1
C---         IOFF    = (I-1)*NOU + 1
C---         CALL DDI_GET(D_VR,ILO,IHI,JCOL_LO,JCOL_HI,V)
C---         CALL DSCAL(NOU2,TWO,V,1)
C---         Y=Y+DDOT(NOU2,O2(IOFF),1,V,1)
C---         CALL TRANMD(V,NO,NU,NU,1,23)
C---         CALL DSCAL_SMP(NOU2,HALF,V,1)
C---         Y=Y-DDOT(NOU2,O2(IOFF),1,V,1)
C---   1  CONTINUE
C---      CALL DDI_GSUMF(231,Y,1)
C---      RETURN
C---      END
C
C*MODULE CCDDI   *DECK PRINT_TIM
      SUBROUTINE PRINT_TIM(CHKSUM)
      IMPLICIT NONE
      INTEGER CHKSUM,DDI_NP,DDI_ME
C
C ROUTINE TO PRINT SOME TIMING INFO
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
C
      IF(DDI_ME.EQ.0) THEN
        IF(CHKSUM.GT.0) THEN
          WRITE(6,*)'CHKSUM NUMBER:',CHKSUM
          CALL TIMIT(1)
          CALL FLSHBF(6)
        END IF
      END IF
      END
C
C*MODULE DDICC   *DECK DDCC_T_DRIVER
      SUBROUTINE DDCC_T_DRIVER(NO,NU,VM,T2,VOE,EH,EP)
      IMPLICIT NONE
C
      INTEGER NO,NU
      DOUBLE PRECISION EH(NO),EP(NU),VM(1),T2(1),VOE(1)
C
      DOUBLE PRECISION X(1)
      DOUBLE PRECISION RUNTYP,EXETYP,CHECK
      INTEGER NEVALS,NGLEVL,NHLEVL
C
      COMMON /FMCOM / X
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      INTEGER ME,MASTER,NPROC,IBTYP,IPTIM
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER NU2,NU3,NOU,NO2U2,NO4,DDI_ME,DDI_NP
C
      INTEGER NGOTMX,LOADFM,LAST,NEED
      INTEGER LT1,LV3,LT3,LO1,LTMP
C
      INTEGER D_V3,D_T3
      CHARACTER*1 ADDR(1)
      DATA CHECK/8HCHECK   /
C
      NU2   = NU*NU
      NU3   = NU*NU2
      NOU   = NO*NU
      NO2U2 = NOU*NOU
      NO4   = NO*NO*NO*NO
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
C
      IF(MASWRK) WRITE(6,1)
C
C      NO2   = NO*NO
C      NO2U2 = NO2*NU2
C      NO3   = NO*NO2
C      NO3U = NO3*NU
C      CALL VALFM(LOADFM)
C      LT1  = LOADFM + 1
C      LV3  = LT1    + NOU
C      LT3  = LV3    + NU3
C      LO1  = LT3    + MAX(NU3,NO3U)
C      LTMP = LO1    + NOU
C      LT2  = LTMP   + NU2
C      LAST = LT2    + NO2U2
C      NEED = LAST   - LOADFM - 1
C
C      IF(MASWRK) THEN
C        WRITE(6,90) NEED
C        CALL FLSHBF(6)
C      END IF
C
C      CALL GOTFM(NGOTMX)
C      IF(NEED.GT.NGOTMX) THEN
C         WRITE(6,91) NEED,NGOTMX
C         GOTO 650
C         CALL ABRT
C      END IF
C 91   FORMAT(1X,'SWITCHING TO NODE BASED ALGORITHM'/
C     *       1X,'REQUIRED:',I13,'     AVAILABLE:',I13)
C
C THIS NEEDS TO BE REPLACED SOON
C
C
C      GO TO 650
C      CALL GETFM(NEED)
C
C      IF(EXETYP.EQ.CHECK) GO TO 800
C
C      CALL CCDD_T_PROC(NO,NU,X(LT1),T2,X(LT2),VM,VOE,X(LV3),X(LT3),
C     *            X(LO1),X(LTMP),EH,EP)
C
C      GO TO 800
C
C  650 CONTINUE
C
C
C THE ABOVE CODE RUNS THE PROCESS BASED CODE.  WE'RE AREN'T USING IT
C NOW BECAUSE IN TIMINGS WE'VE RUN, IT HAS RUN SLOWER THAN THE NODE
C BASED CODE, WHICH IS PUZZLING.  FOR THE MOMENT WE WILL RUN THE NODE
C BASED (T) ALL THE TIME.
C
C        THERE'S NO ATTEMPT HERE TO LOWER NGOTMX TO A POSSIBLE INPUT
C        KEYWORD -NWORD- IN $CCINP, FOR THERE'S NO WAY TO LOWER THE
C        CORE REQUIREMENTS IN THIS PARALLEL CODE.
C
      CALL GOTFM(NGOTMX)
C
      CALL VALFM(LOADFM)
      LT1  = LOADFM + 1
      LO1  = LT1    + NOU
      LTMP = LO1    + NOU
      LAST = LTMP   + NU2
      NEED = LAST - LOADFM - 1
C
C        PRINT ALSO SHARED MEMORY NEED, WHICH IS TWO NEW ARRAYS BELOW,
C        BUT A FEW OTHERS LEFT OVER FROM THE CCSD STEP.
C
      IF(MASWRK) THEN
        WRITE(6,90) NEED,2*NU3 + 2*(NO2U2+NOU) + NO4
        CALL FLSHBF(6)
      END IF
C
      IF(NEED.GT.NGOTMX) THEN
         WRITE(6,92) NEED,NGOTMX
         CALL ABRT
      END IF
C
C           ALLOCATE REPLICATED AND SHARED MEMORY
C           WE ARE REUSING SOME DISTRIBUTED ARRAYS FROM THE INTEGRAL
C           TRANSFORMATION AND CCSD ITERS, NO NEW ONES APPEAR FOR (T)
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL DDI_SMP_CREATE(NU3,D_V3)
      CALL DDI_SMP_CREATE(NU3,D_T3)
C
      CALL DDI_SMP_OFFSET(D_V3,ADDR,LV3)
      CALL DDI_SMP_OFFSET(D_T3,ADDR,LT3)
C
      LV3 = LV3 + 1
      LT3 = LT3 + 1
C
C      CALL DDI_ADDR_TEST(ADDR(LV3))
C      CALL DDI_ADDR_TEST(ADDR(LT3))
C
      CALL DDI_SMP_SYNC()
C
      CALL DDCC_T_NODE(NO,NU,X(LT1),T2,VM,VOE,ADDR(LV3),ADDR(LT3),
     *            X(LO1),X(LTMP),EH,EP)
C
      CALL DDI_SMP_SYNC()
      CALL DDI_SMP_DESTROY(D_T3)
      CALL DDI_SMP_DESTROY(D_V3)
C
  800 CONTINUE
      CALL RETFM(NEED)
      RETURN
C
    1 FORMAT(/1X,'RUNNING THE DISTRIBUTED DATA, PARALLEL TRIPLES',
     *           ' CORRECTION...')
   90 FORMAT(/1X,'  REPLICATED MEMORY REQUIRED FOR TRIPLES IS',
     *           I13,' WORDS.'/
     *        1X,'      SHARED MEMORY REQUIRED FOR TRIPLES IS',
     *           I13,' WORDS.'/
     *        1X,' DISTRIBUTED MEMORY IS ALREADY ALLOCATED ABOVE.'/)
   92 FORMAT(1X,'INSUFFICIENT MEMORY FOR NONITERATIVE TRIPLES'/
     *       1X,'REQUIRED:',I13,'     AVAILABLE:',I13)
      END
C
C---C*MODULE DDICC   *DECK DDCC_T_PROC
C---      SUBROUTINE DDCC_T_PROC(NO,NU,T1,T2RD,T2,VM,VOE,V3,T3,
C---     *                       O1,TMP,EH,EP)
C---      IMPLICIT NONE
C---
C---      INTEGER NO,NU
C---
C---      DOUBLE PRECISION T1(1),T2(1),VM(1),V3(1),T3(*),VOE(1),O1(1),
C---     *                 EH(NO),EP(NU),TMP(1),T2RD(*)
C---C
C---      INTEGER MAXWRK,MYTASK
C---      INTEGER NO2,NO3,NU2,NU3
C---      INTEGER DDI_NP,DDI_ME,SMP_ME,SMP_NP,SR,NR,A
C---      INTEGER I,J,K
C---C
C---      NO2 = NO*NO
C---      NO3 = NO2*NO
C---      NU2 = NU*NU
C---      NU3 = NU2*NU
C---
C---      CALL ZEROMA(V3,1,NU3)
C---      CALL ZEROMA(T1,1,NO*NU)
C---
C---      CALL DDI_NPROC(DDI_NP,DDI_ME)
C---      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
C---
C---
C---      IF(DDI_ME.EQ.0) THEN
C---        WRITE(6,*) 'RUNNING PROCESS-BASED (T) CORRECTION'
C---        CALL FLSHBF(6)
C---        CALL RO1(1,NO,NU,O1)
C---! READING VM INTO V3 TEMPORARILIY TO DO THE VMCP1 TRANSFORMATION
C---! WITHOUT AN EXTRA COPY
C---        CALL CCSD_RDVM(NO,NU,V3,VM)
C---        CALL VMCP1(NO,NU,VM,V3)
C---        CALL TRANMD(VM,NO,NU,NO,NO,13)
C---        CALL RO2(1,NO,NU,T2RD)
C---        CALL INSITU(NO,NU,NU,NO,V3,T2RD,13)
C---        CALL DDCC_T_GETVOE(NO,NU,VOE)
C---      END IF
C---
C---      IF(SMP_ME.EQ.0) THEN
C---        CALL DDI_MASTERS_BCAST(110,'F',VM,NO3*NU,0)
C---        CALL DDI_MASTERS_BCAST(111,'F',T2RD,NO2*NU2,0)
C---        CALL DDI_MASTERS_BCAST(112,'F',VOE,NO2*NU2,0)
C---      END IF
C---      CALL DDI_BCAST(1234,'F',O1,NO*NU,0)
C---
C---      MAXWRK = (NO*(NO-1)*(NO-2))/6
C---      CALL DIV_EVEN(MAXWRK,DDI_NP,DDI_ME,NR,SR)
C---      SR = SR - 1
C---
C---
C---!      CALL DDI_DLBNEXT(MYTASK)
C---      CALL DDI_SMP_SYNC()
C---!      DO WHILE(MYTASK.LT.MAXWRK)
C---!      IF(DDI_ME.GE.0) THEN
C---      DO A = SR, SR + NR - 1
C---        MYTASK = A
C---         CALL DDCC_T_TASK(MYTASK,NO,I,J,K)
C---
C---! CALCULATE THE UNIQUE TUPLE
C---         CALL DCOPY(NO2*NU2,T2RD,1,T2,1)
C---         CALL DCOPY(NO*NO*NO*NU,VM,1,T3,1)
C---         CALL DDCC_T_IJK(NO,NU,I,J,K,T1,T2,T3,
C---     *                   V3,T3,VOE,O1,TMP,EH,EP)
C---
C---! POSSIBLY, UNDER CERTAIN CIRCUMSTANCES, CALCULATE A UNIQUE PAIR
C---         IF(K.EQ.(J-1)) THEN              ! CALC IJ PAIR
C---         CALL DCOPY(NO2*NU2,T2RD,1,T2,1)
C---         CALL DCOPY(NO*NO*NO*NU,VM,1,T3,1)
C---         CALL DDCC_T_IJJ(NO,NU,I,J,T1,T2,T3,V3,T3,VOE,
C---     *                    O1,EH,EP,TMP)
C---         CALL DCOPY(NO2*NU2,T2RD,1,T2,1)
C---         CALL DCOPY(NO*NO*NO*NU,VM,1,T3,1)
C---         CALL DDCC_T_IIJ(NO,NU,I,J,T1,T2,T3,V3,T3,VOE,
C---     *                    O1,EH,EP,TMP)
C---         END IF
C---
C---         IF(K.EQ.1) THEN
C---           IF(J.EQ.2.AND.I.EQ.3) THEN    ! CALC JK PAIR = (1,2)
C---             CALL DCOPY(NO2*NU2,T2RD,1,T2,1)
C---             CALL DCOPY(NO*NO*NO*NU,VM,1,T3,1)
C---             CALL DDCC_T_IJJ(NO,NU,J,K,T1,T2,T3,V3,T3,VOE,
C---     *                    O1,EH,EP,TMP)
C---             CALL DCOPY(NO2*NU2,T2RD,1,T2,1)
C---             CALL DCOPY(NO*NO*NO*NU,VM,1,T3,1)
C---             CALL DDCC_T_IIJ(NO,NU,J,K,T1,T2,T3,V3,T3,VOE,
C---     *                    O1,EH,EP,TMP)
C---           END IF
C---
C---           IF(J.EQ.(I-1)) THEN           ! CALC IK PAIR = (I,1)
C---             CALL DCOPY(NO2*NU2,T2RD,1,T2,1)
C---             CALL DCOPY(NO*NO*NO*NU,VM,1,T3,1)
C---             CALL DDCC_T_IJJ(NO,NU,I,K,T1,T2,T3,V3,T3,VOE,
C---     *                    O1,EH,EP,TMP)
C---             CALL DCOPY(NO2*NU2,T2RD,1,T2,1)
C---             CALL DCOPY(NO*NO*NO*NU,VM,1,T3,1)
C---             CALL DDCC_T_IIJ(NO,NU,I,K,T1,T2,T3,V3,T3,VOE,
C---     *                    O1,EH,EP,TMP)
C---           END IF
C---         END IF
C---
C---
C---!         CALL DDI_DLBNEXT(MYTASK)
C---      END DO
C---
C---      CALL DDI_GSUMF(1234,EH,NO)
C---      CALL DDI_GSUMF(1234,EP,NU)
C---      CALL DDI_GSUMF(1234,T1,NO*NU)
C---      CALL DD_T3SQUA_GSUM
C---
C---      IF(DDI_ME.EQ.0) THEN
C---      CALL TRT1(NU,NO,T3,T1)
C---! ADDS THE CONTRIBUTION FROM THE T1 AMPS
C---      CALL T1SQ(NO,NU,T3,T1)
C---      CALL ADDDEN1(NO,NU,T1,EH,EP)
C---      CALL WO1(4,NO,NU,T1)
C---      END IF
C---      RETURN
C---      END
C
C*MODULE DDICC   *DECK DDCC_T_TASK(MYTASK,I,J,K)
      SUBROUTINE DDCC_T_TASK(MYTASK,NO,I,J,K)
      IMPLICIT NONE
C
      INTEGER MYTASK,NO,I,J,K
      INTEGER II,JJ,KK,I1,J1,ICNTR
C
      ICNTR=0
      DO II=1,NO
         I1=II-1
         DO JJ=1,I1
            J1=JJ-1
            DO KK=1,J1
               IF(ICNTR.EQ.MYTASK) THEN
                  I=II
                  J=JJ
                  K=KK
                  GO TO 10
               END IF
               ICNTR=ICNTR+1
            END DO
         END DO
      END DO
   10 CONTINUE
C
      RETURN
      END
C
C
C*MODULE DDICC   *DECK DDCC_T_GETVOE
      SUBROUTINE DDCC_T_GETVOE(NO,NU,VOE)
      IMPLICIT NONE
C
      INTEGER NO,NU,NO2,NU2
      DOUBLE PRECISION VOE(1)
C
      INTEGER         D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI
      INTEGER         D_VL,D_VL_IBT
      COMMON /CCDDI / D_VR,D_VR_IBT,D_VR_SYM,D_VR_BIT,D_VR_BI,
     *                D_VL,D_VL_IBT
C
      NU2 = NU*NU
      NO2 = NO*NO
C
      CALL DDI_GET(D_VR_BI,1,NU2,1,NO2,VOE)
      RETURN
      END
C---C
C---C*MODULE DDICC   *DECK DDCC_T_IJK
C---      SUBROUTINE DDCC_T_IJK(NO,NU,I,J,K,T1,T2,VM,V3,T3,
C---     *                      VOE,O1,TMP,EH,EP)
C---      IMPLICIT NONE
C---
C---      INTEGER NO,NU,I,J,K
C---
C---      DOUBLE PRECISION T1(*),T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),
C---     *                 V3(NU,NU,NU),T3(*),TMP(NU*NU),
C---     *                 VOE(1),O1(*),EH(NO),EP(NU)
C---
C---      DOUBLE PRECISION DEH
C---      INTEGER NU2,ITMP,JTMP,KTMP
C---
C---      DOUBLE PRECISION ZERO,ONE,OM
C---      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00,OM=-1.0D+00)
C---
C---      NU2 = NU*NU
C---
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,K,J),
C---     *NO,ZERO,V3,NU2)
C---      CALL TRANT3(V3,NU,1)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,K),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,4)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,K,I),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,1)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,K),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,5)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,VM(1,1,J,I),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,1)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,VM(1,1,I,J),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,4)
C---
C---
C---!  BEGINNING OF NEW STUFF
C---      CALL DDCC_T_GETVE(NU,K,TMP,T3)
C---      CALL TRANMD(T3,NU,NU,NU,1,23)
C---
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,1)
C---      CALL TRANT3(V3,NU,5)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,T3,
C---     *NU,ONE,V3,NU)
C---
C---      CALL TRANT3(V3,NU,4)
C---      CALL DDCC_T_GETVE(NU,J,TMP,T3)
C---      CALL TRANMD(T3,NU,NU,NU,1,23)
C---
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,I),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,5)
C---      CALL TRANT3(V3,NU,1)
C---      CALL TRANT3(V3,NU,4)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,K),NU,T3,
C---     *NU,ONE,V3,NU)
C---
C---      CALL TRANT3(V3,NU,5)
C---      CALL DDCC_T_GETVE(NU,I,TMP,T3)
C---      CALL TRANMD(T3,NU,NU,NU,1,23)
C---
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,J),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,4)
C---      CALL TRANT3(V3,NU,1)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,K),NU,T3,
C---     *NU,ONE,V3,NU)
C---
C---!  END OF NEW STUFF
C---
C---      CALL TRANT3(V3,NU,5)
C---
C---      CALL ZEROT3(V3,NU) ! ZERO'S OUT THE DIAGONAL
C---
C---      CALL T3SQUA(I,J,K,NO,NU,O1,T2,V3,EH,EP)
C---      DEH=EH(I)+EH(J)+EH(K)
C---      CALL ADT3DEN(NU,DEH,V3,EP)
C---
C---      ITMP=I
C---      JTMP=J
C---      KTMP=K
C---      CALL DRT1WT3IJK(ITMP,JTMP,KTMP,NO,NU,T1,VOE,V3,T3)
C---      RETURN
C---      END
C---C
C---C*MODULE DDICC   *DECK DDCC_T_IJJ
C---      SUBROUTINE DDCC_T_IJJ(NO,NU,I,J,T1,T2,VM,
C---     *                      V3,T3,VOE,O1,EH,EP,TEMP)
C---      IMPLICIT NONE
C---
C---      INTEGER I,J,NO,NU
C---
C---      DOUBLE PRECISION T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),VOE(1),
C---     *                 TEMP(1),T1(1),T3(NU,NU,NU),V3(NU,NU,NU),
C---     *                 O1(1),EH(NO),EP(NU)
C---
C---      INTEGER NU2
C---      INTEGER ITMP,JTMP
C---      DOUBLE PRECISION DEH
C---
C---      DOUBLE PRECISION ZERO,ONE,OM
C---      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00,OM=-1.0D+00)
C---
C---      NU2 = NU*NU
C---
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,J),
C---     *NO,ZERO,V3,NU2)
C---      CALL TRANT3(V3,NU,2)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,J,I),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,1)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,J),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,4)
C---      CALL DDCC_T_GETVE(NU,J,TEMP,T3)
C---      CALL TRANMD(T3,NU,NU,NU,1,23)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,3)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,1)
C---      CALL DDCC_T_GETVE(NU,I,TEMP,T3)
C---      CALL TRANMD(T3,NU,NU,NU,1,23)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,J),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,2)
C---      CALL SYMT311(V3,NU,23)
C---      CALL ZEROT3(V3,NU)
C---      CALL T3SQUA(I,J,J,NO,NU,O1,T2,V3,EH,EP)
C---      DEH=EH(I)+EH(J)+EH(J)
C---      CALL ADT3DEN(NU,DEH,V3,EP)
C---      ITMP=I
C---      JTMP=J
C---
C---      CALL DRT1WT3IJ(ITMP,JTMP,NO,NU,T1,VOE,V3,T3)
C---      RETURN
C---      END
C---C
C---C*MODULE DDICC  *DECK DDCC_T_IIJ
C---      SUBROUTINE DDCC_T_IIJ(NO,NU,I,J,T1,T2,VM,
C---     *                      V3,T3,VOE,O1,EH,EP,TEMP)
C---      IMPLICIT NONE
C---
C---
C---      INTEGER I,J,NO,NU
C---
C---      DOUBLE PRECISION T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),VOE(1),
C---     *                 TEMP(1),T1(1),T3(NU,NU,NU),V3(NU,NU,NU),
C---     *                 O1(1),EH(NO),EP(NU)
C---
C---      INTEGER NU2
C---      INTEGER ITMP,JTMP
C---      DOUBLE PRECISION DEH
C---
C---      DOUBLE PRECISION ZERO,ONE,OM
C---      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00,OM=-1.0D+00)
C---
C---      NU2 = NU*NU
C---
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,I),
C---     *NO,ZERO,V3,NU2)
C---      CALL TRANT3(V3,NU,1)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,I,J),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,2)
C---      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,I),
C---     *NO,ONE,V3,NU2)
C---      CALL TRANT3(V3,NU,2)
C---      CALL DDCC_T_GETVE(NU,J,TEMP,T3)
C---      CALL TRANMD(T3,NU,NU,NU,1,23)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,I),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,1)
C---      CALL DDCC_T_GETVE(NU,I,TEMP,T3)
C---      CALL TRANMD(T3,NU,NU,NU,1,23)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,3)
C---      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,T3,
C---     *NU,ONE,V3,NU)
C---      CALL TRANT3(V3,NU,3)
C---      CALL SYMT311(V3,NU,12)
C---      CALL ZEROT3(V3,NU)
C---C     IF(IDISC.EQ.0.AND.MET.GT.4) THEN
C---C     CALL WRT3(KK,NU,V3)
C---C     END IF
C---      CALL T3SQUA(I,I,J,NO,NU,O1,T2,V3,EH,EP)
C---      DEH=EH(I)+EH(I)+EH(J)
C---      CALL ADT3DEN(NU,DEH,V3,EP)
C---      ITMP=I
C---      JTMP=J
C---      CALL DRT1WT3JK(ITMP,JTMP,NO,NU,T1,VOE,V3,T3)
C---      RETURN
C---      END
C---C
C---C*MODULE CCDDI   *DECK DD_T3SQUA
C---      SUBROUTINE DD_T3SQUA(I,J,K,NO,NU,T1,T2_I,T2_J,T3,EH,EP)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      LOGICAL IEJ,JEK
C---      INTEGER A,B,C
C---      DIMENSION T1(NO,NU),T2_I(NU,NU,NO),T2_J(NU,NU,NO),
C---     *          T3(NU,NU,NU),EH(NO),EP(NU)
C---      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
C---     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C---      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,ZERO/0.0D+00/,
C---     *     HALF/0.5D+00/,ONE/1.0D+00/
C---C
C---      DIJK=EH(I)+EH(J)+EH(K)
C---      X1=ZERO
C---      X2=ZERO
C---      X3=ZERO
C---      DO 150 A=1,NU
C---      DO 150 B=1,NU
C---      DO 150 C=1,NU
C---      IF (A.EQ.B.AND.B.EQ.C) GOTO 150
C---      DABC=EP(A)+EP(B)+EP(C)
C---      DENOM=DIJK-DABC
C---      XT111=T1(I,A)*T1(J,B)*T1(K,C)
C---      XT21=T1(I,A)*T2_J(B,C,K)
C---     *    +T1(J,B)*T2_I(A,C,K)
C---     *    +T1(K,C)*T2_I(A,B,J)
C---      D1=  T3(A,B,C)
C---      D2=  T3(A,C,B)+T3(C,B,A)+T3(B,A,C)
C---      D3=  T3(B,C,A)+T3(C,A,B)
C---      F=D1*EIGHT-FOUR*D2+D3*TWO
C---      X1=X1+F*XT111/DENOM
C---      X2=X2+F*XT21/DENOM
C---      X3=X3+F*D1/DENOM
C--- 150  CONTINUE
C---      CF=ONE
C---      IEJ=I.EQ.J
C---      JEK=J.EQ.K
C---      IF(IEJ.OR.JEK) CF=HALF
C---      OTS=OTS+CF*X1
C---      OTD=OTD+CF*X2
C---      ETD=ETD+CF*X3
C---      RETURN
C---      END
C
C*MODULE CCDDI   *DECK DD_T3SQUA_GSUM
      SUBROUTINE DD_T3SQUA_GSUM
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C
      CALL DDI_GSUMF(1234,OTS,1)
      CALL DDI_GSUMF(1234,OTD,1)
      CALL DDI_GSUMF(1234,ETD,1)
      RETURN
      END
C
C*MODULE CCDDI   *DECK DD_DRT1WT3IJK
C      SUBROUTINE DD_DRT1WT3IJK(I,J,K,NO,NU,T1,VOE,TI,T3)
C      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C      DIMENSION T1(1),VOE(NU,NU,6),T3(1),TI(1)
CC
C      CALL DD_T1WT3IJK(I,5,NO,NU,T1,VOE,TI,T3) ! JK
C      CALL TRANT3(TI,NU,1)
C      CALL DD_T1WT3IJK(I,6,NO,NU,T1,VOE,TI,T3) ! KJ
C      CALL TRANT3(TI,NU,4)
C      CALL DD_T1WT3IJK(J,3,NO,NU,T1,VOE,TI,T3) ! IK
C      CALL TRANT3(TI,NU,1)
C      CALL DD_T1WT3IJK(J,4,NO,NU,T1,VOE,TI,T3) ! KI
C      CALL TRANT3(TI,NU,5)
C      CALL DD_T1WT3IJK(K,1,NO,NU,T1,VOE,TI,T3) ! IJ
C      CALL TRANT3(TI,NU,1)
C      CALL DD_T1WT3IJK(K,2,NO,NU,T1,VOE,TI,T3) ! JI
C      RETURN
C      END
C
C*MODULE CCDDI   *DECK T1WT3IJK
C      SUBROUTINE DD_T1WT3IJK(I,JK,NO,NU,T1,VOE,TI,T3)
C      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C      DIMENSION T1(NU,NO),VOE(NU,NU,6),T3(1),TI(1)
C      DATA ONE/1.0D+00/
CC
C      NU2 = NU*NU
C      CALL SMT3FOUR(NU,T3,TI)
C      CALL DGEMM('N','N',NU,1,NU2,ONE,T3,NU,VOE(1,1,JK),NU2,ONE,
C     *           T1(1,I),NU)
C      RETURN
C      END
C
C*MODULE CCDDI   *DECK DRT1WT3IJ
C      SUBROUTINE DD_DRT1WT3IJ(I,J,NO,NU,T1,VOE,TI,T3)
C      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C      DIMENSION T1(1),VOE(NU,NU,3),T3(1),TI(1)
CC
C      CALL DD_T1WT3IJK(I,3,NO,NU,T1,VOE,TI,T3) ! JJ
C      CALL TRANT3(TI,NU,2)
C      CALL DD_T1WT3IJK(J,1,NO,NU,T1,VOE,TI,T3) ! IJ
C      CALL TRANT3(TI,NU,1)
C      CALL DD_T1WT3IJK(J,2,NO,NU,T1,VOE,TI,T3) ! JI
C      RETURN
C      END
C
C*MODULE CCDDI   *DECK DRT1WT3JK
C      SUBROUTINE DD_DRT1WT3JK(J,K,NO,NU,T1,VOE,TI,T3)
C      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C      DIMENSION T1(1),VOE(NU,NU,3),T3(1),TI(1)
CC
C      CALL DD_T1WT3IJK(J,1,NO,NU,T1,VOE,TI,T3) ! JK
C      CALL TRANT3(TI,NU,1)
C      CALL DD_T1WT3IJK(J,2,NO,NU,T1,VOE,TI,T3) ! KJ
C      CALL TRANT3(TI,NU,2)
C      CALL DD_T1WT3IJK(K,3,NO,NU,T1,VOE,TI,T3) ! JJ
C      RETURN
C      END
C
C*MODULE CCDDI   *DECK DDCC_T_GETVE
      SUBROUTINE DDCC_T_GETVE(NU,INDX,TEMP,VE)
      IMPLICIT NONE
      INTEGER NU,INDX,I,IOFF,NUTR
C
C     TEMP SHOULD BE NU^2 AND VE SHOULD BE NU^3
      DOUBLE PRECISION TEMP(NU*NU),VE(NU,NU,NU)
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C
      INTEGER LOOP
C
      NUTR = (NU*(NU+1)) / 2
      IOFF = 1
      LOOP = INDX - 1
C
      DO I = LOOP*NU, (LOOP*NU+NU-1)
        CALL DDI_GET(D_VVVO,1,NUTR,I+1,I+1,TEMP)
        CALL CPYTSQ(TEMP,VE(1,1,IOFF),NU,1)
        IOFF = IOFF + 1
      END DO
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK DDCC_T_DRSUMA
      SUBROUTINE DDCC_T_DRSUMA
      IMPLICIT NONE
      LOGICAL CNVR
C
      COMMON /CCENGY/ ENRG,EREF,EMP2,ECCN,ETOT(6),ECORR(6),
     *                DIAGS(3),AMPMX(5,2),IAMPMX(5,4,2),XO1,XO2,
     *                DIFMAX,DIFFENG,ITER,CNVR
      DOUBLE PRECISION ENRG,EREF,EMP2,ECCN,ETOT,ECORR,
     *                DIAGS,AMPMX,XO1,XO2,DIFMAX,DIFFENG
      INTEGER         ITER,IAMPMX
C
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      DOUBLE PRECISION OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      DOUBLE PRECISION ONE,ZERO
      DATA ONE/1.0D+00/
      DATA ZERO/0.0D+00/
      INTEGER I
C
C     INTEGER D_T3,LT3
C     CHARACTER*1 ADDR(1)
C     CALL DDI_SMP_CREATE(NU*NU*NU,D_T3)
C     CALL DDI_SMP_OFFSET(D_T3,ADDR,LT3)
C     LT3 = LT3 + 1
C
      ODS_S = ZERO
      ODS_D = ZERO
C NO CONTRIBUTION TO CCSD(T) SO COMMENT IT OUT
C     DOUBLE PRECISION OEH(NO),OEP(NU),T2(1),O2(1)
C     CALL DDCC_T_DRT3SQTOT(NO,NU,T2,O2,OEH,OEP,ADDR(LT3))
C
      XO1=ONE+OSS+ODS+ODD+OTS+OTD
      XO2=ONE+OSS+ODS+ODD+OTS+OTD+ODS_S+ODS_D
      ECORR(1)=ESD+ ETD
      ECORR(2)=ESD+ ETD+ETS
      ECORR(3)=ESD+ ETD/XO1
      ECORR(4)=ESD+(ETD+ETS)/XO2
      ECORR(5)=ESD+ ETTM/XO1
      ECORR(6)=ESD+(ETTM+ESD_TM)/XO2
      DO I=1,6
         ETOT(I)=EREF+ECORR(I)
      ENDDO
      RETURN
      END
C
C      NOTE ---- THE FOLLOWING ROUTINES DO NOT GET CALLED FOR CCSD(T)
C
C*MODULE CCDDI   *DECK DRT3SQTOT
C      SUBROUTINE DDCC_T_DRT3SQTOT(NO,NU,T2,O2,EH,EP,T3)
C      IMPLICIT NONE
C      INTEGER NO,NU
C      DOUBLE PRECISION T2(1),O2(1),EH(NO),EP(NU),T3(*)
C
C      COMMON /FMCOM/ X(1)
C      DOUBLE PRECISION X
C
C      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C      DOUBLE PRECISION RUNTYP,EXETYP
C      INTEGER NEVALS,NGLEVL,NHLEVL
C
C      INTEGER LI1,LTMP,LVO_CK,LT1T,LT21,LT22,LT23
C
C      DOUBLE PRECISION CHECK
C      DATA CHECK/8HCHECK   /
C
C      INTEGER DDI_NP,DDI_ME
C      INTEGER SMP_NP,SMP_ME
C      INTEGER NO2,NU2,NU3,NOU,NO2U2,NGOTMX,LOADFM,I1,I2,I3,I4,LAST,NEED
C
C      CALL DDI_NPROC(DDI_NP,DDI_ME)
C      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
CC
C      NO2   = NO*NO
C      NU2   = NU*NU
C      NU3   = NU*NU2
C      NOU   = NO*NU
C      NO2U2 = NO2*NU2
C
C      IF(DDI_ME.EQ.0) THEN
C      CALL GOTFM(NGOTMX)
CC
C      CALL VALFM(LOADFM)
C      I1   = LOADFM + 1
C!      I2   = I1     + NOU
C!      I3   = I2     + NO2U2
C      I4 = I1 +  NOU
C!      I4   = I3     + NO2U2
C      LAST = I4     + NU3
C      NEED = LAST - LOADFM - 1
C      WRITE(6,90) NEED
C      CALL FLSHBF(6)
CC
C      IF(NEED.GT.NGOTMX) THEN
C         WRITE(6,91) NEED,NGOTMX
C         CALL ABRT
C      END IF
CC
C      CALL GETFM(NEED)
C      IF(EXETYP.EQ.CHECK) GO TO 800
CC
C!     CALL DDCC_T_T3SQUATOT(NO,NU,X(I1),T2,O2,X(I4),EH,EP)
CC
C  800 CONTINUE
C      CALL RETFM(NEED)
C      END IF
C
C      WRITE(6,*) 'NEW T3SQUATOT ROUTINE'
C
C      CALL VALFM(LOADFM)
C      LI1 = LOADFM + 1
C      CALL GETFM(NOU)
C
C      CALL VALFM(LOADFM)
C      LTMP    = LOADFM   + 1
C      LT21    = LTMP
C      LT22    = LT21     + NU2
C      LT23    = LT22     + NU2
C
C      NEED = MAX(NU2*NO,3*NU2)
C      CALL GETFM(NEED)
C
C      CALL DT_T3SQUATOT(NO,NU,X(LI1),T2,T3,EH,EP,
C     &                  X(LTMP),X(LT21),X(LT22),
C     &                  X(LT23))
C
C      CALL RETFM(NEED)
C      CALL RETFM(NOU)
C
C      RETURN
CC
C 90   FORMAT(1X,'MEMORY REQUIRED FOR NONITERATIVE TRIPLES (T3SQTOT)',
C     *           ' IS ',I13,' WORDS.')
C 91   FORMAT(1X,'INSUFFICIENT MEMORY FOR NONITERATIVE TRIPLES'/
C     *       1X,'REQUIRED:',I13,'     AVAILABLE:',I13)
C      END
C
C
C*MODULE CCDDI   *DECK DDCC_T_T3SQUATOT
C      SUBROUTINE DDCC_T_T3SQUATOT(NO,NU,T1,T2,VO,T3,EH,EP)
C      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C      LOGICAL IEJ,JEK
C      INTEGER A,B,C
C      DIMENSION T1(NO,NU),T2(NO,NU,NU,NO),T3(NU,NU,NU),EH(NO),EP(NU),
C     *          VO(NO,NU,NU,NO)
C      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
C     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,ZERO/0.0D+00/,
C     *     HALF/0.5D+00/,ONE/1.0D+00/
C
C      INTEGER         D_VR,D_VR_IBT,D_VRSYM,D_VR_BIT,D_VR_BI
C      INTEGER         D_VL,D_VL_IBT
C      COMMON /CCDDI / D_VR,D_VR_IBT,D_VRSYM,D_VR_BIT,D_VR_BI,
C     *                D_VL,D_VL_IBT
C
CC
C      READ(NT1,REC=1)T1
C      ODS_S=ZERO
C      ODS_D=ZERO
C!      CALL RO2HPP(1,NO,NU,T3,VO)
C      CALL DDI_GET(D_VR,1,NO*NU,1,NO*NU,VO)
C      CALL RO2(1,NO,NU,T2)
CC      CALL RO2HPP(0,NO,NU,T3,T2)
C      DO 1 I=1,NO
C      DO 1 J=1,I
C      DO 1 K=1,J
C      DIJK=EH(I)+EH(J)+EH(K)
C      IF(I.EQ.K) GO TO 1
C      DO 2 A=1,NU
C      DO 2 B=1,NU
C      DO 2 C=1,NU
C      IF(A.EQ.B.AND.B.EQ.C) GO TO 2
C      T3(A,B,C)=T1(I,A)*VO(J,B,C,K)+T1(J,B)*VO(I,A,C,K)
C     *         +T1(K,C)*VO(I,A,B,J)
C 2    CONTINUE
C      X1=ZERO
C      X2=ZERO
C      DO 150 A=1,NU
C      DO 150 B=1,NU
C      DO 150 C=1,NU
C      IF (A.EQ.B.AND.B.EQ.C) GO TO 150
C      DABC=EP(A)+EP(B)+EP(C)
C      DENOM=DIJK-DABC
C      XT111=T1(I,A)*T1(J,B)*T1(K,C)
C      XT21=T1(I,A)*T2(J,B,C,K)+T1(J,B)*T2(I,A,C,K)+T1(K,C)*T2(I,A,B,J)
C      D1=  T3(A,B,C)
C      D2=  T3(A,C,B)+T3(C,B,A)+T3(B,A,C)
C      D3=  T3(B,C,A)+T3(C,A,B)
C      F=D1*EIGHT-FOUR*D2+D3*TWO
C      X1=X1+F*XT111/DENOM
C      X2=X2+F*XT21/DENOM
C 150  CONTINUE
C      CF=ONE
C      IEJ=I.EQ.J
C      JEK=J.EQ.K
C      IF(IEJ.OR.JEK) CF=HALF
C      ODS_S=ODS_S+CF*X1
C      ODS_D=ODS_D+CF*X2
C 1    CONTINUE
C      WRITE(6,*) 'OLD ODS_S = ',ODS_S
C      WRITE(6,*) 'OLD ODS_D = ',ODS_D
C      RETURN
C      END
C
C
C*MODULE CCDDI   *DECK DT_T3SQUATOT
C      SUBROUTINE DT_T3SQUATOT(NO,NU,T1,T2,T3,EH,EP,
C     &                        TMP,VO_IJ,VO_IK,VO_JK)
C      IMPLICIT NONE
C
C      INTEGER NO,NU
C      DOUBLE PRECISION T1(NU,NO),T2(NU,NU,NO,NO),T3(NU,NU,NU)
C      DOUBLE PRECISION EH(NO),EP(NU),TMP(*),VO_IJ(NU,NU),VO_IK(NU,NU)
C      DOUBLE PRECISION VO_JK(NU,NU)
C
C
C      INTEGER INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
C      DOUBLE PRECISION OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
C     &                 OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
C     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C
C      DOUBLE PRECISION TWO,FOUR,EIGHT,ZERO,HALF,ONE
C      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,ZERO/0.0D+00/,
C     *     HALF/0.5D+00/,ONE/1.0D+00/
C
C      INTEGER         D_VR,D_VR_IBT,D_VRSYM,D_VR_BIT,D_VR_BI
C      INTEGER         D_VL,D_VL_IBT
C      COMMON /CCDDI / D_VR,D_VR_IBT,D_VRSYM,D_VR_BIT,D_VR_BI,
C     *                D_VL,D_VL_IBT
C
C      LOGICAL BANDC
C
C      INTEGER I,J,K,A,B,C
C      INTEGER DDI_NP,DDI_ME
C      INTEGER DDI_NN,DDI_MY
C      INTEGER SMP_NP,SMP_ME
C
C      INTEGER ICNTR,MYWRK
C      INTEGER IBC,SBC,EBC,NBC
C      INTEGER IJ_COL,IK_COL,JK_COL,IJ_PREV
C
C      DOUBLE PRECISION DI,DIJ,DIJK,DC,DBC,DABC,DENOM,D1,D2,D3,F
C      DOUBLE PRECISION XT111,XT21,X1,X2,CF
C
C      DOUBLE PRECISION VO_JBCK,T1_KC,T1_JB,T1_JBXKC,T2_JBCK,TEST(3)
C
C      INTEGER NO2,NU2,NU3,NOU,NO2U2
C
C      NO2 = NO*NO
C      NU2 = NU*NU
C      NU3 = NU*NU2
C      NOU = NO*NU
C      NO2U2 = NOU*NOU
C
C      ODS_S=ZERO
C      ODS_D=ZERO
C
C      CALL DDI_NPROC(DDI_NP,DDI_ME)
C      CALL DDI_NNODE(DDI_NN,DDI_MY)
C      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
C
C      IF(DDI_ME.EQ.0) THEN
C         READ(NT1,REC=1)T1
C         CALL TRPOSE(T1,TMP,NO,NU,1)
C         CALL RO2(1,NO,NU,T2)
C      END IF
C
C      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NBC,SBC)
C      EBC = SBC + NBC - 1
C
C      WRITE(6,*) 'POINT 3'
C      CALL FLSHBF(6)
C
C! --------------------------------------------------------
C! GET T1 AND T2 ... THIS WILL BE REPLACED ... BOTTLENECK!
C! --------------------------------------------------------
C      CALL DDI_BCAST(234,'F',T1,NOU,0)
C      IF(SMP_ME.EQ.0) CALL DDI_MASTERS_BCAST(345,'F',T2,NO2U2,0)
C      CALL DDI_SMP_SYNC()
C
C      CALL INSITU_SMP(NO,NU,NU,NO,TMP,T2,12) ! (I,A,B,J) -> (A,I,B,J)
C      CALL INSITU_SMP(NU,NO,NU,NO,TMP,T2,23) ! (A,I,B,J) -> (A,B,I,J)
C
C!-
C! INITIALIZE VARIABLES
C!
C      ICNTR   = -1
C      IJ_PREV =  0
C
C!-
C! GET FIRST WORK PACKET
C!
C      CALL DDI_DLBRESET()
C      IF(SMP_ME.EQ.0) CALL DDI_DLBNEXT(MYWRK)
C      CALL DDI_SMP_BCAST(1234,'I',MYWRK,1,0)
C
C      DO 1 I = 1,NO
C         DI = EH(I)
C      DO 1 J = 1,I
C         DIJ = DI + EH(J)
C      DO 1 K = 1,J
C         IF(I.EQ.K) GOTO 1
C!-
C! DYNAMIC LOAD BALANCE
C!-
C         ICNTR = ICNTR + 1
C         IF(ICNTR.NE.MYWRK) GOTO 1
C! -
C! IJK WORK PACKET
C! -
C         DIJK   = DIJ + EH(K)
C! -
C! GLOBAL COLUMN IDS FOR EACH OCCUPPIED PAIR
C! -
C         IJ_COL = (J-1)*NO + I
C         JK_COL = (K-1)*NO + J
C         IK_COL = (K-1)*NO + I
C
C         IF(SMP_ME.EQ.0) THEN
C         IF(IJ_COL.NE.IJ_PREV)
C     &   CALL DDI_GET(D_VR_BI,1,NU2,IJ_COL,IJ_COL,VO_IJ)
C         CALL DDI_GET(D_VR_BI,1,NU2,JK_COL,JK_COL,VO_JK)
C         CALL DDI_GET(D_VR_BI,1,NU2,IK_COL,IK_COL,VO_IK)
C         END IF
C
C         IF(IJ_COL.NE.IJ_PREV)
C     &   CALL DDI_SMP_BCAST(1234,'F',VO_IJ,NU2,0)
C         CALL DDI_SMP_BCAST(1234,'F',VO_JK,NU2,0)
C         CALL DDI_SMP_BCAST(1234,'F',VO_IK,NU2,0)
C         CALL DDI_SMP_SYNC()
C! -
C! DIVIDE LOCAL WORK INTO NU2 PIECES
C! -
C         IBC = 0
C         DO 2 C = 1,NU
C            T1_KC = T1(C,K)
C         DO 2 B = 1,NU
C            IBC = IBC + 1
C            IF(IBC.LT.SBC .OR. IBC.GT.EBC) GOTO 2
C            BANDC = B.EQ.C
C            T1_JB = T1(B,J)
C            VO_JBCK = VO_JK(B,C)
C         DO 20 A = 1,NU
C            IF(A.EQ.B .AND. BANDC) GOTO 20
C            T3(A,B,C) = T1(A,I)*VO_JBCK
C     &                  + T1_JB*VO_IK(A,C)
C     &                  + T1_KC*VO_IJ(A,B)
C   20    CONTINUE
C    2    CONTINUE
C
C         X1 = ZERO
C         X2 = ZERO
C         CALL DCOPY(NU2,T2(1,1,I,K),1,VO_IK,1)
C         CALL DCOPY(NU2,T2(1,1,I,J),1,VO_JK,1) ! USE VO_JK FOR VO_IJ
C         CALL DDI_SMP_SYNC()                   ! VO_IJ IS STILL IN USE
C
C         IBC = 0
C         DO 3 C = 1,NU
C            DC = EP(C)
C            T1_KC = T1(C,K)
C         DO 3 B = 1,NU
C            IBC = IBC + 1
C            IF(IBC.LT.SBC .OR. IBC.GT.EBC) GOTO 3
C            DBC = EP(B) + DC
C            BANDC = B.EQ.C
C            T1_JB = T1(B,J)
C            T1_JBXKC = T1_JB*T1_KC
C            T2_JBCK = T2(B,C,J,K)
C         DO 30 A = 1,NU
C            IF(A.EQ.B .AND. BANDC) GOTO 30
C            DABC  = EP(A) + DBC
C            DENOM = DIJK - DABC
C            DENOM = 1/DENOM
C
C            XT111 = T1(A,I)*T1_JBXKC
C            XT21  = T1(A,I)*T2_JBCK
C     &              + T1_JB*VO_IK(A,C)
C     &              + T1_KC*VO_JK(A,B)
C
C            D1 = T3(A,B,C)
C            D2 = T3(A,C,B) + T3(C,B,A) + T3(B,A,C)
C            D3 = T3(B,C,A) + T3(C,A,B)
C
C            F = D1*EIGHT - D2*FOUR + D3*TWO
C
C            X1 = X1 + F*XT111*DENOM
C            X2 = X2 + F*XT21*DENOM
C
C   30    CONTINUE
C    3    CONTINUE
C
C         CF = ONE
C         IF(I.EQ.J .OR. J.EQ.K) CF = HALF
C         ODS_S = ODS_S + CF*X1
C         ODS_D = ODS_D + CF*X2
C
C         IJ_PREV = IJ_COL
C
C         IF(SMP_ME.EQ.0) CALL DDI_DLBNEXT(MYWRK)
C         CALL DDI_SMP_BCAST(1234,'I',MYWRK,1,0)
C
C    1 CONTINUE
C
C      CALL DDI_GSUMF(1234,ODS_S,1)
C      CALL DDI_GSUMF(1234,ODS_D,1)
C
C      WRITE (6,*) 'NEW ODS_S = ',ODS_S
C      WRITE (6,*) 'NEW ODS_D = ',ODS_D
C      CALL FLSHBF(6)
C
C! -----------------------------------
C! RESTORE T2 TO ORIGINAL FORAM
C! -----------------------------------
C      CALL INSITU_SMP(NU,NO,NU,NO,TMP,T2,23) ! (A,I,B,J) -> (A,B,I,J)
C      CALL INSITU_SMP(NO,NU,NU,NO,TMP,T2,12) ! (I,A,B,J) -> (A,I,B,J)
C
C      RETURN
C      END
C
C*MODULE DDICC   *DECK DDCC_T_NODE
      SUBROUTINE DDCC_T_NODE(NO,NU,T1,T2,VM,VOE,V3,T3,O1,TMP,EH,EP)
      IMPLICIT NONE
C
      INTEGER NO,NU
C
      DOUBLE PRECISION T1(1),T2(1),VM(1),V3(1),T3(*),VOE(1),O1(1),
     *                 EH(NO),EP(NU),TMP(1)
      DOUBLE PRECISION CPU,CPU0
C
      INTEGER MAXWRK,MYTASK
      INTEGER PARTIAL,DIVISOR
      INTEGER NO2,NO3,NU2,NU3,NMO
C
      INTEGER DDI_NP,DDI_ME,SMP_ME,SMP_NP,SR,NR,A,DDI_NN,DDI_MY
      INTEGER I,J,K
C
      INTEGER ME,MASTER,NPROC,IBTYP,IPTIM
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DOUBLE PRECISION OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D+00)
C
      CALL TSECND(CPU0)
C        ZERO VARIOUS SUMS CONTRIBUTING TO TRIPLES ENERGY
      OTS=ZERO
      ODS=ZERO
      ETD=ZERO
C
      NO2 = NO*NO
      NO3 = NO2*NO
      NU2 = NU*NU
      NU3 = NU2*NU
      NMO = NO + NU
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_NNODE(DDI_NN,DDI_MY)
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
C
C      IF(SMP_ME.EQ.0) CALL ZEROMA(V3,1,NU3)
C
      CALL ZEROMA_SMP(V3,1,NU3)
      CALL ZEROMA(T1,1,NO*NU)
C
      CALL DDI_SMP_SYNC()
C
      IF(MASWRK) THEN
C              SINCE THERE'S ONLY ONE ACTIVE TRIPLES ROUTINE,
C              THERE'S NOT MUCH POINT IN PRINTING WHICH ONE WE ARE IN.
C---        WRITE(6,*) 'RUNNING NODE-BASED (T) CORRECTION'
        CALL RO1(1,NO,NU,O1)
C              READING VM INTO T2 TEMPORARILIY TO DO THE
C              VMCP1 TRANSFORMATION WITHOUT AN EXTRA COPY
        CALL CCSD_RDVM(NO,NU,T2,VM)
        CALL VMCP1(NO,NU,VM,T2)
        CALL TRANMD(VM,NO,NU,NO,NO,13)
        CALL RO2(1,NO,NU,T2)
        CALL INSITU(NO,NU,NU,NO,V3,T2,13)
        CALL DDCC_T_GETVOE(NO,NU,VOE)
      END IF
C
      IF(SMP_ME.EQ.0) THEN
        CALL DDI_MASTERS_BCAST(110,'F',VM,NO3*NU,0)
        CALL DDI_MASTERS_BCAST(111,'F',T2,NO2*NU2,0)
        CALL DDI_MASTERS_BCAST(112,'F',VOE,NO2*NU2,0)
      END IF
      CALL DDI_BCAST(1234,'F',O1,NO*NU,0)
      CALL DDI_SMP_SYNC()
C
      MAXWRK = (NO*(NO-1)*(NO-2))/6
      CALL DIV_EVEN(MAXWRK,DDI_NN,DDI_MY,NR,SR)
      SR = SR - 1
      DIVISOR = 10
      IF(NR.LT.10) DIVISOR = NR
      PARTIAL = NR/DIVISOR
C
C      CALL DDI_DLBNEXT(MYTASK)
      CALL DDI_SMP_SYNC()
C      DO WHILE(MYTASK.LT.MAXWRK)
      IF(DDI_ME.GE.0) THEN
C
      DO A = SR, SR + NR - 1
         MYTASK = A
         CALL DDCC_T_TASK(MYTASK,NO,I,J,K)
C
C GIVE A LITTLE BIT OF OUTPUT TO SHOW IT IS STILL WORKING HARD...
C OTHERWISE LARGE RUNS DON'T PRINT ANYTHING FOR A VERY LONG TIME!
C
         IF(MOD(MYTASK,PARTIAL).EQ.0.AND.MASWRK.AND.NMO.GT.200) THEN
            CALL TSECND(CPU)
            CPU=CPU-CPU0
            WRITE(6,9010) MYTASK/PARTIAL*DIVISOR,CPU
            CALL FLSHBF(6)
         END IF
C
C CALCULATE THE UNIQUE TUPLE
C
         CALL DDI_SMP_SYNC()
         CALL DDCC_T_IJK_BIG(NO,NU,I,J,K,T1,T2,VM,
     *                   V3,T3,VOE,O1,TMP,EH,EP)
         CALL DDI_SMP_SYNC()
C
C POSSIBLY, UNDER CERTAIN CIRCUMSTANCES, CALCULATE A UNIQUE PAIR
         IF(K.EQ.(J-1)) THEN              ! CALC IJ PAIR
           CALL DDCC_T_IJJ_BIG(NO,NU,I,J,T1,T2,VM,V3,T3,VOE,
     *                    O1,EH,EP,TMP)
           CALL DDCC_T_IIJ_BIG(NO,NU,I,J,T1,T2,VM,V3,T3,VOE,
     *                    O1,EH,EP,TMP)
         END IF
C
         IF(K.EQ.1) THEN
            IF(J.EQ.2.AND.I.EQ.3) THEN    ! CALC JK PAIR = (1,2)
              CALL DDCC_T_IJJ_BIG(NO,NU,J,K,T1,T2,VM,V3,T3,VOE,
     *                    O1,EH,EP,TMP)
              CALL DDCC_T_IIJ_BIG(NO,NU,J,K,T1,T2,VM,V3,T3,VOE,
     *                    O1,EH,EP,TMP)
            END IF
C
            IF(J.EQ.(I-1)) THEN           ! CALC IK PAIR = (I,1)
              CALL DDCC_T_IJJ_BIG(NO,NU,I,K,T1,T2,VM,V3,T3,VOE,
     *                    O1,EH,EP,TMP)
              CALL DDCC_T_IIJ_BIG(NO,NU,I,K,T1,T2,VM,V3,T3,VOE,
     *                    O1,EH,EP,TMP)
            END IF
C
         END IF
C
C         CALL DDI_DLBNEXT(MYTASK)
      END DO
      ENDIF
C
      CALL DDI_GSUMF(1234,EH,NO)
      CALL DDI_GSUMF(1234,EP,NU)
      CALL DDI_GSUMF(1234,T1,NO*NU)
      CALL DD_T3SQUA_GSUM
C
      IF(MASWRK) THEN
         CALL TRT1(NU,NO,T3,T1)
C           ADDS CONTRIBUTION FROM THE T1 AMPS, TO GO FROM [T] TO (T)
         CALL T1SQ(NO,NU,T3,T1)
         CALL ADDDEN1(NO,NU,T1,EH,EP)
         CALL WO1(4,NO,NU,T1)
      END IF
      RETURN
 9010 FORMAT(1X,'TRIPLES IN PROGRESS, APPROX. ',I3,
     *          '% DONE, CPU SO FAR=',F8.1)
      END
C
C*MODULE DDICC   *DECK DDCC_T_IJK_BIG
      SUBROUTINE DDCC_T_IJK_BIG(NO,NU,I,J,K,T1,T2,VM,V3,T3,VOE,O1,TMP,
     *                          EH,EP)
      IMPLICIT NONE
C
      INTEGER NO,NU,I,J,K
C
      DOUBLE PRECISION T1(*),VM(NO,NU,NO,NO),
     *                 V3(*),T3(*),TMP(NU*NU),
     *                 VOE(1),O1(*),EH(NO),EP(NU),T2(*)
C
      DOUBLE PRECISION DEH
      INTEGER NU2,NOU,ITMP,JTMP,KTMP,SMP_NP,SMP_ME,SR,NR,T2OFF,T3OFF
C
      DOUBLE PRECISION ZERO,ONE,OM
      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00,OM=-1.0D+00)
C
      NU2 = NU*NU
      NOU = NO*NU
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NR,SR)
C
C     THE DCOPY ROUTINES ARE CALLED TO COPY THE PIECE OF THE SHARED
C     MEMEORY ARRAY INTO A REPLICATED MEMORY BUFFER.  WE FOUND WHEN ALL
C     THE PROCESSES READ FROM THE SAME SHARED MEMORY ARRAY A PERFORMANCE
C     PENALTY RESULTED
C
C     ALL THE DGEMMS ARE SPLIT ON THE NODE, THAT IS EACH PROCESS ON A
C     NODE GETS PART OF THE DGEMM.
C
      T2OFF = (I-1)*NU2*NO + SR
      CALL DCOPY(NOU,VM(1,1,K,J),1,TMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TMP,
     *NO,ZERO,V3(SR),NU2)
      CALL TRANT3_SMP(V3,NU,1)
C
      CALL DCOPY(NOU,VM(1,1,J,K),1,TMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TMP,
     *NO,ONE,V3(SR),NU2)
      CALL TRANT3_SMP(V3,NU,4)
C
      T2OFF = (J-1)*NU2*NO + SR
      CALL DCOPY(NOU,VM(1,1,K,I),1,TMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TMP,
     *NO,ONE,V3(SR),NU2)
      CALL TRANT3_SMP(V3,NU,1)
C
      CALL DCOPY(NOU,VM(1,1,I,K),1,TMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TMP,
     *NO,ONE,V3(SR),NU2)
      CALL TRANT3_SMP(V3,NU,5)
C
      T2OFF = (K-1)*NU2*NO + SR
      CALL DCOPY(NOU,VM(1,1,J,I),1,TMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TMP,
     *NO,ONE,V3(SR),NU2)
      CALL TRANT3_SMP(V3,NU,1)
C
      CALL DCOPY(NOU,VM(1,1,I,J),1,TMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TMP,
     *NO,ONE,V3(SR),NU2)
      CALL TRANT3_SMP(V3,NU,4)
C
C  BEGINNING OF NEW STUFF
C
      T3OFF = (SR-1)*NU + 1
C
      IF(SMP_ME.EQ.0) CALL DDCC_T_GETVE(NU,K,TMP,T3)
      CALL TRANMD_SMP(T3,NU,NU,NU,1,23)
      CALL DDI_SMP_SYNC()
C
      T2OFF = (I-1)*NU2*NO + (J-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,1)
      CALL TRANT3_SMP(V3,NU,5)
C
      T2OFF = (J-1)*NU2*NO + (I-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,4)
      IF(SMP_ME.EQ.0) THEN
      CALL DDCC_T_GETVE(NU,J,TMP,T3)
      END IF
      CALL TRANMD_SMP(T3,NU,NU,NU,1,23)
      CALL DDI_SMP_SYNC()
C
      T2OFF = (I-1)*NU2*NO + (K-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,5)
      CALL TRANT3_SMP(V3,NU,1)
      CALL TRANT3_SMP(V3,NU,4)
C
      T2OFF = (K-1)*NU2*NO + (I-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,5)
      IF(SMP_ME.EQ.0) THEN
      CALL DDCC_T_GETVE(NU,I,TMP,T3)
      END IF
      CALL TRANMD_SMP(T3,NU,NU,NU,1,23)
      CALL DDI_SMP_SYNC()
C
      T2OFF = (J-1)*NU2*NO + (K-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,4)
      CALL TRANT3_SMP(V3,NU,1)
C
      T2OFF = (K-1)*NU2*NO + (J-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,5)
C
      IF(SMP_ME.EQ.0) THEN
      CALL ZEROT3(V3,NU) ! ZERO'S OUT THE DIAGONAL
      END IF
C
      CALL T3SQUA_SMP(I,J,K,NO,NU,O1,T2,V3,EH,EP)
      DEH=EH(I)+EH(J)+EH(K)
      CALL ADT3DEN_SMP(NU,DEH,V3,EP)
C
      ITMP=I
      JTMP=J
      KTMP=K
      CALL DRT1WT3IJK_SMP(ITMP,JTMP,KTMP,NO,NU,T1,VOE,V3,T3)
      RETURN
      END
C
C*MODULE DDICC   *DECK DDCC_T_IJJ
      SUBROUTINE DDCC_T_IJJ_BIG(NO,NU,I,J,T1,T2,VM,
     *                      V3,T3,VOE,O1,EH,EP,TEMP)
      IMPLICIT NONE
C
      INTEGER I,J,NO,NU
C
      DOUBLE PRECISION T2(*),VM(NO,NU,NO,NO),VOE(1),TEMP(1),
     *                 T1(1),T3(*),V3(*),O1(1),EH(NO),
     *                 EP(NU)
C
      INTEGER NU2,NOU,T2OFF,T3OFF
      INTEGER ITMP,JTMP,SMP_NP,SMP_ME,NR,SR
      DOUBLE PRECISION DEH
C
      DOUBLE PRECISION ZERO,ONE,OM
      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00,OM=-1.0D+00)
C
      NU2 = NU*NU
      NOU = NO*NU
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NR,SR)
C
      T2OFF = (I-1)*NU2*NO + SR
      CALL DDI_SMP_SYNC()
      CALL DCOPY(NOU,VM(1,1,J,J),1,TEMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TEMP,
     *NO,ZERO,V3(SR),NU2)
C
      CALL TRANT3_SMP(V3,NU,2)
C
      T2OFF = (J-1)*NU2*NO + SR
      CALL DCOPY(NOU,VM(1,1,J,I),1,TEMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TEMP,
     *NO,ONE,V3(SR),NU2)
C
      CALL TRANT3_SMP(V3,NU,1)
C
      CALL DCOPY(NOU,VM(1,1,I,J),1,TEMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TEMP,
     *NO,ONE,V3(SR),NU2)
C
      CALL TRANT3_SMP(V3,NU,4)
      IF(SMP_ME.EQ.0) THEN
      CALL DDCC_T_GETVE(NU,J,TEMP,T3)
      END IF
      CALL TRANMD_SMP(T3,NU,NU,NU,1,23)
      CALL DDI_SMP_SYNC()
C
      T3OFF = (SR-1)*NU + 1
C
      T2OFF = (I-1)*NU2*NO + (J-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TEMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TEMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,3)
C
      T2OFF = (J-1)*NU2*NO + (I-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TEMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TEMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,1)
      IF(SMP_ME.EQ.0) THEN
      CALL DDCC_T_GETVE(NU,I,TEMP,T3)
      END IF
      CALL TRANMD_SMP(T3,NU,NU,NU,1,23)
      CALL DDI_SMP_SYNC()
C
      T2OFF = (J-1)*NU2*NO + (J-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TEMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TEMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,2)
      IF(SMP_ME.EQ.0) THEN
      CALL SYMT311(V3,NU,23)
      CALL ZEROT3(V3,NU)
      END IF
      CALL T3SQUA_SMP(I,J,J,NO,NU,O1,T2,V3,EH,EP)
      DEH=EH(I)+EH(J)+EH(J)
      CALL ADT3DEN_SMP(NU,DEH,V3,EP)
      ITMP=I
      JTMP=J
C
      CALL DRT1WT3IJ_SMP(ITMP,JTMP,NO,NU,T1,VOE,V3,T3)
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE DDICC   *DECK DDCC_T_IIJ
      SUBROUTINE DDCC_T_IIJ_BIG(NO,NU,I,J,T1,T2,VM,
     *                      V3,T3,VOE,O1,EH,EP,TEMP)
      IMPLICIT NONE
C
C
      INTEGER I,J,NO,NU
C
      DOUBLE PRECISION T2(*),VM(NO,NU,NO,NO),VOE(1),TEMP(1),
     *                 T1(1),T3(*),V3(*),O1(1),EH(NO),
     *                 EP(NU)
C
      INTEGER NU2,NOU,SMP_ME,SMP_NP,SR,NR,T2OFF,T3OFF
      INTEGER ITMP,JTMP
      DOUBLE PRECISION DEH
C
      DOUBLE PRECISION ZERO,ONE,OM
      PARAMETER(ZERO=0.0D+00,ONE=1.0D+00,OM=-1.0D+00)
C
      NU2 = NU*NU
      NOU = NO*NU
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NR,SR)
C
      CALL DDI_SMP_SYNC()
C
      T2OFF = (I-1)*NU2*NO + SR
      CALL DCOPY(NOU,VM(1,1,J,I),1,TEMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TEMP,
     *NO,ZERO,V3(SR),NU2)
C
      CALL TRANT3_SMP(V3,NU,1)
C
      CALL DCOPY(NOU,VM(1,1,I,J),1,TEMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TEMP,
     *NO,ONE,V3(SR),NU2)
C
      CALL TRANT3_SMP(V3,NU,2)
C
      T2OFF = (J-1)*NU2*NO + SR
      CALL DCOPY(NOU,VM(1,1,I,I),1,TEMP,1)
      CALL DGEMM('N','N',NR,NU,NO,OM,T2(T2OFF),NU2,TEMP,
     *NO,ONE,V3(SR),NU2)
C
      CALL TRANT3_SMP(V3,NU,2)
      IF(SMP_ME.EQ.0) THEN
      CALL DDCC_T_GETVE(NU,J,TEMP,T3)
      END IF
      CALL TRANMD_SMP(T3,NU,NU,NU,1,23)
      CALL DDI_SMP_SYNC()
C
      T3OFF = (SR-1)*NU + 1
C
      T2OFF = (I-1)*NU2*NO + (I-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TEMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TEMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,1)
      IF(SMP_ME.EQ.0) THEN
      CALL DDCC_T_GETVE(NU,I,TEMP,T3)
      END IF
      CALL TRANMD_SMP(T3,NU,NU,NU,1,23)
      CALL DDI_SMP_SYNC()
C
      T2OFF = (I-1)*NU2*NO + (J-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TEMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TEMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,3)
C
      T2OFF = (J-1)*NU2*NO + (I-1)*NU2 + 1
      CALL DCOPY(NU2,T2(T2OFF),1,TEMP,1)
      CALL DGEMM('N','N',NU,NR,NU,ONE,TEMP,NU,T3(T3OFF),
     *NU,ONE,V3(T3OFF),NU)
C
      CALL TRANT3_SMP(V3,NU,3)
      IF(SMP_ME.EQ.0) THEN
      CALL SYMT311(V3,NU,12)
      CALL ZEROT3(V3,NU)
C     IF(IDISC.EQ.0.AND.MET.GT.4) THEN
C     CALL WRT3(KK,NU,V3)
C     END IF
      END IF
      CALL T3SQUA_SMP(I,I,J,NO,NU,O1,T2,V3,EH,EP)
      DEH=EH(I)+EH(I)+EH(J)
      CALL ADT3DEN_SMP(NU,DEH,V3,EP)
      ITMP=I
      JTMP=J
      CALL DRT1WT3JK_SMP(ITMP,JTMP,NO,NU,T1,VOE,V3,T3)
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK TRANT3
      SUBROUTINE TRANT3_SMP(V,NU,ID)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      DIMENSION V(NU,NU,NU)
      INTEGER SMP_ME,SMP_NP
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      GO TO (1,2,3,4,5),ID
    1 CONTINUE
      DO 101 B=1,NU
        IF(MOD(B,SMP_NP).NE.SMP_ME) GOTO 101
      DO 100 C=1,B
      DO 100 A=1,NU
      X=V(A,B,C)
      V(A,B,C)=V(A,C,B)
      V(A,C,B)=X
  100 CONTINUE
  101 CONTINUE
      GO TO 1000
    2 CONTINUE
      DO 201 C=1,NU
        IF(MOD(C,SMP_NP).NE.SMP_ME) GOTO 201
      DO 200 A=1,NU
      DO 200 B=1,A
      X=V(A,B,C)
      V(A,B,C)=V(B,A,C)
      V(B,A,C)=X
  200 CONTINUE
  201 CONTINUE
      GO TO 1000
    3 CONTINUE
      DO 301 B=1,NU
        IF(MOD(B,SMP_NP).NE.SMP_ME) GOTO 301
      DO 300 A=1,NU
      DO 300 C=1,A
      X=V(A,B,C)
      V(A,B,C)=V(C,B,A)
      V(C,B,A)=X
  300 CONTINUE
  301 CONTINUE
      GO TO 1000
    4 CONTINUE
      DO 401 B=1,NU
        IF(MOD(B,SMP_NP).NE.SMP_ME) GOTO 401
      DO 400 C=1,B
      DO 400 A=1,C
      X=V(A,B,C)
      V(A,B,C)=V(B,C,A)
      V(B,C,A)=V(C,A,B)
      V(C,A,B)=X
      IF(B.EQ.C.OR.C.EQ.A) GO TO 400
      X=V(B,A,C)
      V(B,A,C)=V(A,C,B)
      V(A,C,B)=V(C,B,A)
      V(C,B,A)=X
  400 CONTINUE
  401 CONTINUE
      GO TO 1000
    5 CONTINUE
      DO 501 A=1,NU
        IF(MOD(A,SMP_NP).NE.SMP_ME) GOTO 501
      DO 500 C=1,A
      DO 500 D=1,C
      X=V(C,D,A)
      V(C,D,A)=V(A,C,D)
      V(A,C,D)=V(D,A,C)
      V(D,A,C)=X
      IF (A.EQ.C.OR.C.EQ.D) GO TO 500
      X=V(A,D,C)
      V(A,D,C)=V(C,A,D)
      V(C,A,D)=V(D,C,A)
      V(D,C,A)=X
  500 CONTINUE
  501 CONTINUE
      GO TO 1000
 1000 CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK ADT3DEN_SMP
      SUBROUTINE ADT3DEN_SMP(NU,DEH,T3,EP)
      IMPLICIT NONE
      INTEGER A,B,C,NU,SMP_ME,SMP_NP
      DOUBLE PRECISION T3(NU,NU,NU),EP(NU),DEH,DEN
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DO 11 A=1,NU
        IF(MOD(A,SMP_NP).NE.SMP_ME) GOTO 11
      DO 10 B=1,NU
      DO 10 C=1,NU
      DEN=DEH-EP(A)-EP(B)-EP(C)
      T3(A,B,C)=T3(A,B,C)/DEN
 10   CONTINUE
 11   CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK T3SQUA_SMP
      SUBROUTINE T3SQUA_SMP(I,J,K,NO,NU,T1,T2,T3,EH,EP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL IEJ,JEK
      INTEGER A,B,C,SMP_NP,SMP_ME
      DIMENSION T1(NO,NU),T2(NU,NU,NO,NO),T3(NU,NU,NU),EH(NO),EP(NU)
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,ZERO/0.0D+00/,
     *     HALF/0.5D+00/,ONE/1.0D+00/
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DIJK=EH(I)+EH(J)+EH(K)
      X1=ZERO
      X2=ZERO
      X3=ZERO
      DO 151 C=1,NU
      IF(MOD(C,SMP_NP).NE.SMP_ME) GOTO 151
      DC = EP(C)
      T1_KC = T1(K,C)
      DO 150 B=1,NU
      DBC = EP(B) + DC
      T1_JB = T1(J,B)
      T1_JBXKC = T1_JB*T1_KC
      T2_BCKJ = T2(B,C,K,J)
      DO 150 A=1,NU
      IF (A.EQ.B.AND.B.EQ.C) GO TO 150
      DABC = EP(A) + DBC
      DENOM=DIJK-DABC
      DENOM=1/DENOM
      XT111=T1(I,A)*T1_JBXKC
      XT21=T1(I,A)*T2_BCKJ+T1_JB*T2(A,C,K,I)+T1_KC*T2(A,B,J,I)
      D1=  T3(A,B,C)
      D2=  T3(A,C,B)+T3(C,B,A)+T3(B,A,C)
      D3=  T3(B,C,A)+T3(C,A,B)
      F=D1*EIGHT-FOUR*D2+D3*TWO
      X1=X1+F*XT111*DENOM
      X2=X2+F*XT21*DENOM
      X3=X3+F*D1*DENOM
 150  CONTINUE
 151  CONTINUE
      CF=ONE
      IEJ=I.EQ.J
      JEK=J.EQ.K
      IF(IEJ.OR.JEK) CF=HALF
      OTS=OTS+CF*X1
      OTD=OTD+CF*X2
      ETD=ETD+CF*X3
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK T1WT3IJK_SMP
      SUBROUTINE T1WT3IJK_SMP(I,J,K,NO,NU,T1,VOE,TI,T3)
      IMPLICIT NONE
      INTEGER SMP_NP,SMP_ME,NR,SR,T3OFF,VOEOFF,I,J,K,NO,NU,NU2
      DOUBLE PRECISION T1(NU,NO),VOE(*),T3(1),TI(1),ONE
      DATA ONE/1.0D+00/
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
C
      NU2 = NU*NU
      CALL SMT3FOUR_SMP(NU,T3,TI)
      CALL DIV_EVEN(NU2,SMP_NP,SMP_ME,NR,SR)
      T3OFF = (SR - 1)*NU + 1
      VOEOFF = (K - 1)*NU2*NO + (J - 1)*NU2  + SR
      CALL DGEMM('N','N',NU,1,NR,ONE,T3(T3OFF),NU,VOE(VOEOFF),NU2,ONE,
     *           T1(1,I),NU)
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK DRT1WT3IJ_SMP
      SUBROUTINE DRT1WT3IJ_SMP(I,J,NO,NU,T1,VOE,TI,T3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T1(1),VOE(1),T3(1),TI(1)
C
      CALL T1WT3IJK_SMP(I,J,J,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,2)
      CALL T1WT3IJK_SMP(J,I,J,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,1)
      CALL T1WT3IJK_SMP(J,J,I,NO,NU,T1,VOE,TI,T3)
      RETURN
      END
C
C*MODULE CCDDI   *DECK DRT1WT3JK_SMP
      SUBROUTINE DRT1WT3JK_SMP(J,K,NO,NU,T1,VOE,TI,T3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T1(1),VOE(1),T3(1),TI(1)
C
      CALL T1WT3IJK_SMP(J,J,K,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,1)
      CALL T1WT3IJK_SMP(J,K,J,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,2)
      CALL T1WT3IJK_SMP(K,J,J,NO,NU,T1,VOE,TI,T3)
      RETURN
      END
C
C*MODULE CCDDI   *DECK DRT1WT3IJK_SMP
      SUBROUTINE DRT1WT3IJK_SMP(I,J,K,NO,NU,T1,VOE,TI,T3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T1(1),VOE(1),T3(1),TI(1)
C
      CALL T1WT3IJK_SMP(I,J,K,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,1)
      CALL T1WT3IJK_SMP(I,K,J,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,4)
      CALL T1WT3IJK_SMP(J,I,K,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,1)
      CALL T1WT3IJK_SMP(J,K,I,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,5)
      CALL T1WT3IJK_SMP(K,I,J,NO,NU,T1,VOE,TI,T3)
      CALL TRANT3_SMP(TI,NU,1)
      CALL T1WT3IJK_SMP(K,J,I,NO,NU,T1,VOE,TI,T3)
      RETURN
      END
C
C*MODULE CCDDI   *DECK SMT3FOUR_SMP
      SUBROUTINE SMT3FOUR_SMP(NU,T3,V3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,SMP_ME,SMP_NP
      DIMENSION T3(NU,NU,NU),V3(NU,NU,NU)
      DATA TWO/2.0D+00/
C
      CALL DDI_SMP_NPROC(SMP_NP,SMP_ME)
      CALL DDI_SMP_SYNC()
C
      DO 2 C=1,NU
        IF(MOD(C,SMP_NP).NE.SMP_ME) GOTO 2
      DO 1 B=1,NU
      DO 1 A=1,NU
         T3(A,B,C)=(V3(A,B,C)-V3(B,A,C))*TWO-V3(A,C,B)+V3(B,C,A)
 1    CONTINUE
 2    CONTINUE
      CALL DDI_SMP_SYNC()
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_STORE_TRAN2
      SUBROUTINE CCSD_STORE_TRAN2(ISH,KSH,LENI,LENK,NU,TRAN2,NFT80)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER ISH,KSH,LENI,LENK,NU
      DOUBLE PRECISION TRAN2(*)
      INTEGER I,NU2,LEN
      INTEGER DDI_NP,DDI_ME
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      NU2 = NU*NU
      LEN = LENI*LENK*NU2
      WRITE(NFT80) ISH
      WRITE(NFT80) KSH
      WRITE(NFT80) LEN
      WRITE(NFT80) (TRAN2(I),I=1,LEN)
C     IF(DDI_ME.EQ.1)
C    &WRITE(6,FMT='(3I10,2F15.10)') ISH,KSH,LEN,TRAN2(1),TRAN2(LEN)
C
      RETURN
      END
C
C*MODULE CCDDI   *DECK CCSD_PROCESS_TRAN2
      SUBROUTINE CCSD_PROCESS_TRAN2(NO,NU,D_VVVV,O2,TRAN1,TRAN2,
     *                              CLRSIZE,NFT80,TIMERS)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER NO,NU,D_VVVV
      PARAMETER(NTIMERS=5)
      DOUBLE PRECISION O2(*),TRAN1(*),TRAN2(*),TIMERS(NTIMERS)
      INTEGER I,ISH,KSH,LEN,IBLK,INFO(2,5)
      INTEGER DDI_NP,DDI_ME,CLRSIZE
C
      IBLK = 1
      CALL DDI_NPROC(DDI_NP,DDI_ME)
C
      DO WHILE(IBLK.EQ.1)
C
         CALL DCOPY(CLRSIZE,0.0D+00,0,TRAN1,1)
C
         READ(NFT80,END=99,ERR=911) ISH
         READ(NFT80,ERR=911) KSH
         READ(NFT80,ERR=911) LEN
         READ(NFT80,ERR=911) (TRAN1(I),I=1,LEN)
C
         INFO(1,IBLK) = ISH
         INFO(2,IBLK) = KSH
C
C        IF(DDI_ME.EQ.1) THEN
C           WRITE(6,FMT='(3I10,2F15.10)')ISH,KSH,LEN,TRAN1(1),TRAN1(LEN)
C        END IF
         CALL CCSD_O2XVVNN(NO,NU,D_VVVV,IBLK,INFO,
     &                        TIMERS,O2,TRAN1,TRAN2)
      END DO
C
  911 WRITE(6,*) 'ERROR READING FILE 80 IN CCSD_PROCESS_TRAN2'
      STOP
C
   99 CONTINUE
      RETURN
      END
