C  7 Dec 07 - MWS - change printing of some references
C 28 Aug 07 - PP  - change the printing formats, again
C 20 Aug 07 - JRG - permit all runs but NOA.gt.NUB, return type A energy
C 25 Jun 07 - JRG - permit frozen virtuals, fix INTERM2 record length
C 21 May 07 - PP,MW,JRG - new module for open shell CCSD and CR-CC(2,3)
C
C*MODULE ROHFCC  *DECK ROCCDRVR
      SUBROUTINE ROCCDRVR(BESTCC,EOM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL EOM
      LOGICAL CNVR,PACK2E
C
      PARAMETER (MXATM=2000, MXRT=100)
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 /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                MXCCIT,MXRLEIT,NWRDCC,ICCCNV,ICCRST,IDSKCC
      COMMON /ENRGYS/ VNN,EELCT,ETOTX,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / XX(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TEN=1.0D+01)
C
      DATA CHECK/8HCHECK   /
C
C          ---- main driver for open-shell CC calculations ----
C            Marta Wloch, Jeffrey R. Gour, and Piotr Piecuch
C           Department of Chemistry, Michigan State University
C
C     Interfaced to GAMESS in April 2007. For information on the
C     unique features of this code, the open-shell completely
C     renormalized coupled-cluster methods and the underlying theory,
C     see the following:
C     M. Wloch, J.R. Gour, and P. Piecuch,
C               J. Phys. Chem. A, 111, 11359-11382(2007)
C     P. Piecuch and M. Wloch, J. Chem. Phys. 123, 224105 (2005)
C     P. Piecuch, M. Wloch, J.R. Gour, and A. Kinal,
C               Chem. Phys. Lett. 418, 467-474 (2006).
C
      WRITE(IW,9000)
      WRITE(IW,9010)
C
C          this lets us keep -eom- in the args, as a "used" variable,
C          for whenever an actual excited state code is programmed.
C
      IF(EOM) THEN
         WRITE(IW,*) 'THERE IS NO EOM CODE FOR OPEN SHELLS'
         CALL ABRT
      END IF
C
C        Multiplicity in open shell CCSD can be higher than in the SCF.
C        The multiplicity of the open shell CCSD defines orbital counts.
C
      NELS = NA + NB
      NOA = (NELS+MULOPCC-1)/2
      NOB = (NELS-MULOPCC+1)/2
      NELS = NOA + NOB
      IF(NELS.NE.(NA+NB)) THEN
         WRITE(IW,9020) MUL,NA,NB,MULOPCC,NOA,NOB
         CALL ABRT
      END IF
C                virtual space drops any frozen virtuals, off the top.
      NUA = NQMT - NCCFZV - NOA
      NUB = NQMT - NCCFZV - NOB
C                occupied space drops any frozen cores.
      NOA = NOA  - NCCFZC
      NOB = NOB  - NCCFZC
C
C        trivial problems should have DIIS interpolation turned off
C
      IF(NOB.EQ.1  .AND.  NUA.EQ.1  .AND.  MULOPCC.LE.2) THEN
         KMICRO=0
         LMICRO=0
      END IF
C
      IF (IOPCCREF.EQ.2) WRITE(IW,9030) MUL
      IF (IOPCCREF.EQ.3) WRITE(IW,9040) MUL
      WRITE(IW,9050) MULOPCC,NOA,NCCFZC,NOB,NCCFZC,NUA,NUB,
     *               MXCCIT,TEN**(-ICCCNV),
     *               KREST,KMICRO,LREST,LMICRO,IOPCCMET
      IF (NCCFZV.GT.0) WRITE(IW,9060) NCCFZV
C
C        A desire to have DIIS turned off is input of 0.
C        Now that we've printed the 0, we actually do this by setting
C        the number of iterations to DIIS as one more than the maximum.
C        We also turn off DIIS for trivial problems.
C
      IF(KMICRO.EQ.0) KMICRO=MXCCIT+1
      IF(LMICRO.EQ.0) LMICRO=MXCCIT+1
C
C        the code presumes more virtuals than occupied, and at
C        least one filled ROHF orbital and one empty ROHF orbital.
C
      IF(NOA.EQ.0  .OR.  NOB.EQ.0  .OR.  NUA.EQ.0  .OR.  NUB.EQ.0) THEN
         WRITE(IW,9070) NOA,NUA,NOB,NUB
         CALL ABRT
      END IF
      IF(MAX(NOA,NOB) .GT. MAX(NUA,NUB)) THEN
         WRITE(IW,9080) NOA,NUA,NOB,NUB
         CALL ABRT
      END IF
C
C        Zero out the energy results...
C        ETOTX is the SCF energy, including nuclear repulsion.
C        ECCN is for the use of the FMO method.
C
      EREF = ETOTX
      ENRG = ZERO
      EMP2 = ZERO
      ECCN = ZERO
      DO I=1,6
        ECORR(I)= ZERO
        ETOT(I) = ZERO
      ENDDO
      DIAGS(1) = ZERO
      DIAGS(2) = ZERO
      DIAGS(3) = ZERO
      DO J=1,2
         DO I=1,5
            AMPMX(I,J) = ZERO
            IAMPMX(I,1,J) = 0
            IAMPMX(I,2,J) = 0
            IAMPMX(I,3,J) = 0
            IAMPMX(I,4,J) = 0
         ENDDO
      ENDDO
      XO1 = ONE
      XO2 = ONE
C
C        Copy input data to the CCINFO common, although only
C        a few of the entries are used by open shell code.
C
      TSH   = 0.0D+00
      NH    = NCCOCC-NCCFZC
      NP    = NCCTOT-NCCFZV-NCCOCC
      MET   = 0
      MEM   = 0
      ICONV = ICCCNV
      MAXIT = MXCCIT
      IREST = 0
      IDISC = 0
C
C        Fill /NNROHF/ and /NNMAX/ commons with data on problem size
C
      CALL MKBLOCK(NOA,NUA,NOB,NUB)
C
C        Open every disk file used by open shell CCSD or CR-CC(2,3)
C
      CALL OPCCFILE(NOA,NUA,NOB,NUB)
C
C        The "orbital energies" are held throughout the entire run.
C        These are diagonals of F-alpha + F-beta, not eigenvalues!
C
      CALL VALFM(LOADFM)
      LEHA = LOADFM + 1
      LEHB = LEHA   + NOA
      LEPA = LEHB   + NOB
      LEPB = LEPA   + NUA
      LAST = LEPB   + NUB
      NEEDE = LAST-LOADFM-1
      CALL GETFM(NEEDE)
C
C        ----- prepare Fock matrices, and diagonal elements -----
C        L1 = size of the atomic basis set
C        M1 = range of MOs in CC treatment (cores not included)
C
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
      M1 = NQMT-NCCFZC
      M2 = (M1*M1+M1)/2
      LDW = 2*M1
      LTMP = MAX(L1,NOA**2,NOB**2,NOA*NUA,NOB*NUB,NUA**2,NUB**2)
C
      CALL VALFM(LOADFM)
      LWORK = LOADFM + 1
      LVEC  = LWORK  + MAX(LDW*LDW,L2)
      LFA   = LVEC   + L3
      LFB   = LFA    + M2
      LT1   = LFB    + M2
      LT2   = LT1    + LTMP
      LAST  = LT2    + LTMP
      NEED = LAST-LOADFM-1
C
      WRITE(IW,9090) NEED
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 10
C
      CALL OPCCFOCK(NFT843,NOA,NUA,NOB,NUB,
     *              XX(LEHA),XX(LEPA),XX(LEHB),XX(LEPB),
     *              XX(LWORK),XX(LVEC),XX(LFA),XX(LFB),XX(LT1),XX(LT2),
     *              L1,L2,M1,M2,LDW,LTMP)
C
   10 CONTINUE
      CALL RETFM(NEED)
C
C            ----- prepare 2e- integrals for the run -----
C        The biggest memory used later (in CR-CC(2,3) runs) is
C          0*No**4 + 3*No**3*Nu +  7*No**2*Nu**2 + 4*No*Nu**3
C        for the H-bar intermediates.  CCSD only is smaller,
C          1*No**4 + 1*No**3*Nu +  9*No**2*Nu**2 + 3*No*Nu**3
C
C        The strategy is to form the double bar integrals without
C        using any more memory than is needed by the later steps.
C        The integral sets we are sorting are
C          3*No**4 + 4*No**3*Nu +  7*No**2*Nu**2 + 4*No*Nu**3 + 3*Nu**4
C          <-------------- pass 1 -------------> <- pass 2 -> <-3,4,..->
C        It is almost OK to combine pass 1 and 2, but separate
C        passes are certain to be smaller than CC requirements.
C        Passes 3,4,5... do the Nu**4 set in smaller stripes,
C        containing No * Nu**3 elements of the Nu**4 array.
C
      CALL VALFM(LOADFM)
      LXX    = LOADFM + 1
      LIX    = LXX    + NINTMX
      LASTBF = LIX    + NINTMX
C
C        The arrays which are used only during pass 1...
      LVHHAA   = LASTBF
      LVHHBB   = LVHHAA   + NOA*NOA*NOA*NOA
      LVHHAB   = LVHHBB   + NOB*NOB*NOB*NOB
      LVMAA    = LVHHAB   + NOA*NOB*NOA*NOB
      LVMBB    = LVMAA    + NOA*NOA*NOA*NUA
      LVMAB    = LVMBB    + NOB*NOB*NOB*NUB
      LVMBA    = LVMAB    + NOA*NOB*NUA*NOB
      LVHPRAA  = LVMBA    + NOA*NOB*NOA*NUB
      LVHPRBB  = LVHPRAA  + NUA*NOA*NUA*NOA
      LVHPRAB  = LVHPRBB  + NUB*NOB*NUB*NOB
      LVHPLAA  = LVHPRAB  + NUA*NOA*NUB*NOB
      LVHPLBB  = LVHPLAA  + NUA*NOA*NUA*NOA
      LVHPLAB  = LVHPLBB  + NUB*NOB*NUB*NOB
      LVHPLBA  = LVHPLAB  + NUA*NOB*NUA*NOB
      LAST1    = LVHPLBA  + NUB*NOA*NUB*NOA
C
C        overlap with arrays used only during pass 2...
      LVEAA    = LASTBF
      LVEBB    = LVEAA    + NUA*NUA*NUA*NOA
      LVEAB    = LVEBB    + NUB*NUB*NUB*NOB
      LVEBA    = LVEAB    + NUA*NUB*NOA*NUB
      LAST2    = LVEBA    + NUA*NUB*NUA*NOB
C
C        and also overlap with arrays used during pass 3,4,5...,MXPASS.
      NSLICEA = NOA
      NSLICEB = NOB
      MXPASS  = 2 + MAX((NUA-1)/NSLICEA,(NUB-1)/NSLICEB) + 1
      LVPPAA   = LASTBF
      LVPPBB   = LVPPAA   + NUA*NUA*NUA*NSLICEA
      LVPPAB   = LVPPBB   + NUB*NUB*NUB*NSLICEB
      LAST3    = LVPPAB   + NUA*NUB*NUA*NSLICEB
C
      NEED1 = LAST1-LOADFM-1
      NEED2 = LAST2-LOADFM-1
      NEED3 = LAST3-LOADFM-1
C
      WRITE(IW,9100) NEED1,NEED2,MXPASS,NEED3
C
      NEED = MAX(NEED1,NEED2,NEED3)
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 20
C
      CALL OPCCINTS(IW,IJKT,XX(LXX),XX(LIX),NINTMX,NOA,NOB,NUA,NUB,
     *              XX(LVHHAA),XX(LVHHBB),XX(LVHHAB),
     *              XX(LVMAA),XX(LVMBB),XX(LVMAB),XX(LVMBA),
     *              XX(LVHPRAA),XX(LVHPRBB),XX(LVHPRAB),
     *              XX(LVHPLAA),XX(LVHPLBB),XX(LVHPLAB),XX(LVHPLBA),
     *              XX(LVEAA),XX(LVEBB),XX(LVEAB),XX(LVEBA),
     *              XX(LVPPAA),XX(LVPPBB),XX(LVPPAB),NSLICEA,NSLICEB)
C
   20 CONTINUE
      CALL RETFM(NEED)
C
C           --- that's the end of integral manipulations
C
      WRITE(IW,9110)
      CALL TIMIT(1)
C
C        ----- perform the CCSD amplitude iterations -----
C     and perhaps compute the CR-CC(2,3) triples corrections.
C
      CALL DRCCOPEN(NOA,NUA,NOB,NUB,XX(LEHA),XX(LEPA),XX(LEHB),XX(LEPB))
      CALL RETFM(NEEDE)
C
C        return either CCSD, or the type -A- CR-CC(2,3) energy
C        at this point ENRG is the correlation energy, so add reference.
C
      BESTCC = ENRG + EREF
      RETURN
C
 9000 FORMAT(/3X,68(1H-)/
     *        3X,'OPEN-SHELL COUPLED-CLUSTER PROGRAM:',2X,
     *           'M. WLOCH, J.R. GOUR, P. PIECUCH'/
     *        3X,68(1H-))
 9010 FORMAT(/1X,63(1H*)/
     *        1X,'THE FOLLOWING PAPERS SHOULD BE CITED WHEN USING',
     *        1X,'OPEN-SHELL CCSD',/
     *        1X,'AND/OR CR-CCL COUPLED-CLUSTER OPTIONS:'/
     *        1X,'P. PIECUCH AND M. WLOCH,'/
     *        1X,'  J. CHEM. PHYS. 123, 224105-1 - 224105-10 (2005).'/
     *        1X,'M. WLOCH, J.R. GOUR, AND P. PIECUCH,'/
     *        1X,'  J. PHYS. CHEM. A, 111, 11359-11382 (2007).'/
     *        1X,63(1H*)/)
 9020 FORMAT(1X,'MOLECULAR INPUT HAS MULT=',I3,' IMPLYING',I5,
     *          ' ALPHA, AND',I5,' BETA E-'/
     *       1X,'   $CCINP INPUT HAS MULT=',I3,' IMPLYING',I5,
     *          ' ALPHA, AND',I5,' BETA E-'/
     *       1X,'PLEASE FIX THE DISCREPANCY IN THE TOTAL NUMBER OF',
     *          ' ELECTRONS.')
 9030 FORMAT(1X,'UHF REFERENCE STATE WILL BE USED, MULTIPLICITY=',I3)
 9040 FORMAT(1X,'ROHF REFERENCE STATE WILL BE USED, MULTIPLICITY=',I3)
 9050 FORMAT(/14X,30(1H-)/
     *        14X,'OPEN SHELL CC INPUT PARAMETERS'/
     *        14X,30(1H-)/
     *   5X,'CC SPIN MULTIPLICITY (MULT IN $CCINP)    =',I5/
     *   5X,'IMPLYING NO. OF OCCUP. ALPHA =',I5,
     *      ', PLUS',I4,' FROZEN CORES'/
     *   5X,'         NO. OF OCCUP.  BETA =',I5,
     *      ', PLUS',I4,' FROZEN CORES'/
     *   5X,'         NO. OF VIRT.  ALPHA =',I5/
     *   5X,'         NO. OF VIRT.   BETA =',I5/
     *   5X,'MAX.NO. OF CCSD AND LAMBDA ITERS (MAXCC) =',I5/
     *   5X,'CCSD AND LAMBDA CONVERGENCE (FROM ICONV) =',1P,E12.3/
     *   5X,'CCSD EQUATION RESTART OPTION (KREST)     =',I5/
     *   5X,'CCSD DIIS MICROITERATIONS (KMICRO)       =',I5/
     *   5X,'LAMDA EQUATION RESTART OPTION (LREST)    =',I5/
     *   5X,'LAMBDA DIIS MICROITERATIONS (LMICRO)     =',I5/
     *   5X,'MM(2,3) CODE SELECTION (IOPMET)          =',I5)
 9060 FORMAT(5X,'VIRTUAL ORBITALS ABOVE OMIT',I5,
     *          ' FROZEN (HIGHEST) VIRTUALS.')
 9070 FORMAT(1X,'ERROR.  OPEN SHELL CCSD PROGRAM REQUIRES AT LEAST',
     *          ' ONE ORBITAL'/
     *       1X,'IN EACH OF THE FOUR CLASSES:'/
     *       1X,'OCCUPIED ALPHA=',I5,' VIRTUAL ALPHA=',I5/
     *       1X,'OCCUPIED  BETA=',I5,' VIRTUAL  BETA=',I5)
 9080 FORMAT(1X,'ERROR. THE NUMBER OF OCCUPIED ALPHA ORBITALS' /
     *       1X,'CANNOT EXCEED THE NUMBER OF VIRTUAL BETA ORBITALS'/
     *       1X,'OCCUPIED ALPHA=',I5,' VIRTUAL ALPHA=',I5/
     *       1X,'OCCUPIED  BETA=',I5,' VIRTUAL  BETA=',I5/
     *       1X,'TO RUN, INCREASE THE NUMBER OF VIRTUAL ORBITALS')
 9090 FORMAT(/1X,'MEMORY NEEDED BY FOCK PREPARATION   : ',I12,' WORDS')
 9100 FORMAT(1X,'MEMORY NEEDED BY INT. PASS 1        : ',I12,' WORDS'/
     *       1X,'MEMORY NEEDED BY INT. PASS 2        : ',I12,' WORDS'/
     *    1X,'MEMORY NEEDED BY INT. PASS 3,...,',I3,': ',I12,' WORDS')
 9110 FORMAT(1X,'....... DONE WITH CC INTEGRAL PREPARATION .......')
      END
C
C*MODULE ROHFCC  *DECK MKBLOCK
      SUBROUTINE MKBLOCK(NOA,NUA,NOB,NUB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
C        compute the dimensions of the problem at hand
C
      NOAUA=NOA*NUA
      NOAUB=NOA*NUB
      NOBUA=NOB*NUA
      NOBUB=NOB*NUB
      NOA2=NOA**2
      NOA2UA=NOA2*NUA
      NOA4=NOA**4
      NOB2=NOB**2
      NOB2UB=NOB2*NUB
      NOB4=NOB**4
      NUA2=NUA**2
      NOAUA2=NOA*NUA2
      NUA4=NUA**4
      NUB2=NUB**2
      NOBUB2=NOB*NUB2
      NUB4=NUB**4
      NUAB=NUA*NUB
      NOAB=NOA*NOB
      NO2AB=NOAB**2
      NU2AB=NUAB**2
      NOABUB=NOAB*NUB
      NOABUA=NOAB*NUA
      NOAUAB=NOA*NUAB
      NOBUAB=NOB*NUAB
      NOA2UA=NOA2*NUA
      NOA2UA2=NOA2*NUA2
      NOA2UB2=NOA2*NUB2
      NOB2UB2=NOB2*NUB2
      NOB2UA2=NOB2*NUA2
      NO2U2AB=NOA*NOB*NUA*NUB
      NUA3=NUA**3
      NUB3=NUB**3
      NOA3=NOA**3
      NOB3=NOB**3
      NOA3UA=(NOA**3)*NUA
      NOB3UB=(NOB**3)*NUB
      NOA2UB=(NOA**2)*NUB
      NOAUB2=NOA*(NUB**2)
      NOB2UA=(NOB**2)*NUA
      NOBUA2=NOB*(NUA**2)
      NUA2UB=(NUA**2)*NUB
      NOA2OB=(NOA**2)*NOB
      NOAOB2=NOA*(NOB**2)
      NOA2UA=(NOA**2)*NUA
      NOB2UB=(NOB**2)*NUB
      NUA3NOA=(NUA**3)*NOA
      NUAUB2=NUA*(NUB**2)
      NOAOB2UA=NOA*(NOB**2)*NUA
      NUB3NOB=(NUB**3)*NOB
C
C         and now the /NNMAX/ initialization
C
      IF (NOA.GE.NOB) THEN
         NO=NOA
         NU=NUB
      ELSE
         NO=NOB
         NU=NUA
      ENDIF
C
      NOU=NO*NU
      NO2=NO**2
      NU2=NU**2
      NO2U2=NO2*NU2
      NO4=NO2**2
      NU3=NU**3
      NO3U=(NO**3)*NU
      NOU3=NO*(NU**3)
      NOU2=NO*(NU**2)
      NO2U=(NO**2)*NU
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK OPCCFILE
      SUBROUTINE OPCCFILE(NOA,NUA,NOB,NUB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA CCSD/8HCCSD    /
C
C        ---- open all files for open shell coupled cluster ----
C        Marta's original unit numbers survive in the variable names.
C
      IF (NOA .GE. NOB) THEN
              NU3MAX=NUB**3
              NOU3MAX=NOA*(NUB**3)
              NO2U2MAX=(NOA**2)*(NUB**2)
      ELSE
              NU3MAX=NUA**3
              NOU3MAX=NOB*(NUA**3)
              NO2U2MAX=(NOB**2)*(NUA**2)
      ENDIF
C
C        The first file is for restarts, both CCSD and LAMBDA equations.
C
      NFT825=70
      LEN825=NO2U2MAX
      CALL CCOPEN(NFT825,LEN825,'AMPROCC')
C
C        This is data similar to restarts, and filled from that file.
C
      NFT858=71
      LEN858=NO2U2MAX
      CALL CCOPEN(NFT858,LEN858,'ITOPNCC')
C
C     Fock matrices, Fqp = <p|F|q>
C        various submatrices of the alpha and beta Fock matrix
C        are stored here, in ten different records.  See OPCCFOCK.
C
      NFT843=72
      LEN843=(MAX(NUA,NUB))**2
      CALL CCOPEN(NFT843,LEN843,'FOCKMTX')
C
C        this file is used by one of the MM(2,3) algorithms
C
      IF(CCTYP.NE.CCSD) THEN
         NFT859=73
         LEN859=NU3MAX
         CALL CCOPEN(NFT859,LEN859,'LAMB23')
      END IF
C
C     ----- Integral files -----
C     V means two electron integrals, in lots of files, which could
C     potentially be combined wherever the record lengths are similar.
C
C     Files contain "double bar" integrals in the spin-orbital basis.
C
C     The notation "<pq|v|rs> alpha-alpha" (or beta-beta) means
C        <p(1)a(1) q(2)a(2) || r(1)a(1) s(2)a(2)>
C        <pq||rs> = <pq|rs> - <pq|sr> = [pr|qs] - [ps|qr]
C     The notation "<pq|v|rs> beta-alpha" means
C        <p(1)b(1) q(2)a(2) | 1/r12 | r(1)b(1) s(2)a(2)> = [pr|qs]
C                                                           bb aa
C
C     ----- Zero virtual index files, over occupied orbitals only
C
C        <ij|v|kl> for alpha-alpha
C
      NFT820=74
      LEN820=NOA2
      CALL CCOPEN(NFT820,LEN820,'VHHAA')
C
C        <ij|v|kl> for beta-beta
C
      NFT821=75
      LEN821=NOB2
      CALL CCOPEN(NFT821,LEN821,'VHHBB')
C
C        <ij|v|kl> for alpha-beta
C
      NFT822=76
      LEN822=NOAB
      CALL CCOPEN(NFT822,LEN822,'VHHAB')
C
C     ----- One virtual index files
C
C        <aj|v|kl> for alpha-alpha
C
      NFT823=77
      LEN823=NOA2
      CALL CCOPEN(NFT823,LEN823,'VMAA')
C
C        <aj|v|kl> for beta-beta
C
      NFT826=78
      LEN826=NOB2
      CALL CCOPEN(NFT826,LEN826,'VMBB')
C
C        <aj|v|kl> for alpha-beta
C
      NFT827=79
      LEN827=NOAB
      CALL CCOPEN(NFT827,LEN827,'VMAB')
C
C        <aj|v|kl> for beta-alpha
C
      NFT828=80
      LEN828=NOAB
      CALL CCOPEN(NFT828,LEN828,'VMBA')
C
C     ----- Two virtual index files
C     The three files with "R" in the center are actually differences
C     of exchange integrals, rather than double bar integrals.
C     No one is able to remember what "R" and "L" used in the true
C     double bar integral files stands for.
C
C        (ab|v|kl) for alpha-alpha
C
      NFT829=81
      LEN829=NOAUA
      CALL CCOPEN(NFT829,LEN829,'VHPRAA')
C
C        (ab|v|kl) for beta-beta
C
      NFT830=82
      LEN830=NOBUB
      CALL CCOPEN(NFT830,LEN830,'VHPRBB')
C
C        (ab|v|kl) for alpha-beta
C
      NFT833=83
      LEN833=NOAUA
      CALL CCOPEN(NFT833,LEN833,'VHPRAB')
C
C     ----- Two virtual index files, actual double bar integrals.
C
C        <aj|v|cl> for alpha-alpha
C
      NFT831=84
      LEN831=NOAUA
      CALL CCOPEN(NFT831,LEN831,'VHPLAA')
C
C        <aj|v|cl> for beta-beta
C
      NFT832=85
      LEN832=NOBUB
      CALL CCOPEN(NFT832,LEN832,'VHPLBB')
C
C        <aj|v|cl> for alpha-beta
C
      NFT834=86
      LEN834=NOBUA
      CALL CCOPEN(NFT834,LEN834,'VHPLAB')
C
C        <aj|v|cl> for beta-alpha
C
      NFT835=87
      LEN835=NOAUB
      CALL CCOPEN(NFT835,LEN835,'VHPLBA')
C
C     ----- Three virtual index files
C
C        <ab|v|cl> for alpha-alpha
C
      NFT836=88
      LEN836=NUA2
      CALL CCOPEN(NFT836,LEN836,'VEAA')
C
C        <ab|v|cl> for beta-alpha
C
      NFT837=89
      LEN837=NUB2
      CALL CCOPEN(NFT837,LEN837,'VEBB')
C
C        <ab|v|cl> for alpha-beta
C
      NFT838=90
      LEN838=NUAB
      CALL CCOPEN(NFT838,LEN838,'VEAB')
C
C        <ab|v|cl> for beta-beta
C
      NFT839=91
      LEN839=NUAB
      CALL CCOPEN(NFT839,LEN839,'VEBA')
C
C     ----- Four virtual index file
C
C        <ab|v|cd>
C
      NFT848=92
      LEN848=NU3MAX
      CALL CCOPEN(NFT848,LEN848,'VPPPP')
C
C     ----- H-bar files -----
C
C     One body Hbar's
C        record  1 - Hab alpha
C        record  2 - Hab beta
C        record  3 - Hij alpha
C        record  4 - Hij beta
C        record  5 - Hia alpha
C        record  6 - Hia beta
C     and some of the smaller two body Hbar's
C        record  7 - Hij,kl alpha-alpha
C        record  8 - Hij,kl beta-beta
C        record  9 - Hij,kl alpha-beta
C        record 10 - Hai,jk alpha-alpha
C        record 11 - Hai,jk beta-beta
C        record 12 - Hai,jk alpha-beta
C        record 13 - Hai,jk beta-alpha
C        record 14 - Hji,ak alpha-alpha
C        record 15 - Hji,ak beta-beta
C        record 16 - Hji,ak alpha-beta
C        record 17 - Hji,ak beta-alpha
C     note CCTYP=CCSD does something with this file as well, see ONEBODY
C
      NFT891=93
      LEN891=NO2U2MAX
      CALL CCOPEN(NFT891,LEN891,'INTERM1')
C
C     two and three virtual index two body Hbar's
C        record  1 = Hai,bj alpha-alpha
C        record  2 = Hai,bj beta-beta
C        record  4 = Hai,bj alpha-beta
C        record  3 = Hai,bj beta-alpha
C        record  6 = Hab,ij alpha-beta
C        record  5 = Hab,ij beta-alpha
C        record  7 = Hab,ci alpha-alpha
C        record  8 = Hab,ci beta-beta
C        record  9 = Hab,ci alpha-beta
C        record 10 = Hab,ci beta-alpha
C        record 11 = Hai,cb alpha-alpha
C        record 12 = Hai,cb beta-beta
C        record 13 = Hai,cb alpha-beta
C        record 14 = Hai,cb beta-alpha
C     note CCTYP=CCSD does something with this file, see OPEN_CCSD
C
      NFT892=94
      LEN892=NOU3MAX
      CALL CCOPEN(NFT892,LEN892,'INTERM2')
C
C     Four virtual index two body Hbar
C        NU records numbered by B
C        rec=B         = alpha-alpha
C        rec=NUA+B     = beta-beta
C        rec=NUA+NUB+B = alpha-beta
C
      IF(CCTYP.NE.CCSD) THEN
         NFT899=95
         LEN899=NU3MAX
         CALL CCOPEN(NFT899,LEN899,'INTERM3')
      END IF
      RETURN
      END
C
C*MODULE ROHFCC  *DECK OPCCFOCK
      SUBROUTINE OPCCFOCK(NFT843,NOA,NUA,NOB,NUB,EHA,EPA,EHB,EPB,
     *                    WORK,VEC,FA,FB,T1,T2,L1,L2,M1,M2,LDW,LTMP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C               note: WORK is also used as a L2 temporary.
C               T1 and T2 are used with many different sizes.
      DIMENSION WORK(LDW,LDW),VEC(L1,L1),FA(M2),FB(M2),
     *          T1(LTMP),T2(LTMP),
     *          EHA(NOA),EPA(NUA),EHB(NOB),EPB(NUB)
C
      PARAMETER (MXAO=8192)
C
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
C
C          ----- Fock matrix construction -----
C     this is set up to be UHF-ish, but there is only one (1) set
C     of orbital coefficients -VEC- used by ROHF.  We transform
C     both alpha and beta Fock operators to the MO basis, avoiding
C     transforming over the frozen core orbitals.
C
      CALL DAREAD(IDAF,IODA,VEC,L1*L1,15,0)
C
      CALL DAREAD(IDAF,IODA,WORK,L2,14,0)
      CALL TFTRI(FA,WORK,VEC(1,NOPCCFC+1),T1,M1,L1,L1)
C
      CALL DAREAD(IDAF,IODA,WORK,L2,18,0)
      CALL TFTRI(FB,WORK,VEC(1,NOPCCFC+1),T1,M1,L1,L1)
C
C         Copy FA and FB to a combined matrix,
C         alternating alpha and beta spin orbitals.
C         Any alpha/beta cross elements are null.
C
      CALL VCLR(WORK,1,(2*M1)**2)
C
      I = -1
      DO II=1,M1
         I = I + 2
         J = -1
         DO JJ=1,II
            IIJJ = IA(II) + JJ
            J = J + 2
            WORK(I  ,J  ) = FA(IIJJ)
            WORK(J  ,I  ) = FA(IIJJ)
            WORK(I+1,J+1) = FB(IIJJ)
            WORK(J+1,I+1) = FB(IIJJ)
         ENDDO
      ENDDO
C
C        set EHX/EPX arrays to diagonal F elements
C
      NN = LDW
      CALL FOCKHP0(NN,NOA,NUA,NOB,NUB,WORK,EHA,EPA,EHB,EPB)
C
C     ----- create various Fock submatrices on file -NFT843- -----
C     note that "CALL WRTAB2(N1,N2,TAB,IREC,NFILE)" writes a
C     single record -IREC- to file -IFILE- containing TAB(N1,N2)
C
C        record 1 and 2= Fij alpha and beta, with diagonals zero'd out
C        record 3 and 4= Fab alpha and beta, with diagonals zero'd out
C        record 5 and 6= Fia alpha and beta, intact
C        record 7 and 8= Fij alpha and beta, intact
C        record 9 'n 10= Fab alpha and beta, intact
C
      CALL FOCKHP1(NN,NOA,NOB,WORK,T1,T2)
      CALL WRTAB2(NOA,NOA,T1, 1,NFT843)
      CALL WRTAB2(NOB,NOB,T2, 2,NFT843)
C
      CALL FOCKHP2(NN,NOA,NUA,NOB,NUB,WORK,T1,T2)
      CALL WRTAB2(NUA,NUA,T1, 3,NFT843)
      CALL WRTAB2(NUB,NUB,T2, 4,NFT843)
C
      CALL FOCKHP3(NN,NOA,NUA,NOB,NUB,WORK,T1,T2)
      CALL WRTAB2(NUA,NOA,T1, 5,NFT843)
      CALL WRTAB2(NUB,NOB,T2, 6,NFT843)
C
      CALL FOCKHP4(NN,NOA,NOB,WORK,T1,T2)
      CALL WRTAB2(NOA,NOA,T1, 7,NFT843)
      CALL WRTAB2(NOB,NOB,T2, 8,NFT843)
C
      CALL FOCKHP5(NN,NOA,NUA,NOB,NUB,WORK,T1,T2)
      CALL WRTAB2(NUA,NUA,T1, 9,NFT843)
      CALL WRTAB2(NUB,NUB,T2,10,NFT843)
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK FOCKHP0
      SUBROUTINE FOCKHP0(N,NOA,NUA,NOB,NUB,T,EHA,EPA,EHB,EPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION EHA(NOA),EPA(NUA),EHB(NOB),EPB(NUB),T(N,N)
C
C         ----- set diagonal Fock element arrays ----
C     To the extent that the UHF equations have converged, these
C     would be the same as eigenvalues of UHF F-a and F-b matrices.
C     For ROHF computations, the F-a and F-b matrices in the MO basis
C     will of course be quite far from diagonal.
C
      DO I=1, NOA
         NI=2*I-1
         EHA(I)=T(NI,NI)
      ENDDO
C
      DO I=1, NOB
         NI=2*I
         EHB(I)=T(NI,NI)
      ENDDO
C
      DO I=1, NUA
         NI=2*NOA+2*I-1
         EPA(I)=T(NI,NI)
      ENDDO
C
      DO I=1, NUB
         NI=2*NOB+2*I
         EPB(I)=T(NI,NI)
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK FOCKHP1
      SUBROUTINE FOCKHP1(N,NOA,NOB,T,O12AA,O12BB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION T(N,N),O12AA(NOA,NOA),O12BB(NOB,NOB)
C
C         pick out the occupied blocks of Fock matrices
C         Arbitrarily zero out the diagonal of the copy.
C
      DO I=1, NOA
         DO J=1, NOA
            IF(I .EQ. J) THEN
               O12AA(I,J)=0.0D+00
            ELSE
               NI=2*I-1
               NJ=2*J-1
               O12AA(I,J)=T(NI,NJ)
            ENDIF
         ENDDO
      ENDDO
C
      DO I=1, NOB
         DO J=1, NOB
            IF(I .EQ. J) THEN
               O12BB(I,J)=0.0D+00
            ELSE
               NI=2*I
               NJ=2*J
               O12BB(I,J)=T(NI,NJ)
            ENDIF
         ENDDO
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK FOCKHP2
      SUBROUTINE FOCKHP2(N,NOA,NUA,NOB,NUB,T,O12AA,O12BB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION T(N,N),O12AA(NUA,NUA),O12BB(NUB,NUB)
C
C         pick out the virtual blocks of Fock matrices
C         Arbitrarily zero out the diagonal of the copy.
C
      DO I=1, NUA
         DO J=1, NUA
            IF(I .EQ. J) THEN
               O12AA(I,J)=0.0D+00
            ELSE
               NI=2*NOA+2*I-1
               NJ=2*NOA+2*J-1
               O12AA(I,J)=T(NI,NJ)
            ENDIF
         ENDDO
      ENDDO
C
      DO I=1, NUB
         DO J=1, NUB
            IF(I .EQ. J) THEN
               O12BB(I,J)=0.0D+00
            ELSE
               NI=2*NOB+2*I
               NJ=2*NOB+2*J
               O12BB(I,J)=T(NI,NJ)
            ENDIF
         ENDDO
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK FOCKHP3
      SUBROUTINE FOCKHP3(N,NOA,NUA,NOB,NUB,T,O12AA,O12BB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION T(N,N),O12AA(NUA,NOA),O12BB(NUB,NOB)
C
C         pick out occ/virt intersection blocks of Fock matrices
C
      DO I=1, NOA
         DO J=1, NUA
            NI=2*I-1
            NJ=2*NOA+2*J-1
            O12AA(J,I)=T(NJ,NI)
         ENDDO
      ENDDO
C
      DO I=1, NOB
         DO J=1, NUB
            NI=2*I
            NJ=2*NOB+2*J
            O12BB(J,I)=T(NJ,NI)
         ENDDO
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK FOCKHP4
      SUBROUTINE FOCKHP4(N,NOA,NOB,T,O12AA,O12BB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION T(N,N),O12AA(NOA,NOA),O12BB(NOB,NOB)
C
C         pick out the occupied blocks of Fock matrices
C         This time we do not zero out the diagonal.
C
      DO I=1, NOA
         DO J=1, NOA
            NI=2*I-1
            NJ=2*J-1
            O12AA(I,J)=T(NI,NJ)
         ENDDO
      ENDDO
C
      DO I=1, NOB
         DO J=1, NOB
            NI=2*I
            NJ=2*J
            O12BB(I,J)=T(NI,NJ)
         ENDDO
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK FOCKHP5
      SUBROUTINE FOCKHP5(N,NOA,NUA,NOB,NUB,T,O12AA,O12BB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION T(N,N),O12AA(NUA,NUA),O12BB(NUB,NUB)
C
C         pick out the virtual blocks of Fock matrices
C         This time we do not zero out the diagonal.
C
      DO I=1, NUA
         DO J=1, NUA
            NI=2*NOA+2*I-1
            NJ=2*NOA+2*J-1
            O12AA(I,J)=T(NI,NJ)
         ENDDO
      ENDDO
C
      DO I=1, NUB
         DO J=1, NUB
            NI=2*NOB+2*I
            NJ=2*NOB+2*J
            O12BB(I,J)=T(NI,NJ)
         ENDDO
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK OPCCINTS
      SUBROUTINE OPCCINTS(IW,IJKT,XX,IX,NINTMX,NOA,NOB,NUA,NUB,
     *                    VHHAA,VHHBB,VHHAB,
     *                    VMAA,VMBB,VMAB,VMBA,
     *                    VHPRAA,VHPRBB,VHPRAB,
     *                    VHPLAA,VHPLBB,VHPLAB,VHPLBA,
     *                    VEAA,VEBB,VEAB,VEBA,
     *                    VPPAA,VPPBB,VPPAB,NSLICEA,NSLICEB)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL IAOCC,JAOCC,KAOCC,LAOCC,IBOCC,JBOCC,KBOCC,LBOCC
C
      INTEGER A,B,C,D,AX,BX,CX,DX
C
C        storage used by all passes is:
      DIMENSION XX(NINTMX),IX(*)
C
C        CAUTION:
C        the following 3 storage sets are "equivalent by call".
C        storage used by pass 1, only:
      DIMENSION VHHAA(NOA,NOA,NOA,NOA),
     *          VHHBB(NOB,NOB,NOB,NOB),
     *          VHHAB(NOA,NOB,NOA,NOB)
      DIMENSION VMAA(NOA,NOA,NOA,NUA),
     *          VMBB(NOB,NOB,NOB,NUB),
     *          VMAB(NOA,NOB,NUA,NOB),
     *          VMBA(NOA,NOB,NOA,NUB)
      DIMENSION VHPRAA(NUA,NOA,NUA,NOA),
     *          VHPRBB(NUB,NOB,NUB,NOB),
     *          VHPRAB(NUA,NOA,NUB,NOB),
     *          VHPLAA(NUA,NOA,NUA,NOA),
     *          VHPLBB(NUB,NOB,NUB,NOB),
     *          VHPLAB(NUA,NOB,NUA,NOB),
     *          VHPLBA(NUB,NOA,NUB,NOA)
C
C        storage used by pass 2, only:
      DIMENSION VEAA(NUA,NUA,NUA,NOA),
     *          VEBB(NUB,NUB,NUB,NOB),
     *          VEAB(NUA,NUB,NOA,NUB),
     *          VEBA(NUA,NUB,NUA,NOB)
C
C        storage used by pass 3, only:
      DIMENSION VPPAA(NUA,NUA,NUA,NSLICEA),
     *          VPPBB(NUB,NUB,NUB,NSLICEB),
     *          VPPAB(NUA,NUB,NUA,NSLICEB)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (HALF=0.5D+00)
C
C       ----- sort integrals into classes for CC calculations -----
C     The Mulliken integrals over ROHF space orbitals are turned into
C     double bar integrals over spin-orbitals, ala UHF style.  It is
C     EMPHASIZED that we start from integrals over one (1) set of MOs.
C
C        pass 1 processes zero, one, and two virtual index integrals,
C        pass 2 processes three virtual index integrals,
C        pass 3 processes four virtual ints, in MXPASS-2 subpasses.
C        Since pass 3 has the biggest memory need, it must be divided
C        into 'subpasses', each containing at least -NSLICEx- orbitals.
C
C     Within each class, a separate disk file is written, except the
C     three VVVV classes, which write multiple records to one file.
C
      MXPASS = 2 + MAX((NUA-1)/NSLICEA,(NUB-1)/NSLICEB) + 1
C
      MXVIRA = 0
      MXVIRB = 0
C
      IPASS  = 0
    5 CONTINUE
      IPASS=IPASS+1
C
      IF(IPASS.GE.3) THEN
         MNVIRA = MXVIRA+1
         MXVIRA = MXVIRA+NSLICEA
         IF(MXVIRA.GT.NUA) MXVIRA=NUA
         IF(MNVIRA.GT.NUA) THEN
            MNVIRA=0
            MXVIRA=0
         END IF
         MNVIRB = MXVIRB+1
         MXVIRB = MXVIRB+NSLICEB
         IF(MXVIRB.GT.NUB) MXVIRB=NUB
         IF(MNVIRB.GT.NUB) THEN
            MNVIRB=0
            MXVIRB=0
         END IF
      END IF
C
      IF(IPASS.EQ.1) WRITE(IW,9010) IPASS
      IF(IPASS.EQ.2) WRITE(IW,9020) IPASS
      IF(IPASS.EQ.3) WRITE(IW,9030) IPASS,MXPASS
      IF(IPASS.GE.3) THEN
         MNA = NOA+MNVIRA
         MXA = NOA+MXVIRA
         MNB = NOB+MNVIRB
         MXB = NOB+MXVIRB
         IF(MNVIRA.EQ.0) THEN
            MNA=0
            MXA=0
         END IF
         IF(MNVIRB.EQ.0) THEN
            MNB=0
            MXB=0
         END IF
         WRITE(IW,9040) IPASS,MNA,MXA,MNB,MXB
      END IF
      CALL FLSHBF(IW)
C
      IF(IPASS.EQ.1) THEN
         CALL VCLR(VHHAA ,1,NOA*NOA*NOA*NOA)
         CALL VCLR(VHHBB ,1,NOB*NOB*NOB*NOB)
         CALL VCLR(VHHAB ,1,NOA*NOB*NOA*NOB)
         CALL VCLR(VMAA  ,1,NOA*NOA*NOA*NUA)
         CALL VCLR(VMBB  ,1,NOB*NOB*NOB*NUB)
         CALL VCLR(VMAB  ,1,NOA*NOB*NUA*NOB)
         CALL VCLR(VMBA  ,1,NOA*NOB*NOA*NUB)
         CALL VCLR(VHPRAA,1,NUA*NOA*NUA*NOA)
         CALL VCLR(VHPRBB,1,NUB*NOB*NUB*NOB)
         CALL VCLR(VHPRAB,1,NUA*NOA*NUB*NOB)
         CALL VCLR(VHPLAA,1,NUA*NOA*NUA*NOA)
         CALL VCLR(VHPLBB,1,NUB*NOB*NUB*NOB)
         CALL VCLR(VHPLAB,1,NUA*NOB*NUA*NOB)
         CALL VCLR(VHPLBA,1,NUB*NOA*NUB*NOA)
      END IF
C
      IF(IPASS.EQ.2) THEN
         CALL VCLR(VEAA  ,1,NUA*NUA*NUA*NOA)
         CALL VCLR(VEBB  ,1,NUB*NUB*NUB*NOB)
         CALL VCLR(VEAB  ,1,NUA*NUB*NOA*NUB)
         CALL VCLR(VEBA  ,1,NUA*NUB*NUA*NOB)
      END IF
C
      IF(IPASS.GE.3) THEN
         CALL VCLR(VPPAA ,1,NUA*NUA*NUA*NSLICEA)
         CALL VCLR(VPPBB ,1,NUB*NUB*NUB*NSLICEB)
         CALL VCLR(VPPAB ,1,NUA*NUB*NUA*NSLICEB)
      END IF
C
C        Begin reading the transformed integral file.
C        Only the master has the 1e- integral record, we skip over it.
C
      CALL SEQREW(IJKT)
      IF(MASWRK) CALL SEQADV(IJKT)
C
C        Read transformed 2e- integral file in reverse canonical order.
C
   10 CONTINUE
      CALL PREAD(IJKT,XX,IX,NX,NINTMX)
      IF (NX.EQ.0) GO TO 450
      MX = ABS(NX)
      IF (MX.GT.NINTMX) THEN
         IF(MASWRK) WRITE(6,*) 'CONFUSION WITH INTEGRALS IN -OPCCINTS-'
         CALL ABRT
      END IF
C
      DO 400 M = 1,MX
      VALUE = XX(M)
C
      NPACK = M
      IF (LABSIZ .EQ. 2) THEN
*I32     LABEL1 = IX( 2*NPACK - 1 )
*I32     LABEL2 = IX( 2*NPACK     )
*I32     IPACK = ISHFT( LABEL1, -16 )
*I32     JPACK = IAND( LABEL1, 65535 )
*I32     KPACK = ISHFT( LABEL2, -16 )
*I32     LPACK = IAND( LABEL2, 65535 )
*I64     LABEL = IX(NPACK)
*I64     IPACK =       ISHFT( LABEL, -48 )
*I64     JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64     KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64     LPACK = IAND(        LABEL,        65535 )
      ELSE IF (LABSIZ .EQ. 1) THEN
*I32     LABEL = IX(NPACK)
*I32     IPACK = ISHFT( LABEL, -24 )
*I32     JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32     KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32     LPACK = IAND( LABEL, 255 )
*I64     IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64        LABEL = IX( NPACK/2 )
*I64        IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64        LPACK = IAND( LABEL, 255 )
*I64     ELSE
*I64        LABEL = IX( (NPACK/2)+1 )
*I64        IPACK = ISHFT( LABEL, -56 )
*I64        JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64        KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64        LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64     END IF
      END IF
C
C        Switch the indices to usual triangular canonical order,
C        which of course is i>=j, k>=l, ij>=kl.
C
      K = IPACK
      L = JPACK
      I = KPACK
      J = LPACK
C
C        We now have an integral from our single ROHF orbital set.
C
C        It is a Mulliken integral over space orbitals, as God meant
C        integrals to be, namely VALUE = [I J|K L].  Only the unique
C        integral for all eight redundant permutations of I,J,K,L is
C        stored, and then only if VALUE is nonzero.
C
      IF (I.EQ.J)               VALUE = HALF*VALUE
      IF              (K.EQ.L)  VALUE = HALF*VALUE
      IF((I.EQ.K).AND.(J.EQ.L)) VALUE = HALF*VALUE
C
C        We pretend this is a UHF kind of run, so this integral is
C        processed as alpha-alpha, beta-beta, and alpha-beta in turn.
C
C        =============================================
C        Pretend our integral is alpha-alpha spin type
C        =============================================
C
C        determine integral's occupancy type
C
      IF(I.LE.NOA)              GO TO 102
C
      IF(K.GT.NOA) GO TO 101
      IF(J.LE.NOA.AND.L.LE.NOA) GO TO 103
                                GO TO 105
C
  101 IF(J.GT.NOA.AND.L.GT.NOA) GO TO 107
      IF(J.LE.NOA.AND.L.LE.NOA) GO TO 104
                                GO TO 106
C
C        use [ij|kl] integrals
C
C     Noddy code, by which we mean using all integrals previously
C     have been read into a single (noa+nua)**4  matrix -T- in RAM,
C     which makes for very simplistic code, is as follows:
C        do i=1,noa ; do j=1,noa ; do k=1,noa ; do l=1,noa
C           vhhaa(i,j,k,l)=t(i,k,j,l)-t(i,l,j,k)
C     so you see, the V integrals are all double bar type, except
C     for the "R" matrices in the two virtual orbital case.
C
C        Coulomb contributions follow from 8 relabelings of [i,j|k,l]
C           <p q || r s>  =  [p,r|q,s] - [p,s|q,r]
C            i k    j l       i,j,k,l  <- labels as they come from disk.
C            i l    j k       i,j,l,k
C            j k    i l       j,i,k,l
C            j l    i k       j,i,l,k
C            k i    l j       k,l,i,j
C            k j    l i       k,l,j,i
C            l i    k j       l,k,i,j
C            l j    k i       l,k,j,i
C        exchange contributions follow from 8 relabelings of [i,j|k,l]
C           <p q || r s>  =  [p,r|q,s] - [p,s|q,r]
C            i k    l j                   i,j,k,l
C            i l    k j                   i,j,l,k
C            j k    l i                   j,i,k,l
C            j l    k i                   j,i,l,k
C            k i    j l                   k,l,i,j
C            k j    i l                   k,l,j,i
C            l i    j k                   l,k,i,j
C            l j    i k                   l,k,j,i
C
  102 CONTINUE
      IF(IPASS.NE.1) GO TO 200
      VHHAA(I,K,J,L)=VHHAA(I,K,J,L) + VALUE
      VHHAA(I,L,J,K)=VHHAA(I,L,J,K) + VALUE
      VHHAA(J,K,I,L)=VHHAA(J,K,I,L) + VALUE
      VHHAA(J,L,I,K)=VHHAA(J,L,I,K) + VALUE
      VHHAA(K,I,L,J)=VHHAA(K,I,L,J) + VALUE
      VHHAA(K,J,L,I)=VHHAA(K,J,L,I) + VALUE
      VHHAA(L,I,K,J)=VHHAA(L,I,K,J) + VALUE
      VHHAA(L,J,K,I)=VHHAA(L,J,K,I) + VALUE
C
      VHHAA(I,K,L,J)=VHHAA(I,K,L,J) - VALUE
      VHHAA(I,L,K,J)=VHHAA(I,L,K,J) - VALUE
      VHHAA(J,K,L,I)=VHHAA(J,K,L,I) - VALUE
      VHHAA(J,L,K,I)=VHHAA(J,L,K,I) - VALUE
      VHHAA(K,I,J,L)=VHHAA(K,I,J,L) - VALUE
      VHHAA(K,J,I,L)=VHHAA(K,J,I,L) - VALUE
      VHHAA(L,I,J,K)=VHHAA(L,I,J,K) - VALUE
      VHHAA(L,J,I,K)=VHHAA(L,J,I,K) - VALUE
      GO TO 200
C
C        use [aj|kl] integrals
C
C     Noddy code: do j=1,noa ; do k=1,noa ; do l=1,noa ; do a=1,nua
C                    na=noa+a ; vmaa(j,k,l,a)=t(j,l,k,na)-t(j,na,k,l)
C
C     Note here that the subsequent CC program had its own ideas
C     about where the a index is stored (e.g. it has to be the 4th
C     index of VMAA) so we do what that program requires.
C
  103 CONTINUE
      IF(IPASS.NE.1) GO TO 200
      A=I-NOA
      VMAA(K,J,L,A) = VMAA(K,J,L,A) + VALUE
      VMAA(L,J,K,A) = VMAA(L,J,K,A) + VALUE
      VMAA(J,K,L,A) = VMAA(J,K,L,A) - VALUE
      VMAA(J,L,K,A) = VMAA(J,L,K,A) - VALUE
      GO TO 200
C
C        use [aj|cl] integrals
C
  104 CONTINUE
      IF(IPASS.NE.1) GO TO 200
C
C         the -R- matrix is a difference of two exchange type integrals
C         No one seems to know why labels R and L (see below) are used.
C
C     Noddy code: do j=1,noa ; do l=1,noa ; do a=1,nua ; do c=1,nub
C                   na=noa+a ; nc=noa+c
C                   vhpraa(a,j,c,l)=t(na,j,nc,l)-t(na,l,nc,j)
C
      A = I-NOA
      C = K-NOA
      VHPRAA(A,J,C,L) = VHPRAA(A,J,C,L) + VALUE
      VHPRAA(C,L,A,J) = VHPRAA(C,L,A,J) + VALUE
      VHPRAA(A,L,C,J) = VHPRAA(A,L,C,J) - VALUE
      VHPRAA(C,J,A,L) = VHPRAA(C,J,A,L) - VALUE
C
C          exchange contribution, see below for Coulomb and the formula.
C
      VHPLAA(A,J,C,L) = VHPLAA(A,J,C,L) - VALUE
      VHPLAA(C,L,A,J) = VHPLAA(C,L,A,J) - VALUE
      GO TO 200
C
C        use [ab|kl] integrals
C
  105 CONTINUE
      IF(IPASS.NE.1) GO TO 200
C
C         the -L- matrix is a double bar integral combination
C
C          Coulomb contribution (see above for exchange contribution)
C     Noddy code: do k=1,noa ; do l=1,noa ; do a=1,nua ; do b=1,nua
C                    na=noa+a ; nb=noa+b
C                    vhplaa(a,k,b,l)=t(na,nb,k,l)-t(na,l,nb,k)
C
      A = I - NOA
      B = J - NOA
      VHPLAA(A,K,B,L) = VHPLAA(A,K,B,L) + VALUE
      VHPLAA(A,L,B,K) = VHPLAA(A,L,B,K) + VALUE
      VHPLAA(B,K,A,L) = VHPLAA(B,K,A,L) + VALUE
      VHPLAA(B,L,A,K) = VHPLAA(B,L,A,K) + VALUE
      GO TO 200
C
C        use [aj|cd] and [ab|cl] integrals
C
  106 CONTINUE
      IF(IPASS.NE.2) GO TO 200
C
C     Noddy code: do l=1,noa ; do a=1,nua ; do b=1,nua ; do c=1,nua
C                    na=noa+a ; nb=noa+b ; nc=noa+c
C                    veaa(a,c,b,l)=t(na,nb,nc,l)-t(na,l,nb,nc)
C
      IF(J.LE.NOA) THEN
         A = I - NOA
         C = K - NOA
         D = L - NOA
         VEAA(C,A,D,J) = VEAA(C,A,D,J) + VALUE
         VEAA(D,A,C,J) = VEAA(D,A,C,J) + VALUE
         VEAA(A,C,D,J) = VEAA(A,C,D,J) - VALUE
         VEAA(A,D,C,J) = VEAA(A,D,C,J) - VALUE
      END IF
      IF(L.LE.NOA) THEN
         A = I - NOA
         B = J - NOA
         C = K - NOA
         VEAA(A,C,B,L) = VEAA(A,C,B,L) + VALUE
         VEAA(B,C,A,L) = VEAA(B,C,A,L) + VALUE
         VEAA(C,A,B,L) = VEAA(C,A,B,L) - VALUE
         VEAA(C,B,A,L) = VEAA(C,B,A,L) - VALUE
      END IF
      GO TO 200
C
C        use [ab|cd] integrals
C
  107 CONTINUE
      IF(IPASS.LT.3) GO TO 200
C
C        Form <ac||bd> = [ab|cd] - [ad|cb], slicing on d
C        Note that the 16 combinations are identical to the all occupied
C        case, but are rearranged so we can slice on the final index.
C                    the Noddy code is
C     do d=1,nua
C      do a=1,nua ; do c=1,nua ; do b=1,nua
C        na=noa+a ; nb=noa+b ; nc=noa+c ; nd=noa+d
C        vppaa(a,c,b)=t(na,nb,nc,nd)-t(na,nd,nc,nb)
C      enddo ; enddo ; enddo
C      write(nft848,rec=0+c) vppaa
C     enddo
C
      A = I - NOA
      B = J - NOA
      C = K - NOA
      D = L - NOA
      IF(A.GE.MNVIRA  .AND.  A.LE.MXVIRA) THEN
         AX = A-MNVIRA+1
         VPPAA(C,B,D,AX)=VPPAA(C,B,D,AX) + VALUE
         VPPAA(D,B,C,AX)=VPPAA(D,B,C,AX) + VALUE
         VPPAA(B,C,D,AX)=VPPAA(B,C,D,AX) - VALUE
         VPPAA(B,D,C,AX)=VPPAA(B,D,C,AX) - VALUE
      END IF
      IF(B.GE.MNVIRA  .AND.  B.LE.MXVIRA) THEN
         BX = B-MNVIRA+1
         VPPAA(C,A,D,BX)=VPPAA(C,A,D,BX) + VALUE
         VPPAA(D,A,C,BX)=VPPAA(D,A,C,BX) + VALUE
         VPPAA(A,C,D,BX)=VPPAA(A,C,D,BX) - VALUE
         VPPAA(A,D,C,BX)=VPPAA(A,D,C,BX) - VALUE
      END IF
      IF(C.GE.MNVIRA  .AND.  C.LE.MXVIRA) THEN
         CX = C-MNVIRA+1
         VPPAA(A,D,B,CX)=VPPAA(A,D,B,CX) + VALUE
         VPPAA(B,D,A,CX)=VPPAA(B,D,A,CX) + VALUE
         VPPAA(D,A,B,CX)=VPPAA(D,A,B,CX) - VALUE
         VPPAA(D,B,A,CX)=VPPAA(D,B,A,CX) - VALUE
      END IF
      IF(D.GE.MNVIRA  .AND.  D.LE.MXVIRA) THEN
         DX = D-MNVIRA+1
         VPPAA(A,C,B,DX)=VPPAA(A,C,B,DX) + VALUE
         VPPAA(B,C,A,DX)=VPPAA(B,C,A,DX) + VALUE
         VPPAA(C,A,B,DX)=VPPAA(C,A,B,DX) - VALUE
         VPPAA(C,B,A,DX)=VPPAA(C,B,A,DX) - VALUE
      END IF
C
C        ===========================================
C        Pretend our integral is beta-beta spin type
C        ===========================================
C
C        determine integral's occupancy type
C
  200 CONTINUE
      IF(I.LE.NOB)              GO TO 202
C
      IF(K.GT.NOB) GO TO 201
      IF(J.LE.NOB.AND.L.LE.NOB) GO TO 203
                                GO TO 205
C
  201 IF(J.GT.NOB.AND.L.GT.NOB) GO TO 207
      IF(J.LE.NOB.AND.L.LE.NOB) GO TO 204
                                GO TO 206
C
C        use [ij|kl] integrals
C
C     Noddy code: do i=1,nob ; do j=1,nob ; do k=1,nob ; do l=1,nob
C                    vhhbb(i,j,k,l)=t(i,k,j,l)-t(i,l,j,k)
C
  202 CONTINUE
      IF(IPASS.NE.1) GO TO 300
      VHHBB(I,K,J,L)=VHHBB(I,K,J,L) + VALUE
      VHHBB(I,L,J,K)=VHHBB(I,L,J,K) + VALUE
      VHHBB(J,K,I,L)=VHHBB(J,K,I,L) + VALUE
      VHHBB(J,L,I,K)=VHHBB(J,L,I,K) + VALUE
      VHHBB(K,I,L,J)=VHHBB(K,I,L,J) + VALUE
      VHHBB(K,J,L,I)=VHHBB(K,J,L,I) + VALUE
      VHHBB(L,I,K,J)=VHHBB(L,I,K,J) + VALUE
      VHHBB(L,J,K,I)=VHHBB(L,J,K,I) + VALUE
C
      VHHBB(I,K,L,J)=VHHBB(I,K,L,J) - VALUE
      VHHBB(I,L,K,J)=VHHBB(I,L,K,J) - VALUE
      VHHBB(J,K,L,I)=VHHBB(J,K,L,I) - VALUE
      VHHBB(J,L,K,I)=VHHBB(J,L,K,I) - VALUE
      VHHBB(K,I,J,L)=VHHBB(K,I,J,L) - VALUE
      VHHBB(K,J,I,L)=VHHBB(K,J,I,L) - VALUE
      VHHBB(L,I,J,K)=VHHBB(L,I,J,K) - VALUE
      VHHBB(L,J,I,K)=VHHBB(L,J,I,K) - VALUE
      GO TO 300
C
C        use [aj|kl] integrals
C
C     Noddy code: do j=1,nob ; do k=1,nob ; do l=1,nob ; do a=1,nub
C                    na=nob+a ; vmbb(j,k,l,a)=t(j,l,k,na)-t(j,na,k,l)
C
  203 CONTINUE
      IF(IPASS.NE.1) GO TO 300
      A=I-NOB
      VMBB(K,J,L,A) = VMBB(K,J,L,A) + VALUE
      VMBB(L,J,K,A) = VMBB(L,J,K,A) + VALUE
      VMBB(J,K,L,A) = VMBB(J,K,L,A) - VALUE
      VMBB(J,L,K,A) = VMBB(J,L,K,A) - VALUE
      GO TO 300
C
C        use [aj|cl] integrals
C
  204 CONTINUE
      IF(IPASS.NE.1) GO TO 300
C
C         this matrix is a difference of two exchange type integrals
C     Noddy code: do j=1,nob ; do l=1,nob ; do a=1,nub ; do c=1,nub
C                   na=nob+a ; nc=nob+c
C                   vhprbb(a,j,c,l)=t(na,j,nc,l)-t(na,l,nc,j)
      A = I-NOB
      C = K-NOB
      VHPRBB(A,J,C,L) = VHPRBB(A,J,C,L) + VALUE
      VHPRBB(C,L,A,J) = VHPRBB(C,L,A,J) + VALUE
      VHPRBB(A,L,C,J) = VHPRBB(A,L,C,J) - VALUE
      VHPRBB(C,J,A,L) = VHPRBB(C,J,A,L) - VALUE
C
C          exchange contribution, see below for Coulomb and the formula.
C
      VHPLBB(A,J,C,L) = VHPLBB(A,J,C,L) - VALUE
      VHPLBB(C,L,A,J) = VHPLBB(C,L,A,J) - VALUE
      GO TO 300
C
C        use [ab|kl] integrals
C
  205 CONTINUE
      IF(IPASS.NE.1) GO TO 300
C
C          Coulomb contribution (see above for exchange contribution)
C     Noddy code: do k=1,nob ; do l=1,nob ; do a=1,nub ; do b=1,nub
C                    na=nob+a ; nb=nob+b
C                    vhplbb(a,k,b,l)=t(na,nb,k,l)-t(na,l,nb,k)
C
      A = I - NOB
      B = J - NOB
      VHPLBB(A,K,B,L) = VHPLBB(A,K,B,L) + VALUE
      VHPLBB(A,L,B,K) = VHPLBB(A,L,B,K) + VALUE
      VHPLBB(B,K,A,L) = VHPLBB(B,K,A,L) + VALUE
      VHPLBB(B,L,A,K) = VHPLBB(B,L,A,K) + VALUE
      GO TO 300
C
C        use [aj|cd] and [ab|cl] integrals
C
  206 CONTINUE
      IF(IPASS.NE.2) GO TO 300
C
C     Noddy code: do l=1,nob ; do a=1,nub ; do b=1,nub ; do c=1,nub
C                    na=nob+b ; nb=nob+b ; nc=nob+c
C                    vebb(a,c,b,l)=t(na,nb,nc,l)-t(na,l,nb,nc)
C
      IF(J.LE.NOB) THEN
         A = I - NOB
         C = K - NOB
         D = L - NOB
         VEBB(C,A,D,J) = VEBB(C,A,D,J) + VALUE
         VEBB(D,A,C,J) = VEBB(D,A,C,J) + VALUE
         VEBB(A,C,D,J) = VEBB(A,C,D,J) - VALUE
         VEBB(A,D,C,J) = VEBB(A,D,C,J) - VALUE
      END IF
      IF(L.LE.NOB) THEN
         A = I - NOB
         B = J - NOB
         C = K - NOB
         VEBB(A,C,B,L) = VEBB(A,C,B,L) + VALUE
         VEBB(B,C,A,L) = VEBB(B,C,A,L) + VALUE
         VEBB(C,A,B,L) = VEBB(C,A,B,L) - VALUE
         VEBB(C,B,A,L) = VEBB(C,B,A,L) - VALUE
      END IF
      GO TO 300
C
C        use [ab|cd] integrals
C
  207 CONTINUE
      IF(IPASS.LT.3) GO TO 300
C
C        the all-beta code is exactly like the all-alpha code above.
C
      A = I - NOB
      B = J - NOB
      C = K - NOB
      D = L - NOB
      IF(A.GE.MNVIRB  .AND.  A.LE.MXVIRB) THEN
         AX = A-MNVIRB+1
         VPPBB(C,B,D,AX)=VPPBB(C,B,D,AX) + VALUE
         VPPBB(D,B,C,AX)=VPPBB(D,B,C,AX) + VALUE
         VPPBB(B,C,D,AX)=VPPBB(B,C,D,AX) - VALUE
         VPPBB(B,D,C,AX)=VPPBB(B,D,C,AX) - VALUE
      END IF
      IF(B.GE.MNVIRB  .AND.  B.LE.MXVIRB) THEN
         BX = B-MNVIRB+1
         VPPBB(C,A,D,BX)=VPPBB(C,A,D,BX) + VALUE
         VPPBB(D,A,C,BX)=VPPBB(D,A,C,BX) + VALUE
         VPPBB(A,C,D,BX)=VPPBB(A,C,D,BX) - VALUE
         VPPBB(A,D,C,BX)=VPPBB(A,D,C,BX) - VALUE
      END IF
      IF(C.GE.MNVIRB  .AND.  C.LE.MXVIRB) THEN
         CX = C-MNVIRB+1
         VPPBB(A,D,B,CX)=VPPBB(A,D,B,CX) + VALUE
         VPPBB(B,D,A,CX)=VPPBB(B,D,A,CX) + VALUE
         VPPBB(D,A,B,CX)=VPPBB(D,A,B,CX) - VALUE
         VPPBB(D,B,A,CX)=VPPBB(D,B,A,CX) - VALUE
      END IF
      IF(D.GE.MNVIRB  .AND.  D.LE.MXVIRB) THEN
         DX = D-MNVIRB+1
         VPPBB(A,C,B,DX)=VPPBB(A,C,B,DX) + VALUE
         VPPBB(B,C,A,DX)=VPPBB(B,C,A,DX) + VALUE
         VPPBB(C,A,B,DX)=VPPBB(C,A,B,DX) - VALUE
         VPPBB(C,B,A,DX)=VPPBB(C,B,A,DX) - VALUE
      END IF
C
C
C        ============================================
C        Pretend our integral is alpha-beta spin type
C        ============================================
C
C        determine integral's occupancy type
C
  300 CONTINUE
      IAOCC = I.LE.NOA
      JAOCC = J.LE.NOA
      KAOCC = K.LE.NOA
      LAOCC = L.LE.NOA
      IBOCC = I.LE.NOB
      JBOCC = J.LE.NOB
      KBOCC = K.LE.NOB
      LBOCC = L.LE.NOB
C
      IF(IPASS.EQ.2) GO TO 320
      IF(IPASS.GE.3) GO TO 330
C
C        use [ij|kl] integrals
C
C     Noddy code: do i=1,noa ; do j=1,nob ; do k=1,noa ; do l=1,nob
C                    vhhab(i,j,k,l)=t(i,k,j,l)
C
      IF (IAOCC .AND. JAOCC .AND.  KBOCC .AND. LBOCC) THEN
         VHHAB(I,K,J,L)=VHHAB(I,K,J,L) + VALUE
         VHHAB(I,L,J,K)=VHHAB(I,L,J,K) + VALUE
         VHHAB(J,K,I,L)=VHHAB(J,K,I,L) + VALUE
         VHHAB(J,L,I,K)=VHHAB(J,L,I,K) + VALUE
      END IF
C           This one also has to be treated as [kl|ij],aabb
      IF (IBOCC .AND. JBOCC .AND.  KAOCC .AND. LAOCC) THEN
         VHHAB(K,I,L,J)=VHHAB(K,I,L,J) + VALUE
         VHHAB(K,J,L,I)=VHHAB(K,J,L,I) + VALUE
         VHHAB(L,I,K,J)=VHHAB(L,I,K,J) + VALUE
         VHHAB(L,J,K,I)=VHHAB(L,J,K,I) + VALUE
      END IF
C
C        use [aj|kl] integrals: as spins [aa|bb], then [bb|aa]
C
C     Noddy code: do j=1,noa ; do k=1,nob ; do l=1,nob ; do a=1,nua
C                    na=noa+a ; vmab(j,k,a,l)=t(j,na,k,l)
C
      IF(.NOT.IAOCC .AND. JAOCC .AND. KBOCC .AND. LBOCC) THEN
         A = I - NOA
         VMAB(J,K,A,L) = VMAB(J,K,A,L) + VALUE
         VMAB(J,L,A,K) = VMAB(J,L,A,K) + VALUE
      END IF
C
C     Noddy code: do j=1,noa ; do k=1,nob ; do l=1,noa ; do a=1,nub
C                    na=nob+a ; vmba(j,k,l,a)=t(j,l,k,na)
C
      IF(.NOT.IBOCC .AND. JBOCC .AND. KAOCC .AND. LAOCC) THEN
         A = I - NOB
         VMBA(K,J,L,A) = VMBA(K,J,L,A) + VALUE
         VMBA(L,J,K,A) = VMBA(L,J,K,A) + VALUE
      END IF
C           This one also has to be treated as [cl|ij],aabb
C           See below (at VHPLBA) for the rule about how the IF
C           statement below is created from the one just above.
      IF(IAOCC .AND. JAOCC .AND. .NOT.KBOCC .AND. LBOCC) THEN
         C = K - NOB
         VMBA(I,L,J,C) = VMBA(I,L,J,C) + VALUE
         VMBA(J,L,I,C) = VMBA(J,L,I,C) + VALUE
      END IF
C
C        use [aj|cl] integrals
C
C     Noddy code: do j=1,noa ; do l=1,nob ; do a=1,nua ; do b=1,nub
C                    na=noa+a ; nb=nob+b
C                    vhprab(a,j,b,l)=t(na,j,nb,l)
C
      IF(.NOT.IAOCC .AND. JAOCC .AND. .NOT.KBOCC .AND. LBOCC) THEN
         A = I - NOA
         C = K - NOB
         VHPRAB(A,J,C,L) = VHPRAB(A,J,C,L) + VALUE
      END IF
C           This one also has to be treated as [cl|aj],aabb
      IF(.NOT.IBOCC .AND. JBOCC .AND. .NOT.KAOCC .AND. LAOCC) THEN
         A = I - NOB
         C = K - NOA
         VHPRAB(C,L,A,J) = VHPRAB(C,L,A,J) + VALUE
      END IF
C
C        use [ab|kl] integrals
C
C     Noddy code: do k=1,nob ; do l=1,nob ; do a=1,nua ; do b=1,nua
C                    na=noa+a ; nb=noa+b
C                    vhplab(a,k,b,l)=t(na,nb,k,l)
C
      IF(.NOT.IAOCC .AND. .NOT.JAOCC .AND. KBOCC .AND. LBOCC) THEN
         A = I - NOA
         B = J - NOA
         VHPLAB(A,K,B,L) = VHPLAB(A,K,B,L) + VALUE
         VHPLAB(A,L,B,K) = VHPLAB(A,L,B,K) + VALUE
         VHPLAB(B,K,A,L) = VHPLAB(B,K,A,L) + VALUE
         VHPLAB(B,L,A,K) = VHPLAB(B,L,A,K) + VALUE
      END IF
C
C     Noddy code: do k=1,noa ; do l=1,noa ; do a=1,nub ; do b=1,nub
C                    na=nob+a ; nb=nob+b
C                    vhplba(a,k,b,l)=t(na,nb,k,l)
C
      IF(.NOT.IBOCC .AND. .NOT.JBOCC .AND. KAOCC .AND. LAOCC) THEN
         A = I - NOB
         B = J - NOB
         VHPLBA(A,K,B,L) = VHPLBA(A,K,B,L) + VALUE
         VHPLBA(A,L,B,K) = VHPLBA(A,L,B,K) + VALUE
         VHPLBA(B,K,A,L) = VHPLBA(B,K,A,L) + VALUE
         VHPLBA(B,L,A,K) = VHPLBA(B,L,A,K) + VALUE
      END IF
C           This one also has to be treated as [ij|cd],aabb
C           note: As for every other "This one also has to be...",
C                 the IF's pattern is to copy i,j,k,l straight down,
C                 but push a/b and .not.'s between bra <--> ket.
      IF(IAOCC .AND. JAOCC .AND. .NOT.KBOCC .AND. .NOT.LBOCC) THEN
         C = K - NOB
         D = L - NOB
         VHPLBA(C,I,D,J) = VHPLBA(C,I,D,J) + VALUE
         VHPLBA(C,J,D,I) = VHPLBA(C,J,D,I) + VALUE
         VHPLBA(D,I,C,J) = VHPLBA(D,I,C,J) + VALUE
         VHPLBA(D,J,C,I) = VHPLBA(D,J,C,I) + VALUE
      END IF
C
C           now finished with all matrices to be formed during pass 1.
      GO TO 400
C
C        use [aj|cd] and [ab|cl] integrals
C
  320 CONTINUE
C
C     Noddy code: do j=1,noa ; do d=1,nub ; do c=1,nub ; do a=1,nua
C                    na=noa+a ; nc=nob+c ; nd=nob+d
C                    veab(a,c,j,d)=t(na,j,nc,nd)
C
      IF(.NOT.IAOCC .AND. JAOCC .AND. .NOT.KBOCC .AND. .NOT.LBOCC) THEN
         A = I - NOA
         C = K - NOB
         D = L - NOB
         VEAB(A,C,J,D) = VEAB(A,C,J,D) + VALUE
         VEAB(A,D,J,C) = VEAB(A,D,J,C) + VALUE
      END IF
      IF(.NOT.IBOCC .AND. .NOT.JBOCC .AND. .NOT.KAOCC .AND. LAOCC) THEN
         A = I - NOB
         B = J - NOB
         C = K - NOA
         VEAB(C,A,L,B) = VEAB(C,A,L,B) + VALUE
         VEAB(C,B,L,A) = VEAB(C,B,L,A) + VALUE
      END IF
C
C     Noddy code: do j=1,nob ; do d=1,nua ; do a=1,nub ; do c=1,nua
C                    na=nob+a ; nc=noa+c ; nd=noa+d
C                    veba(d,a,c,j)=t(na,j,nc,nd)
C
      IF(.NOT.IBOCC .AND. JBOCC .AND. .NOT.KAOCC .AND. .NOT.LAOCC) THEN
         A = I - NOB
         C = K - NOA
         D = L - NOA
         VEBA(C,A,D,J) = VEBA(C,A,D,J) + VALUE
         VEBA(D,A,C,J) = VEBA(D,A,C,J) + VALUE
      END IF
C           This one also has to be treated as [ab|cl],aabb
      IF(.NOT.IAOCC .AND. .NOT.JAOCC .AND. .NOT.KBOCC .AND. LBOCC) THEN
         A = I - NOA
         B = J - NOA
         C = K - NOB
         VEBA(A,C,B,L) = VEBA(A,C,B,L) + VALUE
         VEBA(B,C,A,L) = VEBA(B,C,A,L) + VALUE
      END IF
C           now finished with all matrices to be formed during pass 2.
      GO TO 400
C
C        use [ab|cd] integrals
C
  330 CONTINUE
C
C        Form <ac||bd> = [ab|cd] - [ad|cb], slicing on d
C                    the Noddy code is
C     do d=1,nub
C      do a=1,nua ; do c=1,nub ; do b=1,nua
C        na=noa+a ; nb=noa+b ; nc=nob+c ; nd=nob+d
C        vppab(a,c,b)=t(na,nb,nc,nd)
C      enddo ; enddo ; enddo
C      write(nft848,rec=nua+nub+d) vppab
C     enddo
C
      IF (.NOT.IAOCC .AND. .NOT.JAOCC .AND.
     *                     .NOT.KBOCC .AND. .NOT.LBOCC) THEN
         A = I - NOA
         B = J - NOA
         C = K - NOB
         D = L - NOB
         IF(C.GE.MNVIRB  .AND.  C.LE.MXVIRB) THEN
            CX = C-MNVIRB+1
            VPPAB(A,D,B,CX)=VPPAB(A,D,B,CX) + VALUE
            VPPAB(B,D,A,CX)=VPPAB(B,D,A,CX) + VALUE
         END IF
         IF(D.GE.MNVIRB  .AND.  D.LE.MXVIRB) THEN
            DX = D-MNVIRB+1
            VPPAB(A,C,B,DX)=VPPAB(A,C,B,DX) + VALUE
            VPPAB(B,C,A,DX)=VPPAB(B,C,A,DX) + VALUE
         END IF
      END IF
C           This one also has to be treated as [cd|ab],aabb
      IF (.NOT.IBOCC .AND. .NOT.JBOCC .AND.
     *                     .NOT.KAOCC .AND. .NOT.LAOCC) THEN
         A = I - NOB
         B = J - NOB
         C = K - NOA
         D = L - NOA
         IF(A.GE.MNVIRB  .AND.  A.LE.MXVIRB) THEN
            AX = A-MNVIRB+1
            VPPAB(C,B,D,AX)=VPPAB(C,B,D,AX) + VALUE
            VPPAB(D,B,C,AX)=VPPAB(D,B,C,AX) + VALUE
         END IF
         IF(B.GE.MNVIRB  .AND.  B.LE.MXVIRB) THEN
            BX = B-MNVIRB+1
            VPPAB(C,A,D,BX)=VPPAB(C,A,D,BX) + VALUE
            VPPAB(D,A,C,BX)=VPPAB(D,A,C,BX) + VALUE
         END IF
      END IF
C
C               end of loop over integrals in the current bufferload
C
  400 CONTINUE
C
C         We are now done processing this particular integral buffer.
C         Go back for next buffer, if not at the end of integral file.
C
      IF(NX.GT.0) GO TO 10
C
C        The entire transformed integral file has now been processed.
C        Write out double bar integrals constructed during this pass.
C
  450 CONTINUE
C
      IF(IPASS.EQ.1) THEN
         CALL WRINT(1,NOA2 ,NOA2 ,VHHAA ,NFT820)
         CALL WRINT(1,NOB2 ,NOB2 ,VHHBB ,NFT821)
         CALL WRINT(1,NOAB ,NOAB ,VHHAB ,NFT822)
         WRITE(IW,9050) NOA2*NOA2,'<OA OA||OA OA>',NFT820
         WRITE(IW,9050) NOB2*NOB2,'<OB OB||OB OB>',NFT821
         WRITE(IW,9050) NOAB*NOAB,'<OA OB||OA OB>',NFT822
C
         CALL WRINT(1,NOAUA,NOA2 ,VMAA  ,NFT823)
         CALL WRINT(1,NOBUB,NOB2 ,VMBB  ,NFT826)
         CALL WRINT(1,NOBUA,NOAB ,VMAB  ,NFT827)
         CALL WRINT(1,NOAUB,NOAB ,VMBA  ,NFT828)
         WRITE(IW,9050) NOA2*NOAUA,'<VA OA||OA OA>',NFT823
         WRITE(IW,9050) NOB2*NOBUB,'<VB OB||OB OB>',NFT826
         WRITE(IW,9050) NOAB*NOBUA,'<VA OB||OA OB>',NFT827
         WRITE(IW,9050) NOAB*NOAUB,'<OA VB||OA OB>',NFT828
C
         CALL WRINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
         CALL WRINT(1,NOBUB,NOBUB,VHPRBB,NFT830)
         CALL WRINT(1,NOBUB,NOAUA,VHPRAB,NFT833)
         WRITE(IW,9050) NOAUA*NOAUA,'(VA OA  VA OA)',NFT829
         WRITE(IW,9050) NOBUB*NOBUB,'(VB OB  VB OB)',NFT830
         WRITE(IW,9050) NOAUA*NOBUB,'(VA OB  VA OB)',NFT833
C
         CALL WRINT(1,NOAUA,NOAUA,VHPLAA,NFT831)
         CALL WRINT(1,NOBUB,NOBUB,VHPLBB,NFT832)
         CALL WRINT(1,NOBUA,NOBUA,VHPLAB,NFT834)
         CALL WRINT(1,NOAUB,NOAUB,VHPLBA,NFT835)
         WRITE(IW,9050) NOAUA*NOAUA,'<VA OA||VA OA>',NFT831
         WRITE(IW,9050) NOBUB*NOBUB,'<VB OB||VB OB>',NFT832
         WRITE(IW,9050) NOBUA*NOBUA,'<VA OB||VA OB>',NFT834
         WRITE(IW,9050) NOAUB*NOAUB,'<OA VB||OA VB>',NFT835
      END IF
C
      IF(IPASS.EQ.2) THEN
         CALL WRINT(1,NOAUA,NUA2 ,VEAA  ,NFT836)
         CALL WRINT(1,NOBUB,NUB2 ,VEBB  ,NFT837)
         CALL WRINT(1,NOAUB,NUAB ,VEAB  ,NFT838)
         CALL WRINT(1,NOBUA,NUAB ,VEBA  ,NFT839)
         WRITE(IW,9050) NUA2*NOAUA,'<VA VA||OA VA>',NFT836
         WRITE(IW,9050) NUB2*NOBUB,'<VB VB||OB VB>',NFT837
         WRITE(IW,9050) NUAB*NOAUB,'<VA VB||OA VB>',NFT838
         WRITE(IW,9050) NUAB*NOBUA,'<VA VB||VA OB>',NFT839
      END IF
C
      IF(IPASS.GE.3) THEN
         DO D=MNVIRA,MXVIRA
            KOL = D-MNVIRA+1
            IREC= D
            IF(D.NE.0) CALL WRRLE(NFT848,IREC,NUA3  ,VPPAA(1,1,1,KOL))
         ENDDO
         DO D=MNVIRB,MXVIRB
            KOL = D-MNVIRB+1
            IREC= NUA+D
            IF(D.NE.0) CALL WRRLE(NFT848,IREC,NUB3  ,VPPBB(1,1,1,KOL))
         ENDDO
         DO D=MNVIRB,MXVIRB
            KOL = D-MNVIRB+1
            IREC= NUA+NUB+D
            IF(D.NE.0) CALL WRRLE(NFT848,IREC,NUA2UB,VPPAB(1,1,1,KOL))
         ENDDO
      END IF
C
C         The actual file size of NFT848 will exceed the sum of these
C         three due to using a worst case record size for all 3 types.
C
      IF(IPASS.EQ.MXPASS) THEN
         WRITE(IW,9050) NUA2*NUA2,'<VA VA||VA VA>',NFT848
         WRITE(IW,9050) NUB2*NUB2,'<VB VB||VB VB>',NFT848
         WRITE(IW,9050) NUAB*NUAB,'<VA VB||VA VB>',NFT848
      END IF
C
C        Go back to the next pass over integrals, if we aren't done yet.
C
      IF(IPASS.LT.MXPASS) GO TO 5
C
      CALL SEQREW(IJKT)
      RETURN
C
 9010 FORMAT(1X,'PASS=',I3,', WILL PROCESS [OO|OO], [VO|OO], [VV|OO],',
     *          ' AND [VO|VO] INTEGRALS.')
 9020 FORMAT(1X,'PASS=',I3,', WILL PROCESS [VV|VO] INTEGRALS.')
 9030 FORMAT(1X,'PASSES',I3,' TO',I3,' WILL PROCESS [VV|VV] INTEGRALS.')
 9040 FORMAT(1X,'PASS=',I3,', DOING MN-MX ALPHA VIRTUAL=',I4,'-',I4,
     *                           ', MN-MX BETA VIRTUAL=',I4,'-',I4)
 9050 FORMAT(11X,'WROTE',I15,' WORDS OF ',A,' INTS TO FILE',I4)
      END
C
C*MODULE ROHFCC  *DECK WRINT
      SUBROUTINE WRINT(N1,N2,N3,T,IFILE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T(N3,N2)
C
C        this routine was changed to match RDINT, by
C           adding the N1 record number option,
C           flipping the order of arg's N2 and N3 to match RDINT's.
C        This eliminated a buffer argument, TI, as well.
C
      DO I=1, N2
         IREC=N1+I-1
         CALL WRRLE(IFILE,IREC,N3,T(1,I))
      ENDDO
      RETURN
      END
C
C*MODULE ROHFCC  *DECK RDINT
      SUBROUTINE RDINT(N1,N2,N3,T,IFILE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T(N3,N2)
C
      DO I=1,N2
         IREC=N1+I-1
         CALL RDRLE(IFILE,IREC,N3,T(1,I))
      ENDDO
      RETURN
      END
C
C*MODULE ROHFCC  *DECK DRCCOPEN
      SUBROUTINE DRCCOPEN(NOA,NUA,NOB,NUB,EHA,EPA,EHB,EPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION EHA(*),EPA(*),EHB(*),EPB(*)
C
      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
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA CCSD/8HCCSD    /
      DATA CHECK/8HCHECK   /
C
C     --- actual driver for open shell ccsd, lambda, mm(2,3) ---
C         h=occupied, h means "holes" which are occupied
C                       states in the Fermi vacuum
C         p= virtual, p means "particles" which are unoccupied
C                       states in the Fermi vacuum
C
      WRITE(IW,9000)
      ITER=0
C
C         ----- open shell ccsd iterations -----
C     the quartic sized arrays used here are
C     1*No**4 + 1*No**3*Nu +  9*No**2*Nu**2 + 3*No*Nu**3 - right CCSD
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU       ! O1AA
      I3   = I2     + NOU       ! T1
      I4   = I3     + NOU       ! O1BB
      I5   = I4     + NO4       ! VHHAA
      I6   = I5     + NO2U2     ! VHPLAA
      I7   = I6     + NO2U2     ! VHPLBB
      I8   = I7     + NO2U2     ! O2AA
      I9   = I8     + NO2U2     ! O2BB
      I10  = I9     + NO2U2     ! O2AB
      I11  = I10    + NOU3      ! VEAB
      I12  = I11    + NOU3      ! VEBA
      I13  = I12    + NO2U2     ! VHPRBB   !JRG
      I14  = I13    + NO2U2     ! VHPRAA   !JRG
      I15  = I14    + NO2U2     ! VHPRAB
      I16  = I15    + NOU3      ! TI
      I17  = I16    + NO3U      ! VMAA
      I18  = I17    + NOU       ! FHP
      I19  = I18    + NO2       ! FHHAA    !JRG
      I20  = I19    + NO2       ! FHHBB    !JRG
      I21  = I20    + NU2       ! FPPAA    !JRG
      I22  = I21    + NU2       ! FPPBB    !JRG
      I23  = I22    + NO2U2     ! T2
      I24  = I23    + NU3       ! VPP
      I25  = I24    + (KMICRO+1)**2  ! XMAT
      I26  = I25    + (KMICRO+1)     ! BVEC
      LAST = I26    + (KMICRO+1)     ! IPVT
      NEED=LAST-LOADFM-1
      ITER=ITER+1
      IF (ITER.EQ.1) THEN
         WRITE(IW,9010) NEED
         CALL FLSHBF(IW)
      END IF
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 22
C
      CALL OPEN_CCSD(NOA,NUA,NOB,NUB,X(I1),X(I2),X(I3),X(I4),
     *               X(I5),X(I6),X(I7),X(I8),X(I9),X(I10),X(I11),
     *               X(I12),X(I13),X(I14),X(I15),X(I16),X(I17),
     *               X(I18),X(I19),X(I20),X(I21),X(I22),X(I23),
     *               X(I24),X(I25),X(I26),EHA,EPA,EHB,EPB)
C
   22 CONTINUE
      CALL RETFM(NEED)
C
      WRITE(IW,9020)
      CALL TIMIT(1)
C
C        if this is just CCSD, we are now finished
C
      IF(CCTYP.EQ.CCSD) RETURN
C
C     ---- one particle h-bar intermediates ----
C     the quartic sized arrays used here are
C     0*No**4 + 4*No**3*Nu +  6*No**2*Nu**2 + 2*No*Nu**3 - H-bar(one)
C
      WRITE(IW,9030)
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NO2     ! FHHAA   !JRG
      I3   = I2     + NOU     ! O1AA    !JRG
      I4   = I3     + NOU     ! O1BB    !JRG
      I5   = I4     + NO2     ! FHHBB   !JRG
      I6   = I5     + NU2     ! FPPAA   !JRG
      I7   = I6     + NU2     ! FPPBB   !JRG
      I8   = I7     + NOU     ! FHPAA   !JRG
      I9   = I8     + NOU     ! FHPBB   !JRG
      I10  = I9     + NO2U2   ! O2AA
      I11  = I10    + NO2U2   ! O2BB
      I12  = I11    + NO2U2   ! O2AB
      I13  = I12    + NOU3    ! VEAA
      I14  = I13    + NO2U2   ! VHPRBB  !JRG
      I15  = I14    + NO2U2   ! VHPRAA  !JRG
      I16  = I15    + NO2U2   ! VHPRAB
      I17  = I16    + NOU3    ! TI
      I18  = I17    + NO3U    ! VMAB
      I19  = I18    + NO3U    ! VMBA
      I20  = I19    + NO3U    ! VMAA
      LAST = I20    + NO3U    ! VMBB
      NEED=LAST-LOADFM-1
      WRITE(IW,9040) NEED
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 33
C
      CALL ONEHBAR(NOA,NUA,NOB,NUB,X(I1),X(I2),X(I3),X(I4),X(I5),
     *             X(I6),X(I7),X(I8),X(I9),X(I10),X(I11),X(I12),X(I13),
     *             X(I14),X(I15),X(I16),X(I17),X(I18),X(I19),X(I20))
C
   33 CONTINUE
      CALL RETFM(NEED)
C
C     ---- two particle h-bar intermediates ----
C     the quartic sized arrays used here are
C     0*No**4 + 3*No**3*Nu +  7*No**2*Nu**2 + 4*No*Nu**3 - H-bar(two)
C
      CALL VALFM(LOADFM)
      I1   = LOADFM +  1
      I2   = I1     + NOU      ! O1AA      !JRG
      I3   = I2     + NOU      ! O1BB      !JRG
      I4   = I3     + NO4      ! VHHHHAA
      I5   = I4     + NO2U2    ! VHPLAA
      I6   = I5     + NO2U2    ! O2AA
      I7   = I6     + NO2U2    ! O2BB
      I8   = I7     + NO2U2    ! O2AB
      I9   = I8     + NOU3     ! VEBB
      I10  = I9     + NOU3     ! VEAB
      I11  = I10    + NOU3     ! VEBA
      I12  = I11    + NO2U2    ! VHPRBB    !JRG
      I13  = I12    + NO2U2    ! VHPRAA    !JRG
      I14  = I13    + NO2U2    ! VHPRAB
      I15  = I14    + NOU3     ! TI
      I16  = I15    + NO3U     ! VMAB
      I17  = I16    + NO3U     ! VMBA
      I18  = I17    + NO3U     ! VMAA
      I19  = I18    + NOU      ! FHP
      LAST = I19    + NU3      ! VPP        !JRG
      NEED=LAST-LOADFM-1
      WRITE(IW,9050) NEED
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 44
C
      CALL TWOHBAR(NOA,NUA,NOB,NUB,X(I1),X(I2),X(I3),X(I4),
     *             X(I5),X(I6),X(I7),X(I8),X(I9),X(I10),X(I11),X(I12),
     *             X(I13),X(I14),X(I15),X(I16),X(I17),X(I18),X(I19))
C
   44 CONTINUE
      CALL RETFM(NEED)
C
      WRITE(IW,9060)
      CALL TIMIT(1)
C
C        ----- solve for left eigenstates (lambda equation) -----
C     the quartic sized arrays used here are
C     1*No**4 + 1*No**3*Nu +  7*No**2*Nu**2 + 2*No*Nu**3 - left CCSD
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU            ! OL1AA
      I3   = I2     + NOU            ! OL1BB
      I4   = I3     + NOU            ! HL1
      I5   = I4     + NO2U2          ! OL2AA
      I6   = I5     + NO2U2          ! OL2BB
      I7   = I6     + NO2U2          ! OL2AB
      I8   = I7     + NO2U2          ! HL2
      I9   = I8     + NOU3           ! TI
      I11  = I9     + NO3U           ! VHPHH
      I12  = I11    + NO2            ! FHH
      I13  = I12    + NU2            ! FPP
      I14  = I13    + NOU            ! FHP
      I15  = I14    + NOU3           ! VHPPP
      I16  = I15    + NO2U2          ! VHPHP
      I17  = I16    + NO4            ! VHHHH
      I18  = I17    + NU3            ! VPPP
      I19  = I18    + NO2U2          ! VHPPH
      I20  = I19    + NO2U2          ! T2
      I21  = I20    + NO2            ! OHHA    !JRG
      I22  = I21    + NO2            ! OHHB    !JRG
      I23  = I22    + NU2            ! OPPA    !JRG
      I24  = I23    + NU2            ! OPPB    !JRG
      I25  = I24    + (LMICRO+1)**2  ! XMAT
      I26  = I25    + (LMICRO+1)     ! BVEC
      LAST = I26    + (LMICRO+1)     ! IPVT
      NEED=LAST-LOADFM-1
      WRITE(IW,9070) NEED
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 55
C
      CALL OPENLEFT(NOA,NUA,NOB,NUB,X(I1),X(I2),X(I3),X(I4),X(I5),
     *              X(I6),X(I7),X(I8),X(I9),X(I11),X(I12),
     *              X(I13),X(I14),X(I15),X(I16),X(I17),X(I18),X(I19),
     *              X(I20),X(I21),X(I22),X(I23),X(I24),X(I25),X(I26),
     *              EHA,EPA,EHB,EPB)
C
   55 CONTINUE
      CALL RETFM(NEED)
C
      WRITE(IW,9080)
      CALL TIMIT(1)
C
C            --- method of moments MM(2,3) energy correction ---
C        There are three options, if keyword IOPMET is 0 (default), we
C        pick the first algorithm whose memory requirement fits into
C        the available space NGOTMX.
C        For debugging, the -IOPMET- keyword forces specific choices.
C
      CALL GOTFM(NGOTMX)
      WRITE(IW,9090) NGOTMX
C
      IF(EXETYP.EQ.CHECK) GO TO 1000
C
      IF(IOPCCMET.EQ.1) GO TO 1000
      IF(IOPCCMET.EQ.2) GO TO 2000
      IF(IOPCCMET.EQ.3) GO TO 3000
C
C         ----- High Memory Option -----
C     Option 1 is the fastest algorithm.
C     The triply excited moments M3 are not stored in LAMB23 file.
C
C     the quartic sized arrays used here are
C     0*No**4 + 6*No**3*Nu + 10*No**2*Nu**2 + 6*No*Nu**3 - MM(2,3) code1
C
 1000 CONTINUE
      CALL VALFM(LOADFM)
      I1  = LOADFM + 1
      I2   = I1     + NOU       ! O1AA    !JRG
      I3   = I2     + NOU       ! O1BB    !JRG
      I4   = I3     + NO2U2     ! L2AA
      I5   = I4     + NO2U2     ! L2BB
      I6   = I5     + NO2U2     ! L2AB
      I7   = I6     + NO2U2     ! O2
      I8   = I7     + NO2U2     ! O2AA
      I9   = I8     + NO2U2     ! O2BB
      I10  = I9     + NO2U2     ! O2AB
      I11  = I10    + NOU3      ! VEAA
      I12  = I11    + NOU3      ! VEBB
      I13  = I12    + NOU3      ! VEAB
      I14  = I13    + NOU3      ! VEBA
      I15  = I14    + NOU3      ! VEAB21
      I16  = I15    + NOU3      ! VEBA21
      I17  = I16    + NOU       ! FHPAA     !JRG
      I18  = I17    + NOU       ! FHPBB     !JRG
      I19  = I18    + NO2U2     ! VHPRAA
      I20  = I19    + NO2U2     ! VHPRBB
      I21  = I20    + NU3       ! M3
      I22  = I21    + NU3       ! L3
      I23  = I22    + NO2U2     ! VHPRAB
      I24  = I23    + NU3       ! TI
      I25  = I24    + NO3U      ! VMAB
      I26  = I25    + NO3U      ! VMBA
      I27  = I26    + NO3U      ! VMAA
      I28  = I27    + NO3U      ! VMBB
      I29  = I28    + NO3U      ! VMAB21
      I30  = I29    + NO3U      ! VMBA21
      I31  = I30    + NO2       ! FHHA      !JRG
      I32  = I31    + NO2       ! FHHB      !JRG
      I33  = I32    + NU2       ! FPPA      !JRG
      I34  = I33    + NU2       ! FPPB      !JRG
      I35  = I34    + NO2       ! X1AA      !JRG
      I36  = I35    + NO2       ! X1BB      !JRG
      I37  = I36    + NO2       ! X1AB      !JRG
      I38  = I37    + NU2       ! X2AA      !JRG
      I39  = I38    + NU2       ! X2BB      !JRG
      I40  = I39    + NU2       ! X2AB      !JRG
      I41  = I40    + NOU       ! X3AA      !JRG
      I42  = I41    + NOU       ! X3BB      !JRG
      I43  = I42    + NOU       ! X3AB      !JRG
      I44  = I43    + NOU       ! X3BA      !JRG
      I45  = I44    + NOU2      ! X4AAA     !JRG
      I46  = I45    + NOU2      ! X4AAB     !JRG
      I47  = I46    + NOU2      ! X4BBA     !JRG
      I48  = I47    + NOU2      ! X4BBB     !JRG
      I49  = I48    + NO2U      ! X5AAA     !JRG
      I50  = I49    + NO2U      ! X5AAB     !JRG
      I51  = I50    + NO2U      ! X5BBA     !JRG
      I52  = I51    + NO2U      ! X5BBB     !JRG
      LAST = I52    + NO4       ! VHHHH
      NEED1=LAST-LOADFM-1
      WRITE(IW,9110) NEED1,'HIGH MEMORY VERSION (1)'
      CALL FLSHBF(IW)
C
      IF(EXETYP.EQ.CHECK) GO TO 2000
      IF(IOPCCMET.EQ.0  .AND.  NEED1.GT.NGOTMX) GO TO 2000
C
      WRITE(IW,9100) 'HIGH MEMORY VERSION'
      IF(NEED1.GT.NGOTMX) WRITE(IW,9150) NEED1,NGOTMX
      CALL GETFM(NEED1)
      CALL LAMB23(NOA,NUA,NOB,NUB,X(I1),X(I2),X(I3),X(I4),X(I5),
     *    X(I6),X(I7),X(I8),X(I9),X(I10),X(I11),X(I12),X(I13),
     *    X(I14),X(I15),X(I16),X(I17),X(I18),X(I19),X(I20),X(I21),
     *    X(I22),X(I23),X(I24),X(I25),X(I26),X(I27),X(I28),X(I29),
     *    X(I30),X(I31),X(I32),X(I33),X(I34),X(I35),X(I36),X(I37),
     *    X(I38),X(I39),X(I40),X(I41),X(I42),X(I43),X(I44),X(I45),
     *    X(I46),X(I47),X(I48),X(I49),X(I50),X(I51),X(I52),
     *    EHA,EPA,EHB,EPB)
      CALL RETFM(NEED1)
      GO TO 7000
C
C         ----- High Disk Option -----
C     Option 2 is slower than the High Memory Option, using less memory.
C     The memory required is about half the above.
C     Triply excited moments M3 are calculated in the following order:
C     M3(aaa), then M3(bbb), then M3(aab), and finally M3(abb),
C     each being stored on the disk in the LAMB23 file.
C     size of LAMB23 = k * record nu**3, where k is defined, more or
C     less, as the no. of triples of i<j<k for a given spin type.
C
C     the quartic sized arrays used here are
C     1*No**4 + 3*No**3*Nu +  6*No**2*Nu**2 + 3*No*Nu**3 - MM(2,3) code2
C
 2000 CONTINUE
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU     ! O1AA    !JRG
      I3   = I2     + NOU     ! O1BB    !JRG
      I4   = I3     + NO2U2   ! O2AA
      I5   = I4     + NO2U2   ! O2BB
      I6   = I5     + NO2U2   ! O2AB
      I7   = I6     + NOU3    ! VEAA
      I8   = I7     + NOU3    ! VEAB
      I9   = I8     + NOU3    ! VEBA
      I10  = I9     + NO4     ! VHHHH
      I11  = I10    + NOU     ! FHPAA
      I12  = I11    + NOU     ! FHPBB
      I13  = I12    + NU3     ! VPP
      I14  = I13    + NO2U2   ! VHPRAA
      I15  = I14    + NO2U2   ! VHPRBB
      I16  = I15    + NO2U2   ! VHPRAB
      I17  = I16    + NU3     ! TI
      I18  = I17    + NO3U    ! VMAB
      I19  = I18    + NO3U    ! VMBA
      I20  = I19    + NO3U    ! VMAA
      I21  = I20    + NO2     ! FHHA    !JRG
      I22  = I21    + NO2     ! FHHB    !JRG
      I23  = I22    + NU2     ! FPPA    !JRG
      I24  = I23    + NU2     ! FPPB    !JRG
      I25  = I24    + NO2     ! X1AA    !JRG
      I26  = I25    + NO2     ! X1BB    !JRG
      I27  = I26    + NO2     ! X1AB    !JRG
      I28  = I27    + NU2     ! X2AA    !JRG
      I29  = I28    + NU2     ! X2BB    !JRG
      I30  = I29    + NU2     ! X2AB    !JRG
      I31  = I30    + NOU     ! X3AA    !JRG
      I32  = I31    + NOU     ! X3BB    !JRG
      I33  = I32    + NOU     ! X3AB    !JRG
      I34  = I33    + NOU     ! X3BA    !JRG
      I35  = I34    + NOU2    ! X4AAA   !JRG
      I36  = I35    + NOU2    ! X4AAB   !JRG
      I37  = I36    + NOU2    ! X4BBA   !JRG
      I38  = I37    + NOU2    ! X4BBB   !JRG
      I39  = I38    + NO2U    ! X5AAA   !JRG
      I40  = I39    + NO2U    ! X5AAB   !JRG
      I41  = I40    + NO2U    ! X5BBA   !JRG
      LAST = I41    + NO2U    ! X5BBB   !JRG
      NEED2=LAST-LOADFM-1
      WRITE(IW,9110) NEED2,'HIGH DISK VERSION   (2)'
      CALL FLSHBF(IW)
C
      IF(EXETYP.EQ.CHECK) GO TO 3000
      IF(IOPCCMET.EQ.0  .AND.  NEED2.GT.NGOTMX) GO TO 3000
C
      WRITE(IW,9100) 'HIGH DISK VERSION'
      IF(NEED2.GT.NGOTMX) WRITE(IW,9160) NEED2,NGOTMX
      CALL GETFM(NEED2)
      CALL MOM23(NOA,NUA,NOB,NUB,X(I1),X(I2),X(I3),X(I4),X(I5),
     *    X(I6),X(I7),X(I8),X(I9),X(I10),X(I11),X(I12),X(I13),X(I14),
     *    X(I15),X(I16),X(I17),X(I18),X(I19),X(I20),X(I21),X(I22),
     *    X(I23),X(I24),X(I25),X(I26),X(I27),X(I28),X(I29),X(I30),
     *    X(I31),X(I32),X(I33),X(I34),X(I35),X(I36),X(I37),X(I38),
     *    X(I39),X(I40),X(I41),EHA,EPA,EHB,EPB)
      CALL RETFM(NEED2)
      GO TO 7000
C
C         ----- High I/O Option -----
C     Option 3 is slower than the High Memory and High Disk options.
C     Option 3 uses less memory than High Memory, more than High Disk.
C     The triply excited moments M3 are not stored in LAMB23 file.
C     For each combination of i<j<k, we read the hbar matrix elements
C     using a matrix of dimension no*nu**3 to multiply them by T2
C     cluster amplitudes.
C
C     the quartic sized arrays used here are
C     1*No**4 + 6*No**3*Nu + 10*No**2*Nu**2 + 3*No*Nu**3 - MM(2,3) code3
C
 3000 CONTINUE
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU       ! O1AA   !JRG
      I3   = I2     + NOU       ! O1BB   !JRG
      I4   = I3     + NO2U2     ! L2AA
      I5   = I4     + NO2U2     ! L2BB
      I6   = I5     + NO2U2     ! L2AB
      I7   = I6     + NO2U2     ! O2
      I8   = I7     + NO2U2     ! O2AA
      I9   = I8     + NO2U2     ! O2BB
      I10  = I9     + NO2U2     ! O2AB
      I11  = I10    + NOU3      ! VEAA
      I12  = I11    + NOU3      ! VEAB
      I13  = I12    + NOU3      ! VEBA
      I14  = I13    + NOU       ! FHPAA   !JRG
      I15  = I14    + NOU       ! FHPBB   !JRG
      I16  = I15    + NO2U2     ! VHPRAA
      I17  = I16    + NO2U2     ! VHPRBB
      I18  = I17    + NU3       ! M3
      I19  = I18    + NU3       ! L3
      I20  = I19    + NO2U2     ! VHPRAB
      I21  = I20    + NU3       ! TI
      I22  = I21    + NO3U      ! VMAB
      I23  = I22    + NO3U      ! VMBA
      I24  = I23    + NO3U      ! VMAA
      I25  = I24    + NO3U      ! VMBB
      I26  = I25    + NO3U      ! VMAB21
      I27  = I26    + NO3U      ! VMBA21
      I28  = I27    + NO2       ! FHHA   !JRG
      I29  = I28    + NO2       ! FHHB   !JRG
      I30  = I29    + NU2       ! FPPA   !JRG
      I31  = I30    + NU2       ! FPPB   !JRG
      I32  = I31    + NO2       ! X1AA   !JRG
      I33  = I32    + NO2       ! X1BB   !JRG
      I34  = I33    + NO2       ! X1AB   !JRG
      I35  = I34    + NU2       ! X2AA   !JRG
      I36  = I35    + NU2       ! X2BB   !JRG
      I37  = I36    + NU2       ! X2AB   !JRG
      I38  = I37    + NOU       ! X3AA   !JRG
      I39  = I38    + NOU       ! X3BB   !JRG
      I40  = I39    + NOU       ! X3AB   !JRG
      I41  = I40    + NOU       ! X3BA   !JRG
      I42  = I41    + NOU2      ! X4AAA  !JRG
      I43  = I42    + NOU2      ! X4AAB  !JRG
      I44  = I43    + NOU2      ! X4BBA  !JRG
      I45  = I44    + NOU2      ! X4BBB  !JRG
      I46  = I45    + NO2U      ! X5AAA  !JRG
      I47  = I46    + NO2U      ! X5AAB  !JRG
      I48  = I47    + NO2U      ! X5BBA  !JRG
      I49  = I48    + NO2U      ! X5BBB  !JRG
      LAST = I49    + NO4       ! VHHHH
      NEED3=LAST-LOADFM-1
      WRITE(IW,9110) NEED3,'HIGH I/O VERSION    (3)'
      CALL FLSHBF(IW)
C
      IF(EXETYP.EQ.CHECK) GO TO 7000
C
      WRITE(IW,9100) 'HIGH I/O VERSION'
      CALL GETFM(NEED3)
      CALL LAMB23_IO(NOA,NUA,NOB,NUB,X(I1),X(I2),X(I3),X(I4),
     *    X(I5),X(I6),X(I7),X(I8),X(I9),X(I10),X(I11),X(I12),X(I13),
     *    X(I14),X(I15),X(I16),X(I17),X(I18),X(I19),X(I20),X(I21),
     *    X(I22),X(I23),X(I24),X(I25),X(I26),X(I27),X(I28),X(I29),
     *    X(I30),X(I31),X(I32),X(I33),X(I34),X(I35),X(I36),X(I37),
     *    X(I38),X(I39),X(I40),X(I41),X(I42),X(I43),X(I44),X(I45),
     *    X(I46),X(I47),X(I48),X(I49),
     *    EHA,EPA,EHB,EPB)
      CALL RETFM(NEED3)
C
C        now done, no matter which of the three options was executed
C
 7000 CONTINUE
      IF(EXETYP.EQ.CHECK) THEN
         NEED = MIN(NEED1,NEED2,NEED3)
         IF(NEED.GT.NGOTMX) THEN
            WRITE(IW,9130) NEED,NGOTMX
            CALL ABRT
         END IF
      END IF
C
      WRITE(IW,9120)
      CALL TIMIT(1)
      RETURN
C
 9000 FORMAT(/8X,'-----------------------'/
     *        8X,'OPEN-SHELL CCSD PROGRAM'/
     *        8X,'-----------------------')
 9010 FORMAT(1X,'MEMORY NEEDED BY CCSD    : ',I12,' WORDS')
 9020 FORMAT(1X,'....... DONE WITH CCSD AMPLITUDE ITERATIONS .......')
 9030 FORMAT(/8X,'-------------------------------------'/
     *        8X,'OPEN-SHELL EQUATION-OF-MOTION PROGRAM'/
     *        8X,'-------------------------------------')
 9040 FORMAT(1X,'MEMORY NEEDED BY ONEHBAR : ',I12,' WORDS')
 9050 FORMAT(1X,'MEMORY NEEDED BY TWOHBAR : ',I12,' WORDS')
 9060 FORMAT(1X,'....... DONE WITH MATRIX ELEMENTS OF HBAR .......')
 9070 FORMAT(/1X,'MEMORY NEEDED BY OPENLEFT: ',I12,' WORDS')
 9080 FORMAT(1X,'....... DONE WITH LAMBDA AMPLITUDE ITERATIONS .......')
 9090 FORMAT(/8X,'-----------------------------'/
     *        8X,'OPEN-SHELL CR-CC(2,3) PROGRAM'/
     *        8X,'-----------------------------'/
     *        9X,'AVAILABLE MEMORY : ',I12,' WORDS')
 9100 FORMAT(1X,'CHOOSING THE -',A,'- FOR OPEN SHELL MM(2,3)')
 9110 FORMAT(1X,'MEMORY NEEDED BY MM(2,3) : ',I12,' WORDS, CODE=',A)
 9120 FORMAT(/1X,'..... DONE WITH CC NON-ITERATIVE TRIPLES CORRECTIONS',
     *          ' .....')
 9130 FORMAT(//1X,'THERE IS NOT ENOUGH MEMORY TO EXECUTE ANY',
     *            ' OF THE MM(2,3) CODES.'/
     *   1X,'REQUIRED=',I14,' AVAILABLE=',I14,' WORDS'//)
 9150 FORMAT(1X,'NOT ENOUGH MEMORY FOR THE FASTEST HIGH MEMORY',
     *          ' CR-CC(2,3) OPTION'/
     *       1X,'MEMORY NEEDED = ',I10,' MEMORY AVAILABLE = ',I10/
     *       1X,'PLEASE INCREASE THE MEMORY AND RESUBMIT OR, IF',
     *          ' THE MEMORY REQUIRED'/
     *       1X,'BY THE IOPMET = 1 OPTION IS NOT AVAILABLE, CHOOSE',
     *          ' ONE OF THE'/
     *       1X,'FOLLOWING ALTERNATIVES:'/
     *       1X,'A. IF THERE IS ENOUGH DISK SPACE TO STORE THE',
     *          ' TRIPLES-LIKE VECTOR'/
     *       1X,'(WHOSE DIMENSION IS ON THE ORDER OF ',
     *          '(NO**3)(NU**3)/6) AND ALL'/
     *       1X,'OTHER INTEGRAL, AMPLITUDE, AND INTERMEDIATE FILES',
     *          ' THAT ARE COMMON'/
     *       1X,'TO ALL CR-CC(2,3) RUNS, CHOOSE THE HIGH DISK',
     *          ' IOPMET = 2 OPTION,'/
     *       1X,'WHICH IS SLOWER THAN THE HIGH MEMORY IOPMET = 1',
     *          ' OPTION, BUT FASTER'/
     *       1X,'THAN THE IOPMET = 3 HIGH I/O OPTION.'/
     *       1X,'B. IF THERE IS NOT ENOUGH DISK SPACE FOR THE',
     *          ' IOPMET = 2 OPTION,'/
     *       1X,'CHOOSE THE HIGH I/O, BUT LOWER-DISK AND SLOWER',
     *          ' IOPMET = 3 OPTION.')
 9160 FORMAT(1X,'NOT ENOUGH MEMORY FOR THE HIGH DISK STORAGE '/
     *          ' CR-CC(2,3) OPTION'/
     *       1X,'MEMORY NEEDED = ',I10,' MEMORY AVAILABLE = ',I10/
     *       1X,'PLEASE CHECK THE REQUESTED MEMORY, MAKE SURE THAT',
     *          ' YOU HAVE ENOUGH DISK,'/
     *       1X,'AND RESUBMIT, OR CHOOSE ONE OF THE FOLLOWING',
     *          ' ALTERNATIVES:'/
     *       1X,'A. IF THERE IS NOT ENOUGH DISK SPACE TO STORE THE',
     *          ' TRIPLES-LIKE VECTOR'/
     *       1X,'(WHOSE DIMENSION IS ON THE ORDER OF',
     *          ' (NO**3)(NU**3)/6) AND ALL'/
     *       1X,'OTHER INTEGRAL, AMPLITUDE, AND INTERMEDIATE FILES',
     *          ' THAT ARE COMMON'/
     *       1X,'TO ALL CR-CC(2,3) RUNS, BUT THERE IS ENOUGH MEMORY',
     *          ' FOR THE HIGH-MEMORY'/
     *       1X,'IOPMET=1 OPTION, CHOOSE OPTION IOPMET=1, WHICH IS',
     *          ' THE FASTEST.'/
     *       1X,'B. IF THERE IS NOT ENOUGH DISK SPACE FOR THE',
     *          ' IOPMET=2 OPTION AND NOT'/
     *       1X,'ENOUGH MEMORY FOR THE IOPMET=1 OPTION, CHOOSE THE',
     *          ' HIGH I/O, BUT LOWER'/
     *       1X,'DISK SPACE BUT SLOWER IOPMET=3 OPTION.')
      END
C
C*MODULE ROHFCC  *DECK OPEN_CCSD
      SUBROUTINE OPEN_CCSD(NOA,NUA,NOB,NUB,O1AA,T1,O1BB,VHHAA,VHPLAA,
     *VHPLBB,O2AA,O2BB,O2AB,VEAB,VEBA,VHPRBB,VHPRAA,VHPRAB,TI,VMAA,FHP,
     *FHHAA,FHHBB,FPPAA,FPPBB,T2,VPP,XMAT,BVEC,IPVT,EHA,EPA,EHB,EPB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      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
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION TI(1),VHPLAA(1),VHPRAA(1),VHHAA(1),
     *          O1AA(1),O1BB(1),O2AA(1),VHPLBB(1),O2AB(1),O2BB(1),
     *          VEAB(1),VHPRAB(1),VMAA(1),VHPRBB(1),VEBA(1),FHP(1),
     *          T1(1),FHHAA(1),FHHBB(1),FPPAA(1),FPPBB(1),VPP(1),
     *          T2(1),EHA(NOA),EPA(NUA),EHB(NOB),EPB(NUB)
C
      DATA TWO/2.0D+0/,HALF/0.5D+0/,ONE/1.0D+00/,
     *     FOURTH/0.25D+0/,FOUR/4.0D+0/,EIGHT/8.0D+0/
C
C          'jestem w open_ccsd'
C
C     --------------------NOTES--------------------------------
C     iconv is convergence threshold
C     maxit is maximum number of iterations
C     kmicro is number of iterations in DIIS cycle
C     ---------------------------------------------------------
C
      TOL=(10.0D+00)**(-ICONV)
C
      WRITE(6,2300)
 2300 FORMAT(/6X,'BEGINNING OPEN SHELL CCSD ITERATIONS')
C
C     ----------------SET INITIAL VALUES OF T--------------
C
C             clean start the CCSD iterations (KREST zero)
C
      IF(KREST.EQ.0) THEN
Cc         call zeroma(o1aa,1,noaua)
         CALL RCCFL(NFT843,5,NOAUA,O1AA)
         CALL TRANSNQN(NUA,NOA,O1AA,TI)
         CALL DENADD1(NOA,NUA,O1AA,EHA,EPA)
         CALL WRTAB2(NOA,NUA,O1AA,1,NFT858)
C
Cc         call zeroma(o1bb,1,nobub)
         CALL RCCFL(NFT843,6,NOBUB,O1BB)
         CALL TRANSNQN(NUB,NOB,O1BB,TI)
         CALL DENADD1(NOB,NUB,O1BB,EHB,EPB)
         CALL WRTAB2(NOB,NUB,O1BB,2,NFT858)
C
Cc         call zeroma(o2aa,1,noa2ua2)
         CALL RDINT(1,NOAUA,NOAUA,O2AA,NFT829)
         CALL INSITU(NUA,NOA,NUA,NOA,TI,O2AA,12)
         CALL DENADD2(NOA,NUA,O2AA,EHA,EPA)
         CALL WRTAB(NOA,NUA,NUA,NOA,O2AA,3,NFT858)
C
Cc         call zeroma(o2bb,1,nob2ub2)
         CALL RDINT(1,NOBUB,NOBUB,O2BB,NFT830)
         CALL INSITU(NUB,NOB,NUB,NOB,TI,O2BB,12)
         CALL DENADD2(NOB,NUB,O2BB,EHB,EPB)
         CALL WRTAB(NOB,NUB,NUB,NOB,O2BB,4,NFT858)
C
Cc         call zeroma(o2ab,1,no2u2ab)
         CALL RDINT(1,NOBUB,NOAUA,O2AB,NFT833)
         CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,12)
         CALL DENADAB(NOA,NUA,NUB,NOB,O2AB,EHA,EHB,EPA,EPB)
         CALL WRTAB(NOA,NUA,NUB,NOB,O2AB,5,NFT858)
C
C             restart of the CCSD iterations (KREST non-zero)
C             Note that this entails records 1-5 of the file, with
C             higher records being used for the LAMBDA iterations.
C
      ELSE
         CALL RDTAB2(NOA,NUA,O1AA,1,NFT825)
         CALL RDTAB2(NOB,NUB,O1BB,2,NFT825)
         CALL RDTAB(NOA,NUA,NUA,NOA,O2AA,3,NFT825)
         CALL RDTAB(NOB,NUB,NUB,NOB,O2BB,4,NFT825)
         CALL RDTAB(NOA,NUA,NUB,NOB,O2AB,5,NFT825)
         CALL WRTAB2(NOA,NUA,O1AA,1,NFT858)
         CALL WRTAB2(NOB,NUB,O1BB,2,NFT858)
         CALL WRTAB(NOA,NUA,NUA,NOA,O2AA,3,NFT858)
         CALL WRTAB(NOB,NUB,NUB,NOB,O2BB,4,NFT858)
         CALL WRTAB(NOA,NUA,NUB,NOB,O2AB,5,NFT858)
      END IF
C
C     -----------------------------------------------------
      ITERTOT=0
      DO 1000,ITMACRO=1,MAXIT
      DO 1001,ITMICRO=2,KMICRO+1
      ITERTOT=ITERTOT+1
      ITER=5*(ITMICRO-2)
      I1AA=ITER+1
      I1BB=ITER+2
      I2AA=ITER+3
      I2BB=ITER+4
      I2AB=ITER+5
C
Cc      call zeroma(o1aa,1,nou)
Cc      call zeroma(o1bb,1,nou)
Cc      call zeroma(o2aa,1,no2u2)
Cc      call zeroma(o2bb,1,no2u2)
Cc      call zeroma(o2ab,1,no2u2)
      CALL RDTAB2(NOA,NUA,O1AA,I1AA,NFT858)
      CALL RDTAB2(NOB,NUB,O1BB,I1BB,NFT858)
      CALL RDTAB(NOA,NUA,NUA,NOA,O2AA,I2AA,NFT858)
      CALL RDTAB(NOB,NUB,NUB,NOB,O2BB,I2BB,NFT858)
      CALL RDTAB(NOA,NUA,NUB,NOB,O2AB,I2AB,NFT858)
C
Cc      write(6,9100)
Cc 9100 FORMAT(1X,'....... BEFORE onebody, twobody .......')
Cc      CALL TIMIT(1)
C
C     ---------COMPUTE H-BAR INTERMEDIATES------------------
C
      CALL ONEBODY(NOA,NUA,NOB,NUB,FHHAA,O1AA,O1BB,
     *             FHHBB,FHP,VHPLBB,O2AA,O2BB,O2AB,
     *             VHPRBB,VHPRAA,VHPRAB,TI,VEBA,VHPLAA,VMAA,VPP)
C
      CALL TWOBODY(NOA,NUA,NOB,NUB,O1AA,O1BB,
     *             VHHAA,VHPLAA,O2AA,O2BB,O2AB,VEAB,VEBA,VHPRBB,
     *             VHPRAA,VHPRAB,TI,VHPLBB,VPP,VMAA,FHP)
C
C     ---------------------------------------------------------
C
Cc      write(6,9105)
Cc 9105 FORMAT(1X,'....... AFTER onebody, twobody .......')
Cc      CALL TIMIT(1)
C
C
      RES=0.00D+00
      ENRG=0.00D+00
C     ------------- T1a Equation -------------------------------
Ccc      call rdtab2(noa,noa,fhhaa,3,nft891)
Ccc      call rdtab2(nob,nob,fhhbb,4,nft891)
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)   !FHPAA
      CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
      CALL RDINT(1,NOAUA,NOAUA,VHPLAA,NFT831)
      CALL RDINT(1,NOBUB,NOBUB,VHPLBB,NFT832)
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
      CALL RDINT(1,NOBUB,NOBUB,VHPRBB,NFT830)
      CALL RDINT(1,NOBUB,NOAUA,VHPRAB,NFT833)
      CALL RDINT(1,NOAUA,NUA2,VEBA,NFT836)
      CALL RDINT(1,NOBUA,NUAB,VEAB,NFT839)
C
      CALL ZEROMA(T1,1,NOU)
      CALL CCMATMUL(FHHAA,O1AA,T1,NOA,NUA,NOA,1,1) !IA
        CALL TRANSNQN(NOA,NUA,FHP,TI)
      CALL TRANMD(O2AA,NOA,NUA,NUA,NOA,23)
      CALL CCMATMUL(O2AA,FHP,T1,NOAUA,1,NOAUA,0,1)
      CALL TRANSQ(O2AA,NOAUA)
      CALL INSITU(NUA,NOA,NOA,NUA,TI,O2AA,13) !NMEA
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,13)
      CALL CCMATMUL(VMAA,O2AA,T1,NOA,NUA,NOA2UA,0,1)
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891) !FHPBB
       CALL TRANSNQN(NOB,NUB,FHP,TI)
      CALL CCMATMUL(O2AB,FHP,T1,NOAUA,1,NOBUB,0,0)
        CALL TRANSNQN(NOAUA,NOBUB,O2AB,TI)
      CALL INSITU(NUB,NOB,NOA,NUA,TI,O2AB,13) !MNEA
      CALL RDTAB(NOA,NOB,NOA,NUB,VMAA,16,NFT891)
      CALL TRANMD(VMAA,NOA,NOB,NOA,NUB,13)
      CALL INSITU(NOA,NOB,NOA,NUB,TI,VMAA,23) !IMNE
      CALL CCMATMUL(VMAA,O2AB,T1,NOA,NUA,NOABUB,0,1)
        CALL TRANSNQN(NOA,NUA,O1AA,TI)
        CALL TRANSNQN(NOB,NUB,O1BB,TI)
        CALL TRANSNQN(NOA,NUA,T1,TI)
      CALL CCMATMUL(VHPLAA,O1AA,T1,NOAUA,1,NOAUA,0,1) !AI
      CALL CCMATMUL(VHPRAB,O1BB,T1,NOAUA,1,NOBUB,0,0)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,13)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,23)
      CALL INSITU(NOA,NOA,NUA,NUA,TI,O2AA,13)
      CALL TRANSQ(O2AA,NOAUA)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,O2AA,13) !FEMI
      CALL CCMATMUL(VEBA,O2AA,T1,NUA,NOA,NOAUA2,0,1)
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13) !AEFM
      CALL INSITU(NOA,NOB,NUB,NUA,TI,O2AB,12)
        CALL TRANSNQN(NOAB,NUAB,O2AB,TI) !EFMI
      CALL CCMATMUL(VEAB,O2AB,T1,NUA,NOA,NOBUAB,0,0)
        CALL RCCFL(NFT843,3,NUA2,FPPAA)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,23)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
      CALL CCMATMUL(VEBA,O1AA,FPPAA,NUA2,1,NOAUA,0,1)
      CALL CCMATMUL(VEAB,O1BB,FPPAA,NUA2,1,NOBUB,0,0)
      CALL CCMATMUL(FPPAA,O1AA,T1,NUA,NOA,NUA,0,0)
      CALL RCCFL(NFT843,5,NOAUA,FHP)
      CALL VECADD(T1,FHP,NOAUA)
      CALL DENAD1A(NOA,NUA,T1,EHA,EPA)
      CALL RESNT1A(NOA,NUA,T1,O1AA,RES)
C Calculate Energy
      CALL VECMUL(VHPRAA,NOA2UA2,HALF)
      CALL CCMATMUL(VHPRAA,T1,FHP,NOAUA,1,NOAUA,0,0)
      CALL CCMATMUL(FHP,T1,ENRG,1,1,NOAUA,1,0)
      CALL VECMUL(VHPRAA,NOA2UA2,TWO)
      CALL CCMATMUL(T1,VHPRAB,VPP,1,NOBUB,NOAUA,1,0)
      CALL TRANSNQN(NUA,NOA,T1,TI)
      CALL WRTAB2(NOA,NUA,T1,(I1AA+5),NFT858)
C     ----------------------------------------------------------
      CALL ZEROMA(T1,1,NOU)
C     ------------- T1b Equation -------------------------------
      CALL RDINT(1,NOBUB,NUB2,VEAB,NFT837)
      CALL RDINT(1,NOAUB,NUAB,VEBA,NFT838)
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891) !FHPBB
        CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL CCMATMUL(FHHBB,O1BB,T1,NOB,NUB,NOB,1,1) !IA
        CALL TRANSNQN(NOB,NUB,FHP,TI)
      CALL TRANMD(O2BB,NOB,NUB,NUB,NOB,23)
      CALL CCMATMUL(O2BB,FHP,T1,NOBUB,1,NOBUB,0,1)
      CALL TRANSQ(O2BB,NOBUB)
      CALL INSITU(NUB,NOB,NOB,NUB,TI,O2BB,13) !NMEA
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
      CALL TRANMD(VMAA,NOB,NOB,NOB,NUB,13)
      CALL CCMATMUL(VMAA,O2BB,T1,NOB,NUB,NOB2UB,0,1)
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891) !FHPAA
       CALL TRANSNQN(NOA,NUA,FHP,TI)
      CALL INSITU(NUB,NUA,NOB,NOA,TI,O2AB,23)
        CALL TRANSNQN(NOB,NUB,T1,TI)
      CALL CCMATMUL(O2AB,FHP,T1,NOBUB,1,NOAUA,0,0)
      CALL INSITU(NUB,NOB,NUA,NOA,TI,O2AB,23) !AEMN
      CALL RDTAB(NOA,NOB,NUA,NOB,VMAA,17,NFT891)
      CALL INSITU(NOA,NOB,NUA,NOB,TI,VMAA,13) !EMNI
      CALL CCMATMUL(O2AB,VMAA,T1,NUB,NOB,NOABUA,0,1)
        CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL CCMATMUL(VHPLBB,O1BB,T1,NOBUB,1,NOBUB,0,1) !AI
      CALL CCMATMUL(O1AA,VHPRAB,T1,1,NOBUB,NOAUA,0,0)
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,13)
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,23)
      CALL INSITU(NOB,NOB,NUB,NUB,TI,O2BB,13)
      CALL TRANSQ(O2BB,NOBUB)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,O2BB,13) !FEMI
      CALL CCMATMUL(VEAB,O2BB,T1,NUB,NOB,NOBUB2,0,1)
      CALL INSITU(NUB,NUA,NOB,NOA,TI,O2AB,13) !IEFM
        CALL RCCFL(NFT843,6,NOBUB,FHP)
        CALL VECADD(T1,FHP,NOBUB)
        CALL TRANSNQN(NUB,NOB,T1,TI)
      CALL CCMATMUL(O2AB,VEBA,T1,NOB,NUB,NOAUAB,0,0)
        CALL RCCFL(NFT843,4,NUB2,FPPBB)
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,23)
      CALL INSITU(NUA,NUB,NOA,NUB,TI,VEBA,23)
      CALL CCMATMUL(VEAB,O1BB,FPPBB,NUB2,1,NOBUB,0,1)
        CALL TRANSNQN(NUB,NUB,FPPBB,TI)
      CALL CCMATMUL(O1AA,VEBA,FPPBB,1,NUB2,NOAUA,0,0)
        CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL CCMATMUL(O1BB,FPPBB,T1,NOB,NUB,NUB,0,0)
      CALL DENADD1(NOB,NUB,T1,EHB,EPB)
      CALL RESNT1B(NOB,NUB,T1,O1BB,RES)
      CALL WRTAB2(NOB,NUB,T1,(I1BB+5),NFT858)
      CALL TRANSNQN(NOB,NUB,T1,TI)
C Calculate Energy
      CALL DAXPY(NOBUB,ONE,VPP,1,FHP,1)
      CALL VECMUL(VHPRBB,NOB2UB2,HALF)
      CALL CCMATMUL(VHPRBB,T1,FHP,NOBUB,1,NOBUB,0,0)
      CALL CCMATMUL(FHP,T1,ENRG,1,1,NOAUA,0,0)
      CALL VECMUL(VHPRBB,NOB2UB2,TWO)
Ccc
Cc      write(6,9115)
Cc 9115 FORMAT(1X,'....... AFTER t1 .......')
Cc      CALL TIMIT(1)
C
C     -------------------------------------------------------------
      CALL ZEROMA(T2,1,NO2U2)
C     -----------------T2aa Equation-------------------------------
      CALL RDTAB(NOA,NOA,NOA,NOA,VHHAA,7,NFT891)
      CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,10,NFT891)
      CALL RDINT(1,NOAUA,NUA2,VEBA,NFT836)
      CALL RDINT(1,NOBUA,NUAB,VEAB,NFT839)
C t2aa
      CALL TRANSQ(FHHAA,NOA)
      CALL CCMATMUL(O2AA,FHHAA,T2,NOAUA2,NOA,NOA,1,1) !ABIJ
      CALL TRANSQ(VHHAA,NOA2) !MNIJ
      CALL VECMUL(O2AA,NOA2UA2,FOURTH)
      CALL CCMATMUL(O2AA,VHHAA,T2,NUA2,NOA2,NOA2,0,0) !ABIJ
        CALL TRANSNQN(NOA2,NOAUA,VMAA,TI)
      CALL VECMUL(O1AA,NOAUA,HALF)
      CALL CCMATMUL(O1AA,VMAA,T2,NUA,NOA2UA,NOA,0,1) !ABIJ
C vhplaa_i
        CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL VECMUL(O1AA,NOAUA,TWO)
      CALL VECMUL(O2AA,NOA2UA2,FOUR)
      CALL INSITU(NUA,NUA,NOA,NOA,TI,O2AA,13)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,O2AA,12)
      CALL TRANMD(VHPRAA,NUA,NOA,NUA,NOA,13)
      CALL TRANSQ(VHPRAA,NOAUA)
      CALL CCMATMUL(O2AA,VHPRAA,VHPLAA,NOAUA,NOAUA,NOAUA,0,1)
Cc
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,12)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,23)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPLAA,12)
      CALL CCMATMUL(O1AA,VEBA,VHPLAA,NOA,NOAUA2,NUA,0,0)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,VHPLAA,12)
Cc
      CALL TRANSQ(VHPLAA,NOAUA)
      CALL VECMUL(O2AA,NOA2UA2,TWO)
      CALL INSITU(NUA,NUA,NOA,NOA,TI,T2,13)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,O2AA,12)
      CALL CCMATMUL(O2AA,VHPLAA,T2,NOAUA,NOAUA,NOAUA,0,1) !IBAJ
C vhprab_i (temp veab)
      CALL VECMUL(O2AB,NO2U2AB,HALF)
      CALL TRAN14(NOB,NUA,NUB,NOA,TI,O2AB)
      CALL CCMATMUL(O2AB,VHPRBB,VHPLAA,NOAUA,NOBUB,NOBUB,1,0) !IABJ
      CALL VECCOP(NO2U2AB,VHPLBB,VHPLAA)
Ccc
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
      CALL CCMATMUL(O1AA,VEAB,VHPLAA,NOA,NOBUAB,NUA,0,0) !IABJ
Ccc
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPLAA,12)
        CALL VECADD(VHPLAA,VHPRAB,NO2U2AB)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPLAA,12)
        CALL VECADD(VHPLBB,VHPLAA,NO2U2AB)
      CALL WRTAB(NOA,NUA,NUB,NOB,VHPLBB,6,NFT892)
      CALL TRANMD(O2AA,NOA,NUA,NUA,NOA,23)
      CALL CCMATMUL(O2AA,VHPRAB,VHPLAA,NOAUA,NOBUB,NOAUA,0,0) !IABJ
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPLAA,12)
      CALL TRANMD(T2,NOA,NUA,NUA,NOA,23) !IABJ
        CALL TRANSNQN(NOAUA,NOBUB,VHPLAA,TI)
      CALL VECMUL(O2AB,NO2U2AB,TWO)
      CALL CCMATMUL(O2AB,VHPLAA,T2,NOAUA,NOAUA,NOBUB,0,0)
C fpp
      CALL INSITU(NOA,NUA,NUA,NOA,TI,O2AA,12)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPRAA,12)
      CALL TRANSQ(VHPRAA,NOAUA)
      CALL INSITU(NUA,NOA,NOA,NUA,TI,VHPRAA,12)
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL CCMATMUL(O2AA,VHPRAA,FPPAA,NUA,NUA,NOA2UA,0,1)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPRAB,12)
        CALL TRANSNQN(NOAUA,NOBUB,VHPRAB,TI)
      CALL TRAN1TO4(NOA,NUA,NUB,NOB,TI,O2AB)
      CALL CCMATMUL(O2AB,VHPRAB,FPPAA,NUA,NUA,NOABUB,0,1)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,T2,12)
      CALL TRANSQ(T2,NOAUA)
      CALL CCMATMUL(FPPAA,O2AA,T2,NUA,NOA2UA,NUA,0,0)
      CALL VECMUL(O2AA,NOA2UA2,FOURTH)
Ccc      call insitu(nua,noa,nua,noa,ti,o2aa,23)
Ccc        call transnqn(nua2,noa2,o2aa,ti)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,T2,23)!BAJI
        CALL TRANSNQN(NUA2,NOA2,T2,TI)
      CALL INSITU(NOA,NOA,NUA,NUA,TI,T2,12)!IJBA
Cc
Cc      call tranmd(veba,nua,nua,nua,noa,23)
Cc      call tranmd(veba,nua,nua,nua,noa,12)
Cc
      CALL VECMUL(O1AA,NOAUA,HALF)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,O2AA,12)
      CALL TRAN34N(NOA,NUA,NUA,NOA,TI,O2AA)
      CALL CCMATMUL4P(VPP,O1AA,O2AA,T2,VEAB,NOA,NUA,0)
Ccccc      call ccmatmul4p_old(vpp,o1aa,o2aa,t2,veba,noa,nua,0)
      CALL TRAN24(NOA,NOA,NUA,NUA,TI,T2) !IABJ
      CALL TRAN34N(NOA,NUA,NOA,NUA,TI,O2AA)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,O2AA,12)
Ccc        call transnqn(noa2,nua2,o2aa,ti)
Ccc      call insitu(nua,nua,noa,noa,ti,o2aa,23)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,13)
Cc      call vecmul(o2aa,noa2ua2,sixteen)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,12)
      CALL INSITU(NUA,NUB,NOB,NOA,TI,O2AB,13)
      CALL INSITU(NOB,NUB,NUA,NOA,TI,O2AB,12)
      CALL CCMATMUL(O1AA,VEBA,T2,NOA,NOAUA2,NUA,0,0) !IABJ
C
      CALL SYMETR2(T2,NOA,NUA,TI)
C
      CALL TRANMD(VHPRAA,NOA,NUA,NOA,NUA,13)
      CALL INSITU(NOA,NUA,NOA,NUA,TI,VHPRAA,12)
      CALL TRANSQ(VHPRAA,NOAUA)
      CALL VECADD(T2,VHPRAA,NOA2UA2)
      CALL DENADD2(NOA,NUA,T2,EHA,EPA)
      CALL VECMUL(O2AA,NOA2UA2,EIGHT)
      CALL RESNT2A(NOA,NUA,T2,O2AA,RES)
      CALL WRTAB(NOA,NUA,NUA,NOA,T2,(I2AA+5),NFT858)
C CALCULATE ENERGY
      CALL VECMUL(T2,NOA2UA2,FOURTH)
      CALL CCMATMUL(VHPRAA,T2,ENRG,1,1,NOA2UA2,0,0)
Ccc
Cc      write(6,9125)
Cc 9125 FORMAT(1X,'....... AFTER t2aa .......')
Cc      CALL TIMIT(1)
C
C     -------------------------------------------------------------
      CALL ZEROMA(T2,1,NO2U2)
C     -----------------T2bb Equation-------------------------------
      CALL RDTAB(NOB,NOB,NOB,NOB,VHHAA,8,NFT891)
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,11,NFT891)
      CALL RDINT(1,NOBUB,NOBUB,VHPLBB,NFT832)
      CALL RDINT(1,NOBUB,NUB2,VEBA,NFT837)
      CALL RDINT(1,NOAUB,NUAB,VEAB,NFT838)
C
      CALL TRANSQ(FHHBB,NOB)
      CALL CCMATMUL(O2BB,FHHBB,T2,NOBUB2,NOB,NOB,1,1) !ABIJ
      CALL TRANSQ(VHHAA,NOB2) !MNIJ
      CALL VECMUL(O2BB,NOB2UB2,FOURTH)
      CALL CCMATMUL(O2BB,VHHAA,T2,NUB2,NOB2,NOB2,0,0) !ABIJ
        CALL TRANSNQN(NOB2,NOBUB,VMAA,TI)
        CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL VECMUL(O1BB,NOBUB,HALF)
      CALL CCMATMUL(O1BB,VMAA,T2,NUB,NOB2UB,NOB,0,1) !ABIJ
C
C vhpl_bb
      CALL VECMUL(O1BB,NOBUB,TWO)
        CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL TRANMD(VHPRBB,NUB,NOB,NUB,NOB,13)
      CALL TRANSQ(VHPRBB,NOBUB)
      CALL VECMUL(O2BB,NOB2UB2,FOUR)
      CALL INSITU(NUB,NUB,NOB,NOB,TI,O2BB,13)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,O2BB,12)
      CALL CCMATMUL(O2BB,VHPRBB,VHPLBB,NOBUB,NOBUB,NOBUB,0,1)
      CALL VECMUL(O2BB,NOB2UB2,TWO)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPLBB,12)
Cc
      CALL TRANMD(VEBA,NUB,NUB,NUB,NOB,12)
      CALL TRANMD(VEBA,NUB,NUB,NUB,NOB,23)
      CALL CCMATMUL(O1BB,VEBA,VHPLBB,NOB,NOBUB2,NUB,0,0)
Cc      call tranmd(veba,nub,nub,nub,nob,23)
Cc      call tranmd(veba,nub,nub,nub,nob,12)
Cc
      CALL TRANSQ(O2BB,NOBUB)
      CALL INSITU(NUB,NUB,NOB,NOB,TI,T2,13)
      CALL CCMATMUL(VHPLBB,O2BB,T2,NOBUB,NOBUB,NOBUB,0,1) !IBAJ
C
C vhprab_i (temp veab)
      CALL INSITU(NUA,NUB,NOA,NUB,TI,VEAB,23)
      CALL VECMUL(O2AB,NO2U2AB,HALF)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,VHPRAA,12)
      CALL CCMATMUL(O2AB,VHPRAA,VHPLAA,NOBUB,NOAUA,NOAUA,1,0)
      CALL VECCOP(NO2U2AB,VHPLBB,VHPLAA)
C
      CALL TRAN34N(NUB,NOB,NOA,NUA,TI,VHPRAB)
      CALL TRANMD(O2BB,NUB,NOB,NUB,NOB,13)
      CALL CCMATMUL(O2BB,VHPRAB,VHPLAA,NOBUB,NOAUA,NOBUB,0,0)
        CALL VECADD(VHPLAA,VHPRAB,NO2U2AB)
Cc
        CALL TRANSNQN(NOAUA,NUB2,VEAB,TI)
      CALL INSITU(NUB,NOB,NUA,NOA,TI,VHPLAA,12)
      CALL CCMATMUL(O1BB,VEAB,VHPLAA,NOB,NOAUAB,NUB,0,0)
      CALL INSITU(NOB,NUB,NUA,NOA,TI,VHPLAA,12)
Cc
        CALL VECADD(VHPLBB,VHPLAA,NO2U2AB)
      CALL WRTAB(NUB,NOB,NUA,NOA,VHPLBB,5,NFT892)
C
      CALL VECMUL(O2AB,NO2U2AB,TWO)
        CALL TRANSNQN(NOBUB,NOAUA,VHPLAA,TI)
      CALL INSITU(NUB,NOB,NUA,NOA,TI,O2AB,12)
      CALL TRANMD(T2,NOB,NUB,NUB,NOB,23) !IABJ
      CALL CCMATMUL(O2AB,VHPLAA,T2,NOBUB,NOBUB,NOAUA,0,0)
C
C fpp_bb
      CALL INSITU(NUB,NOB,NUB,NOB,TI,O2BB,12)
      CALL TRANSQ(O2BB,NOBUB)
      CALL INSITU(NUB,NOB,NOB,NUB,TI,O2BB,12)
      CALL TRANSQ(VHPRBB,NOBUB)
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL CCMATMUL(VHPRBB,O2BB,FPPBB,NUB,NUB,NOB2UB,0,1)
      CALL INSITU(NUB,NOB,NUA,NOA,TI,VHPRAB,23)
        CALL TRANSNQN(NOBUB,NOAUA,O2AB,TI)
      CALL INSITU(NUA,NOA,NOB,NUB,TI,O2AB,23)
      CALL CCMATMUL(VHPRAB,O2AB,FPPBB,NUB,NUB,NOABUA,0,1)
      CALL TRANSQ(T2,NOBUB)
      CALL TRANSQ(FPPBB,NUB)
      CALL INSITU(NOB,NUB,NOB,NUB,TI,O2BB,12)
      CALL CCMATMUL(FPPBB,O2BB,T2,NUB,NOB2UB,NUB,0,0) ! BJIA
C vpp
C
      CALL VECMUL(O2BB,NOB2UB2,FOURTH)
Cc      call tranmd(o2bb,nub,nob,nob,nub,14)
Cc      call insitu(nub,nob,nob,nub,ti,o2bb,13)
      CALL INSITU(NUB,NOB,NOB,NUB,TI,T2,13) !IJBA
      CALL VECMUL(O1BB,NOBUB,HALF)
      CALL INSITU(NUB,NOB,NOB,NUB,TI,O2BB,12)
      CALL TRANSQ(O2BB,NOBUB) !IAJB
      CALL CCMATMUL4P(VPP,O1BB,O2BB,T2,VHPLBB,NOB,NUB,NUA)
Ccc      call ccmatmul4p_old(vpp,o1bb,o2bb,t2,veba,nob,nub,nua)
      CALL INSITU(NOB,NUB,NOB,NUB,TI,O2BB,12)
Cc      call tranmd(o2bb,nob,nob,nub,nub,12)
      CALL TRAN24(NOB,NOB,NUB,NUB,TI,T2)   !IABJ
C
      CALL TRANMD(VEBA,NUB,NUB,NUB,NOB,12)
      CALL TRANMD(VEBA,NUB,NUB,NUB,NOB,23)
        CALL TRANSNQN(NOBUA,NOAUB,O2AB,TI)
      CALL TRAN14(NOA,NUB,NUA,NOB,TI,O2AB)
      CALL INSITU(NOB,NUB,NUA,NOA,TI,O2AB,12)
Cc      call insitu(nob,nob,nub,nub,ti,o2bb,13)
Cc      call vecmul(o2bb,nob2ub2,sixteen)
      CALL CCMATMUL(O1BB,VEBA,T2,NOB,NOBUB2,NUB,0,0)
C
        CALL SYMETR2(T2,NOB,NUB,TI)
C
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPRBB,12)
      CALL TRANMD(VHPRBB,NOB,NUB,NUB,NOB,23)
      CALL VECADD(T2,VHPRBB,NOB2UB2)
      CALL DENADD2(NOB,NUB,T2,EHB,EPB)
      CALL VECMUL(O2BB,NOB2UB2,EIGHT)
      CALL TRANSQ(O2BB,NOBUB)
      CALL RESNT2B(NOB,NUB,T2,O2BB,RES)
      CALL WRTAB(NOB,NUB,NUB,NOB,T2,(I2BB+5),NFT858)
C CALCULATE ENERGY
      CALL VECMUL(T2,NOB2UB2,FOURTH)
      CALL CCMATMUL(VHPRBB,T2,ENRG,1,1,NOB2UB2,0,0)
C
Cc      write(6,9135)
Cc 9135 FORMAT(1X,'....... AFTER t2bb .......')
Cc      CALL TIMIT(1)
C
C     -------------------------------------------------------------
      CALL ZEROMA(T2,1,NO2U2)
C     -----------------T2ab Equation-------------------------------
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAA,12,NFT891)
         CALL RDTAB(NOA,NOB,NOA,NOB,VHHAA,9,NFT891)
         CALL RDINT(1,NOAUB,NOAUB,VHPLBB,NFT835)
         CALL RDINT(1,NOAUA,NUA2,VEBA,NFT836)
C
      CALL CCMATMUL(O2AB,FHHAA,T2,NOBUAB,NOA,NOA,1,1)
        CALL TRANSNQN(NOBUB,NOAUA,O2AB,TI)
        CALL TRANSNQN(NOBUB,NOAUA,T2,TI)
      CALL CCMATMUL(O2AB,FHHBB,T2,NOAUAB,NOB,NOB,0,1)
        CALL TRANSNQN(NOAB,NOAUB,VMAA,TI)
      CALL VECMUL(O1AA,NOAUA,TWO)
      CALL VECMUL(O1BB,NOBUB,TWO)
        CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,T2,23)
      CALL CCMATMUL(O1AA,VMAA,T2,NUA,NOABUB,NOA,0,1) !ABIJ
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,23)
      CALL TRANSQ(VHHAA,NOAB)
      CALL CCMATMUL(O2AB,VHHAA,T2,NUAB,NOAB,NOAB,0,0)
      CALL CCMATMUL(FPPAA,O2AB,T2,NUA,NOABUB,NUA,0,0)
        CALL TRANSNQN(NUAB,NOAB,T2,TI)
         CALL RDTAB(NOA,NOB,NUA,NOB,VMAA,13,NFT891)
      CALL CCMATMUL(VMAA,O1BB,T2,NOABUA,NUB,NOB,0,1) !IJAB
      CALL TRANSQ(FPPBB,NUB)
        CALL TRANSNQN(NUAB,NOAB,O2AB,TI)
      CALL CCMATMUL(O2AB,FPPBB,T2,NOABUA,NUB,NUB,0,0)
C vhpr vhpl
        CALL TRANSNQN(NOAB,NUAB,T2,TI)  !ABIJ
      CALL INSITU(NUA,NUB,NOA,NOB,TI,T2,23) !AIBJ
C
      CALL RDTAB(NUB,NOB,NUA,NOA,VHPLAA,5,NFT892)
        CALL TRANSNQN(NOBUB,NOAUA,VHPLAA,TI)
        CALL TRANSNQN(NOAB,NUAB,O2AB,TI)
      CALL INSITU(NUA,NUB,NOA,NOB,TI,O2AB,23)
      CALL INSITU(NUB,NUA,NOB,NOA,TI,VHPRAB,23)
Cc        call transnqn(nobub,noaua,vhprab,ti)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,O2BB,12)
C
      CALL CCMATMUL(O2AA,VHPLAA,T2,NOAUA,NOBUB,NOAUA,0,0)
C
Cc        call transnqn(noaua,nobub,vhprab,ti)
      CALL CCMATMUL(O2AB,VHPRAB,VHPRAA,NOAUA,NOAUA,NOBUB,1,0)
      CALL CCMATMUL(VHPRAA,O2AB,T2,NOAUA,NOBUB,NOAUA,0,0)
C
C vhplba
      CALL INSITU(NUB,NOB,NUA,NOA,TI,VHPRAB,13)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,13)
      CALL CCMATMUL(O2AB,VHPRAB,VHPLBB,NOAUB,NOAUB,NOBUA,0,1)
Cc
      CALL INSITU(NUB,NUB,NUA,NOA,TI,VEAB,13)
      CALL INSITU(NUB,NOA,NUB,NOA,TI,VHPLBB,12) !IBAJ
        CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL CCMATMUL(O1AA,VEAB,VHPLBB,NOA,NOAUB2,NUA,0,0)
        CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL INSITU(NOA,NUB,NUB,NOA,TI,VHPLBB,12) !BIAJ
Cc
      CALL INSITU(NUA,NOA,NUB,NOB,TI,T2,13) !BIAJ
      CALL CCMATMUL(VHPLBB,O2AB,T2,NOAUB,NOBUA,NOAUB,0,1)
C vhpr
      CALL INSITU(NUA,NOB,NUB,NOA,TI,VHPRAB,13)
      CALL INSITU(NUB,NOA,NUA,NOB,TI,O2AB,13)
        CALL TRANSNQN(NOAUA,NOBUB,O2AB,TI)
      CALL RDTAB(NOA,NUA,NUB,NOB,VHPLAA,6,NFT892)
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPLAA,12)
        CALL TRANSNQN(NOAUA,NOBUB,VHPLAA,TI)
        CALL TRANSNQN(NOAUB,NOBUA,T2,TI) !AJBI
      CALL INSITU(NUA,NOB,NUB,NOA,TI,T2,13) !BJAI
      CALL CCMATMUL(O2BB,VHPLAA,T2,NOBUB,NOAUA,NOBUB,0,0) !BJAI
         CALL RDINT(1,NOAUA,NOAUA,VHPLAA,NFT831)
      CALL TRANSQ(VHPLAA,NOAUA)
Cc
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,13)
        CALL TRANSNQN(NUA2,NOAUA,VEBA,TI)
      CALL CCMATMUL(VEBA,O1AA,VHPLAA,NOAUA2,NOA,NUA,0,0)
Cc
      CALL INSITU(NUB,NOB,NUA,NOA,TI,T2,12) !JBAI
Cc
         CALL RDINT(1,NOBUB,NOBUB,VHPLBB,NFT832)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPLBB,12)
Ccc
      CALL RDINT(1,NOBUB,NUB2,VEAB,NFT837)
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,13)
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,12)
      CALL CCMATMUL(O1BB,VEAB,VHPLBB,NOB,NOBUB2,NUB,0,0)
Ccc
      CALL CCMATMUL(VHPLBB,O2AB,T2,NOBUB,NOAUA,NOBUB,0,1) !JBAI
Cc
      CALL INSITU(NUB,NOB,NUA,NOA,TI,O2AB,12)
      CALL CCMATMUL(O2AB,VHPLAA,T2,NOBUB,NOAUA,NOAUA,0,1) !JBAI
         CALL RDINT(1,NOBUA,NOBUA,VHPLAA,NFT834)
      CALL INSITU(NUA,NOB,NUA,NOB,TI,VHPLAA,12)
      CALL RDINT(1,NOBUA,NUAB,VEAB,NFT839)
Cc
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13)
        CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,12)
      CALL CCMATMUL(O1BB,VEAB,VHPLAA,NOB,NOBUA2,NUB,0,0)
Cc        call insitu(nub,nua,nua,nob,ti,veab,12)
Cc      call tranmd(veab,nua,nub,nua,nob,13)
Cc
      CALL INSITU(NOB,NUB,NUA,NOA,TI,O2AB,23)
      CALL INSITU(NOB,NUA,NUB,NOA,TI,O2AB,12)
      CALL INSITU(NOB,NUB,NUA,NOA,TI,T2,23)
      CALL CCMATMUL(VHPLAA,O2AB,T2,NOBUA,NOAUB,NOBUA,0,1) !JABI
      CALL INSITU(NUA,NOB,NUB,NOA,TI,O2AB,13)
Cc      call insitu(nob,nua,nub,noa,ti,t2,23)
C vppab
Cc      call insitu(nob,nub,nua,noa,ti,t2,13)
        CALL INSITU(NUB,NOB,NUA,NOA,TI,O2AB,12)
        CALL TRANSNQN(NOBUB,NOAUA,O2AB,TI)
Cc      call tran34n(nua,nub,nob,noa,ti,t2)
Cc dodaj
      CALL TRAN1TO4(NOB,NUA,NUB,NOA,TI,T2)
        CALL INSITU(NUA,NOA,NOB,NUB,TI,O2AB,12)
        CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL CCMATMUL4PAB(VPP,O1AA,O1BB,O2AB,VEBA,
     *                     T2,NOA,NOB,NUA,NUB)
Cccc call ccmatmul4pab_old(vpp,o1bb,o2ab,veab,t2,noa,nob,nua,nub)
        CALL TRANSNQN(NOA,NUA,O1AA,TI)
        CALL INSITU(NOA,NUA,NOB,NUB,TI,O2AB,12)
      CALL TRAN34N(NUA,NUB,NOA,NOB,TI,T2)
C vhppp
C
Cc      call tran34n(nua,nub,nua,nob,ti,veab)
        CALL TRANSNQN(NUAB,NOBUA,VEAB,TI)
      CALL INSITU(NUA,NOB,NUB,NUA,TI,VEAB,23)
      CALL CCMATMUL(VEAB,O1AA,T2,NOBUAB,NOA,NUA,0,0) !ABJI
      CALL INSITU(NUA,NUB,NOB,NOA,TI,T2,13) !JBAI
      CALL RDINT(1,NOAUB,NUAB,VEBA,NFT838) !INTEGRAL
      CALL INSITU(NUA,NUB,NOA,NUB,TI,VEBA,23)
        CALL TRANSNQN(NOAUA,NUB2,VEBA,TI)
      CALL TRANMD(VEBA,NUB,NUB,NUA,NOA,12)
      CALL CCMATMUL(O1BB,VEBA,T2,NOB,NOAUAB,NUB,0,0)!JBAI
      CALL INSITU(NUA,NOA,NOB,NUB,TI,O2AB,23)
      CALL TRAN34N(NUA,NOB,NOA,NUB,TI,O2AB)
C
Cc      call rdint(1,nobub,noaua,vhprab,nft833) !aibj
       CALL TRANSNQN(NOBUB,NOAUA,VHPRAB,TI) !AIBJ
      CALL INSITU(NOB,NUB,NUA,NOA,TI,T2,12) !BJAI
       CALL TRANSNQN(NOBUB,NOAUA,T2,TI) !AIBJ
        CALL VECADD(T2,VHPRAB,NO2U2AB)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,T2,12) !IABJ
      CALL DENADAB(NOA,NUA,NUB,NOB,T2,EHA,EHB,EPA,EPB)
      CALL RESNTAB(NOA,NUA,NUB,NOB,T2,O2AB,RES)
      CALL WRTAB(NOA,NUA,NUB,NOB,T2,(I2AB+5),NFT858)
C CALCULATE ENERGY
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPRAB,12)
      CALL CCMATMUL(VHPRAB,T2,ENRG,1,1,NO2U2AB,0,0)
C     -----------------------------------------------------------------
      RES=SQRT(RES)
      WRITE(6,99) ITERTOT,ENRG,RES
      CALL FLSHBF(6)
C
      IF(ITERTOT.EQ.MAXIT) GO TO 4100
C
      IF(RES.LT.TOL) THEN
         WRITE(6,97) ENRG
         WRITE(6,100)
C
         CALL ZEROMA(O1AA,1,NOU)
         CALL RDTAB2(NOA,NUA,O1AA,(I1AA+5),NFT858)
         CALL PRT1A(NOA,NUA,O1AA)
         CALL WRTAB2(NOA,NUA,O1AA,1,NFT825)
C
         CALL ZEROMA(O1BB,1,NOU)
         CALL RDTAB2(NOB,NUB,O1BB,(I1BB+5),NFT858)
         CALL PRT1B(NOB,NUB,O1BB)
         CALL WRTAB2(NOB,NUB,O1BB,2,NFT825)
C
         CALL ZEROMA(O2AA,1,NO2U2)
         CALL RDTAB(NOA,NUA,NUA,NOA,O2AA,(I2AA+5),NFT858)
         CALL PRT2AA(NOA,NUA,O2AA)
         CALL WRTAB(NOA,NUA,NUA,NOA,O2AA,3,NFT825)
C
         CALL ZEROMA(O2BB,1,NO2U2)
         CALL RDTAB(NOB,NUB,NUB,NOB,O2BB,(I2BB+5),NFT858)
         CALL PRT2BB(NOB,NUB,O2BB)
         CALL WRTAB(NOB,NUB,NUB,NOB,O2BB,4,NFT825)
C
         CALL ZEROMA(O2AB,1,NO2U2)
         CALL RDTAB(NOA,NUA,NUB,NOB,O2AB,(I2AB+5),NFT858)
         CALL PRT2AB(NOA,NUA,NUB,NOB,O2AB)
         CALL WRTAB(NOA,NUA,NUB,NOB,O2AB,5,NFT825)
C
         WRITE(6,96) EREF,ENRG+EREF,ENRG
         RETURN
      END IF
C
 1001 CONTINUE
C
C     -------DIIS-------
C
      CALL OPENDIIS(NOA,NOB,NUA,NUB,O1AA,O2AA,O1BB,O2BB,T1,
     *              T2,O2AB,XMAT,BVEC,IPVT,KMICRO)
      WRITE(6,98) KMICRO
C
C          save restart information
C
      CALL WRTAB2(NOA,NUA,O1BB,1,NFT825)
      CALL WRTAB2(NOB,NUB,O1AA,2,NFT825)
      CALL WRTAB(NOA,NUA,NUA,NOA,O2BB,3,NFT825)
      CALL WRTAB(NOB,NUB,NUB,NOB,O2AA,4,NFT825)
      CALL WRTAB(NOA,NUA,NUB,NOB,O2AB,5,NFT825)
C
 1000 CONTINUE
C
 4100 CONTINUE
      WRITE(6,95)
      CALL ABRT
      STOP
C
   95 FORMAT(/5X,'THE CCSD ITERATIONS DID NOT CONVERGE')
   96 FORMAT(/25X,'SUMMARY OF CCSD RESULTS',//
     *        5X,'REFERENCE ENERGY:',F20.10,/
     *        10X,'CCSD ENERGY:',F20.10,3X,'CORR. E=',F15.10, //)
   97 FORMAT(/5X,'THE CCSD ITERATIONS HAVE CONVERGED', /
     *        5X,'CCSD CORRELATION ENERGY:',F15.10, /)
   98 FORMAT(6X,'DOING DIIS EXTRAPOLATION (DIM.OF THE SPACE=',I3,')')
   99 FORMAT(1X,'ITERATION:',I4,'  CCSD CORR E=',F15.10,'  CONV:',F15.9)
  100 FORMAT(1X,'THE LARGEST T1 AND T2 AMPLITUDES ARE')
      END
C
C*MODULE ROHFCC  *DECK ONEBODY
      SUBROUTINE ONEBODY(NOA,NUA,NOB,NUB,FHHAA,O1AA,O1BB,
     *                   FHHBB,FHPAA,FHPBB,O2AA,O2BB,O2AB,
     *                   VHPRBB,VHPRAA,VHPRAB,TI,VMAB,VMBA,VMAA,VMBB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION TI(1),VHPRAA(1),VHPRAB(1),VHPRBB(1),
     *          O1AA(1),O1BB(1),O2AA(1),O2AB(1),O2BB(1),
     *          FHPAA(1),FHPBB(1),FHHAA(1),FHHBB(1),
     *          VMBA(1),VMAB(1),VMAA(1),VMBB(1)
C
      DATA TWO/2.0D+0/,HALF/0.5D+0/
C
C            'jestem w onebody'
C
C vhhhp_aa (vmaa)
      CALL RDINT(1,NOAUA,NOA2,VMAA,NFT823)
C vppph_aa (veaa)
C vhhhp_ab (vmab)
      CALL RDINT(1,NOAUB,NOAB,VMAB,NFT828)
C vppph_ab (veab)
C vhhhp_bb (vmbb)
      CALL RDINT(1,NOBUB,NOB2,VMBB,NFT826)
C vppph_bb (vebb)
C vhhhp_ba (vmba)
      CALL RDINT(1,NOBUA,NOAB,VMBA,NFT827)
C vppph_ba (veba)
C vhpraa
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPRAA,23)
C vhprbb
      CALL RDINT(1,NOBUB,NOBUB,VHPRBB,NFT830)
C vhprab
      CALL RDINT(1,NOBUB,NOAUA,VHPRAB,NFT833)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPRAB,23)
      CALL TRAN34N(NUA,NUB,NOA,NOB,TI,VHPRAB)
C fhpi_a
        CALL RCCFL(NFT843,5,NOAUA,FHPAA)
      CALL INSITU(NUA,NUA,NOA,NOA,TI,VHPRAA,13)
      CALL CCMATMUL(O1AA,VHPRAA,FHPAA,1,NOAUA,NOAUA,0,1)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,VHPRAA,13)
      CALL INSITU(NUA,NUB,NOB,NOA,TI,VHPRAB,13)
      CALL CCMATMUL(O1BB,VHPRAB,FHPAA,1,NOAUA,NOBUB,0,0)
      CALL INSITU(NOB,NUB,NUA,NOA,TI,VHPRAB,13)
      CALL TRANSNQN(NUA,NOA,FHPAA,TI)
      CALL WRTAB2(NOA,NUA,FHPAA,5,NFT891)
C        write(6,*) 'fhpi_a'
C        call flshbf(6)
C        call druk2(noa,nua,fhpaa)
C        call flshbf(6)
C     Fhhi_a
        CALL RCCFL(NFT843,1,NOA2,FHHAA)
      CALL TRANSNQN(NOA,NUA,FHPAA,TI)
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL CCMATMUL(O2AA,VHPRAA,FHHAA,NOA,NOA,NOAUA2,0,1)
      CALL CCMATMUL(O2AB,VHPRAB,FHHAA,NOA,NOA,NOBUAB,0,0)
      CALL CCMATMUL(O1AA,FHPAA,FHHAA,NOA,NOA,NUA,0,0)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,13)
      CALL CCMATMUL(VMAA,O1AA,FHHAA,NOA2,1,NOAUA,0,1)
      CALL TRANMD(VMAB,NOA,NOB,NOA,NUB,13)
      CALL INSITU(NOA,NOB,NOA,NUB,TI,VMAB,23)
      CALL CCMATMUL(VMAB,O1BB,FHHAA,NOA2,1,NOBUB,0,0)
      CALL WRTAB2(NOA,NOA,FHHAA,3,NFT891)
C       write(6,*) 'fhhi_aa'
C        call flshbf(6)
C       call druk2(noa,noa,fhhaa)
C        call flshbf(6)
      CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL TRANSNQN(NOB,NUB,O1BB,TI)
C fhp_b
        CALL RCCFL(NFT843,6,NOBUB,FHPBB)
      CALL TRANMD(VHPRBB,NUB,NOB,NUB,NOB,13)
      CALL CCMATMUL(O1BB,VHPRBB,FHPBB,1,NOBUB,NOBUB,0,1)
      CALL TRANMD(VHPRBB,NUB,NOB,NUB,NOB,13)
      CALL TRANSNQN(NUB,NOB,FHPBB,TI)
      CALL INSITU(NUA,NUB,NOB,NOA,TI,VHPRAB,13)
      CALL CCMATMUL(VHPRAB,O1AA,FHPBB,NOBUB,1,NOAUA,0,0)
      CALL WRTAB2(NOB,NUB,FHPBB,6,NFT891)
C        write(6,*) 'fhpi_b'
C        call flshbf(6)
C        call druk2(nob,nub,fhpbb)
C        call flshbf(6)
C     Fhhi_b
        CALL RCCFL(NFT843,2,NOB2,FHHBB)
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPRBB,23)
      CALL CCMATMUL(O2BB,VHPRBB,FHHBB,NOB,NOB,NOBUB2,0,1)
Cc      call tran24(nub,nob,noa,nua,ti,o2ab)
      CALL INSITU(NOA,NUA,NUB,NOB,TI,O2AB,13)
      CALL TRANSNQN(NOB,NOB,FHHBB,TI)   !JI
      CALL CCMATMUL(VHPRAB,O2AB,FHHBB,NOB,NOB,NOAUAB,0,0)
      CALL CCMATMUL(FHPBB,O1BB,FHHBB,NOB,NOB,NUB,0,0)
      CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL INSITU(NOA,NOB,NUA,NOB,TI,VMBA,23)
      CALL CCMATMUL(O1AA,VMBA,FHHBB,1,NOB2,NOAUA,0,0)
      CALL TRANSNQN(NOB,NOB,FHHBB,TI)   !IJ
      CALL TRAN24(NOB,NOB,NOB,NUB,TI,VMBB)
      CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL CCMATMUL(O1BB,VMBB,FHHBB,1,NOB2,NOBUB,0,1)
      CALL WRTAB2(NOB,NOB,FHHBB,4,NFT891)
C        write(6,*) 'fhhi_bb'
C        call flshbf(6)
C        call druk2(nob,nob,fhhbb)
C        call flshbf(6)
C o1, o2 back ordering
      CALL INSITU(NUA,NUA,NOA,NOA,TI,VHPRAA,23)
      CALL INSITU(NUB,NUB,NOB,NOB,TI,VHPRBB,23)
      CALL VECMUL(O2AA,NOA2UA2,TWO)
      CALL VECMUL(O2BB,NOB2UB2,TWO)
      CALL INSITU(NUB,NUA,NOA,NUB,TI,O2AB,13)
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TWOBODY
      SUBROUTINE TWOBODY(NOA,NUA,NOB,NUB,O1AA,O1BB,
     *                   VHHAA,VHPLAA,O2AA,O2BB,O2AB,
     *                   VEAB,VEBA,VHPRBB,VHPRAA,VHPRAB,TI,
     *                   VMAB,VMBA,VMAA,FHP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION TI(1),VHPLAA(1),VHPRAA(1),VHHAA(1),
     *          O1AA(1),O1BB(1),O2AA(1),O2AB(1),O2BB(1),
     *          VEAB(1),VHPRAB(1),VMBA(1),VMAB(1),VMAA(1),VHPRBB(1),
     *          VEBA(1),FHP(1)
C
      DATA TWO/2.0D+0/,HALF/0.5D+0/
C
      NOA2OBUB=NOA2OB*NUB
C
C        'jestem w twobody'
C
C vhpraa
Ccc      call rdint(1,noaua,noaua,vhpraa,nft829)
C vhprbb
Ccc      call rdint(1,nobub,nobub,vhprbb,nft830)
C
C vhprab
      CALL RDINT(1,NOBUB,NOAUA,VHPRAB,NFT833)
C
C VMAA_I (veaa tepm = vmaa)
      CALL RDINT(1,NOAUA,NOA2,VMAA,NFT823)
      CALL TRAN34N(NUA,NOA,NUA,NOA,TI,VHPRAA)
      CALL CCMATMUL(O1AA,VHPRAA,VEAB,NOA,NOA2UA,NUA,1,0)
      CALL TRANMD(VEAB,NOA,NOA,NOA,NUA,13)
      CALL TRANMD(VEAB,NOA,NOA,NOA,NUA,12)
      CALL VECADD(VMAA,VEAB,NOA3UA)
         CALL WRTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
C        write(6,*) 'vmaa_i'
Cc      CALL DRUK(noa,noa,noa,nua,vmaa)
C VMBB_I (vebb tepm = vmbb)
      CALL RDINT(1,NOBUB,NOB2,VMBA,NFT826)
      CALL TRAN34N(NUB,NOB,NUB,NOB,TI,VHPRBB)
      CALL CCMATMUL(O1BB,VHPRBB,VEBA,NOB,NOB2UB,NUB,1,0)
      CALL TRANMD(VEBA,NOB,NOB,NOB,NUB,13)
      CALL TRANMD(VEBA,NOB,NOB,NOB,NUB,12)
        CALL VECADD(VMBA,VEBA,NOB3UB)
         CALL WRTAB(NOB,NOB,NOB,NUB,VMBA,15,NFT891)
C        write(6,*) 'vmbb_i'
Cc      CALL DRUK(nob,nob,nob,nub,vmba)
C VMAB_I (veab tepm = vmab)
      CALL RDINT(1,NOAUB,NOAB,VMAB,NFT828)
      CALL TRAN34N(NUA,NOA,NUB,NOB,TI,VHPRAB)
      CALL CCMATMUL(O1AA,VHPRAB,VEAB,NOA,NOABUB,NUA,1,0)
      CALL INSITU(NOA,NOA,NOB,NUB,TI,VEAB,13)
      CALL INSITU(NOB,NOA,NOA,NUB,TI,VEAB,12)
        CALL VECADD(VMAB,VEAB,NOA2OBUB)
         CALL WRTAB(NOA,NOB,NOA,NUB,VMAB,16,NFT891)
C        write(6,*) 'vmab_i'
Cc      CALL DRUK(noa,nob,noa,nub,vmab)
C VHHHH_aa
      CALL RDINT(1,NOA2,NOA2,VHHAA,NFT820)
      CALL TRANSQ(VHHAA,NOA2)
      CALL TRAN1TO4(NUA,NOA,NOA,NUA,TI,VHPRAA) !KLFE
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,O2AA,13)
      CALL CCMATMUL(VHPRAA,O2AA,VHHAA,NOA2,NOA2,NUA2,0,0)
        CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL CCMATMUL(VMAA,O1AA,VHHAA,NOA3,NOA,NUA,0,0)
      CALL TRANSQ(VHHAA,NOA2)
      CALL RDINT(1,NOAUA,NOA2,VMAA,NFT823)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,12)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,23)
      CALL TRAN14(NOA,NOA,NOA,NUA,TI,VMAA)
        CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL CCMATMUL(O1AA,VMAA,VHHAA,NOA,NOA3,NUA,0,1)
C        write(6,*) 'vhhaa_i'
      CALL WRTAB(NOA,NOA,NOA,NOA,VHHAA,7,NFT891)
Cc      CALL DRUK(noa,noa,noa,noa,vhhaa)
C VHPLAA_I
      CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
      CALL VECMUL(O2AA,NOA2UA2,TWO)
      CALL INSITU(NUA,NUA,NOA,NOA,TI,O2AA,23)
      CALL INSITU(NOA,NUA,NUB,NOB,TI,O2AB,12)
      CALL TRAN1TO4(NOA,NOA,NOA,NUA,TI,VMAA)
C VHPLBB_I
Cc        call transnqn(nob,nub,o1bb,ti)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,O2BB,13)
      CALL INSITU(NUB,NUB,NOB,NOB,TI,O2BB,23)
Cccccccccc
C VMBA_I
      CALL RDINT(1,NOBUA,NOAB,VMBA,NFT827)
      CALL INSITU(NUA,NOA,NOB,NUB,TI,VHPRAB,13)
      CALL INSITU(NOB,NOA,NUA,NUB,TI,VHPRAB,12)
        CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL CCMATMUL(VHPRAB,O1BB,VMBA,NOABUA,NOB,NUB,0,0)
         CALL WRTAB(NOA,NOB,NUA,NOB,VMBA,17,NFT891)
C        write(6,*) 'vmba_i'
Cc      CALL DRUK(noa,nob,nua,nob,vmba)
Cccccccccc
C VHPLAB_I
Ccc      call rdint(1,nobua,nobua,vhplaa,nft834)
Ccc      call rdint(1,nobua,nuab,veab,nft839)
Ccc      call transq(vhplaa,nobua)
Ccc      call tran24(nua,nub,nua,nob,ti,veab)
Ccc      call ccmatmul(veab,o1bb,vhplaa,nobua2,nob,nub,0,0)
      CALL TRAN24(NUA,NOA,NUB,NOB,TI,O2AB)
      CALL INSITU(NOA,NOB,NUA,NUB,TI,VHPRAB,13)
        CALL TRANSNQN(NOBUA,NOAUB,VHPRAB,TI)
      CALL INSITU(NOA,NUB,NUA,NOB,TI,VHPRAB,12)
Cc      call tran24(nub,nob,nua,noa,ti,vhprab)
Ccc      call transq(vhplaa,nobua)
Ccc      call ccmatmul(o2ab,vhprab,vhplaa,nobua,nobua,noaub,0,1)
      CALL TRAN24(NOA,NOB,NUA,NOB,TI,VMBA)
Ccc      call ccmatmul(o1aa,vmba,vhplaa,nua,nob2ua,noa,0,1)
C        write(6,*) 'vhplab_i'
Ccc      call wrtab(nua,nob,nua,nob,vhplaa,4,nft892)
C      CALL DRUK(nua,nob,nua,nob,vhplaa)
C
C VHPR_AB_I (tmp veab)
Ccc     call zeroma(veab,1,noaub*nobua)
      CALL TRAN24(NUB,NOB,NUB,NOB,TI,O2BB)
      CALL TRAN24(NUB,NOA,NUA,NOB,TI,VHPRAB)
Ccc      call ccmatmul(o2bb,vhprab,veab,nobub,noaua,nobub,1,1)
      CALL INSITU(NUA,NOB,NUB,NOA,TI,O2AB,13)
Ccc      call tranmd(vhpraa,nua,noa,nua,noa,13)
Ccc      call ccmatmul(o2ab,vhpraa,veab,nobub,noaua,noaua,0,1)
Cc      call tran14(nub,noa,nub,nua,ti,veba) !ajbe
Ccc        call transnqn(nobub,noaua,veab,ti)
Ccc      call ccmatmul(veba,o1bb,veab,noauab,nob,nub,0,1)
Ccc        call transnqn(noaua,nobub,veab,ti)
      CALL TRAN14(NOA,NOB,NUA,NOB,TI,VMBA)
Ccc      call ccmatmul(o1bb,vmba,veab,nub,noabua,nob,0,0)
Ccc      call vecsub(veab,vhprab,noaua*nobub)
C
Ccc      call wrtab(nub,nob,nua,noa,veab,6,nft892)
C        write(6,*) 'vhprab_i'
C      CALL DRUK(nub,nob,nua,noa,veab)
C
C VHPR_BA_I (tmp veba)
Ccc     call zeroma(veba,1,noaub*nobua)
      CALL TRANMD(O2AA,NUA,NOA,NUA,NOA,13)
Ccc      call ccmatmul(vhprab,o2aa,veba,nobub,noaua,noaua,1,1)
Ccc      call tranmd(vhprbb,nub,nob,nub,nob,13)
Ccc      call ccmatmul(vhprbb,o2ab,veba,nobub,noaua,nobub,0,1)
Ccc      call rdint(1,nobua,nuab,veab,nft839)
Ccc      call tran1to4(nua,nub,nua,nob,ti,veab)
Ccc      call insitu(nub,nua,nob,nua,ti,veab,23)
Ccc      call ccmatmul(veab,o1aa,veba,nobuab,noa,nua,0,1)
Ccc      call vecsub(veba,vhprab,noaua*nobub)
Ccc      call tran34n(nub,nob,nua,noa,ti,veba) !ajib
Cc      call insitu(nob,noa,nub,noa,ti,vmab,12)
Cc      call insitu(noa,nob,nub,noa,ti,vmab,13)
Ccc        call transnqn(nua,noa,o1aa,ti)
Ccc      call ccmatmul(vmab,o1aa,veba,noabub,nua,noa,0,0)
C
Ccc      call wrtab(nub,nob,noa,nua,veba,5,nft892)
C        write(6,*) 'vhprba_i'
C      CALL DRUK(nub,nob,noa,nua,veba)
C
C VM_21 (vhpraa temp)
      CALL TRAN14(NOA,NOA,NUA,NOA,TI,VMAA)
      CALL TRAN24(NUA,NOA,NUA,NOA,TI,O2AA) !EMAJ
      CALL CCMATMUL(VMAA,O2AA,VHPRAA,NOA2,NOAUA,NOAUA,1,1) !KIAJ
Cc      call tran24(nub,nob,noa,noa,ti,vmab)
Cc      call insitu(nub,noa,noa,nob,ti,vmab,13) !ikem
      CALL TRANMD(VHPRAA,NOA,NOA,NUA,NOA,12) !IKAJ
      CALL TRANSNQN(NOAB,NOAUB,VMAB,TI)
      CALL INSITU(NOA,NUB,NOA,NOB,TI,VMAB,23)
      CALL CCMATMUL(VMAB,O2AB,VHPRAA,NOA2,NOAUA,NOBUB,0,0) !IKAJ
      CALL TRAN14(NOA,NOA,NUA,NOA,TI,VHPRAA) !JKAI
      CALL CCMATMUL(VMAB,O2AB,VHPRAA,NOA2,NOAUA,NOBUB,0,1) !JKAI
      CALL TRANMD(VHPRAA,NOA,NOA,NUA,NOA,12) !KJAI
      CALL CCMATMUL(VMAA,O2AA,VHPRAA,NOA2,NOAUA,NOAUA,0,0)
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)
      CALL CCMATMUL(FHP,O2AA,VHPRAA,NOA,NOA2UA,NUA,0,0) !*
      CALL RDINT(1,NOAUA,NUA2,VEAB,NFT836)
      CALL TRAN14(NUA,NOA,NUA,NOA,TI,O2AA)
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL TRAN14(NOA,NOA,NUA,NOA,TI,VHPRAA) !IJAK
      CALL CCMATMUL(O2AA,VEAB,VHPRAA,NOA2,NOAUA,NUA2,0,0)  !*
      CALL VECMUL(O2AA,NOA2UA2,TWO)
      CALL RDINT(1,NOAUA,NOAUA,VHPLAA,NFT831)
      CALL TRANMD(VHPLAA,NUA,NOA,NUA,NOA,13) ! EJAK
      CALL CCMATMUL(O1AA,VHPLAA,VHPRAA,NOA,NOA2UA,NUA,0,1) !*
      CALL TRANMD(VEAB,NUA,NUA,NUA,NOA,12)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPLAA,12)
      CALL CCMATMUL(O1AA,VEAB,VHPLAA,NOA,NOAUA2,NUA,0,0)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,VHPLAA,12)
      CALL TRANMD(VHPRAA,NOA,NOA,NUA,NOA,12) ! JIAK
      CALL CCMATMUL(O1AA,VHPLAA,VHPRAA,NOA,NOA2UA,NUA,0,0)
      CALL TRANMD(VHPRAA,NOA,NOA,NUA,NOA,12)
      CALL TRAN34N(NOA,NOA,NUA,NOA,TI,VHPRAA)
      CALL VECMUL(O1AA,NOAUA,HALF)                  !CCSD ONLY
      CALL CCMATMUL(VHHAA,O1AA,VHPRAA,NOA3,NUA,NOA,0,1) !IJKA
      CALL VECMUL(O1AA,NOAUA,TWO)                   !CCSD ONLY
      CALL RDINT(1,NOAUA,NOA2,VMAA,NFT823)
        CALL VECADD(VHPRAA,VMAA,NOA3UA)
         CALL WRTAB(NOA,NOA,NOA,NUA,VHPRAA,10,NFT891)
Cc        write(6,*) 'vm21_i'
Cc      CALL DRUK(noa,noa,noa,nua,vhpraa)
C
C VHHHH_bb
      CALL RDINT(1,NOB2,NOB2,VHHAA,NFT821)
      CALL TRANSQ(VHHAA,NOB2)
      CALL TRAN1TO4(NUB,NOB,NOB,NUB,TI,VHPRBB) !KLFE
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL TRANMD(O2BB,NUB,NOB,NUB,NOB,24)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,O2BB,23)
      CALL CCMATMUL(VHPRBB,O2BB,VHHAA,NOB2,NOB2,NUB2,0,0)
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
      CALL CCMATMUL(VMAA,O1BB,VHHAA,NOB3,NOB,NUB,0,0)
      CALL TRANSQ(VHHAA,NOB2)
      CALL RDINT(1,NOBUB,NOB2,VMAA,NFT826)
      CALL TRANMD(VMAA,NOB,NOB,NOB,NUB,12)
      CALL TRANMD(VMAA,NOB,NOB,NOB,NUB,23)
      CALL TRAN14(NOB,NOB,NOB,NUB,TI,VMAA)
        CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL CCMATMUL(O1BB,VMAA,VHHAA,NOB,NOB3,NUB,0,1)
C        write(6,*) 'vhhbb_i'
      CALL WRTAB(NOB,NOB,NOB,NOB,VHHAA,8,NFT891)
Cc      CALL DRUK(nob,nob,nob,nob,vhhaa)
C
C VM_21 (vhprbb temp)
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
      CALL TRAN1TO4(NOB,NOB,NOB,NUB,TI,VMAA)
      CALL TRAN14(NOB,NOB,NUB,NOB,TI,VMAA)
      CALL VECMUL(O2BB,NOB2UB2,TWO)
C      call tranmd(o2bb,nub,nob,nub,nob,13) !emaj
      CALL INSITU(NUB,NUB,NOB,NOB,TI,O2BB,23)
      CALL TRANSQ(O2BB,NOBUB)
C        call transnqn(nobub,nobub,o2bb,ti)
      CALL CCMATMUL(VMAA,O2BB,VHPRBB,NOB2,NOBUB,NOBUB,1,1) !KIAJ
      CALL TRANSNQN(NOBUB,NOAUA,O2AB,TI)
      CALL CCMATMUL(VMBA,O2AB,VHPRBB,NOB2,NOBUB,NOAUA,0,0)
      CALL TRAN24(NOB,NOB,NUB,NOB,TI,VHPRBB) !KJAI
      CALL CCMATMUL(VMBA,O2AB,VHPRBB,NOB2,NOBUB,NOAUA,0,1)
      CALL CCMATMUL(VMAA,O2BB,VHPRBB,NOB2,NOBUB,NOBUB,0,0)
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891)
      CALL CCMATMUL(FHP,O2BB,VHPRBB,NOB,NOB2UB,NUB,0,0)
      CALL RDINT(1,NOBUB,NUB2,VEBA,NFT837)
      CALL TRAN14(NUB,NOB,NUB,NOB,TI,O2BB)
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL TRAN14(NOB,NOB,NUB,NOB,TI,VHPRBB) !IJAK
      CALL CCMATMUL(O2BB,VEBA,VHPRBB,NOB2,NOBUB,NUB2,0,0)
      CALL VECMUL(O2BB,NOB2UB2,TWO)
      CALL RDINT(1,NOBUB,NOBUB,VHPLAA,NFT832)
      CALL TRANMD(VHPLAA,NUB,NOB,NUB,NOB,13) ! EJAK
      CALL CCMATMUL(O1BB,VHPLAA,VHPRBB,NOB,NOB2UB,NUB,0,1)
      CALL TRANMD(VEBA,NUB,NUB,NUB,NOB,12)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPLAA,12)
      CALL CCMATMUL(O1BB,VEBA,VHPLAA,NOB,NOBUB2,NUB,0,0)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,VHPLAA,12)
      CALL TRANMD(VHPRBB,NOB,NOB,NUB,NOB,12) ! JIAK
      CALL CCMATMUL(O1BB,VHPLAA,VHPRBB,NOB,NOB2UB,NUB,0,0)
      CALL TRANMD(VHPRBB,NOB,NOB,NUB,NOB,12)
      CALL TRAN34N(NOB,NOB,NUB,NOB,TI,VHPRBB)
      CALL VECMUL(O1BB,NOBUB,HALF)                  !CCSD ONLY
      CALL CCMATMUL(VHHAA,O1BB,VHPRBB,NOB3,NUB,NOB,0,1) !IJKA
      CALL VECMUL(O1BB,NOBUB,TWO)                   !CCSD ONLY
      CALL RDINT(1,NOBUB,NOB2,VMAA,NFT826)
        CALL VECADD(VHPRBB,VMAA,NOB3UB)
         CALL WRTAB(NOB,NOB,NOB,NUB,VHPRBB,11,NFT891)
Cc        write(6,*) 'vm21bb_i'
Cc      CALL DRUK(nob,nob,nob,nub,vhprbb)
C
C VHHHH_ab
      CALL RDINT(1,NOAB,NOAB,VHHAA,NFT822)
      CALL TRANSQ(VHHAA,NOAB)
      CALL TRAN14(NUB,NOB,NUA,NOA,TI,VHPRAB)
      CALL TRAN34N(NOA,NOB,NUA,NUB,TI,VHPRAB)
Ccc      call tran1to4(nua,noa,nob,nub,ti,vhprab) !klfe
Ccc      call insitu(noa,nua,nub,nob,ti,o2ab,13)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,13)
      CALL INSITU(NUB,NOA,NUA,NOB,TI,O2AB,23)
      CALL CCMATMUL(VHPRAB,O2AB,VHHAA,NOAB,NOAB,NUAB,0,0)
        CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL INSITU(NOA,NOA,NUB,NOB,TI,VMAB,23)
        CALL TRANSNQN(NOAUB,NOAB,VMAB,TI)
      CALL CCMATMUL(VMAB,O1BB,VHHAA,NOA2OB,NOB,NUB,0,0)
      CALL TRANSQ(VHHAA,NOAB)
      CALL RDINT(1,NOBUA,NOAB,VEBA,NFT827)
Ccc      call veccop((noaob2*nua),veba,vmba) ! veba=vmba
      CALL INSITU(NOA,NOB,NUA,NOB,TI,VEBA,13)
      CALL TRAN24(NUA,NOB,NOA,NOB,TI,VEBA)
      CALL CCMATMUL(O1AA,VEBA,VHHAA,NOA,NOAOB2,NUA,0,0)
C        write(6,*) 'vhhab_i'
      CALL WRTAB(NOA,NOB,NOA,NOB,VHHAA,9,NFT891)
Cc      CALL DRUK(noa,nob,noa,nob,vhhaa)
C
C VM_21ab (vhpraa temp)
         CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
        CALL TRANSNQN(NUB,NOB,O1BB,TI)
C      call tran1to4(noa,noa,noa,nua,ti,vmaa)
C      call tran14(noa,noa,nua,noa,ti,vmaa)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,23) !KIME
      CALL INSITU(NUB,NUA,NOA,NOB,TI,O2AB,13)
C      call insitu(nua,noa,nub,nob,ti,o2ab,12)
      CALL CCMATMUL(VMAA,O2AB,VHPRAA,NOA2,NOBUB,NOAUA,1,0) !KIAJ
      CALL INSITU(NOA,NUA,NUB,NOB,TI,O2AB,12)
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)
      CALL CCMATMUL(FHP,O2AB,VHPRAA,NOA,NOABUB,NUA,0,0)
      CALL TRANMD(VHPRAA,NOA,NOA,NUB,NOB,12) !IKAJ
      CALL TRAN1TO4(NOB,NOB,NUB,NUB,TI,O2BB)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,O2BB,12)
        CALL TRANSNQN(NOAB,NOAUB,VMAB,TI)
      CALL INSITU(NOA,NUB,NOA,NOB,TI,VMAB,23)
      CALL CCMATMUL(VMAB,O2BB,VHPRAA,NOA2,NOBUB,NOBUB,0,0)  !IKAJ
      CALL INSITU(NOA,NOA,NUB,NOB,TI,VHPRAA,23) !IAKJ
      CALL TRANSNQN(NOB2,NOAUA,VMBA,TI)
      CALL INSITU(NUA,NOA,NOB,NOB,TI,VMBA,23)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,13)
      CALL INSITU(NUB,NOA,NUA,NOB,TI,O2AB,12)
      CALL CCMATMUL(O2AB,VMBA,VHPRAA,NOAUB,NOAB,NOBUA,0,1)
      CALL TRAN24(NOA,NUB,NOA,NOB,TI,VHPRAA)
      CALL TRAN24(NOA,NUB,NUA,NOB,TI,O2AB)
      CALL RDINT(1,NOAUB,NUAB,VEBA,NFT838)
      CALL CCMATMUL(O2AB,VEBA,VHPRAA,NOAB,NOAUB,NUAB,0,0) !*IJKA
      CALL TRAN14(NOA,NOB,NUB,NUA,TI,VHPRAB)
      CALL TRAN34N(NUA,NOB,NUB,NOA,TI,VHPRAB)
C      call insitu(nub,nob,nua,noa,ti,vhprab,13)
C      call tran34n(nua,nob,nub,noa,ti,vhprab)
      CALL CCMATMUL(O1AA,VHPRAB,VHPRAA,NOA,NOABUB,NUA,0,0) !*
      CALL RDINT(1,NOAUB,NOAUB,VHPLAA,NFT835)
      CALL TRAN1TO4(NUB,NOA,NUB,NOA,TI,VHPLAA)
      CALL CCMATMUL(O1AA,VEBA,VHPLAA,NOA,NOAUB2,NUA,0,0)
      CALL INSITU(NOA,NOB,NOA,NUB,TI,VHPRAA,12) !JIKA
      CALL INSITU(NOA,NUB,NOA,NUB,TI,VHPLAA,12)
      CALL CCMATMUL(O1BB,VHPLAA,VHPRAA,NOB,NOA2UB,NUB,0,0)
      CALL INSITU(NOB,NOA,NOA,NUB,TI,VHPRAA,12) !IJKA
      CALL VECMUL(O1BB,NOBUB,HALF) !CCSD ONLY
      CALL CCMATMUL(VHHAA,O1BB,VHPRAA,NOA2OB,NUB,NOB,0,1) !*
      CALL VECMUL(O1BB,NOBUB,TWO)  !CCSD ONLY
      CALL RDINT(1,NOAUB,NOAB,VMAB,NFT828)
        CALL VECADD(VHPRAA,VMAB,NOA2OBUB)
         CALL WRTAB(NOA,NOB,NOA,NUB,VHPRAA,12,NFT891) !VMAB21
C        write(6,*) 'vm21ab_i'
Cc      CALL DRUK(noa,nob,noa,nub,vhpraa)
C
      CALL RDINT(1,NOBUA,NUAB,VEAB,NFT839)
         CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
      CALL TRANMD(VMAA,NOB,NOB,NOB,NUB,23) !KIME
      CALL INSITU(NOA,NOB,NUA,NUB,TI,O2AB,23)
      CALL INSITU(NOA,NUA,NOB,NUB,TI,O2AB,12)
      CALL TRANSNQN(NOAUA,NOBUB,O2AB,TI)
      CALL CCMATMUL(VMAA,O2AB,VHPRBB,NOB2,NOAUA,NOBUB,1,0) !KIAJ
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891)
      CALL INSITU(NOB,NUB,NOA,NUA,TI,O2AB,12)
      CALL CCMATMUL(FHP,O2AB,VHPRBB,NOB,NOABUA,NUB,0,0) !KIAJ
      CALL TRANSNQN(NOB2,NOAUA,VHPRBB,TI) !AJKI
      CALL INSITU(NOA,NOA,NUA,NUA,TI,O2AA,13)
      CALL INSITU(NUA,NOB,NOA,NOB,TI,VMBA,23)
      CALL INSITU(NUA,NOA,NOB,NOB,TI,VMBA,12)
      CALL CCMATMUL(O2AA,VMBA,VHPRBB,NOAUA,NOB2,NOAUA,0,0)
      CALL TRANSNQN(NOBUB,NOAUA,O2AB,TI)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,13)
      CALL INSITU(NUB,NOA,NUA,NOB,TI,O2AB,12)
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAB,16,NFT891)
      CALL TRANMD(VMAB,NOA,NOB,NOA,NUB,13)
      CALL INSITU(NOA,NOB,NOA,NUB,TI,VMAB,12)
      CALL INSITU(NUA,NOA,NOB,NOB,TI,VHPRBB,13)
      CALL CCMATMUL(VMAB,O2AB,VHPRBB,NOAB,NOBUA,NOAUB,0,1) !KJAI
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,12)
      CALL TRANSNQN(NUAB,NOBUA,VEAB,TI)
C      call insitu(nub,nob,nua,nua,ti,veab,13)
      CALL INSITU(NOA,NUB,NUA,NOB,TI,O2AB,13)
      CALL INSITU(NUA,NUB,NOA,NOB,TI,O2AB,12)
      CALL INSITU(NOB,NOA,NUA,NOB,TI,VHPRBB,23)
      CALL INSITU(NOB,NUA,NOA,NOB,TI,VHPRBB,12)
      CALL CCMATMUL(VEAB,O2AB,VHPRBB,NOBUA,NOAB,NUAB,0,0)
      CALL RDINT(1,NOBUA,NOBUA,VHPLAA,NFT834)
      CALL INSITU(NUA,NOB,NUA,NOB,TI,VHPLAA,23)
      CALL TRANSNQN(NUA2,NOB2,VHPLAA,TI)
      CALL INSITU(NUA,NOB,NUB,NUA,TI,VEAB,13)
      CALL CCMATMUL(O1BB,VEAB,VHPLAA,NOB,NOBUA2,NUB,0,0)
      CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL CCMATMUL(VHPRAB,O1BB,VHPRBB,NOABUA,NOB,NUB,0,0)
      CALL TRANSQ(VHHAA,NOAB)
      CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL VECMUL(O1AA,NOAUA,HALF) !CCSD ONLY
      CALL CCMATMUL(O1AA,VHHAA,VHPRBB,NUA,NOAOB2,NOA,0,1) !*
      CALL VECMUL(O1AA,NOAUA,TWO)  !CCSD ONLY
      CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL INSITU(NOB,NOB,NUA,NUA,TI,VHPLAA,13)
      CALL TRANSNQN(NOBUA,NOBUA,VHPLAA,TI)
      CALL INSITU(NOB,NUA,NUA,NOB,TI,VHPLAA,12)
      CALL TRANSNQN(NOBUA,NOAB,VHPRBB,TI) !JIAK
      CALL CCMATMUL(O1AA,VHPLAA,VHPRBB,NOA,NOB2UA,NUA,0,0)
      CALL RDINT(1,NOBUA,NOAB,VMBA,NFT827)
        CALL VECADD(VHPRBB,VMBA,NOAOB2UA)
         CALL WRTAB(NOA,NOB,NUA,NOB,VHPRBB,13,NFT891) !VMBA21
C        write(6,*) 'vm21ba_i'
Cc      CALL DRUK(noa,nob,nua,nob,vhprbb)
C
C o1, o2 back ordering
      CALL TRANSNQN(NUB,NOB,O1BB,TI)
C
      CALL TRANSQ(O2AA,NOAUA)
      CALL TRANSQ(O2BB,NOBUB)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,O2BB,12)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,O2AB,13)
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK CCMATMUL4PAB
      SUBROUTINE CCMATMUL4PAB(VPP,O1AA,O1BB,O2,VE,
     *                           T2,NOA,NOB,NUA,NUB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION VPP(NUA,NUB,NUA),T2(NUA,NUB,NOA,NOB),O1AA(NOA,NUA),
     *          O1BB(NOB,NUB),VE(NUA,NOA,NOB,NUB),O2(NOA,NUA,NOB,NUB)
C
      NU3=NUA*NUA*NUB
      NOAB=NOA*NOB
      NUAB=NUA*NUB
      NO2U2=NOAB*NUAB
      IREC=NUA+NUB
C
      CALL VECCOP(NO2U2,VE,O2)
         CALL CCMATMUL(O1AA,O1BB,VE,NOA*NUA,NOB*NUB,1,0,0)
      CALL INSITU(NOA,NUA,NOB,NUB,VPP,VE,12) !EIJF
C
      DO IA=1,NUB
         CALL ZEROMA(VPP,1,NU3)
         READ(NFT848,REC=IREC+IA) VPP
         CALL CCMATMUL(VPP,VE(1,1,1,IA),T2,NUAB,NOAB,NUA,0,0)
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK HBAR4P_AB
      SUBROUTINE HBAR4P_AB(VPP,O1AA,O1BB,O2,VHPR,VE,VM,TI,NOA,NUA,
     *                     NOB,NUB,IREC)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION VPP(NUA,NUB,NUA),O2(NUA,NUB,NOA,NOB),
     *          VHPR(NOA,NOB,NUA,NUB),O1AA(NUA,NOA),TI(1),
     *          O1BB(NUB,NOB),VE(NOA,NUB,NUA,NUB),VM(NOB,NUA,NUA,NUB)
C
      NU3=NUA*NUB*NUA
      NOAB=NOA*NOB
      NUAB=NUA*NUB
      NUA2=NUA*NUA
C
      DO IA=1,NUB
        CALL ZEROMA(VPP,1,NU3)
        READ(NFT848,REC=IREC+IA) VPP
        CALL CCMATMUL(O2,VHPR(1,1,1,IA),VPP,NUAB,NUA,NOAB,0,0)
        CALL INSITU(NUA,NUB,NUA,1,TI,VPP,12)
        CALL CCMATMUL(O1BB,VM(1,1,1,IA),VPP,NUB,NUA2,NOB,0,1)
        CALL INSITU(NUB,NUA,NUA,1,TI,VPP,12)
        CALL CCMATMUL(O1AA,VE(1,1,1,IA),VPP,NUA,NUAB,NOA,0,1)
        WRITE(NFT899,REC=IREC+IA) VPP
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK HBAR4P
      SUBROUTINE HBAR4P(VPP,O1,O2,VHPR,VE,VM,NO,NU,IREC)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION VPP(NU,NU,NU),O2(NU,NU,NO,NO),VHPR(NO,NO,NU,NU),
     *          O1(NU,NO),VE(NO,NU,NU,NU),VM(NO,NU,NU,NU)
C
      NO2=NO*NO
      NU2=NU*NU
      NU3=NU*NU*NU
C
      DO IA=1,NU
         CALL ZEROMA(VPP,1,NU3)
         READ(NFT848,REC=IREC+IA) VPP
         CALL CCMATMUL(O2,VHPR(1,1,1,IA),VPP,NU2,NU,NO2,0,0)
         CALL TRANMD(VPP,NU,NU,NU,1,12)
         CALL CCMATMUL(O1,VM(1,1,1,IA),VPP,NU,NU2,NO,0,0)
         CALL TRANMD(VPP,NU,NU,NU,1,12)
         CALL CCMATMUL(O1,VE(1,1,1,IA),VPP,NU,NU2,NO,0,1)
         WRITE(NFT899,REC=IREC+IA) VPP
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK CCMATMUL4P_VEBA
      SUBROUTINE CCMATMUL4P_VEBA(VPP,O1,VE,NOA,NUA,NUB,IREC)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION VPP(NUA,NUB,NUA),O1(NOA,NUA),VE(NOA,NUB,NUA,NUB)
C
      NU3=NUA*NUA*NUB
      NUAB=NUA*NUB
C
      DO IA=1,NUB
         CALL ZEROMA(VPP,1,NU3)
         READ(NFT848,REC=IREC+IA) VPP
         CALL TRANMD(VPP,NUA,NUB,NUA,1,13)
         CALL CCMATMUL(O1,VPP,VE(1,1,1,IA),NOA,NUAB,NUA,0,0)
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK CCMATMUL4P_VEAB
      SUBROUTINE CCMATMUL4P_VEAB(VPP,O1,VE,NOB,NUB,NUA,IREC)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION VPP(NUA,NUB,NUA),O1(NOB,NUB),VE(NUA,NUB,NUA,NOB)
C
      NU3=NUA*NUA*NUB
C
      DO IA=1,NUB
         CALL ZEROMA(VPP,1,NU3)
         READ(NFT848,REC=IREC+IA) VPP
         CALL CCMATMUL(VPP,O1(1,IA),VE,NU3,NOB,1,0,0)
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK CCMATMUL4P_VE
      SUBROUTINE CCMATMUL4P_VE(VPP,O1,VE,NO,NU,IREC)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION VPP(NU,NU,NU),O1(NU,NO),VE(NU,NU,NO,NU)
C
      NU2=NU*NU
      NU3=NU*NU*NU
C
      DO IA=1,NU
         CALL ZEROMA(VPP,1,NU3)
         READ(NFT848,REC=IREC+IA) VPP
         CALL CCMATMUL(VPP,O1,VE(1,1,1,IA),NU2,NO,NU,0,0)
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK CCMATMUL4P
      SUBROUTINE CCMATMUL4P(VPP,O1,O2,T2,VE,NO,NU,IREC)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION VPP(NU,NU,NU),T2(NO,NO,NU,NU),O2(NO,NU,NO,NU),
     *          O1(NO,NU),VE(NO,NO,NU,NU)
C
      NO2=NO*NO
      NU2=NU*NU
      NOU=NO*NU
      NU3=NU*NU*NU
      NO2U2=NO2*NU2
C
      CALL VECCOP(NO2U2,VE,O2)
         CALL CCMATMUL(O1,O1,VE,NOU,NOU,1,0,0)
      CALL INSITU(NO,NU,NO,NU,VPP,VE,23) !IJEF
      DO IA=1,NU
         CALL ZEROMA(VPP,1,NU3)
         READ(NFT848,REC=IREC+IA) VPP
         CALL TRANMD(VPP,NU,NU,NU,1,13)
         CALL CCMATMUL(VE(1,1,1,IA),VPP,T2,NO2,NU2,NU,0,0)
      ENDDO
C
      RETURN
      END
C*MODULE ROHFCC  *DECK PRT1A
      SUBROUTINE PRT1A(NO,NU,C1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
C
      DIMENSION C1(NO,NU)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       IF(ABS(C1(I,IA)).GT.TOLP) THEN
          WRITE(6,101) C1(I,IA),I+NOPCCFC,IA+NOPCCFC+NO
       END IF
 2    CONTINUE
 1    CONTINUE
      RETURN
 101  FORMAT(1X,'T1=',1X,F14.10,1X,'FOR IA -> AA =',2I4)
      END
C
C*MODULE ROHFCC  *DECK PRT1B
      SUBROUTINE PRT1B(NO,NU,C1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C1(NO,NU)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       IF(ABS(C1(I,IA)).GT.TOLP) THEN
          WRITE(6,101) C1(I,IA),I+NOPCCFC,IA+NOPCCFC+NO
       END IF
 2    CONTINUE
 1    CONTINUE
 101  FORMAT(1X,'T1=',1X,F14.10,1X,'FOR IB -> AB =',2I4)
      RETURN
      END
C
C*MODULE ROHFCC  *DECK PRT2AA
      SUBROUTINE PRT2AA(NO,NU,C2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C2(NO,NU,NU,NO)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NO
      DO 2,J=I+1,NO
      DO 3,IA=1,NU
      DO 4,IB=IA+1,NU
        IF(ABS(C2(I,IA,IB,J)).GT.TOLP) THEN
           WRITE(6,102) C2(I,IA,IB,J),I+NOPCCFC,J+NOPCCFC,
     *                    IA+NOPCCFC+NO,IB+NOPCCFC+NO
        END IF
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
 102  FORMAT(1X,'T2=',1X,F14.10,1X,'FOR IA,JA -> AA, BA =',4I4)
      END
C
C*MODULE ROHFCC  *DECK PRT2BB
      SUBROUTINE PRT2BB(NO,NU,C2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C2(NO,NU,NU,NO)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NO
      DO 2,J=I+1,NO
      DO 3,IA=1,NU
      DO 4,IB=IA+1,NU
        IF(ABS(C2(I,IA,IB,J)).GT.TOLP) THEN
           WRITE(6,102) C2(I,IA,IB,J),I+NOPCCFC,J+NOPCCFC,
     *                    IA+NOPCCFC+NO,IB+NOPCCFC+NO
        END IF
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
 102  FORMAT(1X,'T2=',1X,F14.10,1X,'FOR IB,JB -> AB, BB =',4I4)
      END
C
C*MODULE ROHFCC  *DECK PRT2AB
      SUBROUTINE PRT2AB(NOA,NUA,NUB,NOB,C2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C2(NOA,NUA,NUB,NOB)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NOA
      DO 2,J=1,NOB
      DO 3,IA=1,NUA
      DO 4,IB=1,NUB
        IF(ABS(C2(I,IA,IB,J)).GT.TOLP) THEN
           WRITE(6,102) C2(I,IA,IB,J),I+NOPCCFC,J+NOPCCFC,
     *                    IA+NOPCCFC+NOA,IB+NOPCCFC+NOB
        END IF
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
 102  FORMAT(1X,'T2=',1X,F14.10,1X,'FOR IA,JB -> AA, BB =',4I4)
      END
C
C*MODULE ROHFCC  *DECK RESNT1A
      SUBROUTINE RESNT1A(NO,NU,T1,O1,RES)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T1(NU,NO),O1(NU,NO)
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       XXX=T1(IA,I)-O1(IA,I)
       RES=RES+XXX*XXX
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK RESNT1B
      SUBROUTINE RESNT1B(NO,NU,T1,O1,RES)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T1(NO,NU),O1(NO,NU)
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       XXX=T1(I,IA)-O1(I,IA)
       RES=RES+XXX*XXX
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK DENAD1A
      SUBROUTINE DENAD1A(NO,NU,T1,FHH,FPP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T1(NU,NO),FHH(NO),FPP(NU)
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       DEN=FHH(I)-FPP(IA)
       T1(IA,I)=T1(IA,I)/DEN
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK RESNT2A
      SUBROUTINE RESNT2A(NO,NU,T2,O2,RES)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T2(NO,NU,NU,NO)
      DIMENSION O2(NU,NO,NU,NO)
C
      DO 1,I=1,NO-1
      DO 2,IA=1,NU-1
      DO 3,IB=IA+1,NU
      DO 4,J=I+1,NO
       XXX=T2(I,IA,IB,J)-O2(IA,I,IB,J)
       RES=RES+XXX*XXX
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK RESNT2B
      SUBROUTINE RESNT2B(NO,NU,T2,O2,RES)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T2(NO,NU,NU,NO)
      DIMENSION O2(NO,NU,NU,NO)
C
      DO 1,I=1,NO-1
      DO 2,IA=1,NU-1
      DO 3,IB=IA+1,NU
      DO 4,J=I+1,NO
       XXX=T2(I,IA,IB,J)-O2(I,IA,IB,J)
       RES=RES+XXX*XXX
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK RESNTAB
      SUBROUTINE RESNTAB(NOA,NUA,NUB,NOB,T2,O2,RES)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T2(NOA,NUA,NUB,NOB)
      DIMENSION O2(NUA,NOB,NUB,NOA)
C
      DO 1,I=1,NOA
      DO 2,IA=1,NUA
      DO 3,IB=1,NUB
      DO 4,J=1,NOB
       XXX=T2(I,IA,IB,J)-O2(IA,J,IB,I)
       RES=RES+XXX*XXX
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK MOM23
      SUBROUTINE MOM23(NOA,NUA,NOB,NUB,T1AA,T1BB,
     *                 T2AA,T2BB,T2AB,VEAA,VEAB,VEBA,VHHHH,
     *                 FHPAA,FHPBB,XM3,VHPRAA,VHPRBB,VHPRAB,TI,
     *                 VMAB,VMBA,VMAA,FHHA,FHHB,FPPA,FPPB,
     *                 X1AA,X1BB,X1AB,X2AA,X2BB,X2AB,
     *                 X3AA,X3BB,X3AB,X3BA,X4AAA,X4AAB,X4BBA,X4BBB,
     *                 X5AAA,X5AAB,X5BBA,X5BBB,EHA,EPA,EHB,EPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER CR
C
      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
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION TI(1),XM3(1),FPPA(1),FPPB(1),FHHA(1),FHHB(1),
     *          FHPAA(1),FHPBB(1),T2AA(1),T2AB(1),T2BB(1),
     *          VEAA(1),VEAB(1),VHPRAB(1),VHHHH(1),
     *          VMBA(1),VMAB(1),VMAA(1),VEBA(1),
     *          X1AA(1),X1BB(1),X1AB(1),X2AA(1),X2BB(1),X2AB(1),
     *          X3AA(1),X3BB(1),X3AB(1),X3BA(1),
     *          X4AAA(1),X4AAB(1),X4BBA(1),X4BBB(1),
     *          X5AAA(1),X5AAB(1),X5BBA(1),X5BBB(1),
     *          EHA(NOA),EPA(NUA),EHB(NOB),EPB(NUB)
C
      CALL DENMAKE(NOA,NUA,NOB,NUB,VHHHH,XM3,VHPRAB,T2AB,X1AA,
     *             X1BB,X1AB,X2AA,X2BB,X2AB,X3AA,X3BB,X3AB,X3BA,
     *             X4AAA,X4AAB,X4BBA,X4BBB,X5AAA,X5AAB,X5BBA,X5BBB)
C
      CORA=0.00D+00
      CORB=0.00D+00
      CORC=0.00D+00
      CORD=0.00D+00
C
Cc L(2,3)_aaa  cccccccccccccccccccc
         CALL RDTAB(NOA,NUA,NUA,NOA,T2AA,8,NFT825) !L2AA
       CALL RDTAB(NOA,NUA,NUA,NUA,VEAA,11,NFT892)
      CALL TRAN14(NOA,NUA,NUA,NUA,VEAB,VEAA)
      CALL RDTAB2(NOA,NUA,FHPAA,5,NFT891)
        CALL TRANSNQN(NOA,NUA,FHPAA,TI)
C
         CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
        CALL TRANSNQN(NOA2,NOAUA,VMAA,VMAB)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,T2AA,13)
C
      CALL RDTAB2(NOA,NUA,T1AA,6,NFT825)  !L1
        CALL TRANSNQN(NOA,NUA,T1AA,TI)
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPRAA,23)
C
C      write(6,*) 'start of l3_a'
C      call flshbf(6)
C
      CALL LAMB23_LOOPW(NOA,NUA,FHPAA,T1AA,
     *VHPRAA,T2AA,VEAA,XM3,TI,VMAA)
C
C        write(6,*) 'end of l3_a'
C
Cc M(2,3)_aaa  cccccccccccccccccccc
C
         CALL RDTAB(NOA,NUA,NUA,NOA,T2AB,3,NFT825)
       CALL RDTAB(NUA,NUA,NUA,NOA,VEAB,7,NFT892)
      CALL TRANMD(VEAB,NUA,NUA,NUA,NOA,13)
      CALL TRANMD(VEAB,NUA,NUA,NUA,NOA,23)
C      call rdtab2(noa,nua,fhpaa,5,nft891)
C        call transnqn(noa,nua,fhpaa,ti)
      CALL CCMATMUL(FHPAA,T2AB,VEAB,NUA,NOAUA2,NOA,0,0)
C
         CALL RDTAB(NOA,NOA,NOA,NUA,VMAB,10,NFT891)
        CALL TRANSNQN(NOA2,NOAUA,VMAB,VMBA)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,T2AB,13)
C
      CALL WRTAB(NUA,NUA,NUA,NOA,VEAB,15,NFT892)
C
      CALL RDTAB2(NOA,NOA,FHHA,3,NFT891)
      CALL RDTAB2(NOB,NUB,FHHB,4,NFT891)
      CALL RDTAB2(NUA,NUA,FPPA,1,NFT891)
      CALL RDTAB2(NUB,NUB,FPPB,2,NFT891)
C
C      write(6,*) 'start of loop_a'
C      call flshbf(6)
C
      CALL MOM23_LOOP(NOA,NUA,T2AB,VEAB,XM3,TI,VMAB,
     *FHHA,FPPA,X1AA,X2AA,X3AA,X4AAA,X5AAA,EHA,EPA,
     *CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of loop_a'
C      call flshbf(6)
C
Cc L(2,3)_aab   ccccccccccccccccccccccc
      CALL INSITU(NOA,NUA,NOA,NOA,TI,VMAA,12)
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAB,16,NFT891)
        CALL TRANSNQN(NOAB,NOAUB,VMAB,VMBA)
         CALL RDTAB(NOA,NOB,NUA,NOB,VMBA,17,NFT891)
        CALL TRANSNQN(NOAB,NOBUA,VMBA,T2AB)
         CALL RDTAB(NOA,NUA,NUB,NOB,T2AB,10,NFT825)  !L2AB
      CALL VECCOP(NO2U2AB,T2BB,T2AB)
C      call zeroma(vhprab,1,no2u2ab)
      CALL TRAN14(NOA,NUA,NUB,NOB,VHPRAB,T2BB)
      CALL VECCOP(NO2U2AB,VHPRAB,T2AB)
C
       CALL RDTAB(NOA,NUB,NUA,NUB,VEBA,14,NFT892)
      CALL TRAN1TO4(NOA,NUB,NUA,NUB,VEAB,VEBA)
      CALL TRANMD(VEBA,NUB,NUA,NUB,NOA,13)
C
       CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,13,NFT892)
Cc      call tranmd(veab,nua,nub,nua,nob,13)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
C
      CALL RDTAB2(NOB,NUB,FHPBB,6,NFT891)
        CALL TRANSNQN(NOB,NUB,FHPBB,TI)
C
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPRAB,13)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,VHPRAB,12)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,23)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,13)
C
      CALL RDTAB2(NOB,NUB,T1BB,7,NFT825)  !L1
        CALL TRANSNQN(NOB,NUB,T1BB,TI)
      CALL RDINT(1,NOBUB,NOAUA,VHPRBB,NFT833)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPRBB,23)
C
C      write(6,*) 'start of l3_aab'
C      call flshbf(6)
C
      CALL LAMB23_LOOP_AABW(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *T1AA,T1BB,T2AA,T2BB,T2AB,VHPRAB,
     *VHPRAA,VHPRBB,XM3,TI,VMAA,VMBA,VMAB,VEAA,VEBA,VEAB)
C
C      write(6,*) 'end of l3_aab'
C      call flshbf(6)
C
Cc M(2,3)_aab   cccccccccccccccccccccccc
C
         CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,10,NFT891)
        CALL TRANSNQN(NOA2,NOAUA,VMAA,VMAB)
      CALL INSITU(NOA,NUA,NOA,NOA,TI,VMAA,12)
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAB,12,NFT891)
        CALL TRANSNQN(NOAB,NOAUB,VMAB,VMBA)
         CALL RDTAB(NOA,NOB,NUA,NOB,VMBA,13,NFT891)
        CALL TRANSNQN(NOAB,NOBUA,VMBA,T2AA)
      CALL RDTAB(NOA,NUA,NUA,NOA,T2AA,3,NFT825)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,T2AA,13)
         CALL RDTAB(NOA,NUA,NUB,NOB,T2AB,5,NFT825)
      CALL VECCOP(NO2U2AB,T2BB,T2AB)
      CALL TRAN14(NOA,NUA,NUB,NOB,VHPRAB,T2BB)
C      call zeroma(vhprab,1,no2u2ab)
      CALL VECCOP(NO2U2AB,VHPRAB,T2AB)
C
       CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,9,NFT892)
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
      CALL CCMATMUL(FHPAA,T2AB,VEAB,NUA,NOBUAB,NOA,0,0)
      CALL WRTAB(NUA,NUA,NUB,NOB,VEAB,17,NFT892)
C
       CALL RDTAB(NUA,NUB,NOA,NUB,VEBA,10,NFT892)
        CALL TRANSNQN(NUAB,NOAUB,VEBA,VEAA)
      CALL TRAN1TO4(NOA,NUB,NUA,NUB,VEAA,VEBA)
C      call rdtab2(nob,nub,fhp,6,nft891)
C        call transnqn(nob,nub,fhp,ti)
      CALL CCMATMUL(FHPBB,T2BB,VEBA,NUB,NOAUAB,NOB,0,0)
      CALL WRTAB(NUB,NUA,NUB,NOA,VEBA,18,NFT892)
C
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPRAB,13)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,VHPRAB,12)
      CALL RDTAB(NUA,NUA,NUA,NOA,VEAA,15,NFT892)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,23)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,13)
C
C      write(6,*) 'start of loop_aab'
C      call flshbf(6)
C
      CALL MOM23_LOOP_AAB(NOA,NUA,NOB,NUB,T2AA,T2BB,
     *T2AB,VHPRAB,XM3,TI,VMAA,VMBA,VMAB,VEAA,VEBA,VEAB,
     *FHHA,FHHB,FPPA,FPPB,X1AA,X1AB,X2AA,X2AB,X3AA,X3AB,
     *X3BA,X3BB,X4AAA,X4AAB,X4BBA,X5AAA,X5AAB,X5BBA,
     *EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of loop_aab'
C      call flshbf(6)
C
C
Cc L(2,3)_bbb   cccccccccccccccccccccccc
C
      CALL RDTAB(NOB,NUB,NUB,NOB,T2AA,9,NFT825)
      CALL RDINT(1,NOBUB,NOBUB,VHPRAA,NFT830)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPRAA,23)
      CALL RDTAB(NOB,NUB,NUB,NUB,VEAA,12,NFT892)
      CALL TRAN14(NOB,NUB,NUB,NUB,VEAB,VEAA)
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
       CALL TRANSNQN(NOB2,NOBUB,VMAA,VMAB)
C
      CALL INSITU(NOB,NUB,NUB,NOB,TI,T2AA,13)
C
C      call rdtab2(nob,nub,t1aa,7,nft825)  !l1
C        call transnqn(nob,nub,t1aa,ti)
C
C      write(6,*) 'start of l3_b'
C      call flshbf(6)
C
      CALL LAMB23_LOOPW(NOB,NUB,FHPBB,T1BB,
     *VHPRAA,T2AA,VEAA,XM3,TI,VMAA)
C
C      write(6,*) 'end of l3_b'
C      call flshbf(6)
C
Cc M(2,3)_bbb   cccccccccccccccccccccccc
C
      CALL RDTAB(NOB,NUB,NUB,NOB,T2BB,4,NFT825)
      CALL RDTAB(NUB,NUB,NUB,NOB,VEAB,8,NFT892)
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,13)
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,23)
      CALL CCMATMUL(FHPBB,T2BB,VEAB,NUB,NOBUB2,NOB,0,0)
      CALL WRTAB(NUB,NUB,NUB,NOB,VEAB,16,NFT892)
C
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAB,11,NFT891)
      CALL TRANSNQN(NOB2,NOBUB,VMAB,VMBA)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,T2BB,13)
C
C      write(6,*) 'start of loop_b'
C      call flshbf(6)
C
      CALL MOM23_LOOP(NOB,NUB,T2BB,VEAB,XM3,TI,VMAB,
     *FHHB,FPPB,X1BB,X2BB,X3BB,X4BBB,X5BBB,EHB,EPB,
     *CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of loop_b'
C      call flshbf(6)
C
C
Cc L(2,3)_abb   cccccccccccccccccccccccc
C
      CALL RDTAB(NOA,NUA,NUB,NOB,T2BB,10,NFT825)  !L2AB
      CALL INSITU(NOA,NUA,NUB,NOB,TI,T2BB,13)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,T2BB,12)
      CALL VECCOP(NO2U2AB,VHPRAB,T2BB)
      CALL TRAN34N(NUA,NUB,NOA,NOB,T2AB,T2BB)
C
      CALL INSITU(NUB,NUB,NOB,NOB,TI,T2AA,13)
      CALL VECCOP(NOB2UB2,T2AB,T2AA)
C
      CALL INSITU(NOB,NUB,NUB,NOB,TI,T2AB,13)
C
      CALL RDTAB(NOA,NUB,NUA,NUB,VEBA,14,NFT892)
      CALL TRAN1TO4(NOA,NUB,NUA,NUB,VEAB,VEBA)
      CALL TRANMD(VEBA,NUB,NUA,NUB,NOA,13)
      CALL INSITU(NUB,NUA,NUB,NOA,TI,VEBA,23)
      CALL INSITU(NUB,NUB,NUA,NOA,TI,VEBA,13)
      CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,13,NFT892)
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13)
C
      CALL RDTAB(NOA,NOB,NOA,NUB,VMAB,16,NFT891)
      CALL TRANSNQN(NOAB,NOAUB,VMAB,VMBA)
      CALL RDTAB(NOA,NOB,NUA,NOB,VMBA,17,NFT891)
      CALL TRANSNQN(NOAB,NOBUA,VMBA,VHPRAA)
C
      CALL RDINT(1,NOBUB,NOBUB,VHPRAA,NFT830)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPRAA,23)
C
C      write(6,*) 'start of l3_abb'
C      call flshbf(6)
C
      CALL LAMB23_LOOP_ABBW(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *T1AA,T1BB,T2AA,T2BB,T2AB,VHPRAB,
     *VHPRAA,VHPRBB,XM3,TI,VMAA,VMBA,VMAB,VEAA,VEBA,VEAB)
C
C      write(6,*) 'end of l3_abb'
C      call flshbf(6)
C
Cc M(2,3)_abb   cccccccccccccccccccccccc
C
      CALL RDTAB(NUB,NUB,NUB,NOB,VEAA,16,NFT892)
      CALL RDTAB(NUA,NUA,NUB,NOB,VEAB,17,NFT892)
      CALL RDTAB(NUB,NUA,NUB,NOA,VEBA,18,NFT892)
C
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,11,NFT891)
      CALL TRANSNQN(NOB2,NOBUB,VMAA,VMAB)
      CALL RDTAB(NOA,NOB,NOA,NUB,VMAB,12,NFT891)
      CALL TRANSNQN(NOAB,NOAUB,VMAB,VMBA)
      CALL RDTAB(NOA,NOB,NUA,NOB,VMBA,13,NFT891)
      CALL TRANSNQN(NOAB,NOBUA,VMBA,T2BB)
C
      CALL RDTAB(NOA,NUA,NUB,NOB,T2BB,5,NFT825)
      CALL INSITU(NOA,NUA,NUB,NOB,TI,T2BB,13)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,T2BB,12)
      CALL VECCOP(NO2U2AB,VHPRAB,T2BB)
      CALL TRAN34N(NUA,NUB,NOA,NOB,T2AA,T2BB)
         CALL RDTAB(NOB,NUB,NUB,NOB,T2AA,4,NFT825)
      CALL VECCOP(NOB2UB2,T2AB,T2AA)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,T2AB,13)
C
      CALL INSITU(NUA,NUA,NUB,NOB,TI,VEAB,23)
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13)
      CALL INSITU(NUB,NUA,NUB,NOA,TI,VEBA,23)
      CALL INSITU(NUB,NUB,NUA,NOA,TI,VEBA,13)
C
C      write(6,*) 'start of loop_abb'
C      call flshbf(6)
C
      CALL MOM23_LOOP_ABB(NOA,NUA,NOB,NUB,T2AA,T2BB,
     *T2AB,VHPRAB,XM3,TI,VMAA,VMBA,VMAB,VEAA,VEBA,VEAB,
     *FHHA,FHHB,FPPA,FPPB,X1BB,X1AB,X2BB,X2AB,X3AA,X3AB,
     *X3BA,X3BB,X4BBB,X4AAB,X4BBA,X5BBB,X5AAB,X5BBA,
     *EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
C       n.b. there are no less than three places where this kind of
C            printing would need to be changed.
C
      WRITE(6,94)
      ENGCC=ENRG+EREF
C
      CR='A'
      WRITE(6,95) CR,CORA,ENGCC+CORA
      CR='B'
      WRITE(6,95) CR,CORB,ENGCC+CORB
      CR='C'
      WRITE(6,95) CR,CORC,ENGCC+CORC
      CR='D'
      WRITE(6,95) CR,CORD,ENGCC+CORD
C
      WRITE(6,96)
      WRITE(6,97) ENGCC,ENRG,ENGCC+CORA,ENRG+CORA,ENGCC+CORD,ENRG+CORD
      WRITE(6,98)
C
C       Save total correlation: CCSD plus best triples correlation
C       Although type -D- is considered the best energy, it is not
C       invariant to rotations of degenerate orbitals, whereas the
C       type -A- energy is.  Hence the type -A- value is returned.
C
C       n.b. There are three places like this to change.
C
      ENRG = ENRG + CORA
      RETURN
C
   94 FORMAT(/1X,'MAIN RESULTS: CR-CC(2,3) = CR-CC(2,3),D =',
     *           ' CR-CCSD(T)_L CALCULATIONS'/)
   95 FORMAT(1X,'GROUND STATE CR-CC(2,3),',A1,1X,'CORRECTION',F10.6,
     *       ', TOTAL E=',F20.10)
   96 FORMAT(/
     * 1X,'CR-CC(2,3),A ENERGY IS IDENTICAL TO THE CCSD(2)_T ENERGY.'/
     * 1X,'CR-CC(2,3),D ENERGY IS IDENTICAL TO COMPLETE CR-CC(2,3)',
     *    ' ENERGY (CR-CCSD(T)_L)')
   97 FORMAT(/15X,'SUMMARY OF CR-CC(2,3) OR CR-CCSD(T)_L CALCULATIONS'/
     *  1X,'CCSD',23X,'E=',F20.10,3X,'CORR. E=',F15.10/
     *  1X,'CR-CC(2,3),A OR CCSD(2)_T  E=',F20.10,3X,'CORR. E=',F15.10/
     *  1X,'CR-CC(2,3) OR CR-CCSD(T)_L E=',F20.10,3X,'CORR. E=',F15.10)
   98 FORMAT(/1X,'THE MOST ACCURATE ENERGETICS IS PROVIDED BY',
     *           ' CR-CC(2,3) = CR-CC(2,3),D')
      END
C
C*MODULE ROHFCC  *DECK LAMB23_IO
      SUBROUTINE LAMB23_IO(NOA,NUA,NOB,NUB,T1AA,T1BB,
     *   XL2AA,XL2BB,XL2AB,VHPLAB,T2AA,T2BB,T2AB,VEAA,VEAB,VEBA,
     *   FHPAA,FHPBB,VHPRAA,VHPRBB,XM3,XL3,VHPRAB,TI,
     *   VMAB,VMBA,VMAA,VMBB,VMAB21,VMBA21,FHHA,FHHB,FPPA,FPPB,
     *   X1AA,X1BB,X1AB,X2AA,X2BB,X2AB,X3AA,X3BB,X3AB,X3BA,
     *   X4AAA,X4AAB,X4BBA,X4BBB,
     *   X5AAA,X5AAB,X5BBA,X5BBB,VHHHH,EHA,EPA,EHB,EPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER CR
C
      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
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION TI(1),XM3(1),T1AA(1),T1BB(1),XL2AA(1),XL2BB(1),XL3(1),
     *          VHPLAB(1),T2AA(1),T2AB(1),T2BB(1),FHPBB(1),VHPRBB(1),
     *          VEAA(1),VEAB(1),VHPRAA(1),VHPRAB(1),XL2AB(1),
     *          VMBA(1),VMAB(1),VMAA(1),VMBB(1),FHPAA(1),VEBA(1),
     *          VMBA21(1),VMAB21(1),VHHHH(1),
     *          X1AA(1),X1BB(1),X1AB(1),X2AA(1),X2BB(1),X2AB(1),
     *          X3AA(1),X3BB(1),X3AB(1),X3BA(1),
     *          X4AAA(1),X4AAB(1),X4BBA(1),X4BBB(1),
     *          X5AAA(1),X5AAB(1),X5BBA(1),X5BBB(1),
     *          FPPA(1),FPPB(1),FHHA(1),FHHB(1),
     *          EHA(NOA),EPA(NUA),EHB(NOB),EPB(NUB)
C
      CALL DENMAKE(NOA,NUA,NOB,NUB,VHHHH,XM3,VHPRAB,T2AB,X1AA,
     *             X1BB,X1AB,X2AA,X2BB,X2AB,X3AA,X3BB,X3AB,X3BA,X4AAA,
     *             X4AAB,X4BBA,X4BBB,X5AAA,X5AAB,X5BBA,X5BBB)
C
      CALL RDTAB2(NOA,NOA,FHHA,3,NFT891)
      CALL RDTAB2(NOB,NUB,FHHB,4,NFT891)
      CALL RDTAB2(NUA,NUA,FPPA,1,NFT891)
      CALL RDTAB2(NUB,NUB,FPPB,2,NFT891)
      CORA=0.00D+00
      CORB=0.00D+00
      CORC=0.00D+00
      CORD=0.00D+00
C
Cc L3_aaa  cccccccccccccccccccc
C
         CALL RDTAB(NOA,NUA,NUA,NOA,XL2AA,8,NFT825) !L2AA
       CALL RDTAB(NOA,NUA,NUA,NUA,VEAA,11,NFT892)
      CALL TRAN14(NOA,NUA,NUA,NUA,VEBA,VEAA)
Cc       call wrtab(nua,nua,nua,noa,veaa,19,nft892)
      CALL RDTAB2(NOA,NUA,FHPAA,5,NFT891)
        CALL TRANSNQN(NOA,NUA,FHPAA,TI)
C
         CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
        CALL TRANSNQN(NOA2,NOAUA,VMAA,VMBB)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,XL2AA,13)
C
      CALL RDTAB2(NOA,NUA,T1AA,6,NFT825)  !L1
        CALL TRANSNQN(NOA,NUA,T1AA,TI)
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPRAA,23)
C
Cc ----------- M(2,3) ----------------
C
         CALL RDTAB(NOA,NUA,NUA,NOA,T2AA,3,NFT825)
       CALL RDTAB(NUA,NUA,NUA,NOA,VEBA,7,NFT892)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,13)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,23)
      CALL CCMATMUL(FHPAA,T2AA,VEBA,NUA,NOAUA2,NOA,0,0)
         CALL WRTAB(NUA,NUA,NUA,NOA,VEBA,15,NFT892)
C
         CALL RDTAB(NOA,NOA,NOA,NUA,VMBB,10,NFT891)
        CALL TRANSNQN(NOA2,NOAUA,VMBB,VMAB)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,T2AA,13)
Cc ---------------
C
C      write(6,*) 'start of l3_a'
C      call flshbf(6)
C
      CALL LAMB23_LOOP(NOA,NUA,FHPAA,T1AA,
     *VHPRAA,XL2AA,T2AA,VEAA,VEBA,XM3,XL3,TI,VMAA,VMBB,
     *FHHA,FPPA,X1AA,X2AA,X3AA,X4AAA,X5AAA,EHA,EPA,
     *CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of l3_a'
C      call flshbf(6)
C
C
Cc L3_aab   cccccccccccccccccccccccc
C
      CALL INSITU(NOA,NUA,NOA,NOA,TI,VMAA,12)
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAB,16,NFT891)
        CALL TRANSNQN(NOAB,NOAUB,VMAB,VMBA)
         CALL RDTAB(NOA,NOB,NUA,NOB,VMBA,17,NFT891)
        CALL TRANSNQN(NOAB,NOBUA,VMBA,VMAB21)
         CALL RDTAB(NOA,NUA,NUB,NOB,XL2AB,10,NFT825)  !L2AB
      CALL VECCOP(NO2U2AB,XL2BB,XL2AB)
      CALL VECCOP(NO2U2AB,VHPRAB,XL2AB)
      CALL TRAN14(NOA,NUA,NUB,NOB,T2AB,XL2BB)
C
       CALL RDTAB(NOA,NUB,NUA,NUB,VEBA,14,NFT892)
      CALL TRAN1TO4(NOA,NUB,NUA,NUB,VEAB,VEBA)
      CALL TRANMD(VEBA,NUB,NUA,NUB,NOA,13)
       CALL WRTAB(NUB,NUA,NUB,NOA,VEBA,16,NFT892)
      CALL RDTAB2(NOB,NUB,FHPBB,6,NFT891)
        CALL TRANSNQN(NOB,NUB,FHPBB,TI)
C
Ccc       call rdtab(nua,nub,nua,nob,veab,13,nft892)
Ccc      call insitu(nua,nub,nua,nob,ti,veab,23)
C
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPRAB,13)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,VHPRAB,12)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,23)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,13)
       CALL WRTAB(NUA,NUA,NUA,NOA,VEAA,19,NFT892)
C
      CALL RDTAB2(NOB,NUB,T1BB,7,NFT825)  !L1
        CALL TRANSNQN(NOB,NUB,T1BB,TI)
      CALL RDINT(1,NOBUB,NOAUA,VHPRBB,NFT833)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPRBB,23)
C
C ---------------M3----------------
C
      CALL INSITU(NOA,NUA,NOA,NOA,TI,VMBB,12)
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAB21,12,NFT891)
        CALL TRANSNQN(NOAB,NOAUB,VMAB21,VMBA21)
         CALL RDTAB(NOA,NOB,NUA,NOB,VMBA21,13,NFT891)
        CALL TRANSNQN(NOAB,NOBUA,VMBA21,T2AB)
         CALL RDTAB(NOA,NUA,NUB,NOB,T2AB,5,NFT825)
      CALL VECCOP(NO2U2AB,T2BB,T2AB)
C
      CALL TRAN14(NOA,NUA,NUB,NOB,VHPLAB,T2BB)
C
       CALL RDTAB(NUA,NUB,NOA,NUB,VEBA,10,NFT892)
        CALL TRANSNQN(NUAB,NOAUB,VEBA,VEAB)
      CALL TRAN1TO4(NOA,NUB,NUA,NUB,VEAB,VEBA)
      CALL CCMATMUL(FHPBB,T2BB,VEBA,NUB,NOAUAB,NOB,0,0)
       CALL WRTAB(NUB,NUA,NUB,NOA,VEBA,18,NFT892)
C
       CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,9,NFT892)
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
      CALL CCMATMUL(FHPAA,T2AB,VEAB,NUA,NOBUAB,NOA,0,0)
       CALL WRTAB(NUA,NUA,NUB,NOB,VEAB,17,NFT892)
C
C       call rdtab(nua,nub,noa,nub,veba21,10,nft892)
C        call transnqn(nuab,noaub,veba21,ti)
C      call tran1to4(noa,nub,nua,nub,ti,veba21)
C      call ccmatmul(fhpbb,t2bb,veba21,nub,noauab,nob,0,0)
C
      CALL VECCOP(NO2U2AB,VHPLAB,T2AB)
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPLAB,13)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,VHPLAB,12)
         CALL RDTAB(NUA,NUA,NUA,NOA,VEAA,15,NFT892)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,23)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,13)
         CALL WRTAB(NUA,NUA,NUA,NOA,VEAA,15,NFT892)
C
C      write(6,*) 'start of l3_aab'
C      call flshbf(6)
C
C
      CALL LAMB23_LOOP_AAB_IO(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *T1AA,T1BB,VHPLAB,T2AA,T2BB,T2AB,XL2AA,XL2BB,XL2AB,VHPRAB,
     *VHPRAA,VHPRBB,XM3,XL3,TI,VMAA,VMBB,VMBA,VMAB,
     *VMBA21,VMAB21,VEAA,VEBA,VEAB,
     *FHHA,FHHB,FPPA,FPPB,X1AA,X1AB,X2AA,X2AB,X3AA,X3AB,
     *X3BA,X3BB,X4AAA,X4AAB,X4BBA,X5AAA,X5AAB,X5BBA,
     *EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of l3_aab'
C      call flshbf(6)
C
C
Cc L3_abb   cccccccccccccccccccccccc
C
         CALL RDTAB(NOB,NUB,NUB,NOB,XL2AA,9,NFT825)
      CALL VECCOP(NOB2UB2,XL2AB,XL2AA)
C
Cc       call rdtab(nob,nub,nub,nub,veaa,12,nft892)
Cc      call tran14(nob,nub,nub,nub,vebb,veaa)
Cc       call wrtab(nub,nub,nub,nob,veaa,19,nft892)
C
         CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
        CALL TRANSNQN(NOB2,NOBUB,VMAA,VMBB)
      CALL INSITU(NOB,NUA,NUB,NOA,TI,XL2BB,13)
      CALL INSITU(NUB,NUA,NOB,NOA,TI,XL2BB,12)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,XL2AB,13)
C
Ccc       call rdtab(nua,nub,nua,nob,veab,13,nft892)
Ccc      call tranmd(veab,nua,nub,nua,nob,13)
C
Cc       call rdtab(nub,nua,nub,noa,veba,16,nft892)
Cc      call insitu(nub,nua,nub,noa,ti,veba,23)
Cc      call insitu(nub,nub,nua,noa,ti,veba,13)
Cc       call wrtab(nua,nub,nub,noa,veba,16,nft892)
C
      CALL RDINT(1,NOBUB,NOBUB,VHPRAA,NFT830)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPRAA,23)
C
C     ---------------M3--------------
C
         CALL RDTAB(NOB,NUB,NUB,NOB,T2AA,4,NFT825)
      CALL VECCOP(NOB2UB2,T2AB,T2AA)
C
         CALL RDTAB(NOB,NOB,NOB,NUB,VMBB,11,NFT891)
        CALL TRANSNQN(NOB2,NOBUB,VMBB,VEAA)
       CALL RDTAB(NUB,NUB,NUB,NOB,VEAA,8,NFT892)
      CALL TRANMD(VEAA,NUB,NUB,NUB,NOB,13)
      CALL TRANMD(VEAA,NUB,NUB,NUB,NOB,23)
      CALL CCMATMUL(FHPBB,T2AA,VEAA,NUB,NOBUB2,NOB,0,0)
       CALL WRTAB(NUB,NUB,NUB,NOB,VEAA,15,NFT892)
C
C         call rdtab(nob,nob,nob,nub,vmbb,11,nft891)
C        call transnqn(nob2,nobub,vmbb,ti)
      CALL INSITU(NOB,NUA,NUB,NOA,TI,T2BB,13)
      CALL INSITU(NUB,NUA,NOB,NOA,TI,T2BB,12)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,T2AB,13)
C
C
      CALL INSITU(NUA,NUA,NUB,NOB,TI,VEAB,23)
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13)
       CALL WRTAB(NUA,NUB,NUA,NOB,VEAB,17,NFT892)
C
C       call rdtab(nub,nua,nub,noa,veba21,18,nft892)
      CALL INSITU(NUB,NUA,NUB,NOA,TI,VEBA,23)
      CALL INSITU(NUB,NUB,NUA,NOA,TI,VEBA,13)
       CALL WRTAB(NUA,NUB,NUB,NOA,VEBA,18,NFT892)
C
C for L3
C
       CALL RDTAB(NOB,NUB,NUB,NUB,VEAA,12,NFT892)
      CALL TRAN14(NOB,NUB,NUB,NUB,VEBA,VEAA)
       CALL WRTAB(NUB,NUB,NUB,NOB,VEAA,19,NFT892)
C
       CALL RDTAB(NUB,NUA,NUB,NOA,VEBA,16,NFT892)
      CALL INSITU(NUB,NUA,NUB,NOA,TI,VEBA,23)
      CALL INSITU(NUB,NUB,NUA,NOA,TI,VEBA,13)
       CALL WRTAB(NUA,NUB,NUB,NOA,VEBA,16,NFT892)
C
C      write(6,*) 'start of l3_abb'
C      call flshbf(6)
C
      CALL LAMB23_LOOP_ABB_IO(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *T1AA,T1BB,VHPLAB,T2AA,T2BB,T2AB,XL2AA,XL2BB,XL2AB,VHPRAB,
     *VHPRAA,VHPRBB,XM3,XL3,TI,VMAA,VMBB,VMBA,VMAB,
     *VMBA21,VMAB21,VEAA,VEBA,VEAB,
     *FHHA,FHHB,FPPA,FPPB,X1BB,X1AB,X2BB,X2AB,X3AA,X3AB,
     *X3BA,X3BB,X4BBB,X4AAB,X4BBA,X5BBB,X5AAB,X5BBA,
     *EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of l3_abb'
C      call flshbf(6)
C
Cc L3_bbb  cccccccccccccccccccc
C
       CALL RDTAB(NUB,NUB,NUB,NOB,VEAB,19,NFT892)
Cc       call rdtab(nub,nub,nub,nob,vebb,15,nft892)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,XL2AA,13)
C
C     ---------M3-----------
      CALL INSITU(NOB,NUB,NUB,NOB,TI,T2AA,13)
C
C      write(6,*) 'start of l3_b'
C      call flshbf(6)
C
      CALL LAMB23_LOOP(NOB,NUB,FHPBB,T1BB,
     *VHPRAA,XL2AA,T2AA,VEAB,VEAA,XM3,XL3,TI,VMAA,VMBB,
     *FHHB,FPPB,X1BB,X2BB,X3BB,X4BBB,X5BBB,EHB,EPB,
     *CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of l3_b'
C      call flshbf(6)
C
      WRITE(6,94)
      ENGCC=ENRG+EREF
C
      CR='A'
      WRITE(6,95) CR,CORA,ENGCC+CORA
      CR='B'
      WRITE(6,95) CR,CORB,ENGCC+CORB
      CR='C'
      WRITE(6,95) CR,CORC,ENGCC+CORC
      CR='D'
      WRITE(6,95) CR,CORD,ENGCC+CORD
C
      WRITE(6,96)
      WRITE(6,97) ENGCC,ENRG,ENGCC+CORA,ENRG+CORA,ENGCC+CORD,ENRG+CORD
      WRITE(6,98)
C
C       save total correlation: ccsd plus best triples correlation
C       Although type -D- is considered the best energy, it is not
C       invariant to rotations of degenerate orbitals, whereas the
C       type -A- energy is.  Hence the type -A- value is returned.
C
      ENRG = ENRG + CORA
      RETURN
C
   94 FORMAT(/1X,'MAIN RESULTS: CR-CC(2,3) = CR-CC(2,3),D =',
     *           ' CR-CCSD(T)_L CALCULATIONS'/)
   95 FORMAT(1X,'GROUND STATE CR-CC(2,3),',A1,1X,'CORRECTION',F10.6,
     *       ', TOTAL E=',F20.10)
   96 FORMAT(/
     * 1X,'CR-CC(2,3),A ENERGY IS IDENTICAL TO THE CCSD(2)_T ENERGY.'/
     * 1X,'CR-CC(2,3),D ENERGY IS IDENTICAL TO COMPLETE CR-CC(2,3)',
     *    ' ENERGY (CR-CCSD(T)_L)')
   97 FORMAT(/15X,'SUMMARY OF CR-CC(2,3) OR CR-CCSD(T)_L CALCULATIONS'/
     *  1X,'CCSD',23X,'E=',F20.10,3X,'CORR. E=',F15.10/
     *  1X,'CR-CC(2,3),A OR CCSD(2)_T  E=',F20.10,3X,'CORR. E=',F15.10/
     *  1X,'CR-CC(2,3) OR CR-CCSD(T)_L E=',F20.10,3X,'CORR. E=',F15.10)
   98 FORMAT(/1X,'THE MOST ACCURATE ENERGETICS IS PROVIDED BY',
     *           ' CR-CC(2,3) = CR-CC(2,3),D')
      END
C
C*MODULE ROHFCC  *DECK LAMB23
      SUBROUTINE LAMB23(NOA,NUA,NOB,NUB,T1AA,T1BB,
     *XL2AA,XL2BB,XL2AB,VHPLAB,T2AA,T2BB,T2AB,VEAA,VEBB,VEAB,VEBA,
     *VEAB21,VEBA21,FHPAA,FHPBB,VHPRAA,VHPRBB,XM3,XL3,VHPRAB,TI,
     *VMAB,VMBA,VMAA,VMBB,VMAB21,VMBA21,FHHA,FHHB,FPPA,FPPB,X1AA,X1BB,
     *X1AB,X2AA,X2BB,X2AB,X3AA,X3BB,X3AB,X3BA,X4AAA,X4AAB,X4BBA,X4BBB,
     *X5AAA,X5AAB,X5BBA,X5BBB,VHHHH,EHA,EPA,EHB,EPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER CR
C
      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
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION TI(1),XM3(1),T1AA(1),T1BB(1),XL2AA(1),XL2BB(1),XL3(1),
     *          VHPLAB(1),T2AA(1),T2AB(1),T2BB(1),FHPBB(1),VHPRBB(1),
     *          VEAA(1),VEBB(1),VEAB(1),VHPRAA(1),VHPRAB(1),XL2AB(1),
     *          VMBA(1),VMAB(1),VMAA(1),VMBB(1),FHPAA(1),VEBA(1),
     *          VMBA21(1),VMAB21(1),VEAB21(1),VEBA21(1),VHHHH(1),
     *          X1AA(1),X1BB(1),X1AB(1),
     *          X2AA(1),X2BB(1),X2AB(1),
     *          X3AA(1),X3BB(1),X3AB(1),X3BA(1),
     *          X4AAA(1),X4AAB(1),X4BBA(1),X4BBB(1),
     *          X5AAA(1),X5AAB(1),X5BBA(1),X5BBB(1),
     *          FPPA(1),FPPB(1),FHHA(1),FHHB(1),
     *          EHA(NOA),EPA(NUA),EHB(NOB),EPB(NUB)
C
      CALL DENMAKE(NOA,NUA,NOB,NUB,VHHHH,XM3,VHPRAB,T2AB,X1AA,
     *             X1BB,X1AB,X2AA,X2BB,X2AB,X3AA,X3BB,X3AB,X3BA,
     *             X4AAA,X4AAB,X4BBA,X4BBB,X5AAA,X5AAB,X5BBA,X5BBB)
C
      CALL RDTAB2(NOA,NOA,FHHA,3,NFT891)
      CALL RDTAB2(NOB,NUB,FHHB,4,NFT891)
      CALL RDTAB2(NUA,NUA,FPPA,1,NFT891)
      CALL RDTAB2(NUB,NUB,FPPB,2,NFT891)
      CORA=0.00D+00
      CORB=0.00D+00
      CORC=0.00D+00
      CORD=0.00D+00
C
Cc L3_aaa  cccccccccccccccccccc
C
         CALL RDTAB(NOA,NUA,NUA,NOA,XL2AA,8,NFT825) !L2AA
       CALL RDTAB(NOA,NUA,NUA,NUA,VEAA,11,NFT892)
      CALL TRAN14(NOA,NUA,NUA,NUA,VEBB,VEAA)
      CALL RDTAB2(NOA,NUA,FHPAA,5,NFT891)
        CALL TRANSNQN(NOA,NUA,FHPAA,TI)
C
         CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
        CALL TRANSNQN(NOA2,NOAUA,VMAA,VMBB)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,XL2AA,13)
C
      CALL RDTAB2(NOA,NUA,T1AA,6,NFT825)  !L1
        CALL TRANSNQN(NOA,NUA,T1AA,TI)
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPRAA,23)
C
Cc ----------- M(2,3) ----------------
C
         CALL RDTAB(NOA,NUA,NUA,NOA,T2AA,3,NFT825)
       CALL RDTAB(NUA,NUA,NUA,NOA,VEBB,7,NFT892)
      CALL TRANMD(VEBB,NUA,NUA,NUA,NOA,13)
      CALL TRANMD(VEBB,NUA,NUA,NUA,NOA,23)
      CALL CCMATMUL(FHPAA,T2AA,VEBB,NUA,NOAUA2,NOA,0,0)
C
         CALL RDTAB(NOA,NOA,NOA,NUA,VMBB,10,NFT891)
        CALL TRANSNQN(NOA2,NOAUA,VMBB,VMAB)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,T2AA,13)
Cc ---------------
C
C      write(6,*) 'start of l3_a'
C      call flshbf(6)
C
      CALL LAMB23_LOOP(NOA,NUA,FHPAA,T1AA,
     *VHPRAA,XL2AA,T2AA,VEAA,VEBB,XM3,XL3,TI,VMAA,VMBB,
     *FHHA,FPPA,X1AA,X2AA,X3AA,X4AAA,X5AAA,EHA,EPA,
     *CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of l3_a'
C      call flshbf(6)
C
C
Cc L3_aab   cccccccccccccccccccccccc
C
      CALL INSITU(NOA,NUA,NOA,NOA,TI,VMAA,12)
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAB,16,NFT891)
        CALL TRANSNQN(NOAB,NOAUB,VMAB,VMBA)
         CALL RDTAB(NOA,NOB,NUA,NOB,VMBA,17,NFT891)
        CALL TRANSNQN(NOAB,NOBUA,VMBA,VMAB21)
         CALL RDTAB(NOA,NUA,NUB,NOB,XL2AB,10,NFT825)  !L2AB
      CALL VECCOP(NO2U2AB,XL2BB,XL2AB)
      CALL VECCOP(NO2U2AB,VHPRAB,XL2AB)
      CALL TRAN14(NOA,NUA,NUB,NOB,T2AB,XL2BB)
C
       CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,13,NFT892)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
C
       CALL RDTAB(NOA,NUB,NUA,NUB,VEBA,14,NFT892)
      CALL TRAN1TO4(NOA,NUB,NUA,NUB,VEAB21,VEBA)
      CALL TRANMD(VEBA,NUB,NUA,NUB,NOA,13)
      CALL RDTAB2(NOB,NUB,FHPBB,6,NFT891)
        CALL TRANSNQN(NOB,NUB,FHPBB,TI)
C
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPRAB,13)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,VHPRAB,12)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,23)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,13)
C
      CALL RDTAB2(NOB,NUB,T1BB,7,NFT825)  !L1
        CALL TRANSNQN(NOB,NUB,T1BB,TI)
      CALL RDINT(1,NOBUB,NOAUA,VHPRBB,NFT833)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPRBB,23)
C
C ---------------M3----------------
C
      CALL INSITU(NOA,NUA,NOA,NOA,TI,VMBB,12)
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAB21,12,NFT891)
        CALL TRANSNQN(NOAB,NOAUB,VMAB21,VMBA21)
         CALL RDTAB(NOA,NOB,NUA,NOB,VMBA21,13,NFT891)
        CALL TRANSNQN(NOAB,NOBUA,VMBA21,T2AB)
         CALL RDTAB(NOA,NUA,NUB,NOB,T2AB,5,NFT825)
      CALL VECCOP(NO2U2AB,T2BB,T2AB)
C
      CALL TRAN14(NOA,NUA,NUB,NOB,VHPLAB,T2BB)
C
       CALL RDTAB(NUA,NUB,NOA,NUB,VEBA21,10,NFT892)
        CALL TRANSNQN(NUAB,NOAUB,VEBA21,VEAB21)
      CALL TRAN1TO4(NOA,NUB,NUA,NUB,VEAB21,VEBA21)
      CALL CCMATMUL(FHPBB,T2BB,VEBA21,NUB,NOAUAB,NOB,0,0)
C
       CALL RDTAB(NUA,NUB,NUA,NOB,VEAB21,9,NFT892)
      CALL TRANMD(VEAB21,NUA,NUB,NUA,NOB,13)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB21,23)
      CALL CCMATMUL(FHPAA,T2AB,VEAB21,NUA,NOBUAB,NOA,0,0)
C
C       call rdtab(nua,nub,noa,nub,veba21,10,nft892)
C        call transnqn(nuab,noaub,veba21,ti)
C      call tran1to4(noa,nub,nua,nub,ti,veba21)
C      call ccmatmul(fhpbb,t2bb,veba21,nub,noauab,nob,0,0)
C
      CALL VECCOP(NO2U2AB,VHPLAB,T2AB)
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPLAB,13)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,VHPLAB,12)
      CALL TRANMD(VEBB,NUA,NUA,NUA,NOA,23)
      CALL TRANMD(VEBB,NUA,NUA,NUA,NOA,13)
C
C      write(6,*) 'start of l3_aab'
C      call flshbf(6)
C
      CALL LAMB23_LOOP_AAB(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *T1AA,T1BB,VHPLAB,T2AA,T2BB,T2AB,XL2AA,XL2BB,XL2AB,VHPRAB,
     *VHPRAA,VHPRBB,XM3,XL3,TI,VMAA,VMBB,VMBA,VMAB,
     *VMBA21,VMAB21,VEAA,VEBB,VEBA,VEAB,VEBA21,VEAB21,
     *FHHA,FHHB,FPPA,FPPB,X1AA,X1AB,X2AA,X2AB,X3AA,X3AB,
     *X3BA,X3BB,X4AAA,X4AAB,X4BBA,X5AAA,X5AAB,X5BBA,
     *EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of l3_aab'
C      call flshbf(6)
C
C
Cc L3_abb   cccccccccccccccccccccccc
C
         CALL RDTAB(NOB,NUB,NUB,NOB,XL2AA,9,NFT825)
      CALL VECCOP(NOB2UB2,XL2AB,XL2AA)
C
       CALL RDTAB(NOB,NUB,NUB,NUB,VEAA,12,NFT892)
      CALL TRAN14(NOB,NUB,NUB,NUB,VEBB,VEAA)
C
         CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
        CALL TRANSNQN(NOB2,NOBUB,VMAA,VMBB)
      CALL INSITU(NOB,NUA,NUB,NOA,TI,XL2BB,13)
      CALL INSITU(NUB,NUA,NOB,NOA,TI,XL2BB,12)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,XL2AB,13)
C
      CALL INSITU(NUA,NUA,NUB,NOB,TI,VEAB,23)
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13)
      CALL INSITU(NUB,NUA,NUB,NOA,TI,VEBA,23)
      CALL INSITU(NUB,NUB,NUA,NOA,TI,VEBA,13)
C
      CALL RDINT(1,NOBUB,NOBUB,VHPRAA,NFT830)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPRAA,23)
C
C     ---------------M3--------------
C
         CALL RDTAB(NOB,NUB,NUB,NOB,T2AA,4,NFT825)
      CALL VECCOP(NOB2UB2,T2AB,T2AA)
C
         CALL RDTAB(NOB,NOB,NOB,NUB,VMBB,11,NFT891)
        CALL TRANSNQN(NOB2,NOBUB,VMBB,VEBB)
       CALL RDTAB(NUB,NUB,NUB,NOB,VEBB,8,NFT892)
      CALL TRANMD(VEBB,NUB,NUB,NUB,NOB,13)
      CALL TRANMD(VEBB,NUB,NUB,NUB,NOB,23)
      CALL CCMATMUL(FHPBB,T2AA,VEBB,NUB,NOBUB2,NOB,0,0)
C
C         call rdtab(nob,nob,nob,nub,vmbb,11,nft891)
C        call transnqn(nob2,nobub,vmbb,ti)
      CALL INSITU(NOB,NUA,NUB,NOA,TI,T2BB,13)
      CALL INSITU(NUB,NUA,NOB,NOA,TI,T2BB,12)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,T2AB,13)
C
      CALL INSITU(NUA,NUA,NUB,NOB,TI,VEAB21,23)
      CALL TRANMD(VEAB21,NUA,NUB,NUA,NOB,13)
      CALL INSITU(NUB,NUA,NUB,NOA,TI,VEBA21,23)
      CALL INSITU(NUB,NUB,NUA,NOA,TI,VEBA21,13)
C
C      write(6,*) 'start of l3_abb'
C      call flshbf(6)
C
      CALL LAMB23_LOOP_ABB(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *T1AA,T1BB,VHPLAB,T2AA,T2BB,T2AB,XL2AA,XL2BB,XL2AB,VHPRAB,
     *VHPRAA,VHPRBB,XM3,XL3,TI,VMAA,VMBB,VMBA,VMAB,
     *VMBA21,VMAB21,VEAA,VEBB,VEBA,VEAB,VEBA21,VEAB21,
     *FHHA,FHHB,FPPA,FPPB,X1BB,X1AB,X2BB,X2AB,X3AA,X3AB,
     *X3BA,X3BB,X4BBB,X4AAB,X4BBA,X5BBB,X5AAB,X5BBA,
     *EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of l3_abb'
C      call flshbf(6)
C
C
Cc L3_bbb  cccccccccccccccccccc
C
      CALL INSITU(NOB,NUB,NUB,NOB,TI,XL2AA,13)
C
C     ---------M3-----------
      CALL INSITU(NOB,NUB,NUB,NOB,TI,T2AA,13)
C
C      write(6,*) 'start of l3_b'
C      call flshbf(6)
C
      CALL LAMB23_LOOP(NOB,NUB,FHPBB,T1BB,
     *VHPRAA,XL2AA,T2AA,VEAA,VEBB,XM3,XL3,TI,VMAA,VMBB,
     *FHHB,FPPB,X1BB,X2BB,X3BB,X4BBB,X5BBB,EHB,EPB,
     *CORA,CORB,CORC,CORD)
C
C      write(6,*) 'end of l3_b'
C      call flshbf(6)
C
      WRITE(6,94)
      ENGCC=ENRG+EREF
C
      CR='A'
      WRITE(6,95) CR,CORA,ENGCC+CORA
      CR='B'
      WRITE(6,95) CR,CORB,ENGCC+CORB
      CR='C'
      WRITE(6,95) CR,CORC,ENGCC+CORC
      CR='D'
      WRITE(6,95) CR,CORD,ENGCC+CORD
C
      WRITE(6,96)
      WRITE(6,97) ENGCC,ENRG,ENGCC+CORA,ENRG+CORA,ENGCC+CORD,ENRG+CORD
      WRITE(6,98)
C
C       save total correlation: ccsd plus best triples correlation
C       Although type -D- is considered the best energy, it is not
C       invariant to rotations of degenerate orbitals, whereas the
C       type -A- energy is.  Hence the type -A- value is returned.
C
      ENRG = ENRG + CORA
      RETURN
C
   94 FORMAT(/1X,'MAIN RESULTS: CR-CC(2,3) = CR-CC(2,3),D =',
     *           ' CR-CCSD(T)_L CALCULATIONS'/)
   95 FORMAT(1X,'GROUND STATE CR-CC(2,3),',A1,1X,'CORRECTION',F10.6,
     *       ', TOTAL E=',F20.10)
   96 FORMAT(/
     * 1X,'CR-CC(2,3),A ENERGY IS IDENTICAL TO THE CCSD(2)_T ENERGY.'/
     * 1X,'CR-CC(2,3),D ENERGY IS IDENTICAL TO COMPLETE CR-CC(2,3)',
     *    ' ENERGY (CR-CCSD(T)_L)')
   97 FORMAT(/15X,'SUMMARY OF CR-CC(2,3) OR CR-CCSD(T)_L CALCULATIONS'/
     *  1X,'CCSD',23X,'E=',F20.10,3X,'CORR. E=',F15.10/
     *  1X,'CR-CC(2,3),A OR CCSD(2)_T  E=',F20.10,3X,'CORR. E=',F15.10/
     *  1X,'CR-CC(2,3) OR CR-CCSD(T)_L E=',F20.10,3X,'CORR. E=',F15.10)
   98 FORMAT(/1X,'THE MOST ACCURATE ENERGETICS IS PROVIDED BY',
     *           ' CR-CC(2,3) = CR-CC(2,3),D')
      END
C
C*MODULE ROHFCC  *DECK LAMB23_LOOP
      SUBROUTINE LAMB23_LOOP(NO,NU,FHP,T1,
     *                       VHPR,XL2,T2,VE,VE21,XM3,XL3,TI,VM,VM21,
     *                       FHH,FPP,X1,X2,X3,X4,X5,EH,EP,
     *                       CORA,CORB,CORC,CORD)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(1),XM3(NU,NU,NU),T2(NU,NU,NO,NO),
     *          XL3(NU,NU,NU),XL2(NU,NU,NO,NO),
     *          VE(NU,NU,NU,NO),VE21(NU,NU,NU,NO),
     *          VM(NO,NU,NO,NO),VM21(NO,NU,NO,NO),FHP(NU,NO),
     *          VHPR(NU,NU,NO,NO),T1(NU,NO),EH(NO),EP(NU),
     *          FHH(NO,NO),FPP(NU,NU),X1(NO,NO),
     *          X2(NU,NU),X3(NU,NO),X4(NO,NU,NU),X5(NU,NO,NO)
      DATA HALF/0.5D+0/
C
      NU2=NU*NU
      NU3=NU*NU*NU
C
      DO 131 I=1, NO-2
       DO 132 J=I+1, NO-1
        DO 133 K=J+1, NO
C
      CALL ZEROMA(XL3,1,NU3)
C
      CALL CCMATMUL(VHPR(1,1,I,J),T1(1,K),XL3,NU2,NU,1,0,0)
      CALL CCMATMUL(VHPR(1,1,I,K),T1(1,J),XL3,NU2,NU,1,0,1)
      CALL CCMATMUL(VHPR(1,1,K,J),T1(1,I),XL3,NU2,NU,1,0,1)
C
      CALL CCMATMUL(XL2(1,1,J,I),FHP(1,K),XL3,NU2,NU,1,0,0)
      CALL CCMATMUL(XL2(1,1,K,I),FHP(1,J),XL3,NU2,NU,1,0,1)
      CALL CCMATMUL(XL2(1,1,J,K),FHP(1,I),XL3,NU2,NU,1,0,1)
C
      CALL CCMATMUL(XL2(1,1,1,I),VM(1,1,J,K),XL3,NU2,NU,NO,0,1)
      CALL CCMATMUL(XL2(1,1,1,J),VM(1,1,I,K),XL3,NU2,NU,NO,0,0)
      CALL CCMATMUL(XL2(1,1,1,K),VM(1,1,J,I),XL3,NU2,NU,NO,0,0)
C
      CALL CCMATMUL(XL2(1,1,J,I),VE(1,1,1,K),XL3,NU,NU2,NU,0,0)
      CALL CCMATMUL(XL2(1,1,K,I),VE(1,1,1,J),XL3,NU,NU2,NU,0,1)
      CALL CCMATMUL(XL2(1,1,J,K),VE(1,1,1,I),XL3,NU,NU2,NU,0,1)
C --------M3---------
      CALL ZEROMA(XM3,1,NU3)
C
      CALL CCMATMUL(T2(1,1,1,I),VM21(1,1,J,K),XM3,NU2,NU,NO,0,1)
      CALL CCMATMUL(T2(1,1,1,J),VM21(1,1,I,K),XM3,NU2,NU,NO,0,0)
      CALL CCMATMUL(T2(1,1,1,K),VM21(1,1,J,I),XM3,NU2,NU,NO,0,0)
C
      CALL CCMATMUL(T2(1,1,J,I),VE21(1,1,1,K),XM3,NU,NU2,NU,0,0)
      CALL CCMATMUL(T2(1,1,K,I),VE21(1,1,1,J),XM3,NU,NU2,NU,0,1)
      CALL CCMATMUL(T2(1,1,J,K),VE21(1,1,1,I),XM3,NU,NU2,NU,0,1)
C
C
      CALL VECMUL(XL3,NU3,HALF)
      CALL VECMUL(XM3,NU3,HALF)
C
      CALL PERMFULL(NU,TI,XL3)
      CALL PERMFULL(NU,TI,XM3)
C
C      write(6,*) 'L3'
C      call drukm3(nu,nu,nu,i,j,k,xl3)
C        write(6,*) 'M3'
C      call drukm3(nu,nu,nu,i,j,k,xm3)
      DO 231,IA=1,NU-2
      DO 232,IB=IA+1,NU-1
      DO 233,IC=IB+1,NU
       PA1=-FHH(I,I)-FHH(J,J)-FHH(K,K)
       PA2=FPP(IA,IA)+FPP(IB,IB)+FPP(IC,IC)
       PA3=X1(I,J)+X1(I,K)+X1(J,K)
       PA4=X2(IA,IB)+X2(IA,IC)+X2(IB,IC)
       PA5=-X3(IA,I)-X3(IB,I)-X3(IC,I)
     *     -X3(IA,J)-X3(IB,J)-X3(IC,J)
     *     -X3(IA,K)-X3(IB,K)-X3(IC,K)
       PA6=X4(I,IA,IB)+X4(I,IA,IC)+X4(I,IB,IC)+
     *     X4(J,IA,IB)+X4(J,IA,IC)+X4(J,IB,IC)+
     *     X4(K,IA,IB)+X4(K,IA,IC)+X4(K,IB,IC)
       PA7=-X5(IA,I,J)-X5(IA,I,K)-X5(IA,J,K)
     *     -X5(IB,I,J)-X5(IB,I,K)-X5(IB,J,K)
     *     -X5(IC,I,J)-X5(IC,I,K)-X5(IC,J,K)
      YDENA=-EP(IA)-EP(IB)-EP(IC)+EH(I)+EH(J)+EH(K)
      YDENB=-PA1-PA2
      YDENC=YDENB-PA3-PA4-PA5
      YDEND=YDENC-PA6-PA7
      XNUM=XM3(IA,IB,IC)*XL3(IA,IB,IC)
      CORA=CORA+XNUM/YDENA
      CORB=CORB+XNUM/YDENB
      CORC=CORC+XNUM/YDENC
      CORD=CORD+XNUM/YDEND
 233         CONTINUE
 232         CONTINUE
 231         CONTINUE
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK LAMB23_LOOP_AAB_IO
      SUBROUTINE LAMB23_LOOP_AAB_IO(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *     T1AA,T1BB,T2,T2AA,T2BB,T2AB,XL2AA,XL2BB,XL2AB,VHPRAB,
     *     VHPRAA,VHPRBB,XM3,XL3,TI,VMAA,VMBB,VMBA,VMAB,
     *     VMBA21,VMAB21,VEAA,VEBA,VEAB,
     *     FHHA,FHHB,FPPA,FPPB,X1AA,X1AB,X2AA,X2AB,X3AA,X3AB,
     *     X3BA,X3BB,X4AAA,X4AAB,X4BBA,X5AAA,X5AAB,X5BBA,
     *     EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION TI(1),XM3(NUA,NUA,NUB),XL3(NUA,NUA,NUB),
     *          XL2AA(NUA,NUA,NOA,NOA),T2AA(NUA,NUA,NOA,NOA),
     *          T2BB(NOB,NUA,NUB,NOA),T2AB(NOA,NUA,NUB,NOB),
     *          XL2BB(NOB,NUA,NUB,NOA),XL2AB(NOA,NUA,NUB,NOB),
     *          VMAA(NUA,NOA,NOA,NOA),FHPAA(NUA,NOA),FHPBB(NUB,NOB),
     *          VMAB(NOA,NUB,NOA,NOB),VMBA(NUA,NOB,NOA,NOB),
     *          VHPRAB(NUA,NUB,NOA,NOB),VHPRAA(NUA,NUA,NOA,NOA),
     *          VEAA(NUA,NUA,NUA,NOA),VHPRBB(NUA,NUB,NOA,NOB),
     *          VEAB(NUA,NUA,NUB,NOB),VEBA(NUB,NUA,NUB,NOA),
     *          T1AA(NUA,NOA),T1BB(NUB,NOB),
     *          T2(NUA,NUB,NOA,NOB),
     *          VMBB(NUA,NOA,NOA,NOA),
     *          VMAB21(NOA,NUB,NOA,NOB),VMBA21(NUA,NOB,NOA,NOB),
     *          FHHA(NOA,NOA),FHHB(NOB,NOB),FPPA(NUA,NUA),FPPB(NUB,NUB),
     *          X1AA(NOA,NOA),X1AB(NOA,NOB),X2AA(NUA,NUA),X2AB(NUA,NUB),
     *          X3AA(NUA,NOA),X3AB(NUA,NOB),X3BA(NUB,NOA),X3BB(NUB,NOB),
     *         X4AAA(NOA,NUA,NUA),X4AAB(NOA,NUA,NUB),X4BBA(NOB,NUB,NUA),
     *         X5AAA(NUA,NOA,NOA),X5AAB(NUA,NOA,NOB),X5BBA(NUB,NOB,NOA),
     *          EHA(NOA),EHB(NOB),EPA(NUA),EPB(NOA)
C
      DATA HALF/0.5D+0/
C
      NUA2=NUA*NUA
      NUAB=NUA*NUB
C
      DO 131 I=1, NOA-1
       DO 132 J=I+1, NOA
        DO 133 K=1, NOB
C
      CALL ZEROMA(XM3,1,NUA2*NUB)
      CALL ZEROMA(XL3,1,NUA2*NUB)
C
Ccccccccccccccccccccccccc
C
      CALL CCMATMUL(XL2AA(1,1,1,I),VMAB(1,1,J,K),XL3,NUA2,NUB,NOA,0,1)
      CALL CCMATMUL(XL2AA(1,1,1,J),VMAB(1,1,I,K),XL3,NUA2,NUB,NOA,0,0)
C
C
       CALL RDTAB(NUA,NUA,NUA,NOA,VEAA,19,NFT892)
      CALL CCMATMUL(VEAA(1,1,1,J),VHPRAB(1,1,I,K),XL3,NUA2,NUB,NUA,0,0)
      CALL CCMATMUL(VEAA(1,1,1,I),VHPRAB(1,1,J,K),XL3,NUA2,NUB,NUA,0,1)
C
      CALL CCMATMUL(XL2AA(1,1,J,I),FHPBB(1,K),XL3,NUA2,NUB,1,0,0)
C
      CALL CCMATMUL(VHPRAA(1,1,I,J),T1BB(1,K),XL3,NUA2,NUB,1,0,0)
C
      CALL VECMUL(XL3,NUA2*NUB,HALF)
C
      CALL CCMATMUL(VMBA(1,1,J,K),XL2BB(1,1,1,I),XL3,NUA,NUAB,NOB,0,0)
      CALL CCMATMUL(VMBA(1,1,I,K),XL2BB(1,1,1,J),XL3,NUA,NUAB,NOB,0,1)
C
      CALL CCMATMUL(VMAA(1,1,J,I),XL2AB(1,1,1,K),XL3,NUA,NUAB,NOA,0,1)
C
C
       CALL RDTAB(NUB,NUA,NUB,NOA,VEBA,16,NFT892)
      CALL CCMATMUL(VHPRAB(1,1,I,K),VEBA(1,1,1,J),XL3,NUA,NUAB,NUB,0,0)
      CALL CCMATMUL(VHPRAB(1,1,J,K),VEBA(1,1,1,I),XL3,NUA,NUAB,NUB,0,1)
C
       CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,13,NFT892)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
      CALL CCMATMUL(XL2AA(1,1,J,I),VEAB(1,1,1,K),XL3,NUA,NUAB,NUA,0,0)
C
C
      CALL CCMATMUL(FHPAA(1,I),VHPRAB(1,1,J,K),XL3,NUA,NUAB,1,0,0)
      CALL CCMATMUL(FHPAA(1,J),VHPRAB(1,1,I,K),XL3,NUA,NUAB,1,0,1)
C
      CALL CCMATMUL(T1AA(1,I),VHPRBB(1,1,J,K),XL3,NUA,NUAB,1,0,0)
      CALL CCMATMUL(T1AA(1,J),VHPRBB(1,1,I,K),XL3,NUA,NUAB,1,0,1)
C
Ccccccccc M3 cccccccccccc
C
      CALL CCMATMUL(T2AA(1,1,1,I),VMAB21(1,1,J,K),XM3,NUA2,NUB,NOA,0,1)
      CALL CCMATMUL(T2AA(1,1,1,J),VMAB21(1,1,I,K),XM3,NUA2,NUB,NOA,0,0)
C
C
         CALL RDTAB(NUA,NUA,NUA,NOA,VEAA,15,NFT892)
      CALL CCMATMUL(VEAA(1,1,1,J),T2(1,1,I,K),XM3,NUA2,NUB,NUA,0,0)
      CALL CCMATMUL(VEAA(1,1,1,I),T2(1,1,J,K),XM3,NUA2,NUB,NUA,0,1)
C
      CALL VECMUL(XM3,NUA2*NUB,HALF)
C
      CALL CCMATMUL(VMBA21(1,1,J,K),T2BB(1,1,1,I),XM3,NUA,NUAB,NOB,0,0)
      CALL CCMATMUL(VMBA21(1,1,I,K),T2BB(1,1,1,J),XM3,NUA,NUAB,NOB,0,1)
C
      CALL CCMATMUL(VMBB(1,1,J,I),T2AB(1,1,1,K),XM3,NUA,NUAB,NOA,0,1)
C
C
       CALL RDTAB(NUB,NUA,NUB,NOA,VEBA,18,NFT892)
      CALL CCMATMUL(T2(1,1,I,K),VEBA(1,1,1,J),XM3,NUA,NUAB,NUB,0,0)
      CALL CCMATMUL(T2(1,1,J,K),VEBA(1,1,1,I),XM3,NUA,NUAB,NUB,0,1)
C
       CALL RDTAB(NUA,NUA,NUB,NOB,VEAB,17,NFT892)
      CALL CCMATMUL(T2AA(1,1,J,I),VEAB(1,1,1,K),XM3,NUA,NUAB,NUA,0,0)
C
C
      CALL PERM_AAB(NUA,NUB,TI,XM3)
      CALL PERM_AAB(NUA,NUB,TI,XL3)
C
C        write(6,*) 'M3'
C      call drukm3(nua,nua,nub,i,j,k,xm3)
C        write(6,*) 'L3'
C      call drukm3(nua,nua,nub,i,j,k,xl3)
      DO 231,IA=1,NUA-1
      DO 232,IB=IA+1,NUA
      DO 233,IC=1,NUB
       PA1=-FHHA(I,I)-FHHA(J,J)-FHHB(K,K)
       PA2=FPPA(IA,IA)+FPPA(IB,IB)+FPPB(IC,IC)
       PA3=X1AA(I,J)+X1AB(I,K)+X1AB(J,K)
       PA4=X2AA(IA,IB)+X2AB(IA,IC)+X2AB(IB,IC)
       PA5=-X3AA(IA,I)-X3AA(IB,I)-X3BA(IC,I)
     *     -X3AA(IA,J)-X3AA(IB,J)-X3BA(IC,J)
     *     -X3AB(IA,K)-X3AB(IB,K)-X3BB(IC,K)
       PA6=X4AAA(I,IA,IB)+X4AAB(I,IA,IC)+X4AAB(I,IB,IC)+
     *     X4AAA(J,IA,IB)+X4AAB(J,IA,IC)+X4AAB(J,IB,IC)+
     *     X4BBA(K,IC,IA)+X4BBA(K,IC,IB)
       PA7=-X5AAA(IA,I,J)-X5AAB(IA,I,K)-X5AAB(IA,J,K)
     *     -X5AAA(IB,I,J)-X5AAB(IB,I,K)-X5AAB(IB,J,K)
     *     -X5BBA(IC,K,I)-X5BBA(IC,K,J)
      YDENA=-EPA(IA)-EPA(IB)-EPB(IC)+EHA(I)+EHA(J)+EHB(K)
      YDENB=-PA1-PA2
      YDENC=YDENB-PA3-PA4-PA5
      YDEND=YDENC-PA6-PA7
      XNUM=XM3(IA,IB,IC)*XL3(IA,IB,IC)
      CORA=CORA+XNUM/YDENA
      CORB=CORB+XNUM/YDENB
      CORC=CORC+XNUM/YDENC
      CORD=CORD+XNUM/YDEND
 233         CONTINUE
 232         CONTINUE
 231         CONTINUE
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK LAMB23_LOOP_AAB
      SUBROUTINE LAMB23_LOOP_AAB(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *     T1AA,T1BB,T2,T2AA,T2BB,T2AB,XL2AA,XL2BB,XL2AB,VHPRAB,
     *     VHPRAA,VHPRBB,XM3,XL3,TI,VMAA,VMBB,VMBA,VMAB,
     *     VMBA21,VMAB21,VEAA,VEBB,VEBA,VEAB,VEBA21,VEAB21,
     *     FHHA,FHHB,FPPA,FPPB,X1AA,X1AB,X2AA,X2AB,X3AA,X3AB,
     *     X3BA,X3BB,X4AAA,X4AAB,X4BBA,X5AAA,X5AAB,X5BBA,
     *     EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION TI(1),XM3(NUA,NUA,NUB),XL3(NUA,NUA,NUB),
     *          XL2AA(NUA,NUA,NOA,NOA),T2AA(NUA,NUA,NOA,NOA),
     *          T2BB(NOB,NUA,NUB,NOA),T2AB(NOA,NUA,NUB,NOB),
     *          XL2BB(NOB,NUA,NUB,NOA),XL2AB(NOA,NUA,NUB,NOB),
     *          VMAA(NUA,NOA,NOA,NOA),FHPAA(NUA,NOA),FHPBB(NUB,NOB),
     *          VMAB(NOA,NUB,NOA,NOB),VMBA(NUA,NOB,NOA,NOB),
     *          VHPRAB(NUA,NUB,NOA,NOB),VHPRAA(NUA,NUA,NOA,NOA),
     *          VEAA(NUA,NUA,NUA,NOA),VHPRBB(NUA,NUB,NOA,NOB),
     *          VEAB(NUA,NUA,NUB,NOB),VEBA(NUB,NUA,NUB,NOA),
     *          T1AA(NUA,NOA),T1BB(NUB,NOB),
     *          T2(NUA,NUB,NOA,NOB),VEBB(NUA,NUA,NUA,NOA),
     *          VEAB21(NUA,NUA,NUB,NOB),VEBA21(NUB,NUA,NUB,NOA),
     *          VMBB(NUA,NOA,NOA,NOA),
     *          VMAB21(NOA,NUB,NOA,NOB),VMBA21(NUA,NOB,NOA,NOB)
      DIMENSION FHHA(NOA,NOA),FHHB(NOB,NOB),FPPA(NUA,NUA),FPPB(NUB,NUB),
     *          X1AA(NOA,NOA),X1AB(NOA,NOB),X2AA(NUA,NUA),X2AB(NUA,NUB),
     *          X3AA(NUA,NOA),X3AB(NUA,NOB),X3BA(NUB,NOA),X3BB(NUB,NOB),
     *         X4AAA(NOA,NUA,NUA),X4AAB(NOA,NUA,NUB),X4BBA(NOB,NUB,NUA),
     *         X5AAA(NUA,NOA,NOA),X5AAB(NUA,NOA,NOB),X5BBA(NUB,NOB,NOA),
     *          EHA(NOA),EHB(NOB),EPA(NUA),EPB(NOA)
C
      DATA HALF/0.5D+0/
C
      NUA2=NUA*NUA
      NUAB=NUA*NUB
C
      DO 131 I=1, NOA-1
       DO 132 J=I+1, NOA
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=1, NOB
      CALL ZEROMA(XM3,1,NUA2*NUB)
      CALL ZEROMA(XL3,1,NUA2*NUB)
C
Ccccccccc M3 cccccccccccc
C
      CALL CCMATMUL(T2AA(1,1,1,I),VMAB21(1,1,J,K),XM3,NUA2,NUB,NOA,0,1)
      CALL CCMATMUL(T2AA(1,1,1,J),VMAB21(1,1,I,K),XM3,NUA2,NUB,NOA,0,0)
C
C
      CALL CCMATMUL(VEBB(1,1,1,J),T2(1,1,I,K),XM3,NUA2,NUB,NUA,0,0)
      CALL CCMATMUL(VEBB(1,1,1,I),T2(1,1,J,K),XM3,NUA2,NUB,NUA,0,1)
C
      CALL VECMUL(XM3,NUA2*NUB,HALF)
C
      CALL CCMATMUL(VMBA21(1,1,J,K),T2BB(1,1,1,I),XM3,NUA,NUAB,NOB,0,0)
      CALL CCMATMUL(VMBA21(1,1,I,K),T2BB(1,1,1,J),XM3,NUA,NUAB,NOB,0,1)
C
      CALL CCMATMUL(VMBB(1,1,J,I),T2AB(1,1,1,K),XM3,NUA,NUAB,NOA,0,1)
C
C
      CALL CCMATMUL(T2(1,1,I,K),VEBA21(1,1,1,J),XM3,NUA,NUAB,NUB,0,0)
      CALL CCMATMUL(T2(1,1,J,K),VEBA21(1,1,1,I),XM3,NUA,NUAB,NUB,0,1)
C
      CALL CCMATMUL(T2AA(1,1,J,I),VEAB21(1,1,1,K),XM3,NUA,NUAB,NUA,0,0)
C
Ccccccccccccccccccccccccc
C
      CALL CCMATMUL(XL2AA(1,1,1,I),VMAB(1,1,J,K),XL3,NUA2,NUB,NOA,0,1)
      CALL CCMATMUL(XL2AA(1,1,1,J),VMAB(1,1,I,K),XL3,NUA2,NUB,NOA,0,0)
C
C
      CALL CCMATMUL(VEAA(1,1,1,J),VHPRAB(1,1,I,K),XL3,NUA2,NUB,NUA,0,0)
      CALL CCMATMUL(VEAA(1,1,1,I),VHPRAB(1,1,J,K),XL3,NUA2,NUB,NUA,0,1)
C
      CALL CCMATMUL(XL2AA(1,1,J,I),FHPBB(1,K),XL3,NUA2,NUB,1,0,0)
C
      CALL CCMATMUL(VHPRAA(1,1,I,J),T1BB(1,K),XL3,NUA2,NUB,1,0,0)
C
      CALL VECMUL(XL3,NUA2*NUB,HALF)
C
      CALL CCMATMUL(VMBA(1,1,J,K),XL2BB(1,1,1,I),XL3,NUA,NUAB,NOB,0,0)
      CALL CCMATMUL(VMBA(1,1,I,K),XL2BB(1,1,1,J),XL3,NUA,NUAB,NOB,0,1)
C
      CALL CCMATMUL(VMAA(1,1,J,I),XL2AB(1,1,1,K),XL3,NUA,NUAB,NOA,0,1)
C
C
      CALL CCMATMUL(VHPRAB(1,1,I,K),VEBA(1,1,1,J),XL3,NUA,NUAB,NUB,0,0)
      CALL CCMATMUL(VHPRAB(1,1,J,K),VEBA(1,1,1,I),XL3,NUA,NUAB,NUB,0,1)
C
      CALL CCMATMUL(XL2AA(1,1,J,I),VEAB(1,1,1,K),XL3,NUA,NUAB,NUA,0,0)
C
C
      CALL CCMATMUL(FHPAA(1,I),VHPRAB(1,1,J,K),XL3,NUA,NUAB,1,0,0)
      CALL CCMATMUL(FHPAA(1,J),VHPRAB(1,1,I,K),XL3,NUA,NUAB,1,0,1)
C
      CALL CCMATMUL(T1AA(1,I),VHPRBB(1,1,J,K),XL3,NUA,NUAB,1,0,0)
      CALL CCMATMUL(T1AA(1,J),VHPRBB(1,1,I,K),XL3,NUA,NUAB,1,0,1)
C
C
      CALL PERM_AAB(NUA,NUB,TI,XM3)
      CALL PERM_AAB(NUA,NUB,TI,XL3)
C
C        write(6,*) 'M3'
C      call drukm3(nua,nua,nub,i,j,k,xm3)
C        write(6,*) 'L3'
C      call drukm3(nua,nua,nub,i,j,k,xl3)
      DO 231,IA=1,NUA-1
      DO 232,IB=IA+1,NUA
      DO 233,IC=1,NUB
       PA1=-FHHA(I,I)-FHHA(J,J)-FHHB(K,K)
       PA2=FPPA(IA,IA)+FPPA(IB,IB)+FPPB(IC,IC)
       PA3=X1AA(I,J)+X1AB(I,K)+X1AB(J,K)
       PA4=X2AA(IA,IB)+X2AB(IA,IC)+X2AB(IB,IC)
       PA5=-X3AA(IA,I)-X3AA(IB,I)-X3BA(IC,I)
     *     -X3AA(IA,J)-X3AA(IB,J)-X3BA(IC,J)
     *     -X3AB(IA,K)-X3AB(IB,K)-X3BB(IC,K)
       PA6=X4AAA(I,IA,IB)+X4AAB(I,IA,IC)+X4AAB(I,IB,IC)+
     *     X4AAA(J,IA,IB)+X4AAB(J,IA,IC)+X4AAB(J,IB,IC)+
     *     X4BBA(K,IC,IA)+X4BBA(K,IC,IB)
       PA7=-X5AAA(IA,I,J)-X5AAB(IA,I,K)-X5AAB(IA,J,K)
     *     -X5AAA(IB,I,J)-X5AAB(IB,I,K)-X5AAB(IB,J,K)
     *     -X5BBA(IC,K,I)-X5BBA(IC,K,J)
      YDENA=-EPA(IA)-EPA(IB)-EPB(IC)+EHA(I)+EHA(J)+EHB(K)
      YDENB=-PA1-PA2
      YDENC=YDENB-PA3-PA4-PA5
      YDEND=YDENC-PA6-PA7
      XNUM=XM3(IA,IB,IC)*XL3(IA,IB,IC)
      CORA=CORA+XNUM/YDENA
      CORB=CORB+XNUM/YDENB
      CORC=CORC+XNUM/YDENC
      CORD=CORD+XNUM/YDEND
 233         CONTINUE
 232         CONTINUE
 231         CONTINUE
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK LAMB23_LOOP_ABB_IO
      SUBROUTINE LAMB23_LOOP_ABB_IO(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *     T1AA,T1BB,T2,T2AA,T2BB,T2AB,XL2AA,XL2BB,XL2AB,VHPRAB,
     *     VHPRAA,VHPRBB,XM3,XL3,TI,VMAA,VMBB,VMBA,VMAB,
     *     VMBA21,VMAB21,VEAA,VEBA,VEAB,
     *     FHHA,FHHB,FPPA,FPPB,X1BB,X1AB,X2BB,X2AB,X3AA,X3AB,
     *     X3BA,X3BB,X4BBB,X4AAB,X4BBA,X5BBB,X5AAB,X5BBA,
     *     EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION TI(1),XL3(NUA,NUB,NUB),XM3(NUA,NUB,NUB),
     *          XL2AA(NOB,NUB,NUB,NOB),T2AA(NOB,NUB,NUB,NOB),
     *          T2BB(NUA,NUB,NOB,NOA),T2(NUA,NUB,NOA,NOB),
     *          VMBB(NOB,NUB,NOB,NOB),T2AB(NUB,NUB,NOB,NOB),
     *          VMAB21(NUB,NOA,NOA,NOB),VMBA21(NUA,NOB,NOA,NOB),
     *          XL2BB(NUA,NUB,NOB,NOA),VHPRAB(NUA,NUB,NOA,NOB),
     *          VMAA(NOB,NUB,NOB,NOB),XL2AB(NUB,NUB,NOB,NOB),
     *          VMAB(NUB,NOA,NOA,NOB),VMBA(NUA,NOB,NOA,NOB),
     *          VEAA(NUB,NUB,NUB,NOB),VHPRAA(NUB,NUB,NOB,NOB),
     *          FHPAA(NUA,NOA),FHPBB(NUB,NOB),
     *          T1AA(NUA,NOA),T1BB(NUB,NOB),VHPRBB(NUA,NUB,NOA,NOB),
     *          VEAB(NUA,NUB,NUA,NOB),VEBA(NUA,NUB,NUB,NOA),
     *          FHHA(NOA,NOA),FHHB(NOB,NOB),FPPA(NUA,NUA),FPPB(NUB,NUB),
     *          X1BB(NOB,NOB),X1AB(NOA,NOB),X2BB(NUB,NUB),X2AB(NUA,NUB),
     *          X3AA(NUA,NOA),X3AB(NUA,NOB),X3BA(NUB,NOA),X3BB(NUB,NOB),
     *         X4BBB(NOB,NUB,NUB),X4AAB(NOA,NUA,NUB),X4BBA(NOB,NUB,NUA),
     *         X5BBB(NUB,NOB,NOB),X5AAB(NUA,NOA,NOB),X5BBA(NUB,NOB,NOA),
     *          EHA(NOA),EHB(NOB),EPA(NUA),EPB(NOA)
C
      DATA HALF/0.5D+0/
C
      NUB2=NUB*NUB
      NUAB=NUA*NUB
C
      DO 131 I=1, NOA
       DO 132 J=1, NOB-1
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=J+1, NOB
      CALL ZEROMA(XL3,1,NUA*NUB2)
      CALL ZEROMA(XM3,1,NUA*NUB2)
C
      CALL CCMATMUL(VMBA(1,1,I,J),XL2AA(1,1,1,K),XL3,NUA,NUB2,NOB,0,1)
      CALL CCMATMUL(VMBA(1,1,I,K),XL2AA(1,1,1,J),XL3,NUA,NUB2,NOB,0,0)
C
      CALL RDTAB(NUB,NUB,NUB,NOB,VEAA,19,NFT892)
      CALL CCMATMUL(VHPRAB(1,1,I,J),VEAA(1,1,1,K),XL3,NUA,NUB2,NUB,0,0)
      CALL CCMATMUL(VHPRAB(1,1,I,K),VEAA(1,1,1,J),XL3,NUA,NUB2,NUB,0,1)
C
      CALL CCMATMUL(FHPAA(1,I),XL2AB(1,1,K,J),XL3,NUA,NUB2,1,0,0)
C
      CALL CCMATMUL(T1AA(1,I),VHPRAA(1,1,J,K),XL3,NUA,NUB2,1,0,0)
C
      CALL VECMUL(XL3,NUA*NUB2,HALF)
C
      CALL CCMATMUL(VHPRAB(1,1,1,J),VMAB(1,1,I,K),XL3,NUAB,NUB,NOA,0,1)
      CALL CCMATMUL(VHPRAB(1,1,1,K),VMAB(1,1,I,J),XL3,NUAB,NUB,NOA,0,0)
C
      CALL CCMATMUL(XL2BB(1,1,1,I),VMAA(1,1,J,K),XL3,NUAB,NUB,NOB,0,1)
C
       CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,13,NFT892)
      CALL TRANMD(VEAB,NUA,NUB,NUA,NOB,13)
      CALL CCMATMUL(VEAB(1,1,1,J),VHPRAB(1,1,I,K),XL3,NUAB,NUB,NUA,0,0)
      CALL CCMATMUL(VEAB(1,1,1,K),VHPRAB(1,1,I,J),XL3,NUAB,NUB,NUA,0,1)
C
       CALL RDTAB(NUA,NUB,NUB,NOA,VEBA,16,NFT892)
      CALL CCMATMUL(VEBA(1,1,1,I),XL2AB(1,1,K,J),XL3,NUAB,NUB,NUB,0,0)
C
C
      CALL CCMATMUL(VHPRAB(1,1,I,J),FHPBB(1,K),XL3,NUAB,NUB,1,0,0)
      CALL CCMATMUL(VHPRAB(1,1,I,K),FHPBB(1,J),XL3,NUAB,NUB,1,0,1)
C
      CALL CCMATMUL(VHPRBB(1,1,I,J),T1BB(1,K),XL3,NUAB,NUB,1,0,0)
      CALL CCMATMUL(VHPRBB(1,1,I,K),T1BB(1,J),XL3,NUAB,NUB,1,0,1)
C
C
      CALL PERM_ABB(NUA,NUB,TI,XL3)
C
C     -------M3-------------
C
      CALL CCMATMUL(VMBA21(1,1,I,J),T2AA(1,1,1,K),XM3,NUA,NUB2,NOB,0,1)
      CALL CCMATMUL(VMBA21(1,1,I,K),T2AA(1,1,1,J),XM3,NUA,NUB2,NOB,0,0)
C
       CALL RDTAB(NUB,NUB,NUB,NOB,VEAA,15,NFT892)
      CALL CCMATMUL(T2(1,1,I,J),VEAA(1,1,1,K),XM3,NUA,NUB2,NUB,0,0)
      CALL CCMATMUL(T2(1,1,I,K),VEAA(1,1,1,J),XM3,NUA,NUB2,NUB,0,1)
C
      CALL VECMUL(XM3,NUA*NUB2,HALF)
C
      CALL CCMATMUL(T2(1,1,1,J),VMAB21(1,1,I,K),XM3,NUAB,NUB,NOA,0,1)
      CALL CCMATMUL(T2(1,1,1,K),VMAB21(1,1,I,J),XM3,NUAB,NUB,NOA,0,0)
C
      CALL CCMATMUL(T2BB(1,1,1,I),VMBB(1,1,J,K),XM3,NUAB,NUB,NOB,0,1)
C
       CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,17,NFT892)
      CALL CCMATMUL(VEAB(1,1,1,J),T2(1,1,I,K),XM3,NUAB,NUB,NUA,0,0)
      CALL CCMATMUL(VEAB(1,1,1,K),T2(1,1,I,J),XM3,NUAB,NUB,NUA,0,1)
C
       CALL RDTAB(NUA,NUB,NUB,NOA,VEBA,18,NFT892)
      CALL CCMATMUL(VEBA(1,1,1,I),T2AB(1,1,K,J),XM3,NUAB,NUB,NUB,0,0)
C
      CALL PERM_ABB(NUA,NUB,TI,XM3)
C
C        write(6,*) 'L3'
C      call drukm3(nua,nub,nub,i,j,k,xl3)
C        write(6,*) 'M3'
C      call drukm3(nua,nub,nub,i,j,k,xm3)
      DO 231,IA=1,NUA
      DO 232,IB=1,NUB
      DO 233,IC=IB+1,NUB
       PA1=-FHHA(I,I)-FHHB(J,J)-FHHB(K,K)
       PA2=FPPA(IA,IA)+FPPB(IB,IB)+FPPB(IC,IC)
       PA3=X1AB(I,J)+X1AB(I,K)+X1BB(J,K)
       PA4=X2AB(IA,IB)+X2AB(IA,IC)+X2BB(IB,IC)
       PA5=-X3AA(IA,I)-X3BA(IB,I)-X3BA(IC,I)
     *     -X3AB(IA,J)-X3BB(IB,J)-X3BB(IC,J)
     *     -X3AB(IA,K)-X3BB(IB,K)-X3BB(IC,K)
       PA6=X4AAB(I,IA,IB)+X4AAB(I,IA,IC)+
     *     X4BBA(J,IB,IA)+X4BBA(J,IC,IA)+X4BBB(J,IB,IC)+
     *     X4BBA(K,IB,IA)+X4BBA(K,IC,IA)+X4BBB(K,IB,IC)
       PA7=-X5AAB(IA,I,J)-X5AAB(IA,I,K)
     *     -X5BBA(IB,J,I)-X5BBA(IB,K,I)-X5BBB(IB,J,K)
     *     -X5BBA(IC,J,I)-X5BBA(IC,K,I)-X5BBB(IC,J,K)
      YDENA=-EPA(IA)-EPB(IB)-EPB(IC)+EHA(I)+EHB(J)+EHB(K)
      YDENB=-PA1-PA2
      YDENC=YDENB-PA3-PA4-PA5
      YDEND=YDENC-PA6-PA7
      XNUM=XM3(IA,IB,IC)*XL3(IA,IB,IC)
      CORA=CORA+XNUM/YDENA
      CORB=CORB+XNUM/YDENB
      CORC=CORC+XNUM/YDENC
      CORD=CORD+XNUM/YDEND
 233         CONTINUE
 232         CONTINUE
 231         CONTINUE
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK LAMB23_LOOP_ABB
      SUBROUTINE LAMB23_LOOP_ABB(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *     T1AA,T1BB,T2,T2AA,T2BB,T2AB,XL2AA,XL2BB,XL2AB,VHPRAB,
     *     VHPRAA,VHPRBB,XM3,XL3,TI,VMAA,VMBB,VMBA,VMAB,
     *     VMBA21,VMAB21,VEAA,VEBB,VEBA,VEAB,VEBA21,VEAB21,
     *     FHHA,FHHB,FPPA,FPPB,X1BB,X1AB,X2BB,X2AB,X3AA,X3AB,
     *     X3BA,X3BB,X4BBB,X4AAB,X4BBA,X5BBB,X5AAB,X5BBA,
     *     EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION TI(1),XL3(NUA,NUB,NUB),XM3(NUA,NUB,NUB),
     *          XL2AA(NOB,NUB,NUB,NOB),T2AA(NOB,NUB,NUB,NOB),
     *          T2BB(NUA,NUB,NOB,NOA),T2(NUA,NUB,NOA,NOB),
     *          VMBB(NOB,NUB,NOB,NOB),T2AB(NUB,NUB,NOB,NOB),
     *          VMAB21(NUB,NOA,NOA,NOB),VMBA21(NUA,NOB,NOA,NOB),
     *          VEBB(NUB,NUB,NUB,NOB),
     *          VEAB21(NUA,NUB,NUA,NOB),VEBA21(NUA,NUB,NUB,NOA),
     *          XL2BB(NUA,NUB,NOB,NOA),VHPRAB(NUA,NUB,NOA,NOB),
     *          VMAA(NOB,NUB,NOB,NOB),XL2AB(NUB,NUB,NOB,NOB),
     *          VMAB(NUB,NOA,NOA,NOB),VMBA(NUA,NOB,NOA,NOB),
     *          VEAA(NUB,NUB,NUB,NOB),VHPRAA(NUB,NUB,NOB,NOB),
     *          FHPAA(NUA,NOA),FHPBB(NUB,NOB),
     *          T1AA(NUA,NOA),T1BB(NUB,NOB),VHPRBB(NUA,NUB,NOA,NOB),
     *          VEAB(NUA,NUB,NUA,NOB),VEBA(NUA,NUB,NUB,NOA),
     *          FHHA(NOA,NOA),FHHB(NOB,NOB),FPPA(NUA,NUA),FPPB(NUB,NUB),
     *          X1BB(NOB,NOB),X1AB(NOA,NOB),X2BB(NUB,NUB),X2AB(NUA,NUB),
     *          X3AA(NUA,NOA),X3AB(NUA,NOB),X3BA(NUB,NOA),X3BB(NUB,NOB),
     *         X4BBB(NOB,NUB,NUB),X4AAB(NOA,NUA,NUB),X4BBA(NOB,NUB,NUA),
     *         X5BBB(NUB,NOB,NOB),X5AAB(NUA,NOA,NOB),X5BBA(NUB,NOB,NOA),
     *          EHA(NOA),EHB(NOB),EPA(NUA),EPB(NOA)
C
      DATA HALF/0.5D+0/
C
      NUB2=NUB*NUB
      NUAB=NUA*NUB
C
      DO 131 I=1, NOA
       DO 132 J=1, NOB-1
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=J+1, NOB
      CALL ZEROMA(XL3,1,NUA*NUB2)
      CALL ZEROMA(XM3,1,NUA*NUB2)
C
      CALL CCMATMUL(VMBA(1,1,I,J),XL2AA(1,1,1,K),XL3,NUA,NUB2,NOB,0,1)
      CALL CCMATMUL(VMBA(1,1,I,K),XL2AA(1,1,1,J),XL3,NUA,NUB2,NOB,0,0)
C
      CALL CCMATMUL(VHPRAB(1,1,I,J),VEAA(1,1,1,K),XL3,NUA,NUB2,NUB,0,0)
      CALL CCMATMUL(VHPRAB(1,1,I,K),VEAA(1,1,1,J),XL3,NUA,NUB2,NUB,0,1)
C
C
      CALL CCMATMUL(FHPAA(1,I),XL2AB(1,1,K,J),XL3,NUA,NUB2,1,0,0)
C
      CALL CCMATMUL(T1AA(1,I),VHPRAA(1,1,J,K),XL3,NUA,NUB2,1,0,0)
C
      CALL VECMUL(XL3,NUA*NUB2,HALF)
C
      CALL CCMATMUL(VHPRAB(1,1,1,J),VMAB(1,1,I,K),XL3,NUAB,NUB,NOA,0,1)
      CALL CCMATMUL(VHPRAB(1,1,1,K),VMAB(1,1,I,J),XL3,NUAB,NUB,NOA,0,0)
C
      CALL CCMATMUL(XL2BB(1,1,1,I),VMAA(1,1,J,K),XL3,NUAB,NUB,NOB,0,1)
C
      CALL CCMATMUL(VEAB(1,1,1,J),VHPRAB(1,1,I,K),XL3,NUAB,NUB,NUA,0,0)
      CALL CCMATMUL(VEAB(1,1,1,K),VHPRAB(1,1,I,J),XL3,NUAB,NUB,NUA,0,1)
C
      CALL CCMATMUL(VEBA(1,1,1,I),XL2AB(1,1,K,J),XL3,NUAB,NUB,NUB,0,0)
C
C
      CALL CCMATMUL(VHPRAB(1,1,I,J),FHPBB(1,K),XL3,NUAB,NUB,1,0,0)
      CALL CCMATMUL(VHPRAB(1,1,I,K),FHPBB(1,J),XL3,NUAB,NUB,1,0,1)
C
      CALL CCMATMUL(VHPRBB(1,1,I,J),T1BB(1,K),XL3,NUAB,NUB,1,0,0)
      CALL CCMATMUL(VHPRBB(1,1,I,K),T1BB(1,J),XL3,NUAB,NUB,1,0,1)
C
C
      CALL PERM_ABB(NUA,NUB,TI,XL3)
C
C     -------M3-------------
C
      CALL CCMATMUL(VMBA21(1,1,I,J),T2AA(1,1,1,K),XM3,NUA,NUB2,NOB,0,1)
      CALL CCMATMUL(VMBA21(1,1,I,K),T2AA(1,1,1,J),XM3,NUA,NUB2,NOB,0,0)
C
      CALL CCMATMUL(T2(1,1,I,J),VEBB(1,1,1,K),XM3,NUA,NUB2,NUB,0,0)
      CALL CCMATMUL(T2(1,1,I,K),VEBB(1,1,1,J),XM3,NUA,NUB2,NUB,0,1)
C
      CALL VECMUL(XM3,NUA*NUB2,HALF)
C
      CALL CCMATMUL(T2(1,1,1,J),VMAB21(1,1,I,K),XM3,NUAB,NUB,NOA,0,1)
      CALL CCMATMUL(T2(1,1,1,K),VMAB21(1,1,I,J),XM3,NUAB,NUB,NOA,0,0)
C
      CALL CCMATMUL(T2BB(1,1,1,I),VMBB(1,1,J,K),XM3,NUAB,NUB,NOB,0,1)
C
      CALL CCMATMUL(VEAB21(1,1,1,J),T2(1,1,I,K),XM3,NUAB,NUB,NUA,0,0)
      CALL CCMATMUL(VEAB21(1,1,1,K),T2(1,1,I,J),XM3,NUAB,NUB,NUA,0,1)
C
      CALL CCMATMUL(VEBA21(1,1,1,I),T2AB(1,1,K,J),XM3,NUAB,NUB,NUB,0,0)
C
      CALL PERM_ABB(NUA,NUB,TI,XM3)
C
C        write(6,*) 'L3'
C      call drukm3(nua,nub,nub,i,j,k,xl3)
C        write(6,*) 'M3'
C      call drukm3(nua,nub,nub,i,j,k,xm3)
      DO 231,IA=1,NUA
      DO 232,IB=1,NUB
      DO 233,IC=IB+1,NUB
       PA1=-FHHA(I,I)-FHHB(J,J)-FHHB(K,K)
       PA2=FPPA(IA,IA)+FPPB(IB,IB)+FPPB(IC,IC)
       PA3=X1AB(I,J)+X1AB(I,K)+X1BB(J,K)
       PA4=X2AB(IA,IB)+X2AB(IA,IC)+X2BB(IB,IC)
       PA5=-X3AA(IA,I)-X3BA(IB,I)-X3BA(IC,I)
     *     -X3AB(IA,J)-X3BB(IB,J)-X3BB(IC,J)
     *     -X3AB(IA,K)-X3BB(IB,K)-X3BB(IC,K)
       PA6=X4AAB(I,IA,IB)+X4AAB(I,IA,IC)+
     *     X4BBA(J,IB,IA)+X4BBA(J,IC,IA)+X4BBB(J,IB,IC)+
     *     X4BBA(K,IB,IA)+X4BBA(K,IC,IA)+X4BBB(K,IB,IC)
       PA7=-X5AAB(IA,I,J)-X5AAB(IA,I,K)
     *     -X5BBA(IB,J,I)-X5BBA(IB,K,I)-X5BBB(IB,J,K)
     *     -X5BBA(IC,J,I)-X5BBA(IC,K,I)-X5BBB(IC,J,K)
      YDENA=-EPA(IA)-EPB(IB)-EPB(IC)+EHA(I)+EHB(J)+EHB(K)
      YDENB=-PA1-PA2
      YDENC=YDENB-PA3-PA4-PA5
      YDEND=YDENC-PA6-PA7
      XNUM=XM3(IA,IB,IC)*XL3(IA,IB,IC)
      CORA=CORA+XNUM/YDENA
      CORB=CORB+XNUM/YDENB
      CORC=CORC+XNUM/YDENC
      CORD=CORD+XNUM/YDEND
 233         CONTINUE
 232         CONTINUE
 231         CONTINUE
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK DENMAKE
      SUBROUTINE DENMAKE(NOA,NUA,NOB,NUB,VHHHH,VPPP,VHPR,T2,X1AA,
     *                   X1BB,X1AB,
     *                   X2AA,X2BB,X2AB,
     *                   X3AA,X3BB,X3AB,X3BA,
     *                   X4AAA,X4AAB,X4BBA,X4BBB,
     *                   X5AAA,X5AAB,X5BBA,X5BBB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VHHHH(1),VPPP(1),VHPR(1),T2(1),
     *          X1AA(1),X1BB(1),X1AB(1),
     *          X2AA(1),X2BB(1),X2AB(1),
     *          X3AA(1),X3BB(1),X3AB(1),X3BA(1),
     *          X4AAA(1),X4AAB(1),X4BBA(1),X4BBB(1),
     *          X5AAA(1),X5AAB(1),X5BBA(1),X5BBB(1)
C
      IREC=0
      CALL RDTAB(NOA,NOA,NOA,NOA,VHHHH,7,NFT891)
      CALL RDTAB(NUA,NOA,NUA,NOA,VHPR,1,NFT892)
      CALL TWODEN(NOA,NOA,NUA,NUA,IREC,VHHHH,VPPP,VHPR,X1AA,X2AA,X3AA)
      CALL ZEROMA(VHPR,1,NO2U2)
      CALL RDINT(1,NOAUA,NOAUA,VHPR,NFT829)
      CALL RDTAB(NOA,NUA,NUA,NOA,T2,3,NFT825)
      CALL ZEROMA(X4AAA,1,NOAUA2)
      CALL ZEROMA(X5AAA,1,NOA2UA)
      CALL THREDEN(NOA,NOA,NUA,NUA,VHPR,T2,X4AAA,X5AAA)
C
      CALL ZEROMA(VHHHH,1,NO4)
      CALL ZEROMA(VHPR,1,NO2U2)
C
      IREC=NUA
      CALL RDTAB(NOB,NOB,NOB,NOB,VHHHH,8,NFT891)
      CALL RDTAB(NUB,NOB,NUB,NOB,VHPR,2,NFT892)
      CALL TWODEN(NOB,NOB,NUB,NUB,IREC,VHHHH,VPPP,VHPR,X1BB,X2BB,X3BB)
      CALL ZEROMA(VHPR,1,NO2U2)
      CALL RDINT(1,NOBUB,NOBUB,VHPR,NFT830)
      CALL RDTAB(NOB,NUB,NUB,NOB,T2,4,NFT825)
      CALL ZEROMA(X4BBB,1,NOBUB2)
      CALL ZEROMA(X5BBB,1,NOB2UB)
      CALL THREDEN(NOB,NOB,NUB,NUB,VHPR,T2,X4BBB,X5BBB)
C
      CALL ZEROMA(VHHHH,1,NO4)
      CALL ZEROMA(VHPR,1,NO2U2)
C
      IREC=NUA+NUB
      CALL RDTAB(NOA,NOB,NOA,NOB,VHHHH,9,NFT891)
      CALL RDTAB(NUA,NOB,NUA,NOB,VHPR,4,NFT892)
      CALL TWODEN(NOA,NOB,NUA,NUB,IREC,VHHHH,VPPP,VHPR,X1AB,X2AB,X3AB)
      CALL ZEROMA(VHPR,1,NO2U2)
      CALL RDINT(1,NOBUB,NOAUA,VHPR,NFT833)
      CALL RDTAB(NOA,NUA,NUB,NOB,T2,5,NFT825)
      CALL ZEROMA(X4AAB,1,NOAUAB)
      CALL ZEROMA(X5AAB,1,NOABUA)
      CALL THREDEN(NOA,NOB,NUA,NUB,VHPR,T2,X4AAB,X5AAB)
C
      CALL ZEROMA(X4BBA,1,NOBUAB)
      CALL ZEROMA(X5BBA,1,NOABUB)
      CALL THREBBA(NOB,NOA,NUB,NUA,VHPR,T2,X4BBA,X5BBA)
      CALL ZEROMA(VHPR,1,NO2U2)
      CALL RDTAB(NUB,NOA,NUB,NOA,VHPR,3,NFT892)
      CALL TWOBA(NOA,NUB,VHPR,X3BA)
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TWODEN
      SUBROUTINE TWODEN(NI,NJ,NA,NB,IREC,VHHHH,VPPP,VHPR,X1,X2,X3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      DIMENSION VHHHH(NI,NJ,NI,NJ),VPPP(NA,NB,NA),VHPR(NA,NJ,NA,NJ)
      DIMENSION X1(NI,NJ),X2(NA,NB),X3(NA,NJ)
C
      DO 1,I=1,NI
      DO 2,J=1,NI
       X1(I,J)=VHHHH(I,J,I,J)
 2    CONTINUE
 1    CONTINUE
C
      DO 3,IB=1,NB
      READ(NFT899,REC=IREC+IB) VPPP
      DO 4,IA=1,NA
       X2(IA,IB)=VPPP(IA,IB,IA)
 4    CONTINUE
 3    CONTINUE
C
      DO 5,IA=1,NA
      DO 6,J=1,NJ
       X3(IA,J)=VHPR(IA,J,IA,J)
 6    CONTINUE
 5    CONTINUE
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TWOBA
      SUBROUTINE TWOBA(NI,NA,VHPR,X3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VHPR(NA,NI,NA,NI)
      DIMENSION X3(NA,NI)
C
      DO 5,IA=1,NA
      DO 6,I=1,NI
       X3(IA,I)=VHPR(IA,I,IA,I)
 6    CONTINUE
 5    CONTINUE
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TREDEN
      SUBROUTINE THREDEN(NI,NJ,NA,NB,VHPR,T2,X4,X5)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VHPR(NA,NI,NB,NJ),T2(NI,NA,NB,NJ)
      DIMENSION X4(NI,NA,NB),X5(NA,NI,NJ)
C
      DO 1,I=1,NI
      DO 2,IA=1,NA
      DO 3,IB=1,NB
      DO 4,M=1,NJ
       X4(I,IA,IB)=X4(I,IA,IB)-VHPR(IA,I,IB,M)*T2(I,IA,IB,M)
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
C
      DO 5,IA=1,NA
      DO 6,I=1,NI
      DO 7,J=1,NJ
      DO 8,IE=1,NB
       X5(IA,I,J)=X5(IA,I,J)+VHPR(IA,I,IE,J)*T2(I,IA,IE,J)
 8    CONTINUE
 7    CONTINUE
 6    CONTINUE
 5    CONTINUE
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK THREBBA
      SUBROUTINE THREBBA(NI,NJ,NA,NB,VHPR,T2,X4,X5)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VHPR(NB,NJ,NA,NI),T2(NJ,NB,NA,NI)
      DIMENSION X4(NI,NA,NB),X5(NA,NI,NJ)
C
      DO 1,I=1,NI
      DO 2,IA=1,NA
      DO 3,IB=1,NB
      DO 4,M=1,NJ
       X4(I,IA,IB)=X4(I,IA,IB)-VHPR(IB,M,IA,I)*T2(M,IB,IA,I)
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
C
      DO 5,IA=1,NA
      DO 6,I=1,NI
      DO 7,J=1,NJ
      DO 8,IE=1,NB
       X5(IA,I,J)=X5(IA,I,J)+VHPR(IE,J,IA,I)*T2(J,IE,IA,I)
 8    CONTINUE
 7    CONTINUE
 6    CONTINUE
 5    CONTINUE
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK LAMB23_LOOPW
      SUBROUTINE LAMB23_LOOPW(NO,NU,FHP,T1,
     *                        VHPR,T2,VE,XM3,TI,VM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION TI(1),XM3(NU,NU,NU),T2(NU,NU,NO,NO),
     *          VE(NU,NU,NU,NO),VM(NO,NU,NO,NO),FHP(NU,NO),
     *          VHPR(NU,NU,NO,NO),T1(NU,NO)
C
      DATA HALF/0.5D+0/
C
        NU2=NU*NU
        NU3=NU*NU*NU
        NO2=NO*NO
      DO 131 I=1, NO-2
       DO 132 J=I+1, NO-1
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=J+1, NO
      CALL ZEROMA(XM3,1,NU3)
      KK=(I-1)*NO2+(J-1)*NO+K
C
      CALL CCMATMUL(VHPR(1,1,I,J),T1(1,K),XM3,NU2,NU,1,0,0)
      CALL CCMATMUL(VHPR(1,1,I,K),T1(1,J),XM3,NU2,NU,1,0,1)
      CALL CCMATMUL(VHPR(1,1,K,J),T1(1,I),XM3,NU2,NU,1,0,1)
C
      CALL CCMATMUL(T2(1,1,J,I),FHP(1,K),XM3,NU2,NU,1,0,0)
      CALL CCMATMUL(T2(1,1,K,I),FHP(1,J),XM3,NU2,NU,1,0,1)
      CALL CCMATMUL(T2(1,1,J,K),FHP(1,I),XM3,NU2,NU,1,0,1)
C
      CALL CCMATMUL(T2(1,1,1,I),VM(1,1,J,K),XM3,NU2,NU,NO,0,1)
      CALL CCMATMUL(T2(1,1,1,J),VM(1,1,I,K),XM3,NU2,NU,NO,0,0)
      CALL CCMATMUL(T2(1,1,1,K),VM(1,1,J,I),XM3,NU2,NU,NO,0,0)
C
      CALL CCMATMUL(T2(1,1,J,I),VE(1,1,1,K),XM3,NU,NU2,NU,0,0)
      CALL CCMATMUL(T2(1,1,K,I),VE(1,1,1,J),XM3,NU,NU2,NU,0,1)
      CALL CCMATMUL(T2(1,1,J,K),VE(1,1,1,I),XM3,NU,NU2,NU,0,1)
C
      CALL VECMUL(XM3,NU3,HALF)
C
      CALL PERMFULL(NU,TI,XM3)
C
      WRITE(NFT859,REC=KK) XM3
C
C      call drukm3(nu,nu,nu,i,j,k,xm3)
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK LAMB23_LOOP_AABW
      SUBROUTINE LAMB23_LOOP_AABW(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *                            T1AA,T1BB,T2AA,T2BB,T2AB,VHPRAB,
     *                            VHPRAA,VHPRBB,XM3,TI,
     *                            VMAA,VMBA,VMAB,VEAA,VEBA,VEAB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION TI(1),XM3(NUA,NUA,NUB),T2AA(NUA,NUA,NOA,NOA),
     *          T2BB(NOB,NUA,NUB,NOA),T2AB(NOA,NUA,NUB,NOB),
     *          VMAA(NUA,NOA,NOA,NOA),FHPAA(NUA,NOA),FHPBB(NUB,NOB),
     *          VMAB(NOA,NUB,NOA,NOB),VMBA(NUA,NOB,NOA,NOB),
     *          VHPRAB(NUA,NUB,NOA,NOB),VHPRAA(NUA,NUA,NOA,NOA),
     *          VEAA(NUA,NUA,NUA,NOA),VHPRBB(NUA,NUB,NOA,NOB),
     *          VEAB(NUA,NUA,NUB,NOB),VEBA(NUB,NUA,NUB,NOA),
     *          T1AA(NUA,NOA),T1BB(NUB,NOB)
C
      DATA HALF/0.5D+0/
C
      NUA2=NUA*NUA
      NUAB=NUA*NUB
C
      IF (NOA .GE. NOB) THEN
              NO=NOA
      ELSE
              NO=NOB
      ENDIF
C
      NO2=NO*NO
C
      DO 131 I=1, NOA-1
       DO 132 J=I+1, NOA
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=1, NOB
      CALL ZEROMA(XM3,1,NUA2*NUB)
      KK=(I-1)*NO2+(J-1)*NO+K
C
C
      CALL CCMATMUL(T2AA(1,1,1,I),VMAB(1,1,J,K),XM3,NUA2,NUB,NOA,0,1)
      CALL CCMATMUL(T2AA(1,1,1,J),VMAB(1,1,I,K),XM3,NUA2,NUB,NOA,0,0)
C
C
      CALL CCMATMUL(VEAA(1,1,1,J),VHPRAB(1,1,I,K),XM3,NUA2,NUB,NUA,0,0)
      CALL CCMATMUL(VEAA(1,1,1,I),VHPRAB(1,1,J,K),XM3,NUA2,NUB,NUA,0,1)
C
      CALL CCMATMUL(T2AA(1,1,J,I),FHPBB(1,K),XM3,NUA2,NUB,1,0,0)
C
      CALL CCMATMUL(VHPRAA(1,1,I,J),T1BB(1,K),XM3,NUA2,NUB,1,0,0)
C
      CALL VECMUL(XM3,NUA2*NUB,HALF)
C
      CALL CCMATMUL(VMBA(1,1,J,K),T2BB(1,1,1,I),XM3,NUA,NUAB,NOB,0,0)
      CALL CCMATMUL(VMBA(1,1,I,K),T2BB(1,1,1,J),XM3,NUA,NUAB,NOB,0,1)
C
      CALL CCMATMUL(VMAA(1,1,J,I),T2AB(1,1,1,K),XM3,NUA,NUAB,NOA,0,1)
C
C
      CALL CCMATMUL(VHPRAB(1,1,I,K),VEBA(1,1,1,J),XM3,NUA,NUAB,NUB,0,0)
      CALL CCMATMUL(VHPRAB(1,1,J,K),VEBA(1,1,1,I),XM3,NUA,NUAB,NUB,0,1)
C
      CALL CCMATMUL(T2AA(1,1,J,I),VEAB(1,1,1,K),XM3,NUA,NUAB,NUA,0,0)
C
C
      CALL CCMATMUL(FHPAA(1,I),VHPRAB(1,1,J,K),XM3,NUA,NUAB,1,0,0)
      CALL CCMATMUL(FHPAA(1,J),VHPRAB(1,1,I,K),XM3,NUA,NUAB,1,0,1)
C
      CALL CCMATMUL(T1AA(1,I),VHPRBB(1,1,J,K),XM3,NUA,NUAB,1,0,0)
      CALL CCMATMUL(T1AA(1,J),VHPRBB(1,1,I,K),XM3,NUA,NUAB,1,0,1)
C
C
      CALL PERM_AAB(NUA,NUB,TI,XM3)
C
      WRITE(NFT859,REC=KK) XM3
C
C      call drukm3(nua,nua,nub,i,j,k,xm3)
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK LAMB23_LOOP_ABBW
      SUBROUTINE LAMB23_LOOP_ABBW(NOA,NUA,NOB,NUB,FHPAA,FHPBB,
     *                            T1AA,T1BB,T2AA,T2BB,T2AB,VHPRAB,
     *                            VHPRAA,VHPRBB,XM3,TI,
     *                            VMAA,VMBA,VMAB,VEAA,VEBA,VEAB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION TI(1),XM3(NUA,NUB,NUB),T2AA(NOB,NUB,NUB,NOB),
     *          T2BB(NUA,NUB,NOB,NOA),VHPRAB(NUA,NUB,NOA,NOB),
     *          VMAA(NOB,NUB,NOB,NOB),T2AB(NUB,NUB,NOB,NOB),
     *          VMAB(NUB,NOA,NOA,NOB),VMBA(NUA,NOB,NOA,NOB),
     *          VEAA(NUB,NUB,NUB,NOB),VHPRAA(NUB,NUB,NOB,NOB),
     *          FHPAA(NUA,NOA),FHPBB(NUB,NOB),
     *          T1AA(NUA,NOA),T1BB(NUB,NOB),VHPRBB(NUA,NUB,NOA,NOB),
     *          VEAB(NUA,NUB,NUA,NOB),VEBA(NUA,NUB,NUB,NOA)
C
      DATA HALF/0.5D+0/
C
      NUB2=NUB*NUB
      NUAB=NUA*NUB
C
      IF (NOA .GE. NOB) THEN
              NO=NOA
      ELSE
              NO=NOB
      ENDIF
C
      NO2=NO*NO
C
      DO 131 I=1, NOA
       DO 132 J=1, NOB-1
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=J+1, NOB
      CALL ZEROMA(XM3,1,NUA*NUB2)
      KK=(I-1)*NO2+(J-1)*NO+K
C
      CALL CCMATMUL(VMBA(1,1,I,J),T2AA(1,1,1,K),XM3,NUA,NUB2,NOB,0,1)
      CALL CCMATMUL(VMBA(1,1,I,K),T2AA(1,1,1,J),XM3,NUA,NUB2,NOB,0,0)
C
      CALL CCMATMUL(VHPRAB(1,1,I,J),VEAA(1,1,1,K),XM3,NUA,NUB2,NUB,0,0)
      CALL CCMATMUL(VHPRAB(1,1,I,K),VEAA(1,1,1,J),XM3,NUA,NUB2,NUB,0,1)
C
C
      CALL CCMATMUL(FHPAA(1,I),T2AB(1,1,K,J),XM3,NUA,NUB2,1,0,0)
C
      CALL CCMATMUL(T1AA(1,I),VHPRAA(1,1,J,K),XM3,NUA,NUB2,1,0,0)
C
      CALL VECMUL(XM3,NUA*NUB2,HALF)
C
      CALL CCMATMUL(VHPRAB(1,1,1,J),VMAB(1,1,I,K),XM3,NUAB,NUB,NOA,0,1)
      CALL CCMATMUL(VHPRAB(1,1,1,K),VMAB(1,1,I,J),XM3,NUAB,NUB,NOA,0,0)
C
      CALL CCMATMUL(T2BB(1,1,1,I),VMAA(1,1,J,K),XM3,NUAB,NUB,NOB,0,1)
C
      CALL CCMATMUL(VEAB(1,1,1,J),VHPRAB(1,1,I,K),XM3,NUAB,NUB,NUA,0,0)
      CALL CCMATMUL(VEAB(1,1,1,K),VHPRAB(1,1,I,J),XM3,NUAB,NUB,NUA,0,1)
C
      CALL CCMATMUL(VEBA(1,1,1,I),T2AB(1,1,K,J),XM3,NUAB,NUB,NUB,0,0)
C
C
      CALL CCMATMUL(VHPRAB(1,1,I,J),FHPBB(1,K),XM3,NUAB,NUB,1,0,0)
      CALL CCMATMUL(VHPRAB(1,1,I,K),FHPBB(1,J),XM3,NUAB,NUB,1,0,1)
C
      CALL CCMATMUL(VHPRBB(1,1,I,J),T1BB(1,K),XM3,NUAB,NUB,1,0,0)
      CALL CCMATMUL(VHPRBB(1,1,I,K),T1BB(1,J),XM3,NUAB,NUB,1,0,1)
C
C
      CALL PERM_ABB(NUA,NUB,TI,XM3)
C
      WRITE(NFT859,REC=KK) XM3
C
C      call drukm3(nua,nub,nub,i,j,k,xm3)
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK MOM23_LOOP
      SUBROUTINE MOM23_LOOP(NO,NU,T2,VE,XM3,TI,VM,
     *                      FHH,FPP,X1,X2,X3,X4,X5,EH,EP,
     *                      CORA,CORB,CORC,CORD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION TI(NU,NU,NU),XM3(NU,NU,NU),T2(NU,NU,NO,NO),
     *          VE(NU,NU,NU,NO),VM(NO,NU,NO,NO),EH(NO),EP(NU),
     *          FHH(NO,NO),FPP(NU,NU),X1(NO,NO),
     *          X2(NU,NU),X3(NU,NO),X4(NO,NU,NU),X5(NU,NO,NO)
C
      DATA HALF/0.5D+0/
C
      NU2=NU*NU
      NU3=NU*NU*NU
      NO2=NO*NO
C
      DO 131 I=1, NO-2
       DO 132 J=I+1, NO-1
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=J+1, NO
      KK=(I-1)*NO2+(J-1)*NO+K
      CALL ZEROMA(XM3,1,NU3)
C
      CALL CCMATMUL(T2(1,1,1,I),VM(1,1,J,K),XM3,NU2,NU,NO,0,1)
      CALL CCMATMUL(T2(1,1,1,J),VM(1,1,I,K),XM3,NU2,NU,NO,0,0)
      CALL CCMATMUL(T2(1,1,1,K),VM(1,1,J,I),XM3,NU2,NU,NO,0,0)
C
      CALL CCMATMUL(T2(1,1,J,I),VE(1,1,1,K),XM3,NU,NU2,NU,0,0)
      CALL CCMATMUL(T2(1,1,K,I),VE(1,1,1,J),XM3,NU,NU2,NU,0,1)
      CALL CCMATMUL(T2(1,1,J,K),VE(1,1,1,I),XM3,NU,NU2,NU,0,1)
C
      CALL VECMUL(XM3,NU3,HALF)
C
      CALL PERMFULL(NU,TI,XM3)
C
      CALL ZEROMA(TI,1,NU3)
      READ(NFT859,REC=KK) TI
C
C      call drukm3(nu,nu,nu,i,j,k,xm3)
      DO 231,IA=1,NU-2
      DO 232,IB=IA+1,NU-1
      DO 233,IC=IB+1,NU
       PA1=-FHH(I,I)-FHH(J,J)-FHH(K,K)
       PA2=FPP(IA,IA)+FPP(IB,IB)+FPP(IC,IC)
       PA3=X1(I,J)+X1(I,K)+X1(J,K)
       PA4=X2(IA,IB)+X2(IA,IC)+X2(IB,IC)
       PA5=-X3(IA,I)-X3(IB,I)-X3(IC,I)
     *     -X3(IA,J)-X3(IB,J)-X3(IC,J)
     *     -X3(IA,K)-X3(IB,K)-X3(IC,K)
       PA6=X4(I,IA,IB)+X4(I,IA,IC)+X4(I,IB,IC)+
     *     X4(J,IA,IB)+X4(J,IA,IC)+X4(J,IB,IC)+
     *     X4(K,IA,IB)+X4(K,IA,IC)+X4(K,IB,IC)
       PA7=-X5(IA,I,J)-X5(IA,I,K)-X5(IA,J,K)
     *     -X5(IB,I,J)-X5(IB,I,K)-X5(IB,J,K)
     *     -X5(IC,I,J)-X5(IC,I,K)-X5(IC,J,K)
      YDENA=-EP(IA)-EP(IB)-EP(IC)+EH(I)+EH(J)+EH(K)
      YDENB=-PA1-PA2
      YDENC=YDENB-PA3-PA4-PA5
      YDEND=YDENC-PA6-PA7
      XNUM=XM3(IA,IB,IC)*TI(IA,IB,IC)
      CORA=CORA+XNUM/YDENA
      CORB=CORB+XNUM/YDENB
      CORC=CORC+XNUM/YDENC
      CORD=CORD+XNUM/YDEND
 233         CONTINUE
 232         CONTINUE
 231         CONTINUE
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK MOM23_LOOP_AAB
      SUBROUTINE MOM23_LOOP_AAB(NOA,NUA,NOB,NUB,T2AA,T2BB,
     *             T2AB,VHPRAB,XM3,TI,VMAA,VMBA,VMAB,VEAA,VEBA,VEAB,
     *             FHHA,FHHB,FPPA,FPPB,X1AA,X1AB,X2AA,X2AB,X3AA,X3AB,
     *             X3BA,X3BB,X4AAA,X4AAB,X4BBA,X5AAA,X5AAB,X5BBA,
     *             EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION TI(NUA,NUA,NUB),XM3(NUA,NUA,NUB),T2AA(NUA,NUA,NOA,NOA),
     *          T2BB(NOB,NUA,NUB,NOA),T2AB(NOA,NUA,NUB,NOB),
     *          VMAA(NUA,NOA,NOA,NOA),
     *          VMAB(NOA,NUB,NOA,NOB),VMBA(NUA,NOB,NOA,NOB),
     *          VHPRAB(NUA,NUB,NOA,NOB),
     *          VEAA(NUA,NUA,NUA,NOA),
     *          VEAB(NUA,NUA,NUB,NOB),VEBA(NUB,NUA,NUB,NOA),
     *          FHHA(NOA,NOA),FHHB(NOB,NOB),FPPA(NUA,NUA),FPPB(NUB,NUB),
     *          X1AA(NOA,NOA),X1AB(NOA,NOB),X2AA(NUA,NUA),X2AB(NUA,NUB),
     *          X3AA(NUA,NOA),X3AB(NUA,NOB),X3BA(NUB,NOA),X3BB(NUB,NOB),
     *         X4AAA(NOA,NUA,NUA),X4AAB(NOA,NUA,NUB),X4BBA(NOB,NUB,NUA),
     *         X5AAA(NUA,NOA,NOA),X5AAB(NUA,NOA,NOB),X5BBA(NUB,NOB,NOA),
     *          EHA(NOA),EHB(NOB),EPA(NUA),EPB(NOA)
C
      DATA HALF/0.5D+0/
C
      NUA2=NUA*NUA
      NUAB=NUA*NUB
C
      IF (NOA .GE. NOB) THEN
              NO=NOA
      ELSE
              NO=NOB
      ENDIF
         NO2=NO*NO
      DO 131 I=1, NOA-1
       DO 132 J=I+1, NOA
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=1, NOB
      CALL ZEROMA(XM3,1,NUA2*NUB)
      KK=(I-1)*NO2+(J-1)*NO+K
C
      CALL CCMATMUL(T2AA(1,1,1,I),VMAB(1,1,J,K),XM3,NUA2,NUB,NOA,0,1)
      CALL CCMATMUL(T2AA(1,1,1,J),VMAB(1,1,I,K),XM3,NUA2,NUB,NOA,0,0)
C
C
      CALL CCMATMUL(VEAA(1,1,1,J),VHPRAB(1,1,I,K),XM3,NUA2,NUB,NUA,0,0)
      CALL CCMATMUL(VEAA(1,1,1,I),VHPRAB(1,1,J,K),XM3,NUA2,NUB,NUA,0,1)
C
      CALL VECMUL(XM3,NUA2*NUB,HALF)
C
      CALL CCMATMUL(VMBA(1,1,J,K),T2BB(1,1,1,I),XM3,NUA,NUAB,NOB,0,0)
      CALL CCMATMUL(VMBA(1,1,I,K),T2BB(1,1,1,J),XM3,NUA,NUAB,NOB,0,1)
C
      CALL CCMATMUL(VMAA(1,1,J,I),T2AB(1,1,1,K),XM3,NUA,NUAB,NOA,0,1)
C
C
      CALL CCMATMUL(VHPRAB(1,1,I,K),VEBA(1,1,1,J),XM3,NUA,NUAB,NUB,0,0)
      CALL CCMATMUL(VHPRAB(1,1,J,K),VEBA(1,1,1,I),XM3,NUA,NUAB,NUB,0,1)
C
      CALL CCMATMUL(T2AA(1,1,J,I),VEAB(1,1,1,K),XM3,NUA,NUAB,NUA,0,0)
C
C
      CALL PERM_AAB(NUA,NUB,TI,XM3)
C
      CALL ZEROMA(TI,1,NUA*NUA*NUB)
      READ(NFT859,REC=KK) TI
C
C      call drukm3(nua,nua,nub,i,j,k,xm3)
      DO 231,IA=1,NUA-1
      DO 232,IB=IA+1,NUA
      DO 233,IC=1,NUB
       PA1=-FHHA(I,I)-FHHA(J,J)-FHHB(K,K)
       PA2=FPPA(IA,IA)+FPPA(IB,IB)+FPPB(IC,IC)
       PA3=X1AA(I,J)+X1AB(I,K)+X1AB(J,K)
       PA4=X2AA(IA,IB)+X2AB(IA,IC)+X2AB(IB,IC)
       PA5=-X3AA(IA,I)-X3AA(IB,I)-X3BA(IC,I)
     *     -X3AA(IA,J)-X3AA(IB,J)-X3BA(IC,J)
     *     -X3AB(IA,K)-X3AB(IB,K)-X3BB(IC,K)
       PA6=X4AAA(I,IA,IB)+X4AAB(I,IA,IC)+X4AAB(I,IB,IC)+
     *     X4AAA(J,IA,IB)+X4AAB(J,IA,IC)+X4AAB(J,IB,IC)+
     *     X4BBA(K,IC,IA)+X4BBA(K,IC,IB)
       PA7=-X5AAA(IA,I,J)-X5AAB(IA,I,K)-X5AAB(IA,J,K)
     *     -X5AAA(IB,I,J)-X5AAB(IB,I,K)-X5AAB(IB,J,K)
     *     -X5BBA(IC,K,I)-X5BBA(IC,K,J)
      YDENA=-EPA(IA)-EPA(IB)-EPB(IC)+EHA(I)+EHA(J)+EHB(K)
      YDENB=-PA1-PA2
      YDENC=YDENB-PA3-PA4-PA5
      YDEND=YDENC-PA6-PA7
      XNUM=XM3(IA,IB,IC)*TI(IA,IB,IC)
      CORA=CORA+XNUM/YDENA
      CORB=CORB+XNUM/YDENB
      CORC=CORC+XNUM/YDENC
      CORD=CORD+XNUM/YDEND
 233         CONTINUE
 232         CONTINUE
 231         CONTINUE
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK MOM23_LOOP_ABB
      SUBROUTINE MOM23_LOOP_ABB(NOA,NUA,NOB,NUB,T2AA,T2BB,
     *             T2AB,VHPRAB,XM3,TI,VMAA,VMBA,VMAB,VEAA,VEBA,VEAB,
     *             FHHA,FHHB,FPPA,FPPB,X1BB,X1AB,X2BB,X2AB,X3AA,X3AB,
     *             X3BA,X3BB,X4BBB,X4AAB,X4BBA,X5BBB,X5AAB,X5BBA,
     *             EHA,EHB,EPA,EPB,CORA,CORB,CORC,CORD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
C
      DIMENSION TI(NUA,NUB,NUB),XM3(NUA,NUB,NUB),T2AA(NOB,NUB,NUB,NOB),
     *          T2BB(NUA,NUB,NOB,NOA),VHPRAB(NUA,NUB,NOA,NOB),
     *          VMAA(NOB,NUB,NOB,NOB),T2AB(NUB,NUB,NOB,NOB),
     *          VMAB(NUB,NOA,NOA,NOB),VMBA(NUA,NOB,NOA,NOB),
     *          VEAA(NUB,NUB,NUB,NOB),
     *          VEAB(NUA,NUB,NUA,NOB),VEBA(NUA,NUB,NUB,NOA),
     *          FHHA(NOA,NOA),FHHB(NOB,NOB),FPPA(NUA,NUA),FPPB(NUB,NUB),
     *          X1BB(NOB,NOB),X1AB(NOA,NOB),X2BB(NUB,NUB),X2AB(NUA,NUB),
     *          X3AA(NUA,NOA),X3AB(NUA,NOB),X3BA(NUB,NOA),X3BB(NUB,NOB),
     *         X4BBB(NOB,NUB,NUB),X4AAB(NOA,NUA,NUB),X4BBA(NOB,NUB,NUA),
     *         X5BBB(NUB,NOB,NOB),X5AAB(NUA,NOA,NOB),X5BBA(NUB,NOB,NOA),
     *          EHA(NOA),EHB(NOB),EPA(NUA),EPB(NOA)
C
      DATA HALF/0.5D+0/
C
      NUB2=NUB*NUB
      NUAB=NUA*NUB
C
      IF (NOA .GE. NOB) THEN
              NO=NOA
      ELSE
              NO=NOB
      ENDIF
         NO2=NO*NO
      DO 131 I=1, NOA
       DO 132 J=1, NOB-1
C        write(6,*) 'main loop over triples ij',i,j
C      call flshbf(6)
        DO 133 K=J+1, NOB
      CALL ZEROMA(XM3,1,NUA*NUB2)
      KK=(I-1)*NO2+(J-1)*NO+K
C
      CALL CCMATMUL(VMBA(1,1,I,J),T2AA(1,1,1,K),XM3,NUA,NUB2,NOB,0,1)
      CALL CCMATMUL(VMBA(1,1,I,K),T2AA(1,1,1,J),XM3,NUA,NUB2,NOB,0,0)
C
      CALL CCMATMUL(VHPRAB(1,1,I,J),VEAA(1,1,1,K),XM3,NUA,NUB2,NUB,0,0)
      CALL CCMATMUL(VHPRAB(1,1,I,K),VEAA(1,1,1,J),XM3,NUA,NUB2,NUB,0,1)
C
      CALL VECMUL(XM3,NUA*NUB2,HALF)
C
      CALL CCMATMUL(VHPRAB(1,1,1,J),VMAB(1,1,I,K),XM3,NUAB,NUB,NOA,0,1)
      CALL CCMATMUL(VHPRAB(1,1,1,K),VMAB(1,1,I,J),XM3,NUAB,NUB,NOA,0,0)
C
      CALL CCMATMUL(T2BB(1,1,1,I),VMAA(1,1,J,K),XM3,NUAB,NUB,NOB,0,1)
C
      CALL CCMATMUL(VEAB(1,1,1,J),VHPRAB(1,1,I,K),XM3,NUAB,NUB,NUA,0,0)
      CALL CCMATMUL(VEAB(1,1,1,K),VHPRAB(1,1,I,J),XM3,NUAB,NUB,NUA,0,1)
C
      CALL CCMATMUL(VEBA(1,1,1,I),T2AB(1,1,K,J),XM3,NUAB,NUB,NUB,0,0)
C
C
C      call vecmul(xm3,nu3,half)
C
      CALL PERM_ABB(NUA,NUB,TI,XM3)
C      call drukm3(nua,nub,nub,i,j,k,xm3)
      CALL ZEROMA(TI,1,NUA*NUB*NUB)
      READ(NFT859,REC=KK) TI
C
C      call drukm3(nua,nua,nub,i,j,k,xm3)
      DO 231,IA=1,NUA
      DO 232,IB=1,NUB
      DO 233,IC=IB+1,NUB
       PA1=-FHHA(I,I)-FHHB(J,J)-FHHB(K,K)
       PA2=FPPA(IA,IA)+FPPB(IB,IB)+FPPB(IC,IC)
       PA3=X1AB(I,J)+X1AB(I,K)+X1BB(J,K)
       PA4=X2AB(IA,IB)+X2AB(IA,IC)+X2BB(IB,IC)
       PA5=-X3AA(IA,I)-X3BA(IB,I)-X3BA(IC,I)
     *     -X3AB(IA,J)-X3BB(IB,J)-X3BB(IC,J)
     *     -X3AB(IA,K)-X3BB(IB,K)-X3BB(IC,K)
       PA6=X4AAB(I,IA,IB)+X4AAB(I,IA,IC)+
     *     X4BBA(J,IB,IA)+X4BBA(J,IC,IA)+X4BBB(J,IB,IC)+
     *     X4BBA(K,IB,IA)+X4BBA(K,IC,IA)+X4BBB(K,IB,IC)
       PA7=-X5AAB(IA,I,J)-X5AAB(IA,I,K)
     *     -X5BBA(IB,J,I)-X5BBA(IB,K,I)-X5BBB(IB,J,K)
     *     -X5BBA(IC,J,I)-X5BBA(IC,K,I)-X5BBB(IC,J,K)
      YDENA=-EPA(IA)-EPB(IB)-EPB(IC)+EHA(I)+EHB(J)+EHB(K)
      YDENB=-PA1-PA2
      YDENC=YDENB-PA3-PA4-PA5
      YDEND=YDENC-PA6-PA7
      XNUM=XM3(IA,IB,IC)*TI(IA,IB,IC)
      CORA=CORA+XNUM/YDENA
      CORB=CORB+XNUM/YDENB
      CORC=CORC+XNUM/YDENC
      CORD=CORD+XNUM/YDEND
 233         CONTINUE
 232         CONTINUE
 231         CONTINUE
 133         CONTINUE
 132         CONTINUE
 131         CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK PERMFULL
      SUBROUTINE PERMFULL(M,TI,R3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION R3(M,M,M),TI(M,M,M)
C
      CALL VECCOP(M**3,TI,R3)
      CALL ZEROMA(R3,1,M**3)
      DO 1 I=1, M-2
       DO 2 J=I+1, M-1
        DO 3 K=J+1, M
          R3(I,J,K)=TI(I,J,K)-TI(K,J,I)-TI(J,I,K)
     *             -TI(I,K,J)+TI(J,K,I)+TI(K,I,J)
 3      CONTINUE
 2     CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK PERM_AAB
      SUBROUTINE PERM_AAB(M,N,TI,R3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION R3(M,M,N),TI(M,M,N)
C
      CALL VECCOP(M*M*N,TI,R3)
      CALL ZEROMA(R3,1,M*M*N)
      DO 1 I=1, M-1
       DO 2 J=I+1, M
        DO 3 K=1, N
         R3(I,J,K)=TI(I,J,K)-TI(J,I,K)
 3      CONTINUE
 2     CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK PERM_ABB
      SUBROUTINE PERM_ABB(M,N,TI,R3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION R3(M,N,N),TI(M,N,N)
C
      CALL VECCOP(M*N*N,TI,R3)
      CALL ZEROMA(R3,1,M*N*N)
      DO 1 I=1, M
       DO 2 J=1, N-1
        DO 3 K=J+1, N
         R3(I,J,K)=TI(I,J,K)-TI(I,K,J)
 3      CONTINUE
 2     CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TRAN14
      SUBROUTINE TRAN14(N1,N2,N3,N4,TI,O2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(N1,N2,N3,N4),O2(N4,N2,N3,N1)
C
      N=N1*N2*N3*N4
      CALL VECCOP(N,TI,O2)
      DO 10 I=1,N1
      DO 10 J=1,N2
      DO 10 K=1,N3
      DO 10 L=1,N4
      O2(L,J,K,I)=TI(I,J,K,L)
 10   CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TRAN24
      SUBROUTINE TRAN24(N1,N2,N3,N4,TI,O2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(N1,N2,N3,N4),O2(N1,N4,N3,N2)
C
      N=N1*N2*N3*N4
      CALL VECCOP(N,TI,O2)
      DO 10 I=1,N1
      DO 10 J=1,N2
      DO 10 K=1,N3
      DO 10 L=1,N4
      O2(I,L,K,J)=TI(I,J,K,L)
 10   CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TRAN1TO4
      SUBROUTINE TRAN1TO4(N1,N2,N3,N4,TI,O2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(N1,N2,N3,N4),O2(N2,N3,N4,N1)
C
      N=N1*N2*N3*N4
      CALL VECCOP(N,TI,O2)
      DO 10 I=1,N1
      DO 10 J=1,N2
      DO 10 K=1,N3
      DO 10 L=1,N4
      O2(J,K,L,I)=TI(I,J,K,L)
 10   CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TRANSNQN
      SUBROUTINE TRANSNQN(NO,NU,O1,TI)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(NO,NU),O1(NU,NO)
C
      NOU=NO*NU
      CALL VECCOP(NOU,TI,O1)
      DO 1 I=1, NO
       DO 2 J=1, NU
        O1(J,I)=TI(I,J)
2       CONTINUE
1     CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TRAN34N
      SUBROUTINE TRAN34N(N1,N2,N3,N4,TI,O2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI((N1*N2),(N3*N4)),O2((N1*N2),(N3*N4))
C
      N=N1*N2*N3*N4
      N12=N1*N2
      CALL VECCOP(N,TI,O2)
      KK=0
      DO 1 K=1, N4
       DO 2 L=1, N3
        ISIT=((L-1)*N4+K)
        KK=KK+1
        CALL VECCOP(N12,O2(1,ISIT),TI(1,KK))
2      CONTINUE
1     CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK ONEHBAR
      SUBROUTINE ONEHBAR(NOA,NUA,NOB,NUB,FHHAA,O1AA,O1BB,
     *                   FHHBB,FPPAA,FPPBB,FHPAA,FHPBB,O2AA,O2BB,O2AB,
     *                   VEAA,VHPRBB,VHPRAA,VHPRAB,TI,
     *                   VMAB,VMBA,VMAA,VMBB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION TI(1),FHHAA(1),VHPRAA(1),O1AA(1),O1BB(1),O2AA(1),
     *          FHHBB(1),O2AB(1),O2BB(1),FHPBB(1),FPPAA(1),FHPAA(1),
     *          VEAA(1),VHPRAB(1),VMBA(1),VMAB(1),VMAA(1),VMBB(1),
     *          VHPRBB(1),FPPBB(1)
C
      DATA TWO/2.0D+00/,HALF/0.5D+00/
C
C         'jestem w onebody'
C
      CALL RDTAB2(NOA,NUA,O1AA,1,NFT825)
      CALL RDTAB2(NOB,NUB,O1BB,2,NFT825)
      CALL RDTAB(NOA,NUA,NUA,NOA,O2AA,3,NFT825)
      CALL RDTAB(NOB,NUB,NUB,NOB,O2BB,4,NFT825)
      CALL RDTAB(NOA,NUA,NUB,NOB,O2AB,5,NFT825)
C vhhhp_aa (vmaa)
      CALL RDINT(1,NOAUA,NOA2,VMAA,NFT823)
C vppph_aa (veaa)
C vhhhp_ab (vmab)
      CALL RDINT(1,NOAUB,NOAB,VMAB,NFT828)
C vppph_ab (veab)
C vhhhp_bb (vmbb)
      CALL RDINT(1,NOBUB,NOB2,VMBB,NFT826)
C vppph_bb (vebb)
C vhhhp_ba (vmba)
      CALL RDINT(1,NOBUA,NOAB,VMBA,NFT827)
C vppph_ba (veba)
C vhpraa
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPRAA,23)
C vhprbb
      CALL RDINT(1,NOBUB,NOBUB,VHPRBB,NFT830)
C vhprab
      CALL RDINT(1,NOBUB,NOAUA,VHPRAB,NFT833)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPRAB,23)
      CALL TRAN34N(NUA,NUB,NOA,NOB,TI,VHPRAB)
C fhpi_a
      CALL RCCFL(NFT843,5,NOAUA,FHPAA)
      CALL INSITU(NUA,NUA,NOA,NOA,TI,VHPRAA,13)
      CALL CCMATMUL(O1AA,VHPRAA,FHPAA,1,NOAUA,NOAUA,0,1)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,VHPRAA,13)
      CALL INSITU(NUA,NUB,NOB,NOA,TI,VHPRAB,13)
      CALL CCMATMUL(O1BB,VHPRAB,FHPAA,1,NOAUA,NOBUB,0,0)
      CALL INSITU(NOB,NUB,NUA,NOA,TI,VHPRAB,13)
      CALL TRANSNQN(NUA,NOA,FHPAA,TI)
      CALL WRTAB2(NOA,NUA,FHPAA,5,NFT891)
C        write(6,*) 'fhpi_a'
C        call flshbf(6)
C        call druk2(noa,nua,fhpaa)
C        call flshbf(6)
C     Fhhi_a
      CALL RCCFL(NFT843,7,NOA2,FHHAA)
      CALL TRANSNQN(NOA,NUA,FHPAA,TI)
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL CCMATMUL(O2AA,VHPRAA,FHHAA,NOA,NOA,NOAUA2,0,1)
      CALL CCMATMUL(O2AB,VHPRAB,FHHAA,NOA,NOA,NOBUAB,0,0)
      CALL CCMATMUL(O1AA,FHPAA,FHHAA,NOA,NOA,NUA,0,0)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,13)
      CALL CCMATMUL(VMAA,O1AA,FHHAA,NOA2,1,NOAUA,0,1)
      CALL TRANMD(VMAB,NOA,NOB,NOA,NUB,13)
      CALL INSITU(NOA,NOB,NOA,NUB,TI,VMAB,23)
      CALL CCMATMUL(VMAB,O1BB,FHHAA,NOA2,1,NOBUB,0,0)
      CALL WRTAB2(NOA,NOA,FHHAA,3,NFT891)
C       write(6,*) 'fhhi_aa'
C        call flshbf(6)
C       call druk2(noa,noa,fhhaa)
C        call flshbf(6)
C     Fppi_a
      CALL RCCFL(NFT843,9,NUA2,FPPAA)
      CALL RDINT(1,NOAUA,NUA2,VEAA,NFT836)
      CALL TRAN24(NOA,NUA,NUA,NOA,TI,O2AA)
      CALL TRANMD(O2AA,NOA,NOA,NUA,NUA,12)
      CALL INSITU(NOA,NOA,NUA,NUA,TI,O2AA,13)
      CALL TRANMD(VHPRAA,NUA,NUA,NOA,NOA,12)
      CALL CCMATMUL(VHPRAA,O2AA,FPPAA,NUA,NUA,NOA2UA,0,0)
      CALL TRAN24(NOA,NUA,NUB,NOB,TI,O2AB)
      CALL INSITU(NOA,NOB,NUB,NUA,TI,O2AB,13)
      CALL CCMATMUL(VHPRAB,O2AB,FPPAA,NUA,NUA,NOABUB,0,1)
      CALL CCMATMUL(FHPAA,O1AA,FPPAA,NUA,NUA,NOA,0,1)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,13)
      CALL TRANMD(VEAA,NUA,NUA,NUA,NOA,12)
      CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL CCMATMUL(VEAA,O1AA,FPPAA,NUA2,1,NOAUA,0,1)
      CALL RDINT(1,NOBUA,NUAB,VEAA,NFT839)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAA,23)
      CALL CCMATMUL(VEAA,O1BB,FPPAA,NUA2,1,NOBUB,0,0)
      CALL WRTAB2(NUA,NUA,FPPAA,1,NFT891)
C        write(6,*) 'fppi_aa'
C        call flshbf(6)
C        call druk2(nua,nua,fppaa)
C        call flshbf(6)
C fhp_b
        CALL RCCFL(NFT843,6,NOBUB,FHPBB)
      CALL TRANMD(VHPRBB,NUB,NOB,NUB,NOB,13)
      CALL CCMATMUL(O1BB,VHPRBB,FHPBB,1,NOBUB,NOBUB,0,1)
      CALL TRANMD(VHPRBB,NUB,NOB,NUB,NOB,13)
      CALL TRANSNQN(NUB,NOB,FHPBB,TI)
      CALL INSITU(NUA,NUB,NOB,NOA,TI,VHPRAB,13)
      CALL CCMATMUL(VHPRAB,O1AA,FHPBB,NOBUB,1,NOAUA,0,0)
      CALL WRTAB2(NOB,NUB,FHPBB,6,NFT891)
C        write(6,*) 'fhpi_b'
C        call flshbf(6)
C        call druk2(nob,nub,fhpbb)
C        call flshbf(6)
C     Fhhi_b
        CALL RCCFL(NFT843,8,NOB2,FHHBB)
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPRBB,23)
      CALL CCMATMUL(O2BB,VHPRBB,FHHBB,NOB,NOB,NOBUB2,0,1)
      CALL TRAN24(NUB,NOB,NOA,NUA,TI,O2AB)
      CALL TRANSNQN(NOB,NOB,FHHBB,TI)   !JI
      CALL CCMATMUL(VHPRAB,O2AB,FHHBB,NOB,NOB,NOAUAB,0,0)
      CALL CCMATMUL(FHPBB,O1BB,FHHBB,NOB,NOB,NUB,0,0)
      CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL INSITU(NOA,NOB,NUA,NOB,TI,VMBA,23)
      CALL CCMATMUL(O1AA,VMBA,FHHBB,1,NOB2,NOAUA,0,0)
      CALL TRANSNQN(NOB,NOB,FHHBB,TI)   !IJ
      CALL TRAN24(NOB,NOB,NOB,NUB,TI,VMBB)
      CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL CCMATMUL(O1BB,VMBB,FHHBB,1,NOB2,NOBUB,0,1)
      CALL WRTAB2(NOB,NOB,FHHBB,4,NFT891)
C        write(6,*) 'fhhi_bb'
C        call flshbf(6)
C        call druk2(nob,nob,fhhbb)
C        call flshbf(6)
C     Fppi_b
        CALL RCCFL(NFT843,10,NUB2,FPPBB)
      CALL RDINT(1,NOBUB,NUB2,VEAA,NFT837)
      CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL CCMATMUL(O1BB,FHPBB,FPPBB,NUB,NUB,NOB,0,1) !BA
      CALL TRANMD(VEAA,NUB,NUB,NUB,NOB,13)
      CALL CCMATMUL(VEAA,O1BB,FPPBB,NUB2,1,NOBUB,0,1) !BA
      CALL RDINT(1,NOAUB,NUAB,VEAA,NFT838)
      CALL TRAN14(NUA,NUB,NOA,NUB,TI,VEAA)
      CALL CCMATMUL(VEAA,O1AA,FPPBB,NUB2,1,NOAUA,0,0) !BA
      CALL TRAN24(NOB,NUB,NUB,NOB,TI,O2BB)
      CALL TRANMD(O2BB,NOB,NOB,NUB,NUB,12)
      CALL INSITU(NOB,NOB,NUB,NUB,TI,O2BB,13)
      CALL TRANMD(VHPRBB,NUB,NUB,NOB,NOB,12)
      CALL TRAN14(NUB,NUA,NOA,NOB,TI,O2AB)
      CALL INSITU(NOB,NUB,NUA,NOA,TI,VHPRAB,12)
      CALL TRANSNQN(NUB,NUB,FPPBB,TI)
      CALL CCMATMUL(VHPRAB,O2AB,FPPBB,NUB,NUB,NOABUA,0,1)
      CALL CCMATMUL(VHPRBB,O2BB,FPPBB,NUB,NUB,NOB2UB,0,0) !AB
      CALL WRTAB2(NUB,NUB,FPPBB,2,NFT891)
C      write(6,*) 'fppi_bb'
C        call flshbf(6)
C        call druk2(nub,nub,fppbb)
C        call flshbf(6)
C
C o1, o2 back ordering
      CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL VECMUL(O2AA,NOA2UA2,TWO)
      CALL TRANSQ(O2AA,NOAUA)
      CALL TRAN14(NOA,NUA,NUA,NOA,TI,O2AA) !IABJ
      CALL VECMUL(O2BB,NOB2UB2,TWO)
      CALL TRANSQ(O2BB,NOBUB)
      CALL TRAN14(NOB,NUB,NUB,NOB,TI,O2BB) !IABJ
      CALL INSITU(NOB,NUA,NOA,NUB,TI,O2AB,13)
      CALL TRAN34N(NOA,NUA,NOB,NUB,TI,O2AB) !IABJ
      RETURN
      END
C
C*MODULE ROHFCC  *DECK TWOHBAR
      SUBROUTINE TWOHBAR(NOA,NUA,NOB,NUB,O1AA,O1BB,
     *                   VHHAA,VHPLAA,O2AA,O2BB,O2AB,VEBB,VEAB,VEBA,
     *                   VHPRBB,VHPRAA,VHPRAB,TI,VMAB,VMBA,VMAA,
     *                   FHP,VPP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION TI(1),VHPLAA(1),VHPRAA(1),VHHAA(1),
     *          O1AA(1),O1BB(1),O2AA(1),O2AB(1),O2BB(1),
     *          VEBB(1),VEAB(1),VHPRAB(1),VHPRBB(1),
     *          VMBA(1),VMAB(1),VMAA(1),VEBA(1),FHP(1),VPP(1)
C
      DATA TWO/2.0D+00/,HALF/0.5D+00/
C
C        'jestem w twobody'
C
      NOA2OBUB=NOA2OB*NUB
C
      CALL RDTAB2(NOA,NUA,O1AA,1,NFT825)
      CALL RDTAB2(NOB,NUB,O1BB,2,NFT825)
      CALL RDTAB(NOA,NUA,NUA,NOA,O2AA,3,NFT825)
      CALL RDTAB(NOB,NUB,NUB,NOB,O2BB,4,NFT825)
      CALL RDTAB(NOA,NUA,NUB,NOB,O2AB,5,NFT825)
C
C vhpraa
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
C vhprbb
      CALL RDINT(1,NOBUB,NOBUB,VHPRBB,NFT830)
C vhprab
      CALL RDINT(1,NOBUB,NOAUA,VHPRAB,NFT833)
C
C VMAA_I (veaa tepm = vmaa)
      CALL RDINT(1,NOAUA,NOA2,VMAA,NFT823)
      CALL TRAN34N(NUA,NOA,NUA,NOA,TI,VHPRAA)
      CALL CCMATMUL(O1AA,VHPRAA,VEAB,NOA,NOA2UA,NUA,1,0)
      CALL TRANMD(VEAB,NOA,NOA,NOA,NUA,13)
      CALL TRANMD(VEAB,NOA,NOA,NOA,NUA,12)
        CALL VECADD(VMAA,VEAB,NOA3UA)
         CALL WRTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
C        write(6,*) 'vmaa_i'
Cc      CALL DRUK(noa,noa,noa,nua,vmaa)
C VMBB_I (vebb tepm = vmbb)
      CALL RDINT(1,NOBUB,NOB2,VMBA,NFT826)
      CALL TRAN34N(NUB,NOB,NUB,NOB,TI,VHPRBB)
      CALL CCMATMUL(O1BB,VHPRBB,VEBA,NOB,NOB2UB,NUB,1,0)
      CALL TRANMD(VEBA,NOB,NOB,NOB,NUB,13)
      CALL TRANMD(VEBA,NOB,NOB,NOB,NUB,12)
        CALL VECADD(VMBA,VEBA,NOB3UB)
         CALL WRTAB(NOB,NOB,NOB,NUB,VMBA,15,NFT891)
C        write(6,*) 'vmbb_i'
Cc      CALL DRUK(nob,nob,nob,nub,vmba)
C VMAB_I (veab tepm = vmab)
      CALL RDINT(1,NOAUB,NOAB,VMAB,NFT828)
      CALL TRAN34N(NUA,NOA,NUB,NOB,TI,VHPRAB)
      CALL CCMATMUL(O1AA,VHPRAB,VEAB,NOA,NOABUB,NUA,1,0)
      CALL INSITU(NOA,NOA,NOB,NUB,TI,VEAB,13)
      CALL INSITU(NOB,NOA,NOA,NUB,TI,VEAB,12)
        CALL VECADD(VMAB,VEAB,NOA2OBUB)
         CALL WRTAB(NOA,NOB,NOA,NUB,VMAB,16,NFT891)
C        write(6,*) 'vmab_i'
Cc      CALL DRUK(noa,nob,noa,nub,vmab)
C VHHHH_aa
      CALL RDINT(1,NOA2,NOA2,VHHAA,NFT820)
      CALL TRANSQ(VHHAA,NOA2)
      CALL TRAN1TO4(NUA,NOA,NOA,NUA,TI,VHPRAA) !KLFE
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,O2AA,13)
      CALL CCMATMUL(VHPRAA,O2AA,VHHAA,NOA2,NOA2,NUA2,0,0)
        CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL CCMATMUL(VMAA,O1AA,VHHAA,NOA3,NOA,NUA,0,0)
      CALL TRANSQ(VHHAA,NOA2)
      CALL RDINT(1,NOAUA,NOA2,VMAA,NFT823)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,12)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,23)
      CALL TRAN14(NOA,NOA,NOA,NUA,TI,VMAA)
        CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL CCMATMUL(O1AA,VMAA,VHHAA,NOA,NOA3,NUA,0,1)
C        write(6,*) 'vhhaa_i'
      CALL WRTAB(NOA,NOA,NOA,NOA,VHHAA,7,NFT891)
Cc      CALL DRUK(noa,noa,noa,noa,vhhaa)
C
C VHPLAA_I
      CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
      CALL RDINT(1,NOAUA,NOAUA,VHPLAA,NFT831)
      CALL RDINT(1,NOAUA,NUA2,VEAB,NFT836)
      CALL TRANSQ(VHPLAA,NOAUA)
      CALL TRAN24(NUA,NUA,NUA,NOA,TI,VEAB)
        CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL CCMATMUL(VEAB,O1AA,VHPLAA,NOAUA2,NOA,NUA,0,0)
      CALL TRAN14(NOA,NOA,NUA,NUA,TI,VHPRAA)
      CALL VECMUL(O2AA,NOA2UA2,TWO)
      CALL INSITU(NUA,NUA,NOA,NOA,TI,O2AA,23)
      CALL CCMATMUL(VHPRAA,O2AA,VHPLAA,NOAUA,NOAUA,NOAUA,0,1)
      CALL TRANSQ(VHPLAA,NOAUA)
        CALL TRANSNQN(NOAUA,NOBUB,VHPRAB,TI)
      CALL INSITU(NOB,NUB,NUA,NOA,TI,VHPRAB,12)
      CALL INSITU(NOA,NUA,NUB,NOB,TI,O2AB,12)
      CALL CCMATMUL(O2AB,VHPRAB,VHPLAA,NOAUA,NOAUA,NOBUB,0,1)
      CALL TRAN1TO4(NOA,NOA,NOA,NUA,TI,VMAA)
      CALL CCMATMUL(O1AA,VMAA,VHPLAA,NUA,NOA2UA,NOA,0,1)
C        write(6,*) 'vhpla_i'
      CALL WRTAB(NUA,NOA,NUA,NOA,VHPLAA,1,NFT892)
C      CALL DRUK(nua,noa,nua,noa,vhplaa)
C VHPLBB_I
        CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL RDINT(1,NOBUB,NOBUB,VHPLAA,NFT832)
      CALL RDINT(1,NOBUB,NUB2,VEBA,NFT837)
      CALL TRANSQ(VHPLAA,NOBUB)
      CALL TRAN24(NUB,NUB,NUB,NOB,TI,VEBA)
      CALL CCMATMUL(VEBA,O1BB,VHPLAA,NOBUB2,NOB,NUB,0,0)
      CALL TRAN1TO4(NUB,NOB,NOB,NUB,TI,VHPRBB)
      CALL TRAN14(NOB,NOB,NUB,NUB,TI,VHPRBB)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,O2BB,13)
      CALL INSITU(NUB,NUB,NOB,NOB,TI,O2BB,23)
      CALL CCMATMUL(VHPRBB,O2BB,VHPLAA,NOBUB,NOBUB,NOBUB,0,1)
      CALL CCMATMUL(VHPRAB,O2AB,VHPLAA,NOBUB,NOBUB,NOAUA,0,1)
      CALL TRANSQ(VHPLAA,NOBUB)
      CALL TRAN1TO4(NOB,NOB,NOB,NUB,TI,VMBA)
      CALL CCMATMUL(O1BB,VMBA,VHPLAA,NUB,NOB2UB,NOB,0,1)
      CALL WRTAB(NUB,NOB,NUB,NOB,VHPLAA,2,NFT892)
C      CALL DRUK(nub,nob,nub,nob,vhplaa)
C
C VMBA_I
      CALL RDINT(1,NOBUA,NOAB,VMBA,NFT827)
      CALL TRAN14(NUB,NOB,NUA,NOA,TI,VHPRAB)
      CALL CCMATMUL(VHPRAB,O1BB,VMBA,NOABUA,NOB,NUB,0,0)
         CALL WRTAB(NOA,NOB,NUA,NOB,VMBA,17,NFT891)
C        write(6,*) 'vmba_i'
Cc      CALL DRUK(noa,nob,nua,nob,vmba)
C VHPLAB_I
      CALL RDINT(1,NOBUA,NOBUA,VHPLAA,NFT834)
      CALL RDINT(1,NOBUA,NUAB,VEAB,NFT839)
      CALL TRANSQ(VHPLAA,NOBUA)
      CALL TRAN24(NUA,NUB,NUA,NOB,TI,VEAB)
      CALL CCMATMUL(VEAB,O1BB,VHPLAA,NOBUA2,NOB,NUB,0,0)
      CALL TRAN24(NUA,NOA,NUB,NOB,TI,O2AB)
      CALL INSITU(NOA,NOB,NUA,NUB,TI,VHPRAB,13)
        CALL TRANSNQN(NOBUA,NOAUB,VHPRAB,TI)
      CALL INSITU(NOA,NUB,NUA,NOB,TI,VHPRAB,12)
      CALL TRANSQ(VHPLAA,NOBUA)
      CALL CCMATMUL(O2AB,VHPRAB,VHPLAA,NOBUA,NOBUA,NOAUB,0,1)
      CALL TRAN24(NOA,NOB,NUA,NOB,TI,VMBA)
      CALL CCMATMUL(O1AA,VMBA,VHPLAA,NUA,NOB2UA,NOA,0,1)
C        write(6,*) 'vhplab_i'
      CALL WRTAB(NUA,NOB,NUA,NOB,VHPLAA,4,NFT892)
C      CALL DRUK(nua,nob,nua,nob,vhplaa)
C
C VHPLBA_I
      CALL RDINT(1,NOAUB,NOAUB,VHPLAA,NFT835)
C      CALL DRUK(nub,noa,nub,noa,vhplba)
      CALL RDINT(1,NOAUB,NUAB,VEBA,NFT838)
      CALL TRANSQ(VHPLAA,NOAUB)
      CALL TRAN1TO4(NUA,NUB,NOA,NUB,TI,VEBA)
      CALL CCMATMUL(VEBA,O1AA,VHPLAA,NOAUB2,NOA,NUA,0,0)
      CALL CCMATMUL(VHPRAB,O2AB,VHPLAA,NOAUB,NOAUB,NOBUA,0,1)
      CALL TRANSQ(VHPLAA,NOAUB)
      CALL TRAN1TO4(NOA,NOB,NOA,NUB,TI,VMAB)
      CALL CCMATMUL(O1BB,VMAB,VHPLAA,NUB,NOA2UB,NOB,0,1)
      CALL WRTAB(NUB,NOA,NUB,NOA,VHPLAA,3,NFT892)
C        write(6,*) 'vhplba_i'
C      CALL DRUK(nub,noa,nub,noa,vhplaa)
C
C VHPR_AB_I (tmp veab)
        CALL ZEROMA(VEAB,1,NOAUB*NOBUA)
      CALL TRAN24(NUB,NOB,NUB,NOB,TI,O2BB)
      CALL TRAN24(NUB,NOA,NUA,NOB,TI,VHPRAB)
      CALL CCMATMUL(O2BB,VHPRAB,VEAB,NOBUB,NOAUA,NOBUB,1,1)
      CALL INSITU(NUA,NOB,NUB,NOA,TI,O2AB,13)
      CALL TRANMD(VHPRAA,NUA,NOA,NUA,NOA,13)
      CALL CCMATMUL(O2AB,VHPRAA,VEAB,NOBUB,NOAUA,NOAUA,0,1)
      CALL TRAN14(NUB,NOA,NUB,NUA,TI,VEBA) !AJBE
        CALL TRANSNQN(NOBUB,NOAUA,VEAB,TI)
      CALL CCMATMUL(VEBA,O1BB,VEAB,NOAUAB,NOB,NUB,0,1)
        CALL TRANSNQN(NOAUA,NOBUB,VEAB,TI)
      CALL TRAN14(NOA,NOB,NUA,NOB,TI,VMBA)
      CALL CCMATMUL(O1BB,VMBA,VEAB,NUB,NOABUA,NOB,0,0)
      CALL VECSUB(VEAB,VHPRAB,NOAUA*NOBUB)
C
      CALL WRTAB(NUB,NOB,NUA,NOA,VEAB,6,NFT892)
C        write(6,*) 'vhprab_i'
C      CALL DRUK(nub,nob,nua,noa,veab)
C
C VHPR_BA_I (tmp veba)
        CALL ZEROMA(VEBA,1,NOAUB*NOBUA)
      CALL TRANMD(O2AA,NUA,NOA,NUA,NOA,13)
      CALL CCMATMUL(VHPRAB,O2AA,VEBA,NOBUB,NOAUA,NOAUA,1,1)
      CALL TRANMD(VHPRBB,NUB,NOB,NUB,NOB,13)
      CALL CCMATMUL(VHPRBB,O2AB,VEBA,NOBUB,NOAUA,NOBUB,0,1)
      CALL RDINT(1,NOBUA,NUAB,VEAB,NFT839)
      CALL TRAN1TO4(NUA,NUB,NUA,NOB,TI,VEAB)
      CALL INSITU(NUB,NUA,NOB,NUA,TI,VEAB,23)
      CALL CCMATMUL(VEAB,O1AA,VEBA,NOBUAB,NOA,NUA,0,1)
      CALL VECSUB(VEBA,VHPRAB,NOAUA*NOBUB)
      CALL TRAN34N(NUB,NOB,NUA,NOA,TI,VEBA) !AJIB
      CALL INSITU(NOB,NOA,NUB,NOA,TI,VMAB,12)
      CALL INSITU(NOA,NOB,NUB,NOA,TI,VMAB,13)
        CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL CCMATMUL(VMAB,O1AA,VEBA,NOABUB,NUA,NOA,0,0)
C
      CALL WRTAB(NUB,NOB,NOA,NUA,VEBA,5,NFT892)
C        write(6,*) 'vhprba_i'
C      CALL DRUK(nub,nob,noa,nua,veba)
C
C VM_21 (vhpraa temp)
      CALL TRAN14(NOA,NOA,NUA,NOA,TI,VMAA)
      CALL TRAN24(NUA,NOA,NUA,NOA,TI,O2AA) !EMAJ
      CALL CCMATMUL(VMAA,O2AA,VHPRAA,NOA2,NOAUA,NOAUA,1,1) !KIAJ
      CALL TRAN24(NUB,NOB,NOA,NOA,TI,VMAB)
      CALL INSITU(NUB,NOA,NOA,NOB,TI,VMAB,13) !IKEM
      CALL TRANMD(VHPRAA,NOA,NOA,NUA,NOA,12) !IKAJ
      CALL CCMATMUL(VMAB,O2AB,VHPRAA,NOA2,NOAUA,NOBUB,0,0) !IKAJ
      CALL TRAN14(NOA,NOA,NUA,NOA,TI,VHPRAA) !JKAI
      CALL CCMATMUL(VMAB,O2AB,VHPRAA,NOA2,NOAUA,NOBUB,0,1) !JKAI
      CALL TRANMD(VHPRAA,NOA,NOA,NUA,NOA,12) !KJAI
      CALL CCMATMUL(VMAA,O2AA,VHPRAA,NOA2,NOAUA,NOAUA,0,0)
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)
      CALL CCMATMUL(FHP,O2AA,VHPRAA,NOA,NOA2UA,NUA,0,0) !*
      CALL RDINT(1,NOAUA,NUA2,VEAB,NFT836)
      CALL TRAN14(NUA,NOA,NUA,NOA,TI,O2AA)
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL TRAN14(NOA,NOA,NUA,NOA,TI,VHPRAA) !IJAK
      CALL CCMATMUL(O2AA,VEAB,VHPRAA,NOA2,NOAUA,NUA2,0,0)  !*
      CALL VECMUL(O2AA,NOA2UA2,TWO)
      CALL RDINT(1,NOAUA,NOAUA,VHPLAA,NFT831)
      CALL TRANMD(VHPLAA,NUA,NOA,NUA,NOA,13) ! EJAK
      CALL CCMATMUL(O1AA,VHPLAA,VHPRAA,NOA,NOA2UA,NUA,0,1) !*
      CALL TRANMD(VEAB,NUA,NUA,NUA,NOA,12)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPLAA,12)
      CALL CCMATMUL(O1AA,VEAB,VHPLAA,NOA,NOAUA2,NUA,0,0)
      CALL INSITU(NOA,NUA,NUA,NOA,TI,VHPLAA,12)
      CALL TRANMD(VHPRAA,NOA,NOA,NUA,NOA,12) ! JIAK
      CALL CCMATMUL(O1AA,VHPLAA,VHPRAA,NOA,NOA2UA,NUA,0,0)
      CALL TRANMD(VHPRAA,NOA,NOA,NUA,NOA,12)
      CALL TRAN34N(NOA,NOA,NUA,NOA,TI,VHPRAA)
      CALL CCMATMUL(VHHAA,O1AA,VHPRAA,NOA3,NUA,NOA,0,1) !IJKA
      CALL RDINT(1,NOAUA,NOA2,VMAA,NFT823)
        CALL VECADD(VHPRAA,VMAA,NOA3UA)
         CALL WRTAB(NOA,NOA,NOA,NUA,VHPRAA,10,NFT891)
Cc        write(6,*) 'vm21_i'
Cc      CALL DRUK(noa,noa,noa,nua,vhpraa)
C
C VHHHH_bb
      CALL RDINT(1,NOB2,NOB2,VHHAA,NFT821)
      CALL TRANSQ(VHHAA,NOB2)
      CALL TRAN14(NUB,NOB,NUB,NOB,TI,VHPRBB)
      CALL TRANMD(VHPRBB,NOB,NOB,NUB,NUB,34)
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL TRANMD(O2BB,NUB,NOB,NUB,NOB,24)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,O2BB,23)
      CALL CCMATMUL(VHPRBB,O2BB,VHHAA,NOB2,NOB2,NUB2,0,0)
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
      CALL CCMATMUL(VMAA,O1BB,VHHAA,NOB3,NOB,NUB,0,0)
      CALL TRANSQ(VHHAA,NOB2)
      CALL RDINT(1,NOBUB,NOB2,VMAA,NFT826)
      CALL TRANMD(VMAA,NOB,NOB,NOB,NUB,12)
      CALL TRANMD(VMAA,NOB,NOB,NOB,NUB,23)
      CALL TRAN14(NOB,NOB,NOB,NUB,TI,VMAA)
        CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL CCMATMUL(O1BB,VMAA,VHHAA,NOB,NOB3,NUB,0,1)
C        write(6,*) 'vhhbb_i'
      CALL WRTAB(NOB,NOB,NOB,NOB,VHHAA,8,NFT891)
Cc      CALL DRUK(nob,nob,nob,nob,vhhaa)
C
C VM_21 (vhprbb temp)
      CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
      CALL TRAN1TO4(NOB,NOB,NOB,NUB,TI,VMAA)
      CALL TRAN14(NOB,NOB,NUB,NOB,TI,VMAA)
      CALL VECMUL(O2BB,NOB2UB2,TWO)
      CALL INSITU(NUB,NUB,NOB,NOB,TI,O2BB,23)
      CALL TRANSQ(O2BB,NOBUB)
      CALL CCMATMUL(VMAA,O2BB,VHPRBB,NOB2,NOBUB,NOBUB,1,1) !KIAJ
      CALL TRANSNQN(NOBUB,NOAUA,O2AB,TI)
      CALL CCMATMUL(VMBA,O2AB,VHPRBB,NOB2,NOBUB,NOAUA,0,0)
      CALL TRAN24(NOB,NOB,NUB,NOB,TI,VHPRBB) !KJAI
      CALL CCMATMUL(VMBA,O2AB,VHPRBB,NOB2,NOBUB,NOAUA,0,1)
      CALL CCMATMUL(VMAA,O2BB,VHPRBB,NOB2,NOBUB,NOBUB,0,0)
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891)
      CALL CCMATMUL(FHP,O2BB,VHPRBB,NOB,NOB2UB,NUB,0,0)
      CALL RDINT(1,NOBUB,NUB2,VEBA,NFT837)
      CALL TRAN14(NUB,NOB,NUB,NOB,TI,O2BB)
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL TRAN14(NOB,NOB,NUB,NOB,TI,VHPRBB) !IJAK
      CALL CCMATMUL(O2BB,VEBA,VHPRBB,NOB2,NOBUB,NUB2,0,0)
      CALL VECMUL(O2BB,NOB2UB2,TWO)
      CALL RDINT(1,NOBUB,NOBUB,VHPLAA,NFT832)
      CALL TRANMD(VHPLAA,NUB,NOB,NUB,NOB,13) ! EJAK
      CALL CCMATMUL(O1BB,VHPLAA,VHPRBB,NOB,NOB2UB,NUB,0,1)
      CALL TRANMD(VEBA,NUB,NUB,NUB,NOB,12)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPLAA,12)
      CALL CCMATMUL(O1BB,VEBA,VHPLAA,NOB,NOBUB2,NUB,0,0)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,VHPLAA,12)
      CALL TRANMD(VHPRBB,NOB,NOB,NUB,NOB,12) ! JIAK
      CALL CCMATMUL(O1BB,VHPLAA,VHPRBB,NOB,NOB2UB,NUB,0,0)
      CALL TRANMD(VHPRBB,NOB,NOB,NUB,NOB,12)
      CALL TRAN34N(NOB,NOB,NUB,NOB,TI,VHPRBB)
      CALL CCMATMUL(VHHAA,O1BB,VHPRBB,NOB3,NUB,NOB,0,1) !IJKA
      CALL RDINT(1,NOBUB,NOB2,VMAA,NFT826)
        CALL VECADD(VHPRBB,VMAA,NOB3UB)
         CALL WRTAB(NOB,NOB,NOB,NUB,VHPRBB,11,NFT891)
Cc        write(6,*) 'vm21bb_i'
Cc      CALL DRUK(nob,nob,nob,nub,vhprbb)
C
C VHHHH_ab
      CALL RDINT(1,NOAB,NOAB,VHHAA,NFT822)
      CALL TRANSQ(VHHAA,NOAB)
      CALL TRAN14(NUB,NOB,NUA,NOA,TI,VHPRAB)
      CALL TRAN34N(NOA,NOB,NUA,NUB,TI,VHPRAB)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,13)
      CALL INSITU(NUB,NOA,NUA,NOB,TI,O2AB,23)
      CALL CCMATMUL(VHPRAB,O2AB,VHHAA,NOAB,NOAB,NUAB,0,0)
        CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL INSITU(NOA,NOA,NUB,NOB,TI,VMAB,23)
        CALL TRANSNQN(NOAUB,NOAB,VMAB,TI)
      CALL CCMATMUL(VMAB,O1BB,VHHAA,NOA2OB,NOB,NUB,0,0)
      CALL TRANSQ(VHHAA,NOAB)
      CALL RDINT(1,NOBUA,NOAB,VEBA,NFT827)
      CALL INSITU(NOA,NOB,NUA,NOB,TI,VEBA,13)
      CALL TRAN24(NUA,NOB,NOA,NOB,TI,VEBA)
      CALL CCMATMUL(O1AA,VEBA,VHHAA,NOA,NOAOB2,NUA,0,0)
C        write(6,*) 'vhhab_i'
      CALL WRTAB(NOA,NOB,NOA,NOB,VHHAA,9,NFT891)
Cc      CALL DRUK(noa,nob,noa,nob,vhhaa)
C
C VM_21ab (vhpraa temp)
         CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
        CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,23) !KIME
      CALL INSITU(NUB,NUA,NOA,NOB,TI,O2AB,13)
      CALL CCMATMUL(VMAA,O2AB,VHPRAA,NOA2,NOBUB,NOAUA,1,0) !KIAJ
      CALL INSITU(NOA,NUA,NUB,NOB,TI,O2AB,12)
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)
      CALL CCMATMUL(FHP,O2AB,VHPRAA,NOA,NOABUB,NUA,0,0)
      CALL TRANMD(VHPRAA,NOA,NOA,NUB,NOB,12) !IKAJ
      CALL TRAN1TO4(NOB,NOB,NUB,NUB,TI,O2BB)
      CALL INSITU(NOB,NUB,NUB,NOB,TI,O2BB,12)
        CALL TRANSNQN(NOAB,NOAUB,VMAB,TI)
      CALL INSITU(NOA,NUB,NOA,NOB,TI,VMAB,23)
      CALL CCMATMUL(VMAB,O2BB,VHPRAA,NOA2,NOBUB,NOBUB,0,0)  !IKAJ
      CALL INSITU(NOA,NOA,NUB,NOB,TI,VHPRAA,23) !IAKJ
      CALL TRANSNQN(NOB2,NOAUA,VMBA,TI)
      CALL INSITU(NUA,NOA,NOB,NOB,TI,VMBA,23)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,13)
      CALL INSITU(NUB,NOA,NUA,NOB,TI,O2AB,12)
      CALL CCMATMUL(O2AB,VMBA,VHPRAA,NOAUB,NOAB,NOBUA,0,1)
      CALL TRAN24(NOA,NUB,NOA,NOB,TI,VHPRAA)
      CALL TRAN24(NOA,NUB,NUA,NOB,TI,O2AB)
      CALL RDINT(1,NOAUB,NUAB,VEBA,NFT838)
      CALL CCMATMUL(O2AB,VEBA,VHPRAA,NOAB,NOAUB,NUAB,0,0) !*IJKA
      CALL TRAN14(NOA,NOB,NUB,NUA,TI,VHPRAB)
      CALL TRAN34N(NUA,NOB,NUB,NOA,TI,VHPRAB)
      CALL CCMATMUL(O1AA,VHPRAB,VHPRAA,NOA,NOABUB,NUA,0,0) !*
      CALL RDINT(1,NOAUB,NOAUB,VHPLAA,NFT835)
      CALL TRAN1TO4(NUB,NOA,NUB,NOA,TI,VHPLAA)
      CALL CCMATMUL(O1AA,VEBA,VHPLAA,NOA,NOAUB2,NUA,0,0)
      CALL INSITU(NOA,NOB,NOA,NUB,TI,VHPRAA,12) !JIKA
      CALL INSITU(NOA,NUB,NOA,NUB,TI,VHPLAA,12)
      CALL CCMATMUL(O1BB,VHPLAA,VHPRAA,NOB,NOA2UB,NUB,0,0)
      CALL INSITU(NOB,NOA,NOA,NUB,TI,VHPRAA,12) !IJKA
      CALL CCMATMUL(VHHAA,O1BB,VHPRAA,NOA2OB,NUB,NOB,0,1) !*
      CALL RDINT(1,NOAUB,NOAB,VMAB,NFT828)
        CALL VECADD(VHPRAA,VMAB,NOA2OBUB)
         CALL WRTAB(NOA,NOB,NOA,NUB,VHPRAA,12,NFT891) !VMAB21
C        write(6,*) 'vm21ab_i'
Cc      CALL DRUK(noa,nob,noa,nub,vhpraa)
C
      CALL RDINT(1,NOBUA,NUAB,VEAB,NFT839)
         CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
      CALL TRANMD(VMAA,NOB,NOB,NOB,NUB,23) !KIME
      CALL INSITU(NOA,NOB,NUA,NUB,TI,O2AB,23)
      CALL INSITU(NOA,NUA,NOB,NUB,TI,O2AB,12)
      CALL TRANSNQN(NOAUA,NOBUB,O2AB,TI)
      CALL CCMATMUL(VMAA,O2AB,VHPRBB,NOB2,NOAUA,NOBUB,1,0) !KIAJ
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891)
      CALL INSITU(NOB,NUB,NOA,NUA,TI,O2AB,12)
      CALL CCMATMUL(FHP,O2AB,VHPRBB,NOB,NOABUA,NUB,0,0) !KIAJ
      CALL TRANSNQN(NOB2,NOAUA,VHPRBB,TI) !AJKI
      CALL INSITU(NOA,NOA,NUA,NUA,TI,O2AA,13)
      CALL INSITU(NUA,NOB,NOA,NOB,TI,VMBA,23)
      CALL INSITU(NUA,NOA,NOB,NOB,TI,VMBA,12)
      CALL CCMATMUL(O2AA,VMBA,VHPRBB,NOAUA,NOB2,NOAUA,0,0)
      CALL TRANSNQN(NOBUB,NOAUA,O2AB,TI)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,13)
      CALL INSITU(NUB,NOA,NUA,NOB,TI,O2AB,12)
         CALL RDTAB(NOA,NOB,NOA,NUB,VMAB,16,NFT891)
      CALL TRANMD(VMAB,NOA,NOB,NOA,NUB,13)
      CALL INSITU(NOA,NOB,NOA,NUB,TI,VMAB,12)
      CALL INSITU(NUA,NOA,NOB,NOB,TI,VHPRBB,13)
      CALL CCMATMUL(VMAB,O2AB,VHPRBB,NOAB,NOBUA,NOAUB,0,1) !KJAI
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,12)
      CALL TRANSNQN(NUAB,NOBUA,VEAB,TI)
      CALL INSITU(NOA,NUB,NUA,NOB,TI,O2AB,13)
      CALL INSITU(NUA,NUB,NOA,NOB,TI,O2AB,12)
      CALL INSITU(NOB,NOA,NUA,NOB,TI,VHPRBB,23)
      CALL INSITU(NOB,NUA,NOA,NOB,TI,VHPRBB,12)
      CALL CCMATMUL(VEAB,O2AB,VHPRBB,NOBUA,NOAB,NUAB,0,0)
      CALL RDINT(1,NOBUA,NOBUA,VHPLAA,NFT834)
      CALL INSITU(NUA,NOB,NUA,NOB,TI,VHPLAA,23)
      CALL TRANSNQN(NUA2,NOB2,VHPLAA,TI)
      CALL INSITU(NUA,NOB,NUB,NUA,TI,VEAB,13)
      CALL CCMATMUL(O1BB,VEAB,VHPLAA,NOB,NOBUA2,NUB,0,0)
      CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL CCMATMUL(VHPRAB,O1BB,VHPRBB,NOABUA,NOB,NUB,0,0)
      CALL TRANSQ(VHHAA,NOAB)
      CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL CCMATMUL(O1AA,VHHAA,VHPRBB,NUA,NOAOB2,NOA,0,1) !*
      CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL INSITU(NOB,NOB,NUA,NUA,TI,VHPLAA,13)
      CALL TRANSNQN(NOBUA,NOBUA,VHPLAA,TI)
      CALL INSITU(NOB,NUA,NUA,NOB,TI,VHPLAA,12)
      CALL TRANSNQN(NOBUA,NOAB,VHPRBB,TI) !JIAK
      CALL CCMATMUL(O1AA,VHPLAA,VHPRBB,NOA,NOB2UA,NUA,0,0)
      CALL RDINT(1,NOBUA,NOAB,VMBA,NFT827)
        CALL VECADD(VHPRBB,VMBA,NOAOB2UA)
         CALL WRTAB(NOA,NOB,NUA,NOB,VHPRBB,13,NFT891) !VMBA21
C        write(6,*) 'vm21ba_i'
Cc      CALL DRUK(noa,nob,nua,nob,vhprbb)
C
      CALL TRANSNQN(NOA,NUA,O1AA,TI)
      CALL TRANSNQN(NOBUA,NOAUB,VHPRAB,TI)
      CALL TRANSNQN(NOBUB,NUA2,VEAB,TI)
      CALL INSITU(NUA,NUA,NUB,NOB,TI,VEAB,23)
      CALL CCMATMUL(O1AA,VHPRAB,VEAB,NUA,NOBUAB,NOA,0,1) !CBAI
         CALL WRTAB(NUA,NUB,NUA,NOB,VEAB,13,NFT892) !VEAB
C        write(6,*) 'veab_i for left'
C      CALL DRUK(nua,nub,nua,nob,veab)
C
      CALL INSITU(NUA,NUB,NOA,NUB,TI,VEBA,13)
      CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL CCMATMUL(VHPRAB,O1BB,VEBA,NOAUAB,NUB,NOB,0,1) !IABC
         CALL WRTAB(NOA,NUB,NUA,NUB,VEBA,14,NFT892) !VEBA
C        write(6,*) 'veba_i for left'
C      CALL DRUK(noa,nub,nua,nub,veba)
C
C VE_AA_I
      CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL RDINT(1,NOAUA,NUA2,VEAB,NFT836)
      CALL VECCOP((NOAUA*NUA2),VEBA,VEAB)
      CALL TRAN24(NUA,NUA,NUA,NOA,TI,VEAB)
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
      CALL TRAN24(NUA,NOA,NUA,NOA,TI,VHPRAA)
      CALL TRAN34N(NUA,NOA,NUA,NUA,TI,VEAB) !AIBC
      CALL CCMATMUL(VHPRAA,O1AA,VEAB,NOAUA2,NUA,NOA,0,1)
      CALL INSITU(NUA,NOA,NUA,NUA,TI,VEAB,12)
C        write(6,*) 'veaa_i'
      CALL WRTAB(NOA,NUA,NUA,NUA,VEAB,11,NFT892)
C      CALL DRUK(noa,nua,nua,nua,veab)
C
C -- VPP --
      CALL TRAN1TO4(NUA,NUA,NUA,NOA,TI,VEBA)
      CALL INSITU(NUA,NUA,NOA,NUA,TI,VEBA,13) !MCAB
C
      CALL RDINT(1,NOAUA,NOAUA,VHPRAA,NFT829)
      CALL TRANSNQN(NOAUA,NOAUA,VHPRAA,TI)
      CALL TRAN14(NUA,NOA,NUA,NOA,TI,VHPRAA) !MNAB
      CALL INSITU(NUA,NOA,NOA,NUA,TI,O2AA,23)
      CALL TRAN24(NUA,NOA,NOA,NUA,TI,O2AA) !CDMN
      CALL VECMUL(O2AA,NOA2UA2,HALF)
      CALL TRANSNQN(NOA,NUA,O1AA,TI)
C
      CALL TRANSNQN(NOAUA,NUA2,VEAB,TI)
      CALL INSITU(NUA,NUA,NOA,NUA,TI,VEAB,13)
C
      CALL HBAR4P(VPP,O1AA,O2AA,VHPRAA,VEAB,VEBA,NOA,NUA,0)
C
C VE_BB_I
      CALL RDINT(1,NOBUB,NUB2,VEBA,NFT837)
      CALL VECCOP((NOBUB*NUB2),VEAB,VEBA)
      CALL TRAN24(NUB,NUB,NUB,NOB,TI,VEBA)
      CALL RDINT(1,NOBUB,NOBUB,VHPRBB,NFT830)
      CALL TRAN24(NUB,NOB,NUB,NOB,TI,VHPRBB)
      CALL TRAN34N(NUB,NOB,NUB,NUB,TI,VEBA) !AIBC
      CALL CCMATMUL(VHPRBB,O1BB,VEBA,NOBUB2,NUB,NOB,0,1)
      CALL INSITU(NUB,NOB,NUB,NUB,TI,VEBA,12)
      CALL WRTAB(NOB,NUB,NUB,NUB,VEBA,12,NFT892)
C        write(6,*) 'vebb_i'
C      CALL DRUK(nob,nub,nub,nub,vebb)
C
C -----VPP------
C
      CALL TRAN1TO4(NUB,NUB,NUB,NOB,TI,VEAB)
      CALL INSITU(NUB,NUB,NOB,NUB,TI,VEAB,13)
C
      CALL RDINT(1,NOBUB,NOBUB,VHPRBB,NFT830)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPRBB,23)
      CALL TRANSNQN(NUB2,NOB2,VHPRBB,TI)
      CALL TRAN14(NUB,NOB,NUB,NOB,TI,O2BB)
      CALL TRANSNQN(NOB2,NUB2,O2BB,TI)
      CALL VECMUL(O2BB,NOB2UB2,HALF)
      CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL TRANSNQN(NOBUB,NUB2,VEBA,TI)
      CALL INSITU(NUB,NUB,NOB,NUB,TI,VEBA,13)
C
      CALL HBAR4P(VPP,O1BB,O2BB,VHPRBB,VEBA,VEAB,NOB,NUB,NUA)
C
         CALL RDTAB(NOA,NUB,NUA,NUB,VEBA,14,NFT892)
C
      CALL RDINT(1,NOBUA,NUAB,VEAB,NFT839)
      CALL TRANSNQN(NUAB,NOBUA,VEAB,TI)
      CALL INSITU(NUA,NOB,NUA,NUB,TI,VEAB,12)
      CALL INSITU(NUB,NUA,NOA,NOB,TI,O2AB,12)
      CALL INSITU(NOA,NUB,NUA,NOB,TI,VHPRAB,13)
      CALL TRANSNQN(NUAB,NOAB,VHPRAB,TI)
      CALL TRANSNQN(NOAUB,NUAB,VEBA,TI)
      CALL INSITU(NUA,NUB,NOA,NUB,TI,VEBA,13)
      CALL HBAR4P_AB(VPP,O1AA,O1BB,O2AB,VHPRAB,VEBA,VEAB,TI,
     *NOA,NUA,NOB,NUB,NUA+NUB)
C     ----------------------
C VEAA-21
         CALL RDTAB(NOA,NOA,NOA,NUA,VMAA,14,NFT891)
      CALL TRANMD(VMAA,NOA,NOA,NOA,NUA,23) !KIME
C
       CALL RDINT(1,NOAUA,NUA2,VEBB,NFT836)
      CALL TRANSNQN(NOA2,NOAUA,VMAA,TI)
      CALL INSITU(NOA,NUA,NOA,NOA,TI,VMAA,23)
      CALL TRANMD(O2AA,NUA,NUA,NOA,NOA,34)
      CALL TRANMD(O2AA,NUA,NUA,NOA,NOA,12)
      CALL CCMATMUL(O2AA,VMAA,VEBB,NUA2,NOAUA,NOA2,0,0) !ABCI SPROK
      CALL TRANSNQN(NUA2,NOAUA,VEBB,TI)
      CALL RDTAB(NUA,NOA,NUA,NOA,VHPLAA,1,NFT892)
      CALL TRANMD(VHPLAA,NUA,NOA,NUA,NOA,13)
      CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL CCMATMUL(VHPLAA,O1AA,VEBB,NOAUA2,NUA,NOA,0,1) !CIAB SPROK
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)
      CALL TRANSNQN(NOA,NUA,FHP,TI)
      CALL TRANSNQN(NUA2,NOA2,O2AA,TI)
      CALL VECMUL(O2AA,NOA2UA2,TWO)
      CALL CCMATMUL(FHP,O2AA,VEBB,NUA,NOAUA2,NOA,0,1) !CIAB SPROK
      CALL TRANSNQN(NUAB,NOAB,O2AB,TI)
      CALL INSITU(NOA,NOB,NUA,NUB,TI,O2AB,23)
      CALL TRANSNQN(NOAUA,NOBUB,O2AB,TI)
      CALL RDTAB(NOA,NUA,NUA,NUA,VEBA,11,NFT892)
      CALL TRANSNQN(NOAUA,NUA2,VEBA,TI)
      CALL INSITU(NUA,NUA,NOA,NUA,TI,VEBA,13)
      CALL TRANMD(VEBA,NOA,NUA,NUA,NUA,23)
      CALL INSITU(NOA,NOA,NUA,NUA,TI,O2AA,23)
      CALL TRANSQ(O2AA,NOAUA)
      CALL INSITU(NUA,NOA,NUA,NUA,TI,VEBB,12)
      CALL TRANMD(VEBB,NOA,NUA,NUA,NUA,24)
      CALL CCMATMUL(O2AA,VEBA,VEBB,NOAUA,NUA2,NOAUA,0,0) !IBAC SPROK
      CALL RDINT(1,NOAUA,NUA2,VEBA,NFT836)
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,23)
      CALL TRANMD(O2AA,NOA,NUA,NOA,NUA,13)
      CALL INSITU(NOA,NUA,NOA,NUA,TI,O2AA,12)
      CALL INSITU(NOA,NUA,NUA,NUA,TI,VEBB,13)
      CALL TRANMD(VEBB,NUA,NUA,NOA,NUA,14)
      CALL CCMATMUL(VEBA,O2AA,VEBB,NUA2,NOAUA,NOAUA,0,0) !CBIA
      CALL INSITU(NOB,NUA,NUA,NUB,TI,VEAB,12)
      CALL TRANSNQN(NOBUA,NUAB,VEAB,TI)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
      CALL INSITU(NOB,NUB,NOA,NUA,TI,O2AB,12)
      CALL CCMATMUL(VEAB,O2AB,VEBB,NUA2,NOAUA,NOBUB,0,1) !CBIA
      CALL TRANMD(VEBA,NUA,NUA,NUA,NOA,13)
      CALL RDINT(1,NOAUA,NOAUA,VHPLAA,NFT831)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPLAA,12)
      CALL CCMATMUL(O1AA,VEBA,VHPLAA,NOA,NOAUA2,NUA,0,0) !SPROK
      CALL INSITU(NUA,NUA,NOA,NUA,TI,VEBB,13)
      CALL CCMATMUL(VHPLAA,O1AA,VEBB,NOAUA2,NUA,NOA,0,0) !IBCA SPROK
      CALL TRANMD(VEBB,NOA,NUA,NUA,NUA,23)
      CALL TRANSNQN(NOAUA,NUA2,VEBB,TI)   !BAIC
      CALL TRANSNQN(NOA,NUA,O1AA,TI)
C        call rd4p(nuaperm,noa,nua,vpp,ti,nft840)
C        call ccmatmul(o1aa,vpp,vebb,noa,nua3,nua,0,0) !icba sprOK
      CALL CCMATMUL4P_VE(VPP,O1AA,VEBB,NOA,NUA,0)
         CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,13,NFT892)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
      CALL INSITU(NUA,NUA,NOA,NUA,TI,VEBB,23)  !BIAC
      CALL INSITU(NUA,NOA,NUA,NUA,TI,VEBB,12)  !IBAC
Cc      call tranmd(vebb,noa,nua,nua,nua,23)
      CALL TRANSNQN(NOAUA,NUA2,VEBB,TI)
Cc      call tranmd(vebb,nua,nua,noa,nua,12)
      CALL CCMATMUL(VEAB,O2AB,VEBB,NUA2,NOAUA,NOBUB,0,0) !ACIB SPROK
C
      CALL INSITU(NUA,NUA,NOA,NUA,TI,VEBB,23)
      CALL TRANSNQN(NOAUA,NUA2,VEBB,TI)
      CALL TRANMD(VEBB,NUA,NUA,NUA,NOA,13)
C        write(6,*) 'veaa_21 for left'
Cc      CALL DRUK(nua,nua,nua,noa,vebb)
       CALL WRTAB(NUA,NUA,NUA,NOA,VEBB,7,NFT892)
C
C VEBB-21
       CALL RDINT(1,NOBUB,NUB2,VEAB,NFT837)
         CALL RDTAB(NOB,NOB,NOB,NUB,VMAA,15,NFT891)
      CALL TRANMD(VMAA,NOB,NOB,NOB,NUB,23) !KIME
C
      CALL TRANSNQN(NOB2,NOBUB,VMAA,TI)
      CALL INSITU(NOB,NUB,NOB,NOB,TI,VMAA,23)
C
      CALL TRANMD(O2BB,NUB,NUB,NOB,NOB,34)
      CALL TRANMD(O2BB,NUB,NUB,NOB,NOB,12)
      CALL CCMATMUL(O2BB,VMAA,VEAB,NUB2,NOBUB,NOB2,0,0) !ABCI
      CALL TRANSNQN(NUB2,NOBUB,VEAB,TI)
      CALL RDTAB(NUB,NOB,NUB,NOB,VHPLAA,2,NFT892)
      CALL TRANMD(VHPLAA,NUB,NOB,NUB,NOB,13)
      CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL CCMATMUL(VHPLAA,O1BB,VEAB,NOBUB2,NUB,NOB,0,1) !CIAB
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891)
      CALL TRANSNQN(NOB,NUB,FHP,TI)
      CALL TRANSNQN(NUB2,NOB2,O2BB,TI)
      CALL VECMUL(O2BB,NOB2UB2,TWO)
      CALL CCMATMUL(FHP,O2BB,VEAB,NUB,NOBUB2,NOB,0,1) !CIAB
       CALL RDTAB(NOB,NUB,NUB,NUB,VEBB,12,NFT892)
      CALL TRANMD(VEBB,NOB,NUB,NUB,NUB,23)
      CALL INSITU(NOB,NOB,NUB,NUB,TI,O2BB,23)
      CALL TRANSQ(O2BB,NOBUB)
      CALL INSITU(NUB,NOB,NUB,NUB,TI,VEAB,12)
      CALL TRANMD(VEAB,NOB,NUB,NUB,NUB,23)
      CALL TRANMD(VEAB,NOB,NUB,NUB,NUB,24)
      CALL CCMATMUL(O2BB,VEBB,VEAB,NOBUB,NUB2,NOBUB,0,0) !IBCA
      CALL TRANMD(VEAB,NOB,NUB,NUB,NUB,34)
         CALL RDTAB(NOA,NUB,NUA,NUB,VEBA,14,NFT892)
      CALL TRANSNQN(NOAUB,NUAB,VEBA,TI)
      CALL INSITU(NUA,NUB,NOA,NUB,TI,VEBA,13)
      CALL INSITU(NOA,NUB,NUA,NUB,TI,VEBA,23)
      CALL INSITU(NUB,NOB,NOA,NUA,TI,O2AB,12)
      CALL CCMATMUL(O2AB,VEBA,VEAB,NOBUB,NUB2,NOAUA,0,0) !IBAC
      CALL TRANMD(VEAB,NOB,NUB,NUB,NUB,34)
      CALL RDINT(1,NOBUB,NUB2,VEBB,NFT837)
      CALL TRANMD(VEBB,NUB,NUB,NUB,NOB,23)
      CALL TRANMD(O2BB,NOB,NUB,NOB,NUB,13)
      CALL INSITU(NOB,NUB,NOB,NUB,TI,O2BB,12)
      CALL INSITU(NOB,NUB,NUB,NUB,TI,VEAB,13)
      CALL CCMATMUL(VEBB,O2BB,VEAB,NUB2,NOBUB,NOBUB,0,0) !CBIA
       CALL RDINT(1,NOAUB,NUAB,VEBA,NFT838)
      CALL TRAN14(NUA,NUB,NOA,NUB,TI,VEBA)
      CALL TRANSNQN(NOBUB,NOAUA,O2AB,TI)
      CALL TRANMD(VEAB,NUB,NUB,NOB,NUB,12)
      CALL CCMATMUL(VEBA,O2AB,VEAB,NUB2,NOBUB,NOAUA,0,1) !BCIA
      CALL INSITU(NUB,NUB,NOB,NUB,TI,VEAB,13)
      CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL TRANSNQN(NOBUB,NUB2,VEAB,TI)   !BAIC
C        call rd4p(nubperm,nob,nub,vpp,ti,nft841)
C        call ccmatmul(o1bb,vpp,veab,nob,nub3,nub,0,0) !icba
      CALL CCMATMUL4P_VE(VPP,O1BB,VEAB,NOB,NUB,NUA)  !BAIC
      CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL RDINT(1,NOBUB,NOBUB,VHPLAA,NFT832)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPLAA,12)
      CALL TRANMD(VEBB,NUB,NUB,NUB,NOB,13)
      CALL CCMATMUL(O1BB,VEBB,VHPLAA,NOB,NOBUB2,NUB,0,0)
      CALL TRANSNQN(NUB2,NOBUB,VEAB,TI)   !ICBA
      CALL TRANMD(VEAB,NOB,NUB,NUB,NUB,23)
      CALL CCMATMUL(VHPLAA,O1BB,VEAB,NOBUB2,NUB,NOB,0,0) !IBCA
C
      CALL TRAN1TO4(NOB,NUB,NUB,NUB,TI,VEAB) !BCAI
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,13)   !ACBI
      CALL TRANMD(VEAB,NUB,NUB,NUB,NOB,23)   !ABCI
C        write(6,*) 'vebb_21 for left'
Cc      CALL DRUK(nub,nub,nub,nob,veaa)
       CALL WRTAB(NUB,NUB,NUB,NOB,VEAB,8,NFT892)
C
C VEAB-21
Cc      call rdint(1,nuab,nuab,vpp,nft842)
Cc      call transq(vpp,nuab)
C
       CALL RDINT(1,NOBUA,NUAB,VEBB,NFT839)
         CALL RDTAB(NOA,NOB,NUA,NOB,VMBA,17,NFT891)
      CALL RDTAB(NUA,NOB,NUA,NOB,VHPLAA,4,NFT892)
      CALL INSITU(NOA,NUA,NOB,NUB,TI,O2AB,23)
      CALL TRANSNQN(NOAB,NUAB,O2AB,TI)
      CALL CCMATMUL(O2AB,VMBA,VEBB,NUAB,NOBUA,NOAB,0,0) !ABCI
Cc      call transnqn(nob,nub,o1bb,ti)
C
C      call ccmatmul(vpp,o1bb,vebb,nua2ub,nob,nub,0,0) !abci
      CALL CCMATMUL4P_VEAB(VPP,O1BB,VEBB,NOB,NUB,NUA,NUA+NUB)
C
      CALL TRANSNQN(NOB,NUB,O1BB,TI)
      CALL TRANSNQN(NUB2,NOAUA,VEBA,TI)
      CALL INSITU(NOA,NUA,NUB,NUB,TI,VEBA,23)
      CALL TRANSNQN(NOAB,NUAB,VHPRAB,TI)
      CALL INSITU(NUA,NUB,NOA,NOB,TI,VHPRAB,13)
      CALL CCMATMUL(VEBA,O1BB,VHPRAB,NOAUAB,NOB,NUB,0,0)
C      call transnqn(noa,nua,o1aa,ti)
      CALL CCMATMUL(O1AA,VHPRAB,VEBB,NUA,NOBUAB,NOA,0,1) !ABCI
      CALL TRANSNQN(NUB,NOB,O1BB,TI)
      CALL TRANMD(VHPLAA,NUA,NOB,NUA,NOB,13)
      CALL TRANSNQN(NUAB,NOBUA,VEBB,TI)
      CALL CCMATMUL(VHPLAA,O1BB,VEBB,NOBUA2,NUB,NOB,0,1) !CIAB
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)
      CALL TRANSNQN(NOA,NUA,FHP,TI)
      CALL TRANSNQN(NUAB,NOAB,O2AB,TI)
      CALL CCMATMUL(FHP,O2AB,VEBB,NUA,NOBUAB,NOA,0,1) !CIAB
         CALL RDTAB(NUA,NUB,NUA,NOB,VEAB,13,NFT892)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VEAB,23)
      CALL TRANMD(VEAB,NUA,NUA,NUB,NOB,12)
      CALL TRANMD(O2BB,NUB,NOB,NOB,NUB,14)
      CALL INSITU(NUA,NOB,NUA,NUB,TI,VEBB,23)
      CALL CCMATMUL(VEAB,O2BB,VEBB,NUA2,NOBUB,NOBUB,0,0) !CAIB
      CALL RDTAB(NOA,NUA,NUA,NUA,VEAB,11,NFT892)
      CALL TRANMD(VEAB,NOA,NUA,NUA,NUA,23)
      CALL TRANSNQN(NOAUA,NUA2,VEAB,TI)
      CALL INSITU(NOA,NOB,NUA,NUB,TI,O2AB,23)
      CALL CCMATMUL(VEAB,O2AB,VEBB,NUA2,NOBUB,NOAUA,0,0) !CAIB
      CALL INSITU(NOA,NUB,NUA,NUB,TI,VEBA,13)
      CALL TRAN24(NOA,NUA,NOB,NUB,TI,O2AB)
      CALL TRAN24(NUA,NUA,NOB,NUB,TI,VEBB)
      CALL CCMATMUL(VEBA,O2AB,VEBB,NUAB,NOBUA,NOAUB,0,1) !CBIA
C
      CALL INSITU(NUA,NUB,NOB,NUA,TI,VEBB,23)
      CALL TRANSNQN(NOBUA,NUAB,VEBB,TI)
      CALL INSITU(NUB,NUA,NUA,NOB,TI,VEBB,12)
C        write(6,*) 'veab_21 for left'
C      CALL DRUK(nua,nub,nua,nob,vebb)
       CALL WRTAB(NUA,NUB,NUA,NOB,VEBB,9,NFT892)
C
C VEBA-21
      CALL RDTAB(NUB,NOA,NUB,NOA,VHPLAA,3,NFT892)
       CALL RDINT(1,NOAUB,NUAB,VEAB,NFT838)
      CALL TRANMD(VMAB,NOB,NOA,NOA,NUB,23)
      CALL TRAN14(NOA,NUB,NOB,NUA,TI,O2AB)
      CALL CCMATMUL(O2AB,VMAB,VEAB,NUAB,NOAUB,NOAB,0,0) !BAIC
      CALL TRAN1TO4(NUA,NUB,NOA,NUB,TI,VEAB) !AICB
      CALL TRANSNQN(NUA,NOA,O1AA,TI)
      CALL CCMATMUL(VHPLAA,O1AA,VEAB,NOAUB2,NUA,NOA,0,1) !AICB
      CALL INSITU(NUA,NUB,NOB,NOA,TI,O2AB,12)
      CALL TRANSNQN(NUAB,NOAB,O2AB,TI)
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891)
      CALL TRANSNQN(NOB,NUB,FHP,TI)
      CALL TRANMD(VEAB,NUB,NOA,NUB,NUA,13)
      CALL CCMATMUL(FHP,O2AB,VEAB,NUB,NOAUAB,NOB,0,1) !CIAB
         CALL RDTAB(NOA,NUB,NUA,NUB,VEBA,14,NFT892)
      CALL RDTAB(NOB,NUB,NUB,NUB,VEBB,12,NFT892)
      CALL INSITU(NOA,NUB,NUA,NUB,TI,VEBA,23)
      CALL TRANMD(O2AA,NUA,NOA,NOA,NUA,23)
      CALL TRANMD(VEAB,NUB,NOA,NUB,NUA,13)
      CALL TRAN14(NUB,NOA,NUB,NUA,TI,VEAB)
      CALL CCMATMUL(O2AA,VEBA,VEAB,NOAUA,NUB2,NOAUA,0,0) !BICA
      CALL TRANMD(VEBB,NOB,NUB,NUB,NUB,23)
      CALL INSITU(NOB,NUB,NUB,NUB,TI,VEBB,12)
      CALL TRAN14(NOB,NOA,NUB,NUA,TI,O2AB)
      CALL CCMATMUL(O2AB,VEBB,VEAB,NOAUA,NUB2,NOBUB,0,0) !BICA
Cc      call transq(vpp,nuab)
Cc      call rdint(1,nuab,nuab,vpp,nft842)
      CALL INSITU(NUA,NOA,NUB,NUB,TI,VEAB,13)
      CALL INSITU(NUB,NOA,NUA,NUB,TI,VEAB,12)
C
      CALL TRANMD(VEAB,NOA,NUB,NUA,NUB,24)   !IABC
Ccc      call ccmatmul(o1aa,vpp,veab,noa,nuaub2,nua,0,0) !icba
      CALL CCMATMUL4P_VEBA(VPP,O1AA,VEAB,NOA,NUA,NUB,NUA+NUB)
      CALL TRANMD(VEAB,NOA,NUB,NUA,NUB,24)
C
      CALL RDINT(1,NOBUB,NOAUA,VHPRAB,NFT833)
      CALL RDINT(1,NOBUA,NUAB,VEBA,NFT839)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPRAB,12)
      CALL INSITU(NOA,NUA,NUB,NOB,TI,VHPRAB,23)
      CALL CCMATMUL(O1AA,VEBA,VHPRAB,NOA,NOBUAB,NUA,0,0)
      CALL CCMATMUL(VHPRAB,O1BB,VEAB,NOAUAB,NUB,NOB,0,1) !ICBA
      CALL TRAN24(NUA,NUB,NUA,NOB,TI,VEBA)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,O2AB,13)
      CALL TRANMD(VEAB,NOA,NUB,NUA,NUB,24)
      CALL INSITU(NOA,NUB,NUA,NUB,TI,VEAB,12)
      CALL CCMATMUL(O2AB,VEBA,VEAB,NOAUB,NUAB,NOBUA,0,1) !AIBC
C
      CALL INSITU(NUB,NOA,NUA,NUB,TI,VEAB,13)
      CALL INSITU(NUA,NOA,NUB,NUB,TI,VEAB,23)
C        write(6,*) 'veba_21 for left'
C      CALL DRUK(nua,nub,noa,nub,veaa)
       CALL WRTAB(NUA,NUB,NOA,NUB,VEAB,10,NFT892)
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK OPENLEFT
      SUBROUTINE OPENLEFT(NOA,NUA,NOB,NUB,C1A,C1B,C1H,
     *                    C2AA,C2BB,C2AB,C2H,TI,VHPHH,
     *                    FHH,FPP,FHP,VHPPP,VHPHP,VHHHH,VPPP,VHPPH,
     *                    T2,OHHA,OHHB,OPPA,OPPB,XMAT,BVEC,IPVT,
     *                    EHA,EPA,EHB,EPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION C1A(1),C1B(1),C1H(1),C2AA(1),C2BB(1),C2AB(1),C2H(1)
      DIMENSION TI(1),VHPHH(1)
      DIMENSION FHH(1),FPP(1),FHP(1),VHPPP(1),VHPHP(1)
      DIMENSION VHHHH(1),VPPP(1),VHPPH(1),T2(1)
      DIMENSION OHHA(1),OHHB(1),OPPA(1),OPPB(1)
      DIMENSION XMAT(1),BVEC(1),IPVT(1)
      DIMENSION EHA(NOA),EPA(NUA),EHB(NOB),EPB(NUB)
C
      DATA TWO/2.0D+00/, HALF/0.5D+00/, ONE/1.00D+00/
C
C     --------------------NOTES--------------------------------
C     iconv is convergence threshold
C     maxit is maximum number of iterations
C     lmicro is number of iterations in DIIS cycle
C     c1 = l1, c2=l2,etc.
C     ---------------------------------------------------------
C
      TOL=(10.0D+00)**(-ICONV)
C
      WRITE(6,2300)
 2300 FORMAT(/6X,'BEGINNING LAMBDA VECTOR ITERATIONS')
C
C     ----------SET INITIAL VALUES OF L-------------
C
C             clean start the LAMBDA iterations (LREST zero)
C
      IF(LREST.EQ.0) THEN
C
         CALL ZEROMA(C1A,1,NOAUA)
         CALL RDTAB2(NOA,NUA,C1A,1,NFT825)
         CALL WRTAB2(NOA,NUA,C1A,1,NFT858)
C
         CALL ZEROMA(C1B,1,NOBUB)
         CALL RDTAB2(NOB,NUB,C1B,2,NFT825)
         CALL WRTAB2(NOB,NUB,C1B,2,NFT858)
C
         CALL ZEROMA(C2AA,1,NOA2UA2)
         CALL RDTAB(NOA,NUA,NUA,NOA,C2AA,3,NFT825)
         CALL WRTAB(NOA,NUA,NUA,NOA,C2AA,3,NFT858)
C
         CALL ZEROMA(C2BB,1,NOB2UB2)
         CALL RDTAB(NOB,NUB,NUB,NOB,C2BB,4,NFT825)
         CALL WRTAB(NOB,NUB,NUB,NOB,C2BB,4,NFT858)
C
         CALL ZEROMA(C2AB,1,NO2U2AB)
         CALL RDTAB(NOA,NUA,NUB,NOB,C2AB,5,NFT825)
         CALL WRTAB(NOA,NUA,NUB,NOB,C2AB,5,NFT858)
C
C             restart of the LAMBDA iterations (LREST non-zero)
C             Note that this entails records 6-10 of the file, with
C             lower records being used for the CCSD iterations.
C
      ELSE
         CALL RDTAB2(NOA,NUA,C1A,6,NFT825)
         CALL RDTAB2(NOB,NUB,C1B,7,NFT825)
         CALL RDTAB(NOA,NUA,NUA,NOA,C2AA,8,NFT825)
         CALL RDTAB(NOB,NUB,NUB,NOB,C2BB,9,NFT825)
         CALL RDTAB(NOA,NUA,NUB,NOB,C2AB,10,NFT825)
         CALL WRTAB2(NOA,NUA,C1A,1,NFT858)
         CALL WRTAB2(NOB,NUB,C1B,2,NFT858)
         CALL WRTAB(NOA,NUA,NUA,NOA,C2AA,3,NFT858)
         CALL WRTAB(NOB,NUB,NUB,NOB,C2BB,4,NFT858)
         CALL WRTAB(NOA,NUA,NUB,NOB,C2AB,5,NFT858)
      END IF
C
C     --------------------------------------------------------
      ITERTOT=0
C
      DO 1000,ITMACRO=1,MAXIT
      DO 1001,ITMICRO=2,LMICRO+1
      ITERTOT=ITERTOT+1
      LEFT=5*(ITMICRO-2)
      L1AA=LEFT+1
      L1BB=LEFT+2
      L2AA=LEFT+3
      L2BB=LEFT+4
      L2AB=LEFT+5
C
      CALL ZEROMA(C1A,1,NOU)
      CALL ZEROMA(C1B,1,NOU)
      CALL ZEROMA(C2AA,1,NO2U2)
      CALL ZEROMA(C2BB,1,NO2U2)
      CALL ZEROMA(C2AB,1,NO2U2)
      CALL RDTAB2(NOA,NUA,C1A,L1AA,NFT858)
      CALL RDTAB2(NOB,NUB,C1B,L1BB,NFT858)
      CALL RDTAB(NOA,NUA,NUA,NOA,C2AA,L2AA,NFT858)
      CALL RDTAB(NOB,NUB,NUB,NOB,C2BB,L2BB,NFT858)
      CALL RDTAB(NOA,NUA,NUB,NOB,C2AB,L2AB,NFT858)
C     -----------COMPUTE INTERMEDIATES-----------------------
      CALL ZEROMA(OHHA,1,NO2)
      CALL ZEROMA(OHHB,1,NO2)
      CALL ZEROMA(OPPA,1,NU2)
      CALL ZEROMA(OPPB,1,NU2)
C
      CALL ZEROMA(T2,1,NO2U2)
      CALL RDTAB(NOA,NUA,NUA,NOA,T2,3,NFT825)
C
      CALL VECMUL(C2AA,NOA2UA2,HALF)
      CALL TRANSQ(C2AA,NOAUA)
      CALL INSITU(NUA,NOA,NOA,NUA,TI,C2AA,13)
      CALL CCMATMUL(C2AA,T2,OHHA,NOA,NOA,NOAUA2,1,0)
      CALL TRANSQ(T2,NOAUA)
      CALL CCMATMUL(T2,C2AA,OPPA,NUA,NUA,NOA2UA,1,1)
      CALL INSITU(NOA,NOA,NUA,NUA,TI,C2AA,13)
C
      CALL ZEROMA(T2,1,NO2U2)
      CALL RDTAB(NOA,NUA,NUB,NOB,T2,5,NFT825)
C
      CALL TRAN1TO4(NOA,NUA,NUB,NOB,TI,T2)
      CALL CCMATMUL(C2AB,T2,OHHA,NOA,NOA,NOBUAB,0,0)
      CALL TRANSNQN(NOAUA,NOBUB,C2AB,TI)
      CALL CCMATMUL(T2,C2AB,OPPA,NUA,NUA,NOABUB,0,1)
      CALL TRANSNQN(NUAB,NOAB,T2,TI)
      CALL CCMATMUL(C2AB,T2,OPPB,NUB,NUB,NOABUA,1,1)
      CALL TRANSNQN(NOBUB,NOAUA,C2AB,TI)
      CALL CCMATMUL(T2,C2AB,OHHB,NOB,NOB,NOAUAB,1,0)
      CALL TRANSQ(OHHB,NOB)
      CALL TRANSQ(OPPB,NUB)
C
      CALL ZEROMA(T2,1,NO2U2)
      CALL RDTAB(NOB,NUB,NUB,NOB,T2,4,NFT825)
C
      CALL VECMUL(C2BB,NOB2UB2,HALF)
      CALL TRANSQ(C2BB,NOBUB)
      CALL INSITU(NUB,NOB,NOB,NUB,TI,C2BB,13)
      CALL CCMATMUL(C2BB,T2,OHHB,NOB,NOB,NOBUB2,0,0)
      CALL TRANSQ(T2,NOBUB)
      CALL CCMATMUL(T2,C2BB,OPPB,NUB,NUB,NOB2UB,0,1)
      CALL INSITU(NOB,NOB,NUB,NUB,TI,C2BB,13)
C
      CALL TRANSQ(OHHA,NOA)
      CALL TRANSQ(OHHB,NOB)
C     -----------------------------------------------------
      RES=0.00D+00
C     -----------ALPHA-ALPHA SINGLES and DOUBLES---------------------
      CALL C1HCAA(NOA,NUA,NOB,NUB,C1A,C1B,FHH,FPP,C1H,TI,C2AA,
     *C2AB,VHPHP,VHPHH,VHPPP,OHHA,OHHB,OPPA,OPPB)
C
      CALL C2HCAA(NOA,NUA,NOB,NUB,C1A,FHP,FHH,FPP,C2H,TI,C2AA,
     *C2AB,VHPHP,VHPHH,VHPPP,VHHHH,VPPP,VHPPH,OHHA,OPPA)
C
      CALL VECMUL(C1A,NOAUA,TWO)
      CALL TRT1(NUA,NOA,TI,C1A)
C
      CALL DAXPY(NOAUA,ONE,FHP,1,C1H,1)
      CALL DENADD1(NOA,NUA,C1H,EHA,EPA)
      CALL RESN1(NOA,NUA,C1H,RES)
      CALL DAXPY(NOAUA,ONE,C1A,1,C1H,1)
      CALL WRTAB2(NOA,NUA,C1H,(L1AA+5),NFT858)
C
      CALL VECMUL(VHPPH,NOA2UA2,TWO)
      CALL TRANSQ(VHPPH,NOAUA)
      CALL DAXPY(NOA2UA2,ONE,VHPPH,1,C2H,1)
      CALL DENADD2(NOA,NUA,C2H,EHA,EPA)
      CALL RESN2(NOA,NUA,C2H,RES)
      CALL DAXPY(NOA2UA2,ONE,C2AA,1,C2H,1)
      CALL WRTAB(NOA,NUA,NUA,NOA,C2H,(L2AA+5),NFT858)
C
C     --------------BETA-BETA SINGLES and DOUBLES---------------------
C
      CALL C1HCBB(NOA,NUA,NOB,NUB,C1A,C1B,FHH,FPP,C1H,TI,C2BB,
     *C2AB,VHPHP,VHPHH,VHPPP,OHHA,OHHB,OPPA,OPPB)
C
      CALL C2HCBB(NOA,NUA,NOB,NUB,C1B,FHP,FHH,FPP,C2H,TI,C2BB,
     *C2AB,VHPHP,VHPHH,VHPPP,VHHHH,VPPP,VHPPH,OHHB,OPPB)
C
      CALL VECMUL(C1B,NOAUA,TWO)
C
      CALL DAXPY(NOBUB,ONE,FHP,1,C1H,1)
      CALL DENADD1(NOB,NUB,C1H,EHB,EPB)
      CALL RESN1(NOB,NUB,C1H,RES)
C
      CALL VECMUL(VHPPH,NOB2UB2,TWO)
      CALL TRANSQ(VHPPH,NOBUB)
      CALL DAXPY(NOB2UB2,ONE,VHPPH,1,C2H,1)
      CALL DENADD2(NOB,NUB,C2H,EHB,EPB)
      CALL RESN2(NOB,NUB,C2H,RES)
      CALL DAXPY(NOB2UB2,ONE,C2BB,1,C2H,1)
      CALL WRTAB(NOB,NUB,NUB,NOB,C2H,(L2BB+5),NFT858)
C
C     --------------------ALPHA-BETA DOUBLES---------------------------
C
      CALL C2HCAB(NOA,NUA,NOB,NUB,C1A,C1B,FHP,FHH,FPP,C2H,TI,
     *C2AA,C2BB,C2AB,VHPHP,VHPHH,VHPPP,VHHHH,VPPP,VHPPH,OHHA,OPPA,
     *OHHB,OPPB)
C
      CALL DAXPY(NOBUB,ONE,C1B,1,C1H,1)
      CALL WRTAB2(NOB,NUB,C1H,(L1BB+5),NFT858)
C
      CALL TRAN34N(NOA,NUA,NOB,NUB,TI,VHPPH)
      CALL DAXPY(NO2U2AB,ONE,VHPPH,1,C2H,1)
      CALL DENADAB(NOA,NUA,NUB,NOB,C2H,EHA,EHB,EPA,EPB)
      CALL RESNAB(NOA,NUA,NUB,NOB,C2H,RES)
      CALL DAXPY(NO2U2AB,ONE,C2AB,1,C2H,1)
      CALL WRTAB(NOA,NUA,NUB,NOB,C2H,(L2AB+5),NFT858)
C     -----------------------------------------------------------------
      RES=SQRT(RES)
      WRITE(6,99)ITERTOT,RES
      CALL FLSHBF(6)
C
      IF(ITERTOT.EQ.MAXIT) GO TO 4100
C
C         converged iterations should print amplitude results
C
      IF(RES.LT.TOL) THEN
         WRITE(6,100)
C
         CALL ZEROMA(C1A,1,NOU)
         CALL RDTAB2(NOA,NUA,C1A,(L1AA+5),NFT858)
         CALL PRTL1A(NOA,NUA,C1A)
         CALL WRTAB2(NOA,NUA,C1A,6,NFT825)
C
         CALL ZEROMA(C1B,1,NOU)
         CALL RDTAB2(NOB,NUB,C1B,(L1BB+5),NFT858)
         CALL PRTL1B(NOB,NUB,C1B)
         CALL WRTAB2(NOB,NUB,C1B,7,NFT825)
C
         CALL ZEROMA(C2AA,1,NO2U2)
         CALL RDTAB(NOA,NUA,NUA,NOA,C2AA,(L2AA+5),NFT858)
         CALL PRTL2AA(NOA,NUA,C2AA)
         CALL WRTAB(NOA,NUA,NUA,NOA,C2AA,8,NFT825)
C
         CALL ZEROMA(C2BB,1,NO2U2)
         CALL RDTAB(NOB,NUB,NUB,NOB,C2BB,(L2BB+5),NFT858)
         CALL PRTL2BB(NOB,NUB,C2BB)
         CALL WRTAB(NOB,NUB,NUB,NOB,C2BB,9,NFT825)
C
         CALL ZEROMA(C2AB,1,NO2U2)
         CALL RDTAB(NOA,NUA,NUB,NOB,C2AB,(L2AB+5),NFT858)
         CALL PRTL2AB(NOA,NUA,NUB,NOB,C2AB)
         CALL WRTAB(NOA,NUA,NUB,NOB,C2AB,10,NFT825)
C
         RETURN
      END IF
C
 1001 CONTINUE
C           -------DIIS-----
      CALL OPENDIIS(NOA,NOB,NUA,NUB,C1A,C2AA,C1H,C2H,FHP,
     *VHPPH,VHPHP,XMAT,BVEC,IPVT,LMICRO)
      WRITE(6,98) LMICRO
C
C          save restart information
C
      CALL WRTAB2(NOA,NUA,C1H,6,NFT825)
      CALL WRTAB2(NOB,NUB,C1A,7,NFT825)
      CALL WRTAB(NOA,NUA,NUA,NOA,C2H,8,NFT825)
      CALL WRTAB(NOB,NUB,NUB,NOB,C2AA,9,NFT825)
      CALL WRTAB(NOA,NUA,NUB,NOB,VHPHP,10,NFT825)
C
 1000 CONTINUE
C
C          too many iterations
C
 4100 CONTINUE
      WRITE(6,101)
      CALL ABRT
      STOP
C
   98 FORMAT(6X,'DOING DIIS EXTRAPOLATION (DIM.OF THE SPACE=',I3,')')
   99 FORMAT(1X,'ITERATION: ',I5,4X,'CONV: ',F15.9)
  100 FORMAT(/1X,'LAMBDA VECTOR ITERATIONS HAVE CONVERGED,'/
     *       1X,'THE LARGEST LA1 AND LA2 AMPLITUDES ARE')
  101 FORMAT(1X,'LAMBDA VECTOR ITERATIONS DID NOT CONVERGE')
      END
C
C*MODULE ROHFCC  *DECK OPENDIIS
      SUBROUTINE OPENDIIS(NOA,NOB,NUA,NUB,O1,O2,T1,T2,AUX1,AUX2,TAB,
     *                    XMAT,B,IPVT,IMICRO)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION O1(*),O2(*),T1(*),T2(*),AUX1(*),AUX2(*),TAB(*),
     *          XMAT(IMICRO+1,IMICRO+1),B(IMICRO+1),IPVT(IMICRO+1)
C
      DATA ONEM/-1.0D+00/
      IDIM2=(IMICRO+1)*(IMICRO+1)
      CALL ZEROMA(XMAT,1,IDIM2)
      CALL ZEROMA(B,1,IMICRO+1)
      DO 1,I=1,IMICRO
       ITER=5*(I-1)
       I1AA=ITER+1
       I1BB=ITER+2
       I2AA=ITER+3
       I2BB=ITER+4
       I2AB=ITER+5
       XMAT(IMICRO+1,I)=ONEM
       XMAT(I,IMICRO+1)=ONEM
      DO 2,J=I,IMICRO
       JTER=5*(J-1)
       J1AA=JTER+1
       J1BB=JTER+2
       J2AA=JTER+3
       J2BB=JTER+4
       J2AB=JTER+5
C
C      -----Singles Alpha-Alpha------------------
C
       CALL ZEROMA(O1,1,NOU)
       CALL ZEROMA(AUX1,1,NOU)
       CALL RDTAB2(NOA,NUA,O1,(I1AA+5),NFT858)
       CALL RDTAB2(NOA,NUA,AUX1,I1AA,NFT858)
       CALL DAXPY(NOAUA,ONEM,AUX1,1,O1,1)
C
       CALL ZEROMA(T1,1,NOU)
       CALL ZEROMA(AUX1,1,NOU)
       CALL RDTAB2(NOA,NUA,T1,(J1AA+5),NFT858)
       CALL RDTAB2(NOA,NUA,AUX1,J1AA,NFT858)
       CALL DAXPY(NOAUA,ONEM,AUX1,1,T1,1)
C
       XXX=DDOT(NOAUA,O1,1,T1,1)
C
C      -----Singles Beta-Beta-------------------
C
       CALL ZEROMA(O1,1,NOU)
       CALL ZEROMA(AUX1,1,NOU)
       CALL RDTAB2(NOB,NUB,O1,(I1BB+5),NFT858)
       CALL RDTAB2(NOB,NUB,AUX1,I1BB,NFT858)
       CALL DAXPY(NOBUB,ONEM,AUX1,1,O1,1)
C
       CALL ZEROMA(T1,1,NOU)
       CALL ZEROMA(AUX1,1,NOU)
       CALL RDTAB2(NOB,NUB,T1,(J1BB+5),NFT858)
       CALL RDTAB2(NOB,NUB,AUX1,J1BB,NFT858)
       CALL DAXPY(NOBUB,ONEM,AUX1,1,T1,1)
C
       XXX=XXX+DDOT(NOBUB,O1,1,T1,1)
C
C      ------Doubles Alpha-Alpha-----------------
C
       CALL ZEROMA(O2,1,NO2U2)
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOA,NUA,NUA,NOA,O2,(I2AA+5),NFT858)
       CALL RDTAB(NOA,NUA,NUA,NOA,AUX2,I2AA,NFT858)
       CALL DAXPY(NOA2UA2,ONEM,AUX2,1,O2,1)
C
       CALL ZEROMA(T2,1,NO2U2)
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOA,NUA,NUA,NOA,T2,(J2AA+5),NFT858)
       CALL RDTAB(NOA,NUA,NUA,NOA,AUX2,J2AA,NFT858)
       CALL DAXPY(NOA2UA2,ONEM,AUX2,1,T2,1)
C
       XXX=XXX+DDOT(NOA2UA2,O2,1,T2,1)
C
C      ------Doubles Beta-Beta-----------------
C
       CALL ZEROMA(O2,1,NO2U2)
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOB,NUB,NUB,NOB,O2,(I2BB+5),NFT858)
       CALL RDTAB(NOB,NUB,NUB,NOB,AUX2,I2BB,NFT858)
       CALL DAXPY(NOB2UB2,ONEM,AUX2,1,O2,1)
C
       CALL ZEROMA(T2,1,NO2U2)
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOB,NUB,NUB,NOB,T2,(J2BB+5),NFT858)
       CALL RDTAB(NOB,NUB,NUB,NOB,AUX2,J2BB,NFT858)
       CALL DAXPY(NOB2UB2,ONEM,AUX2,1,T2,1)
C
       XXX=XXX+DDOT(NOA2UA2,O2,1,T2,1)
C
C      ------Doubles Alpha-Beta-----------------
C
       CALL ZEROMA(O2,1,NO2U2)
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOA,NUA,NUB,NOB,O2,(I2AB+5),NFT858)
       CALL RDTAB(NOA,NUA,NUB,NOB,AUX2,I2AB,NFT858)
       CALL DAXPY(NO2U2AB,ONEM,AUX2,1,O2,1)
C
       CALL ZEROMA(T2,1,NO2U2)
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOA,NUA,NUB,NOB,T2,(J2AB+5),NFT858)
       CALL RDTAB(NOA,NUA,NUB,NOB,AUX2,J2AB,NFT858)
       CALL DAXPY(NO2U2AB,ONEM,AUX2,1,T2,1)
C
       YYY=DDOT(NO2U2AB,O2,1,T2,1)
       XXX=XXX+(4.0D+00*YYY)
C      ------------------------------------------
       XMAT(I,J)=XXX
       XMAT(J,I)=XXX
 2    CONTINUE
 1    CONTINUE
      XMAT(IMICRO+1,IMICRO+1)=0.0D+00
      B(IMICRO+1)=ONEM
C
      INFO1=0
      CALL DGEFA(XMAT,IMICRO+1,IMICRO+1,IPVT,INFO1)
      IF(INFO1.NE.0) THEN
         WRITE(6,*) 'OPENDIIS: FAILURE TO FACTOR COEFFICIENT MATRIX'
         CALL ABRT
      END IF
      JOBX=0
      CALL DGESL(XMAT,IMICRO+1,IMICRO+1,IPVT,B,JOBX)
C
      CALL ZEROMA(T1,1,NOU)
      CALL ZEROMA(O1,1,NOU)
      CALL ZEROMA(T2,1,NO2U2)
      CALL ZEROMA(O2,1,NO2U2)
      CALL ZEROMA(TAB,1,NO2U2)
      DO 3,I=1,IMICRO
       ITER=5*(I-1)
       I1AA=ITER+1
       I1BB=ITER+2
       I2AA=ITER+3
       I2BB=ITER+4
       I2AB=ITER+5
       XF=B(I)
C
       CALL ZEROMA(AUX1,1,NOU)
       CALL RDTAB2(NOA,NUA,AUX1,I1AA,NFT858)
       CALL DAXPY(NOAUA,XF,AUX1,1,T1,1)
C
       CALL ZEROMA(AUX1,1,NOU)
       CALL RDTAB2(NOB,NUB,AUX1,I1BB,NFT858)
       CALL DAXPY(NOBUB,XF,AUX1,1,O1,1)
C
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOA,NUA,NUA,NOA,AUX2,I2AA,NFT858)
       CALL DAXPY(NOA2UA2,XF,AUX2,1,T2,1)
C
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOB,NUB,NUB,NOB,AUX2,I2BB,NFT858)
       CALL DAXPY(NOB2UB2,XF,AUX2,1,O2,1)
C
       CALL ZEROMA(AUX2,1,NO2U2)
       CALL RDTAB(NOA,NUA,NUB,NOB,AUX2,I2AB,NFT858)
       CALL DAXPY(NO2U2AB,XF,AUX2,1,TAB,1)
 3    CONTINUE
C
      CALL WRTAB2(NOA,NUA,T1,1,NFT858)
      CALL WRTAB2(NOB,NUB,O1,2,NFT858)
      CALL WRTAB(NOA,NUA,NUA,NOA,T2,3,NFT858)
      CALL WRTAB(NOB,NUB,NUB,NOB,O2,4,NFT858)
      CALL WRTAB(NOA,NUA,NUB,NOB,TAB,5,NFT858)
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK PRTL1A
      SUBROUTINE PRTL1A(NO,NU,C1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C1(NO,NU)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       IF(ABS(C1(I,IA)).GT.TOLP) THEN
          WRITE(6,101) C1(I,IA),I+NOPCCFC,IA+NOPCCFC+NO
       END IF
 2    CONTINUE
 1    CONTINUE
      RETURN
 101  FORMAT(1X,'LA1=',1X,F14.10,1X,'FOR IA -> AA =',2I4)
      END
C
C*MODULE ROHFCC  *DECK PRTL1B
      SUBROUTINE PRTL1B(NO,NU,C1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C1(NO,NU)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       IF(ABS(C1(I,IA)).GT.TOLP) THEN
          WRITE(6,101) C1(I,IA),I+NOPCCFC,IA+NOPCCFC+NO
       END IF
 2    CONTINUE
 1    CONTINUE
      RETURN
 101  FORMAT(1X,'LA1=',1X,F14.10,1X,'FOR IB -> AB =',2I4)
      END
C
C*MODULE ROHFCC  *DECK PRTL2AA
      SUBROUTINE PRTL2AA(NO,NU,C2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C2(NO,NU,NU,NO)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NO
      DO 2,J=I+1,NO
      DO 3,IA=1,NU
      DO 4,IB=IA+1,NU
        IF(ABS(C2(I,IA,IB,J)).GT.TOLP) THEN
           WRITE(6,102) C2(I,IA,IB,J),I+NOPCCFC,J+NOPCCFC,
     *                   IA+NOPCCFC+NO,IB+NOPCCFC+NO
        END IF
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
 102  FORMAT(1X,'LA2=',1X,F14.10,1X,'FOR IA,JA -> AA, BA =',4I4)
      END
C
C*MODULE ROHFCC  *DECK PRTL2BB
      SUBROUTINE PRTL2BB(NO,NU,C2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C2(NO,NU,NU,NO)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NO
      DO 2,J=I+1,NO
      DO 3,IA=1,NU
      DO 4,IB=IA+1,NU
        IF(ABS(C2(I,IA,IB,J)).GT.TOLP) THEN
           WRITE(6,102) C2(I,IA,IB,J),I+NOPCCFC,J+NOPCCFC,
     *                    IA+NOPCCFC+NO,IB+NOPCCFC+NO
        END IF
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
 102  FORMAT(1X,'LA2=',1X,F14.10,1X,'FOR IB,JB -> AB, BB =',4I4)
      RETURN
      END
C
C*MODULE ROHFCC  *DECK PRTL2AB
      SUBROUTINE PRTL2AB(NOA,NUA,NUB,NOB,C2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /CCOPIN/ IOPCCREF,IOPCCMET,NOPCCFC,MULOPCC,
     *                KMICRO,KREST,LMICRO,LREST
      DIMENSION C2(NOA,NUA,NUB,NOB)
C
      TOLP=0.025D+00
C
      DO 1,I=1,NOA
      DO 2,J=1,NOB
      DO 3,IA=1,NUA
      DO 4,IB=1,NUB
        IF(ABS(C2(I,IA,IB,J)).GT.TOLP) THEN
           WRITE(6,102) C2(I,IA,IB,J),I+NOPCCFC,J+NOPCCFC,
     *                    IA+NOPCCFC+NOA,IB+NOPCCFC+NOB
        END IF
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
 102  FORMAT(1X,'LA2=',1X,F14.10,1X,'FOR IA,JB -> AA, BB =',4I4)
      RETURN
      END
C
C*MODULE ROHFCC  *DECK C1HCAA
      SUBROUTINE C1HCAA(NOA,NUA,NOB,NUB,C1A,C1B,FHH,FPP,C1H,TI,C2AA,
     *                  C2AB,VHPHP,VHPHH,VHPPP,OHHA,OHHB,OPPA,OPPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VHPHH(1)
      DIMENSION TI(1)
      DIMENSION FHH(1),FPP(1)
      DIMENSION VHPPP(1)
      DIMENSION VHPHP(1)
      DIMENSION C2AA(1),C2AB(1)
      DIMENSION C1A(1),C1B(1)
      DIMENSION C1H(1)
      DIMENSION OHHA(1),OHHB(1),OPPA(1),OPPB(1)
C
      CALL ZEROMA(TI,1,NOU3)
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL ZEROMA(FHH,1,NO2)
      CALL ZEROMA(FPP,1,NU2)
      CALL ZEROMA(C1H,1,NOU)
C
      CALL RDTAB2(NOA,NOA,FHH,3,NFT891)
      CALL RDTAB2(NUA,NUA,FPP,1,NFT891)
      CALL RDTAB(NUA,NOA,NUA,NOA,VHPHP,1,NFT892)
      CALL RDTAB(NOA,NOA,NOA,NUA,VHPHH,10,NFT891)
      CALL RDTAB(NUA,NUA,NUA,NOA,VHPPP,7,NFT892)
      CALL TRT1(NOA,NUA,TI,C1A)
      CALL CCMATMUL(C1A,FHH,C1H,NUA,NOA,NOA,1,1)
      CALL CCMATMUL(FPP,C1A,C1H,NUA,NOA,NUA,0,0)
      CALL CCMATMUL(C1A,VHPHP,C1H,1,NOAUA,NOAUA,0,1)
C
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL RDTAB(NUB,NOB,NUA,NOA,VHPHP,6,NFT892)
      CALL TRT1(NOB,NUB,TI,C1B)
      CALL CCMATMUL(C1B,VHPHP,C1H,1,NOAUA,NOBUB,0,1)
      CALL TRT1(NUA,NOA,TI,C1H)
      CALL TRANSNQN(NOA2,NOAUA,VHPHH,TI)
      CALL CCMATMUL(VHPHH,C2AA,C1H,NOA,NUA,NOA2UA,0,0)
      CALL TRANSQ(C2AA,NOAUA)
      CALL TRAN34N(NUA,NUA,NUA,NOA,TI,VHPPP)
      CALL CCMATMUL(C2AA,VHPPP,C1H,NOA,NUA,NOAUA2,0,0)
C
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL RDTAB(NOA,NOA,NOA,NUA,VHPHH,14,NFT891)
      CALL RDTAB(NOA,NUA,NUA,NUA,VHPPP,11,NFT892)
      CALL TRANMD(VHPHH,NOA,NOA,NOA,NUA,23)
      CALL CCMATMUL(OHHA,VHPHH,C1H,1,NOAUA,NOA2,0,1)
      CALL TRANMD(VHPPP,NOA,NUA,NUA,NUA,23)
      CALL CCMATMUL(VHPPP,OPPA,C1H,NOAUA,1,NUA2,0,1)
C
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL RDTAB(NOA,NOB,NUA,NOB,VHPHH,17,NFT891)
      CALL RDTAB(NOA,NUB,NUA,NUB,VHPPP,14,NFT892)
      CALL INSITU(NOA,NOB,NUA,NOB,TI,VHPHH,23)
      CALL CCMATMUL(VHPHH,OHHB,C1H,NOAUA,1,NOB2,0,1)
      CALL INSITU(NOA,NUB,NUA,NUB,TI,VHPPP,23)
      CALL CCMATMUL(VHPPP,OPPB,C1H,NOAUA,1,NUB2,0,1)
C
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL RDTAB(NOA,NOB,NOA,NUB,VHPHH,12,NFT891)
      CALL RDTAB(NUA,NUB,NUA,NOB,VHPPP,9,NFT892)
      CALL TRAN34N(NUA,NUB,NUA,NOB,TI,VHPPP)
      CALL CCMATMUL(C2AB,VHPPP,C1H,NOA,NUA,NOBUAB,0,0)
      CALL TRANSNQN(NOAUA,NOBUB,C2AB,TI)
      CALL TRANSNQN(NOAB,NOAUB,VHPHH,TI)
      CALL TRAN34N(NOA,NUB,NOA,NOB,TI,VHPHH)
      CALL CCMATMUL(VHPHH,C2AB,C1H,NOA,NUA,NOABUB,0,1)
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK C1HCBB
      SUBROUTINE C1HCBB(NOA,NUA,NOB,NUB,C1A,C1B,FHH,FPP,C1H,TI,C2BB,
     *                  C2AB,VHPHP,VHPHH,VHPPP,OHHA,OHHB,OPPA,OPPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VHPHH(1)
      DIMENSION TI(1)
      DIMENSION FHH(1),FPP(1)
      DIMENSION VHPPP(1)
      DIMENSION VHPHP(1)
      DIMENSION C2BB(1),C2AB(1)
      DIMENSION C1A(1),C1B(1)
      DIMENSION C1H(1)
      DIMENSION OHHA(1),OHHB(1),OPPA(1),OPPB(1)
C
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL ZEROMA(FHH,1,NO2)
      CALL ZEROMA(FPP,1,NU2)
      CALL ZEROMA(C1H,1,NOU)
C
      CALL RDTAB2(NOB,NOB,FHH,4,NFT891)
      CALL RDTAB2(NUB,NUB,FPP,2,NFT891)
      CALL RDTAB(NUB,NOB,NUB,NOB,VHPHP,2,NFT892)
      CALL RDTAB(NOB,NOB,NOB,NUB,VHPHH,11,NFT891)
      CALL RDTAB(NUB,NUB,NUB,NOB,VHPPP,8,NFT892)
      CALL CCMATMUL(C1B,FHH,C1H,NUB,NOB,NOB,1,1)
      CALL CCMATMUL(FPP,C1B,C1H,NUB,NOB,NUB,0,0)
      CALL CCMATMUL(C1B,VHPHP,C1H,1,NOBUB,NOBUB,0,1)
C
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL RDTAB(NUB,NOB,NOA,NUA,VHPHP,5,NFT892)
      CALL CCMATMUL(VHPHP,C1A,C1H,NOBUB,1,NOAUA,0,1)
      CALL TRT1(NUB,NOB,TI,C1H)
      CALL TRANSNQN(NOB2,NOBUB,VHPHH,TI)
      CALL CCMATMUL(VHPHH,C2BB,C1H,NOB,NUB,NOB2UB,0,0)
      CALL TRANSQ(C2BB,NOBUB)
      CALL TRAN34N(NUB,NUB,NUB,NOB,TI,VHPPP)
      CALL CCMATMUL(C2BB,VHPPP,C1H,NOB,NUB,NOBUB2,0,0)
C
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL RDTAB(NOB,NOB,NOB,NUB,VHPHH,15,NFT891)
      CALL RDTAB(NOB,NUB,NUB,NUB,VHPPP,12,NFT892)
      CALL TRANMD(VHPHH,NOB,NOB,NOB,NUB,23)
      CALL CCMATMUL(OHHB,VHPHH,C1H,1,NOBUB,NOB2,0,1)
      CALL TRANMD(VHPPP,NOB,NUB,NUB,NUB,23)
      CALL CCMATMUL(VHPPP,OPPB,C1H,NOBUB,1,NUB2,0,1)
C
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL RDTAB(NOA,NOB,NOA,NUB,VHPHH,16,NFT891)
      CALL RDTAB(NUA,NUB,NUA,NOB,VHPPP,13,NFT892)
      CALL INSITU(NOA,NOB,NOA,NUB,TI,VHPHH,23)
      CALL CCMATMUL(OHHA,VHPHH,C1H,1,NOBUB,NOA2,0,1)
      CALL TRAN14(NUA,NUB,NUA,NOB,TI,VHPPP)
      CALL TRANSQ(OPPA,NUA)
      CALL CCMATMUL(VHPPP,OPPA,C1H,NOBUB,1,NUA2,0,1)
      CALL TRANSQ(OPPA,NUA)
C
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL RDTAB(NOA,NOB,NUA,NOB,VHPHH,13,NFT891)
      CALL RDTAB(NUA,NUB,NOA,NUB,VHPPP,10,NFT892)
      CALL TRAN14(NOA,NUA,NUB,NOB,TI,C2AB)
      CALL CCMATMUL(C2AB,VHPPP,C1H,NOB,NUB,NOAUAB,0,0)
      CALL TRAN14(NOA,NOB,NUA,NOB,TI,VHPHH)
      CALL TRAN34N(NOB,NUA,NUB,NOA,TI,C2AB)
      CALL CCMATMUL(VHPHH,C2AB,C1H,NOB,NUB,NOABUA,0,1)
      CALL TRAN34N(NOB,NUA,NOA,NUB,TI,C2AB)
      CALL TRAN14(NOB,NUA,NUB,NOA,TI,C2AB)
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK C2HCAA
      SUBROUTINE C2HCAA(NOA,NUA,NOB,NUB,C1A,FHP,FHH,FPP,C2H,TI,C2AA,
     *                  C2AB,VHPHP,VHPHH,VHPPP,VHHHH,VPPP,VHPPH,
     *                  OHHA,OPPA)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VHPHH(1)
      DIMENSION TI(1)
      DIMENSION FHH(1),FPP(1),FHP(1)
      DIMENSION VHPPP(1)
      DIMENSION VHPHP(1),VHHHH(1),VPPP(1),VHPPH(1)
      DIMENSION C2AA(1),C2AB(1)
      DIMENSION C1A(1)
      DIMENSION C2H(1)
      DIMENSION OHHA(1),OPPA(1)
C
      DATA HALF/0.5D+00/
      DATA QUARTER/0.25D+00/
      DATA EIGHT/8.00D+00/
C
      CALL ZEROMA(FHH,1,NO2)
      CALL ZEROMA(FPP,1,NU2)
      CALL ZEROMA(FHP,1,NOU)
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL ZEROMA(VHHHH,1,NO4)
      CALL ZEROMA(VHPPH,1,NO2U2)
      CALL ZEROMA(VPPP,1,NU3)
      CALL ZEROMA(C2H,1,NO2U2)
C
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)
      CALL RDTAB2(NOA,NOA,FHH,3,NFT891)
      CALL RDTAB2(NUA,NUA,FPP,1,NFT891)
      CALL RDTAB(NOA,NOA,NOA,NUA,VHPHH,14,NFT891)
      CALL RDTAB(NOA,NUA,NUA,NUA,VHPPP,11,NFT892)
      CALL RDTAB(NUA,NOA,NUA,NOA,VHPHP,1,NFT892)
      CALL RDTAB(NOA,NOA,NOA,NOA,VHHHH,7,NFT891)
      CALL RDINT(1,NOAUA,NOAUA,VHPPH,NFT829)
C
      CALL CCMATMUL(FHP,C1A,C2H,NOAUA,NOAUA,1,1,0)
      CALL VECMUL(C1A,NOAUA,HALF)
      CALL CCMATMUL(VHPPP,C1A,C2H,NOAUA2,NOA,NUA,0,1)
      CALL TRANMD(VHPHH,NOA,NOA,NOA,NUA,13)
      CALL VECMUL(VHPPH,NOA2UA2,HALF)
      CALL INSITU(NUA,NOA,NUA,NOA,TI,VHPPH,12)
      CALL CCMATMUL(C2AA,FHH,C2H,NOAUA2,NOA,NOA,0,1)
      CALL CCMATMUL(VHPPH,OHHA,C2H,NOAUA2,NOA,NOA,0,1)
C      -----c2h(ba,ja,ia,aa)---------------------------
      CALL TRANSQ(C2H,NOAUA)
      CALL TRANSQ(C2AA,NOAUA)
      CALL TRANSQ(OPPA,NUA)
      CALL TRANSQ(VHPPH,NOAUA)
      CALL CCMATMUL(FPP,C2AA,C2H,NUA,NOA2UA,NUA,0,0)
      CALL CCMATMUL(C1A,VHPHH,C2H,NUA,NOA2UA,NOA,0,0)
      CALL CCMATMUL(OPPA,VHPPH,C2H,NUA,NOA2UA,NUA,0,0)
      CALL VECMUL(C2AA,NOA2UA2,QUARTER)
      CALL TRAN24(NUA,NOA,NOA,NUA,TI,C2AA)
      CALL C2PPAA(NOA,NUA,VPPP,C2AA,C2H)
C      -----c2h(ba,aa,ia,ja)-----------------------
      CALL TRAN24(NUA,NOA,NOA,NUA,TI,C2H)
      CALL CCMATMUL(C2AA,VHHHH,C2H,NUA2,NOA2,NOA2,0,0)
      CALL INSITU(NUA,NUA,NOA,NOA,TI,C2H,13)
C      ----------------------------------------------
      CALL INSITU(NUA,NUA,NOA,NOA,TI,C2AA,13)
      CALL VECMUL(C2AA,NOA2UA2,EIGHT)
      CALL CCMATMUL(C2AA,VHPHP,C2H,NOAUA,NOAUA,NOAUA,0,1)
C
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL RDTAB(NUB,NOB,NUA,NOA,VHPHP,6,NFT892)
      CALL TRANSNQN(NOBUB,NOAUA,C2AB,TI)
      CALL CCMATMUL(C2AB,VHPHP,C2H,NOAUA,NOAUA,NOBUB,0,1)
C
      CALL SYMETR2(C2H,NOA,NUA,TI)
      RETURN
      END
C
C*MODULE ROHFCC  *DECK C2PPAA
      SUBROUTINE C2PPAA(NOA,NUA,VPPP,C2,C2H)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VPPP(NUA,NUA,NUA),C2(NUA,NUA,NOA,NOA),
     *          C2H(NUA,NOA,NOA,NUA)
C
      DO IA=1,NUA
         CALL ZEROMA(VPPP,1,NU3)
         READ(NFT899,REC=IA) VPPP
         CALL TRANMD(VPPP,NUA,NUA,NUA,1,13)
         CALL CCMATMUL(VPPP,C2,C2H(1,1,1,IA),NUA,NOA2,NUA2,0,0)
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK C2HCBB
      SUBROUTINE C2HCBB(NOA,NUA,NOB,NUB,C1B,FHP,FHH,FPP,C2H,TI,C2BB,
     *                  C2AB,VHPHP,VHPHH,VHPPP,VHHHH,VPPP,VHPPH,
     *                  OHHB,OPPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VHPHH(1)
      DIMENSION TI(1)
      DIMENSION FHH(1),FPP(1),FHP(1)
      DIMENSION VHPPP(1)
      DIMENSION VHPHP(1),VHHHH(1),VPPP(1),VHPPH(1)
      DIMENSION C2BB(1),C2AB(1)
      DIMENSION C1B(1)
      DIMENSION C2H(1)
      DIMENSION OHHB(1),OPPB(1)
C
      DATA HALF/0.5D+00/
      DATA QUARTER/0.25D+00/
      DATA EIGHT/8.00D+00/
C
      CALL ZEROMA(FHH,1,NO2)
      CALL ZEROMA(FPP,1,NU2)
      CALL ZEROMA(FHP,1,NOU)
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL ZEROMA(VHHHH,1,NO4)
      CALL ZEROMA(VHPPH,1,NO2U2)
      CALL ZEROMA(VPPP,1,NU3)
      CALL ZEROMA(C2H,1,NO2U2)
C
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891)
      CALL RDTAB2(NOB,NOB,FHH,4,NFT891)
      CALL RDTAB2(NUB,NUB,FPP,2,NFT891)
      CALL RDTAB(NOB,NOB,NOB,NUB,VHPHH,15,NFT891)
      CALL RDTAB(NOB,NUB,NUB,NUB,VHPPP,12,NFT892)
      CALL RDTAB(NUB,NOB,NUB,NOB,VHPHP,2,NFT892)
      CALL RDTAB(NOB,NOB,NOB,NOB,VHHHH,8,NFT891)
      CALL RDINT(1,NOBUB,NOBUB,VHPPH,NFT830)
C
      CALL CCMATMUL(FHP,C1B,C2H,NOBUB,NOBUB,1,1,0)
      CALL VECMUL(C1B,NOBUB,HALF)
      CALL CCMATMUL(VHPPP,C1B,C2H,NOBUB2,NOB,NUB,0,1)
      CALL TRANMD(VHPHH,NOB,NOB,NOB,NUB,13)
      CALL VECMUL(VHPPH,NOB2UB2,HALF)
      CALL INSITU(NUB,NOB,NUB,NOB,TI,VHPPH,12)
      CALL CCMATMUL(C2BB,FHH,C2H,NOBUB2,NOB,NOB,0,1)
      CALL CCMATMUL(VHPPH,OHHB,C2H,NOBUB2,NOB,NOB,0,1)
C     ------c2h(bb,jb,ib,ab)---------------------------
      CALL TRANSQ(C2H,NOBUB)
      CALL TRANSQ(C2BB,NOBUB)
      CALL TRANSQ(OPPB,NUB)
      CALL TRANSQ(VHPPH,NOBUB)
      CALL CCMATMUL(FPP,C2BB,C2H,NUB,NOB2UB,NUB,0,0)
      CALL CCMATMUL(C1B,VHPHH,C2H,NUB,NOB2UB,NOB,0,0)
      CALL CCMATMUL(OPPB,VHPPH,C2H,NUB,NOB2UB,NUB,0,0)
      CALL VECMUL(C2BB,NOB2UB2,QUARTER)
      CALL TRAN24(NUB,NOB,NOB,NUB,TI,C2BB)
      CALL C2PPBB(NOB,NUB,NUA,VPPP,C2BB,C2H)
C
C     ------c2h(ba,aa,ia,ja)-----------------------
      CALL TRAN24(NUB,NOB,NOB,NUB,TI,C2H)
      CALL CCMATMUL(C2BB,VHHHH,C2H,NUB2,NOB2,NOB2,0,0)
      CALL INSITU(NUB,NUB,NOB,NOB,TI,C2H,13)
C     -----------------------------------------------
      CALL INSITU(NUB,NUB,NOB,NOB,TI,C2BB,13)
      CALL VECMUL(C2BB,NOB2UB2,EIGHT)
      CALL CCMATMUL(C2BB,VHPHP,C2H,NOBUB,NOBUB,NOBUB,0,1)
C
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL RDTAB(NUB,NOB,NOA,NUA,VHPHP,5,NFT892)
      CALL INSITU(NUB,NOB,NOA,NUA,TI,VHPHP,12)
      CALL CCMATMUL(VHPHP,C2AB,C2H,NOBUB,NOBUB,NOAUA,0,1)
C
      CALL SYMETR2(C2H,NOB,NUB,TI)
      RETURN
      END
C
C*MODULE ROHFCC  *DECK C2PPBB
      SUBROUTINE C2PPBB(NOB,NUB,NUA,VPPP,C2,C2H)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VPPP(NUB,NUB,NUB),C2(NUB,NUB,NOB,NOB),
     *          C2H(NUB,NOB,NOB,NUB)
C
      DO IA=1,NUB
         CALL ZEROMA(VPPP,1,NU3)
         READ(NFT899,REC=NUA+IA) VPPP
         CALL TRANMD(VPPP,NUB,NUB,NUB,1,13)
         CALL CCMATMUL(VPPP,C2,C2H(1,1,1,IA),NUB,NOB2,NUB2,0,0)
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK C2HCAB
      SUBROUTINE C2HCAB(NOA,NUA,NOB,NUB,C1A,C1B,FHP,FHH,FPP,C2H,TI,
     *                  C2AA,C2BB,C2AB,VHPHP,VHPHH,VHPPP,VHHHH,
     *                  VPPP,VHPPH,OHHA,OPPA,OHHB,OPPB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VHPHH(1)
      DIMENSION TI(1)
      DIMENSION FHH(1),FPP(1),FHP(1)
      DIMENSION VHPPP(1)
      DIMENSION VHPHP(1),VHHHH(1),VPPP(1),VHPPH(1)
      DIMENSION C2AA(1),C2BB(1),C2AB(1)
      DIMENSION C1A(1),C1B(1)
      DIMENSION C2H(1)
      DIMENSION OHHA(1),OPPA(1),OHHB(1),OPPB(1)
C
      CALL ZEROMA(FHH,1,NO2)
      CALL ZEROMA(FPP,1,NU2)
      CALL ZEROMA(FHP,1,NOU)
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL ZEROMA(VHHHH,1,NO4)
      CALL ZEROMA(VHPPH,1,NO2U2)
      CALL ZEROMA(VPPP,1,NU3)
      CALL ZEROMA(C2H,1,NO2U2)
C
      CALL RDTAB2(NOA,NUA,FHP,5,NFT891)
      CALL RDTAB2(NOB,NOB,FHH,4,NFT891)
      CALL RDTAB2(NUB,NUB,FPP,2,NFT891)
      CALL RDTAB(NOA,NUB,NUA,NUB,VHPPP,14,NFT892)
      CALL RDTAB(NOA,NOB,NUA,NOB,VHPHH,17,NFT891)
      CALL RDTAB(NOA,NOB,NOA,NOB,VHHHH,9,NFT891)
      CALL RDTAB(NUA,NOA,NUA,NOA,VHPHP,1,NFT892)
      CALL RDINT(1,NOBUB,NOAUA,VHPPH,NFT833)
C
      CALL CCMATMUL(OPPA,VHPPH,C2H,NUA,NOABUB,NUA,1,0)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,C2H,12)
      CALL INSITU(NUA,NOA,NUB,NOB,TI,VHPPH,12)
      CALL CCMATMUL(VHPPH,OHHB,C2H,NOAUAB,NOB,NOB,0,1)
      CALL TRANSQ(OHHA,NOA)
      CALL CCMATMUL(OHHA,VHPPH,C2H,NOA,NOBUAB,NOA,0,1)
      CALL CCMATMUL(FHP,C1B,C2H,NOAUA,NOBUB,1,0,0)
      CALL INSITU(NOA,NUB,NUA,NUB,TI,VHPPP,23)
      CALL CCMATMUL(VHPPP,C1B,C2H,NOAUAB,NOB,NUB,0,0)
      CALL CCMATMUL(C2AB,FHH,C2H,NOAUAB,NOB,NOB,0,1)
      CALL TRAN14(NUA,NOA,NUA,NOA,TI,VHPHP)
      CALL INSITU(NOA,NOA,NUA,NUA,TI,VHPHP,23)
      CALL CCMATMUL(VHPHP,C2AB,C2H,NOAUA,NOBUB,NOAUA,0,1)
C     -------------c2h(ia,aa,jb,bb)---------------------
      CALL TRAN34N(NOA,NUA,NUB,NOB,TI,C2H)
      CALL TRAN34N(NOA,NUA,NUB,NOB,TI,C2AB)
      CALL TRANSQ(FPP,NUB)
      CALL CCMATMUL(C2AB,FPP,C2H,NOABUA,NUB,NUB,0,0)
      CALL INSITU(NOA,NOB,NUA,NOB,TI,VHPHH,23)
      CALL TRT1(NUB,NOB,TI,C1B)
      CALL CCMATMUL(VHPHH,C1B,C2H,NOABUA,NUB,NOB,0,1)
      CALL TRAN34N(NOA,NUA,NUB,NOB,TI,VHPPH)
      CALL TRANSQ(OPPB,NUB)
      CALL CCMATMUL(VHPPH,OPPB,C2H,NOABUA,NUB,NUB,0,0)
      CALL TRAN34N(NOA,NUA,NOB,NUB,TI,C2H)
      CALL TRAN34N(NOA,NUA,NOB,NUB,TI,C2AB)
C     --------------------------------------------------
C
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL RDTAB(NUB,NOB,NUB,NOB,VHPHP,2,NFT892)
      CALL CCMATMUL(C2AB,VHPHP,C2H,NOAUA,NOBUB,NOBUB,0,1)
C
      CALL ZEROMA(FHH,1,NO2)
      CALL ZEROMA(FPP,1,NU2)
      CALL ZEROMA(FHP,1,NOU)
      CALL ZEROMA(VHPHH,1,NO3U)
      CALL ZEROMA(VHPPP,1,NOU3)
      CALL ZEROMA(VHPHP,1,NO2U2)
C
      CALL RDTAB2(NOB,NUB,FHP,6,NFT891)
      CALL RDTAB2(NOA,NOA,FHH,3,NFT891)
      CALL RDTAB2(NUA,NUA,FPP,1,NFT891)
      CALL RDTAB(NUA,NUB,NUA,NOB,VHPPP,13,NFT892)
      CALL RDTAB(NOA,NOB,NOA,NUB,VHPHH,16,NFT891)
      CALL RDTAB(NUB,NOA,NUB,NOA,VHPHP,3,NFT892)
C
      CALL TRT1(NOB,NUB,TI,FHP)
      CALL CCMATMUL(C1A,FHP,C2H,NOAUA,NOBUB,1,0,0)
      CALL INSITU(NUA,NUB,NUA,NOB,TI,VHPPP,23)
      CALL CCMATMUL(C1A,VHPPP,C2H,NOA,NOBUAB,NUA,0,0)
      CALL TRANSQ(FHH,NOA)
      CALL CCMATMUL(FHH,C2AB,C2H,NOA,NOBUAB,NOA,0,1)
C     ---------C2H(ia,jb,bb,aa)---------------------
      CALL TRAN24(NOA,NUA,NUB,NOB,TI,C2H)
      CALL TRAN24(NOA,NUA,NUB,NOB,TI,C2AB)
      CALL TRANSQ(FPP,NUA)
      CALL CCMATMUL(C2AB,FPP,C2H,NOABUB,NUA,NUA,0,0)
      CALL TRAN34N(NOA,NOB,NOA,NUB,TI,VHPHH)
      CALL CCMATMUL(VHPHH,C1A,C2H,NOABUB,NUA,NOA,0,1)
      CALL TRANSQ(VHHHH,NOAB)
      CALL CCMATMUL(VHHHH,C2AB,C2H,NOAB,NUAB,NOAB,0,0)
C     -----------------------------------------------
C     ---------C2H(ia,jb,aa,bb)---------------------
      CALL TRAN34N(NOA,NOB,NUB,NUA,TI,C2H)
      CALL TRAN34N(NOA,NOB,NUB,NUA,TI,C2AB)
      CALL C2PPAB(NOA,NOB,NUA,NUB,VPPP,C2AB,C2H)
C     ----------------------------------------------
C     ---------C2H(jb,aa,bb,ia)---------------------
      CALL TRAN1TO4(NOA,NOB,NUA,NUB,TI,C2H)
      CALL TRAN1TO4(NOA,NOB,NUA,NUB,TI,C2AB)
      CALL CCMATMUL(C2AB,VHPHP,C2H,NOBUA,NOAUB,NOAUB,0,1)
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL RDTAB(NUA,NOB,NUA,NOB,VHPHP,4,NFT892)
      CALL INSITU(NUA,NOB,NUA,NOB,TI,VHPHP,23)
      CALL TRAN14(NUA,NUA,NOB,NOB,TI,VHPHP)
      CALL CCMATMUL(VHPHP,C2AB,C2H,NOBUA,NOAUB,NOBUA,0,1)
      CALL TRAN14(NOB,NUA,NUB,NOA,TI,C2H)
      CALL TRAN14(NOB,NUA,NUB,NOA,TI,C2AB)
C     ----------------------------------------------
C
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL RDTAB(NUB,NOB,NOA,NUA,VHPHP,5,NFT892)
      CALL TRANSNQN(NOBUB,NOAUA,VHPHP,TI)
      CALL TRAN34N(NOA,NUA,NUA,NOA,TI,C2AA)
      CALL CCMATMUL(C2AA,VHPHP,C2H,NOAUA,NOBUB,NOAUA,0,1)
C
      CALL ZEROMA(VHPHP,1,NO2U2)
      CALL RDTAB(NUB,NOB,NUA,NOA,VHPHP,6,NFT892)
      CALL INSITU(NUB,NOB,NUA,NOA,TI,VHPHP,23)
      CALL TRAN14(NUB,NUA,NOB,NOA,TI,VHPHP)
      CALL CCMATMUL(VHPHP,C2BB,C2H,NOAUA,NOBUB,NOBUB,0,1)
      RETURN
      END
C
C*MODULE ROHFCC  *DECK C2PPAB
      SUBROUTINE C2PPAB(NOA,NOB,NUA,NUB,VPPP,C2,C2H)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /CCOPIO/ NFT820,NFT821,NFT822,NFT823,NFT825,NFT826,NFT827,
     *                NFT828,NFT829,NFT830,NFT831,NFT832,NFT833,NFT834,
     *                NFT835,NFT836,NFT837,NFT838,NFT839,NFT843,NFT848,
     *                NFT858,NFT859,NFT891,NFT892,NFT899
      COMMON /NNMAX / NOU,NO2,NU2,NO2U2,NO4,NU3,NO3U,NOU3,NOU2,NO2U
      COMMON /NNROHF/ NOAUA,NOAUB,NOBUA,NOBUB,NOA2,NOA2UA,NOA4,NOB2,
     *                NOB2UB,NOB4,NUA2,NOAUA2,NUA4,NUB2,NOBUB2,NUB4,
     *                NUAB,NOAB,NO2AB,NU2AB,NOABUB,NOABUA,NOAUAB,
     *                NOBUAB,NOA2UA2,NOB2UB2,NOA2UB2,NOB2UA2,NO2U2AB,
     *                NUA3,NUB3,NOA3,NOB3,NOA3UA,NOB3UB,NOA2UB,NOAUB2,
     *                NOB2UA,NOBUA2,NUA2UB,NOA2OB,NOAOB2,NUA3NOA,
     *                NUAUB2,NOAOB2UA,NUB3NOB
C
      DIMENSION VPPP(NUA,NUB,NUA),C2(NOA,NOB,NUA,NUB),
     *          C2H(NOA,NOB,NUA,NUB)
C
      DO IB=1,NUB
         CALL ZEROMA(VPPP,1,NU3)
         READ(NFT899,REC=NUA+NUB+IB) VPPP
         CALL CCMATMUL(C2,VPPP,C2H(1,1,1,IB),NOAB,NUA,NUAB,0,0)
      ENDDO
C
      RETURN
      END
C
C*MODULE ROHFCC  *DECK DENADD1
      SUBROUTINE DENADD1(NO,NU,T1,FHH,FPP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION T1(NO,NU),FHH(NO),FPP(NU)
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       DEN=FHH(I)-FPP(IA)
       T1(I,IA)=T1(I,IA)/DEN
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK DENADD2
      SUBROUTINE DENADD2(NO,NU,T2,FHH,FPP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T2(NO,NU,NU,NO),FHH(NO)
      DIMENSION FPP(NU)
C
      DO 1,I=1,NO
      DO 2,J=1,NO
      DO 3,IA=1,NU
      DO 4,IB=1,NU
       DEN=FHH(I)+FHH(J)-FPP(IA)-FPP(IB)
       T2(I,IA,IB,J)=T2(I,IA,IB,J)/DEN
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK DENADAB
      SUBROUTINE DENADAB(NOA,NUA,NUB,NOB,T2,OHHA,OHHB,OPPA,OPPB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T2(NOA,NUA,NUB,NOB)
      DIMENSION OHHA(NOA),OHHB(NOB)
      DIMENSION OPPA(NUA),OPPB(NUB)
C
      DO 1,I=1,NOA
      DO 2,IA=1,NUA
      DO 3,IB=1,NUB
      DO 4,J=1,NOB
       DEN=OHHA(I)+OHHB(J)-OPPA(IA)-OPPB(IB)
       T2(I,IA,IB,J)=T2(I,IA,IB,J)/DEN
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK RESN1
      SUBROUTINE RESN1(NO,NU,T1,RES)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T1(NO,NU)
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       XXX=T1(I,IA)
       RES=RES+XXX*XXX
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK RESN2
      SUBROUTINE RESN2(NO,NU,T2,RES)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T2(NO,NU,NU,NO)
C
      DO 1,I=1,NO-1
      DO 2,IA=1,NU-1
      DO 3,IB=IA+1,NU
      DO 4,J=I+1,NO
       XXX=T2(I,IA,IB,J)
       RES=RES+XXX*XXX
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE ROHFCC  *DECK RESNAB
      SUBROUTINE RESNAB(NOA,NUA,NUB,NOB,T2,RES)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T2(NOA,NUA,NUB,NOB)
C
      DO 1,I=1,NOA
      DO 2,IA=1,NUA
      DO 3,IB=1,NUB
      DO 4,J=1,NOB
       XXX=T2(I,IA,IB,J)
       RES=RES+XXX*XXX
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
