C 17 JAN 06 - PP  - DRT4: FIX MEMORY ALLOCATION
C  6 JUL 05 - DGF - DRT4: INITIALIZE EC2 VALUE
C  1 JUN 05 - MWS - USE CC(T)MATMUL(T) MATRIX MULTIPLY NAMES ONLY
C 30 APR 05 - SK,KK - NEW MODULE FOR CC NON-ITERATIVE QUADRUPLES
C
C*MODULE CCQUAD  *DECK DRQUADS
      SUBROUTINE DRQUADS(NO,NU,OEH,OEP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      LOGICAL CNVR
CCCX      COMMON /CCENGY/ ENRG,EREF,EMP2,ECCN,ETOT(6),ECORR(6),
CCCX     *                DIAGS(3),AMPMX(5,2),IAMPMX(5,4,2),XO1,XO2,
CCCX     *                DIFMAX,DIFFENG,ITER,CNVR
CCCX      COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
CCCX     *                MXCCIT,MXRLEIT,NWRDCC,ICCCNV,ICCRST,IDSKCC
CCCX      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
      COMMON /EOMFIL/ NSTAR,NC1,NC2,NHC1,NHC2,NHH,NPP,NAX,NAXX,NDIAG,
     *                ITAPP,IFAX,NRR1,NRR2,NEXM,NEXE,NW2C,NW4C,
     *                NW4D,NW2BD,NW4B,NROO,NREXM,NREXE,
     *                JCISD,KCIF,JCISDNX
      COMMON/NEWIO/L46,NHHQ,NPPQ,NTVO,NVT
CCCX      COMMON /FMCOM / X(1)
      DIMENSION OEH(NO),OEP(NU)
      NO2=NO*NO
      NU2=NU*NU
      NU3=NU*NU2
      NOU2=NO*NU2
      NO2U2=NO*NOU2
      L46 =78
      NTVO=79
      NHH =85
      NPP =86
      NHHQ=41
      NPPQ=42
      NVT =43
      LNU3=NU3
CCCX      LREC46=700
      CALL CCOPEN(NPP,LNU3,'EOMPPPP') !
      CALL CCOPEN(L46,LNU3,'CCQUADS')
      CALL CCCLOS(NHHQ,'DELETE')
      CALL CCOPEN(NHHQ,NO2,'AABB41') !!! ---
      CALL CCCLOS(NPPQ,'DELETE')
      CALL CCOPEN(NPPQ,NU2,'BBAA42') !!! ---
      CALL CCOPEN(NTVO,NOU2,'QUADSVO')
      CALL CCCLOS(NVT,'DELETE')
      CALL CCOPEN(NVT,NO2U2,'BBBB43') !!! ---
      CALL DRT3WT2Q(NO,NU,OEH,OEP)
      CALL DRINTRIQ(NO,NU,0)
      CALL DRT3WT2NQ(NO,NU,OEH,OEP)
      CALL DRINTRI2(NO,NU,0)
      CALL DRT3WT2P(NO,NU,OEH,OEP)
      CALL DRSUMA(NO,NU,OEH,OEP)
      CALL DRT4(NO,NU,OEH,OEP)
      RETURN
      END
C*MODULE CCQUAD  *DECK DRT4
      SUBROUTINE DRT4(NO,NU,OEH,OEP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
CCCX      COMMON/IOPOS/ICRSIZ,ICSC1(4)
CCCX      COMMON/NEWIO/L46,NHH,NPP,NTVO,NVT
CCCX      COMMON/FLAGS/IFLAGS(100)
      COMMON/FMCOM/CR(1)
      COMMON/EN51/EC1,EC2
CCCX      COMMON/AVLSPACE/MAXCOR
      DIMENSION OEH(NO),OEP(NU)
CCCX      DATA HALF/0.5D+00/
C
      EC1=0.0D+00
      EC2=0.0D+00
C
      NO2=NO*NO
      NO3=NO*NO2
      NO4=NO*NO3
      NU2=NU*NU
      NU3=NU*NU2
      NU4=NU*NU3
      NOU=NO*NU
      NO2U=NO2*NU
      NO3U=NO3*NU
      NOU2=NO*NU2
      NOU3=NO*NU3
      NO2U2=NO2*NU2
C
C        NOTE THAT THE ADDRESS LOADFM+1 IS THE ONLY THING
C        PASSED TO THE COMPUTATIONAL ROUTINE.  THE VARIOUS
C        USES FOR THIS CHUNK OF MEMORY SEEM TO HAVE THEIR
C        GRAND TOTALS COMPUTED BELOW, AND THE MEMORY NEEDED
C        IS THE HIGHEST OF ANY OF THESE.
C
C        SOMEONE SHOULD WORK OUT WHAT THE EXCESS 10 MWORDS
C        IS, AS EVEN THE SMALLEST PROBLEMS ASK FOR THAT.
C        IT IS QUITE POSSIBLE THAT 10 MW IS NOT ENOUGH FOR
C        LARGE RUNS, AND THUS REPRESENTS A BUG.
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      IMNO3U=NO3U
      IF(NU3.GT.NO3U)IMNO3U=NU3
      IMNU3=NO2U2
      IF(NU3.GT.NO2U2)IMNU3=NU3
CCCX      ITO1=LOADFM+4*NU2
      ITO2=LOADFM+2*NO2U2+  IMNU3+NU3
      ITO3=LOADFM+8*NO2U2+  IMNU3
      ITO4=LOADFM+5*NO2U2+3*IMNU3
      ITO5=LOADFM+4*NO2U2+  IMNU3+NO4
      ITO6=LOADFM+2*NO2U2+  IMNU3+NOU3+NOU+IMNO3U+10000000
      WRITE(IW,9090) '     RANK1',ITO2,NGOTMX
      WRITE(IW,9090) '    T2HPT2',ITO3,NGOTMX
      WRITE(IW,9090) '    T2PPT2',ITO4,NGOTMX
      WRITE(IW,9090) '    T2HHT3',ITO5,NGOTMX
      WRITE(IW,9090) '    T2WWT3',ITO6,NGOTMX
      IMAXS=MAX(ITO2,ITO3,ITO4,ITO5,ITO6)
      NEED=IMAXS-LOADFM
      CALL GETFM(NEED)
C
      I1=LOADFM+1
      CALL TQF12(NO,NU,CR(I1),OEH,OEP,NEED)
      CALL TQFCR(NO,NU,CR(I1),OEH,OEP,NEED)
      CALL DRSUMAQ
C
      CALL RETFM(NEED)
      RETURN
C
 9090 FORMAT(1X,'MEMORY USAGE BY ',A10,':',I10,' NEEDED,',I10,
     *          ' AVAILABLE')
      END
C*MODULE CCQUAD  *DECK T1WT3INT
      SUBROUTINE T1WT3INT(NO,NU,TI,T1,VOE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B,C,D,E,F
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(NU,NU,NU),VOE(NU,NU,NO,NO),T1(NU,NO)
CCCX      DATA ZERO/0.0D+0/,TWO/2.0D+00/,HALF/0.5D+00/,FOUR/4.0D+0/
      NU3=NU*NU*NU
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL SYMT21(VOE,NU,NU,NO,NO,12)
      CALL ZEROMA(TI,1,NU3)
      DO 10 I=1,NO
      DO 10 M=1,NO
      DO 10 N=1,NO
      IF(I.EQ.M.AND.M.EQ.N)GOTO 10
      CALL RDT3N(I,M,N,NU,TI)
      CALL CCMATMUL(TI,VOE(1,1,M,N),T1(1,I),NU,1,NU2,0,0)
      CALL TRANT3(TI,NU,2)
      CALL CCMATMUL(TI,VOE(1,1,M,N),T1(1,I),NU,1,NU2,0,1)
 10   CONTINUE
      CALL TRT1(NU,NO,TI,T1)
      CALL DESM21(VOE,NU,NU,NO,NO,12)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL INSITU(NU,NU,NO,NO,TI,VOE,13)
      RETURN
      END
C*MODULE CCQUAD  *DECK T1WT3Q
      SUBROUTINE T1WT3Q(NO,NU,TI,T1,VOE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B,C,D,E,F
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(NU,NU,NU),VOE(NU,NU,NO,NO),T1(NU,NO)
CCCX      DATA ZERO/0.0D+0/,TWO/2.0D+00/,HALF/0.5D+00/,FOUR/4.0D+0/
      NU3=NU*NU*NU
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL SYMT21(VOE,NU,NU,NO,NO,12)
      CALL ZEROMA(TI,1,NU3)
      DO 10 I=1,NO
      DO 10 M=1,NO
      DO 10 N=1,NO
      IF(I.EQ.M.AND.M.EQ.N)GOTO 10
      CALL RDT3Q(I,M,N,NO,NU,TI)
      CALL CCMATMUL(TI,VOE(1,1,M,N),T1(1,I),NU,1,NU2,0,0)
      CALL TRANT3(TI,NU,2)
      CALL CCMATMUL(TI,VOE(1,1,M,N),T1(1,I),NU,1,NU2,0,1)
 10   CONTINUE
      CALL DESM21(VOE,NU,NU,NO,NO,12)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL INSITU(NU,NU,NO,NO,TI,VOE,13)
      RETURN
      END
C*MODULE CCQUAD  *DECK T2FT3INT
      SUBROUTINE T2FT3INT(NO,NU,T2,T3,FPH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NU,NU,NO,NO),T3(NU,NU,NU),FPH(NU,NO)
      DO 500 I=1,NO
      DO 500 J=1,NO
      DO 400 M=1,NO
      IF (I.EQ.J.AND.J.EQ.M)GOTO 400
      CALL RDT3N(I,J,M,NU,T3)
      CALL SYMT3(T3,NU,6)
      CALL CCMATMUL(T3,FPH(1,M),T2(1,1,I,J),NU2,1,NU,0,0)
 400  CONTINUE
 500  CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK T2FT3Q
      SUBROUTINE T2FT3Q(NO,NU,T2,T3,FPH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NU,NU,NO,NO),T3(NU,NU,NU),FPH(NU,NO)
      NU2=NU*NU
      DO 500 I=1,NO
      DO 500 J=1,NO
      DO 400 M=1,NO
      IF (I.EQ.J.AND.J.EQ.M)GOTO 400
      CALL RDT3Q(I,J,M,NO,NU,T3)
      CALL SYMT3(T3,NU,6)
      CALL CCMATMUL(T3,FPH(1,M),T2(1,1,I,J),NU2,1,NU,0,0)
 400  CONTINUE
 500  CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK T2WT3P
      SUBROUTINE T2WT3P(NO,NU,T2,T3,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NU,NU,NO,NO),T3(NU,NU,NU),VE(NU,NU,NU,NO)
CCCX      DATA TWO/2.0D+0/
      DO 11 I=1,NO
      DO 11 J=1,NO
      DO 12 M=1,NO
      IF (I.EQ.J.AND.I.EQ.M) GO TO 12
      CALL RDT3N(I,M,J,NU,T3)
      CALL SYMT3(T3,NU,1)
      CALL CCMATMUL(VE(1,1,1,M),T3,T2(1,1,J,I),NU,NU,NU2,0,0)
   12 CONTINUE
   11 CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK T2WT3PQ
      SUBROUTINE T2WT3PQ(NO,NU,T2,T3,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NU,NU,NO,NO),T3(NU,NU,NU),VE(NU,NU,NU,NO)
CCCX      DATA TWO/2.0D+0/
      DO 11 I=1,NO
      DO 11 J=1,NO
      DO 12 M=1,NO
      IF (I.EQ.J.AND.I.EQ.M) GO TO 12
      CALL RDT3Q(I,M,J,NO,NU,T3)
      CALL SYMT3(T3,NU,1)
      CALL CCMATMUL(VE(1,1,1,M),T3,T2(1,1,J,I),NU,NU,NU2,0,0)
   12 CONTINUE
   11 CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK T2WT3H
      SUBROUTINE T2WT3H(NO,NU,T2,T3,VM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NU,NU,NO,NO),T3(NU,NU,NU),VM(NO,NU,NO,NO)
      DATA TWO/2.0D+0/
      DO 13 J=1,NO
      DO 14 M=1,NO
      DO 14 N=1,NO
      IF (M.EQ.N.AND.M.EQ.J) GO TO 14
      CALL RDT3N(M,N,J,NU,T3)
      CALL VECMUL(T3,NU3,TWO)
      CALL CCMATMUL(VM(1,1,M,N),T3,T2(1,1,1,J),NO,NU2,NU,0,1)
      CALL RDT3N(N,M,J,NU,T3)
      CALL CCMATMUL(VM(1,1,M,N),T3,T2(1,1,1,J),NO,NU2,NU,0,0)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL RDT3N(J,M,N,NU,T3)
      CALL CCMATMUL(VM(1,1,M,N),T3,T2(1,1,1,J),NO,NU2,NU,0,0)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
   14 CONTINUE
   13 CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK T2WT3HQ
      SUBROUTINE T2WT3HQ(NO,NU,T2,T3,VM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NU,NU,NO,NO),T3(NU,NU,NU),VM(NO,NU,NO,NO)
      DATA TWO/2.0D+0/
      DO 13 J=1,NO
      DO 14 M=1,NO
      DO 14 N=1,NO
      IF (M.EQ.N.AND.M.EQ.J) GO TO 14
      CALL RDT3Q(M,N,J,NO,NU,T3)
      CALL VECMUL(T3,NU3,TWO)
      CALL CCMATMUL(VM(1,1,M,N),T3,T2(1,1,1,J),NO,NU2,NU,0,1)
      CALL RDT3Q(N,M,J,NO,NU,T3)
      CALL CCMATMUL(VM(1,1,M,N),T3,T2(1,1,1,J),NO,NU2,NU,0,0)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL RDT3Q(J,M,N,NO,NU,T3)
      CALL CCMATMUL(VM(1,1,M,N),T3,T2(1,1,1,J),NO,NU2,NU,0,0)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
   14 CONTINUE
   13 CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK VMWT3
      SUBROUTINE VMWT3(NO,NU,VM,T3,VO)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION VM(NO,NU,NO,NO),T3(NU,NU,NU),VO(NO,NU,NU,NO)
CCCX      DATA TWO/2.0D+0/
      DO 11 I=1,NO
      DO 11 J=1,NO
      DO 12 M=1,NO
      IF (I.EQ.J.AND.I.EQ.M) GO TO 12
      CALL RDT3N(I,M,J,NU,T3)
      CALL SYMT3(T3,NU,1)
      CALL CCMATMUL(VO(1,1,1,M),T3,VM(1,1,J,I),NO,NU,NU2,0,0)
   12 CONTINUE
   11 CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK VEWT3
      SUBROUTINE VEWT3(NO,NU,VE,T3,VO)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION VE(NU,NU,NU,NO),T3(NU,NU,NU),VO(NU,NU,NO,NO)
      DATA TWO/2.0D+0/
      DO 13 J=1,NO
      DO 14 M=1,NO
      DO 14 N=1,NO
      IF (M.EQ.N.AND.M.EQ.J) GO TO 14
      CALL RDT3N(M,N,J,NU,T3)
      CALL VECMUL(T3,NU3,TWO)
      CALL CCMATMUL(VO(1,1,M,N),T3,VE(1,1,1,J),NU,NU2,NU,0,1)
      CALL RDT3N(N,M,J,NU,T3)
      CALL CCMATMUL(VO(1,1,M,N),T3,VE(1,1,1,J),NU,NU2,NU,0,0)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL RDT3N(J,M,N,NU,T3)
      CALL CCMATMUL(VO(1,1,M,N),T3,VE(1,1,1,J),NU,NU2,NU,0,0)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
   14 CONTINUE
   13 CONTINUE
      RETURN
      END
C
C*MODULE CCQUAD  *DECK TQF12
      SUBROUTINE TQF12(NO,NU,CR,OEH,OEP,NEED)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
CCCX      COMMON/EN51/EC1
      COMMON/T4TOT/ETT2,ETS2,EQ1A,EQ1B,EQ2A,EQ2B,EQ3A,EQ3B,EQ4A,
     *EQ4B,O4A,O4B,ECORQ(8),ETOTQ(8)
      DIMENSION CR(1),OEH(NO),OEP(NU)
      DATA HALF/0.5D+0/,ZERO/0.0D+0/
C
C        NOTE THAT ONLY -NEED- WORDS WERE FORMALLY
C        ALLOCATED BEFORE THIS ROUTINE WAS CALLED
C
      EQ3A=ZERO
      EQ3B=ZERO
      EQ4A=ZERO
      EQ4B=ZERO
      CALL ZEROMA(CR,1,NO2U2)
      IMNO3U=NO3U
      IF(NU3.GT.NO3U)IMNO3U=NU3
      IMNU3=NO2U2
      IF(NU3.GT.NO2U2)IMNU3=NU3
      CALL DRWT1T3(NO,NU,CR,NEED)
C
      I2=1+NO2U2
      I3=I2+NO2U2
      CALL ENGY1CR(NO,NU,CR,CR(I2),CR(I3),OEH,OEP)
C
      I0=1            ! T2N
      I1=I0+NO2U2     ! T1
      I2=I1+NOU       ! TI
      I3=I2+IMNU3     ! V
      I4=I3+NOU3      ! VOE
      I5=I4+NO2U2     ! VE
      ITO=I5+IMNO3U
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'NOT ENOUGH MEMORY FOR T2WWT3'
         CALL ABRT
      END IF
C
      CALL ZEROMA(CR,1,NO2U2)
      CALL T2WWT3(NO,NU,CR(I1),CR(I2),CR(I3),CR(I4),CR(I5),CR,OEH,OEP)
C
      L46=78
      CALL CCCLOS(L46,'DELETE')
      L46=61
      CALL CCCLOS(L46,'DELETE')
      LREC46=700
      CALL CCOPEN(L46,LREC46,'NMRINT1')
C
C --------------------------------
C
      IO0=1              !O2
      IO1=IO0+NO2U2      !A
      IO0=NO2U2+1           !TI
      IO1=IO0+NU3     !O2
      IO2=IO1+NO2U2   !VO2
      IO3=IO2+NO2U2   ! V
      ITO=IO3+IMNU3   ! ITO
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR RANK1'
         CALL ABRT
      END IF
C
      CALL RANK1(NO,NU,CR(IO0),CR(IO1),CR(IO2),CR(IO3))
C
      I0=1          ! T2N
      I1=I0+NO2U2   ! FPP
      I2=I1+NO2U2   ! TI
      I3=I2+NO2U2   ! O2
      I4=I3+NO2U2   ! T2
      I5=I4+NO2U2   ! VO2
      I6=I5+NO2U2   ! V
      I7=I6+IMNU3   ! VOE
      I8=I7+NO2U2   ! VO
      ITO=I8+NO2U2
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR T2HPT2SQ'
         CALL ABRT
      END IF
C
      CALL ZEROMA(CR,1,ITO)
      CALL T2HPT2SQ(NO,NU,CR(I1),CR(I2),CR(I3),CR(I4),CR(I5),CR(I6),
     *              CR(I7),CR(I8),CR)
C
      IO1=NO2U2+1
      IO2=NO2U2+IO1
      CALL SYMETR(CR,NO,NU)
      CALL ENGY1(NO,NU,CR(IO1),CR,CR(IO2),OEH,OEP)
      CALL ZEROMA(CR,1,NO2U2)
C
      I0=1            !T2N
      I1=I0+NO2U2     !TI
      I2=I1+IMNU3     !O2
      I3=I2+NO2U2     !T2
      I4=I3+IMNU3     !VOE
      I5=I4+NO2U2     !V
      I6=I5+IMNU3     !O4
      I7=I6+IMNU3     !VO2
      ITO=I7+NO2U2
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR T2PPT2SQ'
         CALL ABRT
      END IF
C
      CALL T2PPT2SQ(NO,NU,CR(I1),CR(I2),CR(I3),CR(I4),CR(I5),CR(I6),
     *              CR(I7),CR)
C
      IO1=NO2U2+1
      IO2=NO2U2+IO1
      CALL SYMETR(CR,NO,NU)
      CALL ENGY1(NO,NU,CR(IO1),CR,CR(IO2),OEH,OEP)
      CALL ZEROMA(CR,1,NO2U2)
C
      I0=1             !T2N
      I1=I0+NO2U2 +10000    !TI
      I2=I1+IMNU3 +10000    !O2
      I3=I2+NO2U2 +10000    !T2
      I4=I3+NO2U2 +10000    !VO2
      I5=I4+NO2U2 +10000    !V
      ITO=I5+NO4   +10000
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR T2HHT2SQ'
         CALL ABRT
      END IF
C
      CALL T2HHT2SQ(NO,NU,CR(I1),CR(I2),CR(I3),CR(I4),CR(I5),CR)
C
      IO0=1             ! T2N
      IO1=IO0+NO2U2     ! T1
      IO2=IO1+NO2U2     ! TI
      ITO=IO2+NO2U2
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR ENGY1/ENGY'
         CALL ABRT
      END IF
C
      CALL SYMETR(CR,NO,NU)
      CALL ENGY1(NO,NU,CR(IO1),CR,CR(IO2),OEH,OEP)
      CALL ENGY
C
      IO0=1             ! FHH
      IO1=IO0+NO2       ! FPP
      IO2=IO1+IMNU3       ! TI
      IO3=IO2+NOU2      ! O2
      IO4=IO3+NO2U2     ! T2
      IO5=IO4+NO2U2     ! VOE
      IO6=IO5+NO2U2     ! T2N
      ITO=IO6+NO2U2     !
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR T2WT2SQ'
         CALL ABRT
      END IF
C
      CALL T2WT2SQ(NO,NU,CR,CR(IO1),CR(IO2),CR(IO3),CR(IO4),
     2             CR(IO5),CR(IO6),OEH,OEP,HALF,1)
      CALL T2WT2SQ(NO,NU,CR,CR(IO1),CR(IO2),CR(IO3),CR(IO4),
     2             CR(IO5),CR(IO6),OEH,OEP,HALF,2)
      RETURN
      END
C
C*MODULE CCQUAD  *DECK TQFCR
      SUBROUTINE TQFCR(NO,NU,CR,OEH,OEP,NEED)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION CR(1),OEH(NO),OEP(NU)
C
C        NOTE THAT ONLY -NEED- WORDS WERE FORMALLY
C        ALLOCATED BEFORE THIS ROUTINE WAS CALLED
C
      NO2=NO*NO
      NO3=NO*NO2
      NO4=NO*NO3
      NU2=NU*NU
      NU3=NU*NU2
      NOU2=NO*NU2
      NO2U2=NO2*NU2
      IMNU3=NO2U2
      IF(NU3.GT.NO2U2)IMNU3=NU3
C
      N1=NO3*NU2
      N2=4*NO2U2+2*IMNU3+2*NU3
      N3=8*NO2U2+4*NO4+NOU2+NO2
      MXMEM=MAX(N1,N2,N3)
      WRITE(6,996) MXMEM
C
      I1=1
      I2=I1+NU3
      ITO=I2+NU3
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR PPEX'
         CALL ABRT
      END IF
C
      CALL PPEX(NU,CR(I1),CR(I2))
C
      IO0=1               !TI
      IO1=IO0+NOU2        !O2
      IO2=IO1+NO2U2       !VO2
      IO3=IO2+NO2U2       ! V
      ITO=IO3+IMNU3       !ITO
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR RANK1CR'
         CALL ABRT
      END IF
C
      CALL RANK1CR(NO,NU,CR(IO0),CR(IO1),CR(IO2),CR(IO3),OEH,OEP)
      CALL DRINTHM(NO,NU,CR,NEED)
C
      I0=1            !T2N
      I1=I0+NO2U2    !TI
      I2=I1+IMNU3    !O2
      I3=I2+NO2U2    !T2
      I4=I3+IMNU3    !VOE
      I5=I4+NO2U2    !V
      I6=I5+NU3      !O4
      I7=I6+NU3      !VO2
      ITO=I7+NO2U2
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR T2PPT2SQCR'
         CALL ABRT
      END IF
C
      CALL T2PPT2SQCR(NO,NU,CR(I1),CR(I2),CR(I3),CR(I4),CR(I5),CR(I6),
     *                CR(I7),CR,OEH,OEP)
C
      I0=1            !TI
      I1=I0+NOU2    !VH
      I2=I1+NO2     !VHA
      I3=I2+NO4     !VHB
      I4=I3+NO4     !VHC
      I5=I4+NO4     !VHD
      I6=I5+NO4     !O2
      I7=I6+NO2U2   !O2A
      I8=I7+NO2U2   !VO
      I9=I8+NO2U2   !VOA
      I10=I9+NO2U2  !VT
      I11=I10+NO2U2 !VO2
      I12=I11+NO2U2 !T2N
      I13=I12+NO2U2 !T2NN
      ITO=I13+NO2U2
      IF(ITO.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR T2HHVT'
         CALL ABRT
      END IF
C
      CALL T2HHVT(NO,NU,CR,CR(I1),CR(I2),CR(I3),CR(I4),CR(I5),CR(I6),
     *            CR(I7),CR(I8),CR(I9),CR(I10),CR(I11),CR(I12),CR(I13),
     *            OEH,OEP)
  996 FORMAT(1X,'MEMORY REQUIRED FOR COMPLETELY RENOR. QUADS.',I8,
     *          ' WORDS')
      RETURN
      END
C
C*MODULE CCQUAD  *DECK T2HHT2SQ
      SUBROUTINE T2HHT2SQ(NO,NU,TI,O2,T2,VO2,V,T2N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B,C,E,F
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(NU,NU,NO),O2(NO,NU,NU,NO),T2(NO,NU,NU,NO),
     *VO2(NO,NU,NU,NO),T2N(NO,NU,NU,NO),V(NU,NU,NU,NU)
      DATA TWO/2.0D+0/,HALF/0.5D+0/
      CALL RO2(1,NO,NU,O2)
      CALL RINTHH(1,NO,VO2)
      CALL TRANSQ(VO2,NO)
      CALL RDOV4(1,NU,NO,TI,V)
      CALL MTRANSQ(V,NO,7)
      CALL VECMUL(VO2,NO2,TWO)
      CALL TRANSQ(VO2,NO)
      CALL CCMATMUL(V,  VO2,TI,NO2,1,   NO2,1,1)
      CALL VECMUL(VO2,NO2,HALF)
      CALL MTRANSQ(V,NO,7)
      CALL CCMATMUL(V,  VO2,TI,NO2,1,   NO2,0,0)
      CALL CCMATMUL(TI,O2, T2N,NO, NOU2,NO, 0,1)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
C2
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL CCMATMUL(V,VO2,T2,NO3,NO,NO,1,1)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
      CALL CCMATMUL(T2,O2,T2N,NO2,NU2,NO2,0,0)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,VO2,TI,OEH,OEP)
C3
      CALL RINTVO(1,NO,NU,TI,VO2)
      CALL INSITU(NO,NU,NU,NO,TI,VO2,13)
      CALL CCMATMUL(VO2,V,T2,NU2,NO2,NO2,1,0)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,0)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL MTRANSQ(V,NO,7)
      CALL CCMATMUL(VO2,V,T2,NU2,NO2,NO2,1,0)
      CALL SYMT21(V,NO,NO,NO,NO,23)
      CALL RINTVO(2,NO,NU,TI,VO2)
      CALL INSITU(NO,NU,NU,NO,TI,VO2,13)
      CALL CCMATMUL(VO2,V,T2,NU2,NO2,NO2,0,1)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,VO2,TI,OEH,OEP)
C4
      CALL RINTVO(1,NO,NU,TI,VO2)
      CALL CCMATMUL(VO2,O2,T2,NOU,NOU,NOU,1,0)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL CCMATMUL(VO2,O2,T2,NOU,NOU,NOU,0,1)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL RINTVO(2,NO,NU,TI,VO2)
      CALL VECMUL(VO2,NO2U2,HALF)
      CALL CCMATMUL(VO2,O2,T2,NOU,NOU,NOU,0,1)
      CALL RDOV4(1,NU,NO,TI,V)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,T2,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL INSITU(NO,NU,NU,NO,TI,T2N,13)
      CALL CCMATMUL(T2,V,T2N,NU2,NO2,NO2,0,0)
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
C5
      CALL RINTVO(5,NO,NU,TI,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANMD(T2,NU,NU,NO,NO,12)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,TI,NO,NO,NOU2,1,0)
      CALL DESM21(O2,NO,NU,NU,NO,23)
      CALL TRANSQ(TI,NO)
      CALL CCMATMUL(O2,TI,T2N,NOU2,NO,NO,0,1)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
C6
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL RINTHH(3,NO2,T2)
      CALL MTRANSQ(T2,NO,13)
      CALL SYMT21(T2,NO,NO,NO,NO,13)
      CALL MTRANSQ(V,NO,7)
      CALL CCMATMUL(V,T2,VO2,NO2,NO2,NO2,1,1)
      CALL DESM21(T2,NO,NO,NO,NO,13)
      CALL MTRANSQ(V,NO,7)
      CALL CCMATMUL(V,T2,VO2,NO2,NO2,NO2,0,0)
      CALL MTRANSQ(VO2,NO,10)
      CALL MTRANSQ(T2,NO,8)
      CALL CCMATMUL(V,T2,VO2,NO2,NO2,NO2,0,0)
      CALL MTRANSQ(VO2,NO,3)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
      CALL CCMATMUL(VO2,O2,T2N,NO2,NU2,NO2,0,0)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
C7
      CALL RINTVO(5,NO,NU,TI,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,VO2,NOU,NOU,NOU,1,1)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,VO2,NOU,NOU,NOU,0,0)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL DESM21(O2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,0)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL CCMATMUL(O2,T2,VO2,NOU,NOU,NOU,1,1)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,1)
CCCX      CALL ENGY2(NO,NU,T2N,VO2,TI,OEH,OEP)
      RETURN
      END
C
C*MODULE CCQUAD  *DECK T2PPT2SQ
      SUBROUTINE T2PPT2SQ(NO,NU,TI,O2,T2,VOE,V,O4,VO2,T2N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B,C,E,F
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(1),O2(NU,NU,NO,NO),T2(NU,NO,NO,NU),VOE(NU,NU,NO,NO),
     *T2N(NO,NO,NU,NU),VO2(NU,NU,NO,NO),V(1),O4(1)
      DATA TWO/2.0D+0/,
     *     HALF/0.5D+0/
      CALL RO2(1,NO,NU,O2)
      CALL RINTPP(1,NU,VOE)
      CALL TRANSQ( VOE,NU)
      CALL VT4(NO,NU,VOE,V,O4)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
      CALL CCMATMUL(O2,O4,T2N,NO2U,NU,NU,0,0)
C
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
C
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
C
CCCX      CALL ZCLOCK(1)
      CALL TRANSQ( VOE,NU)
      CALL TRANMD(O2,NO,NO,NU,NU,34)
      CALL CCMATMUL(O2,VOE,T2,NO2U,NU,NU,1,0)
      CALL TRANMD(O2,NO,NO,NU,NU,34)
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANMD(T2,NU,NO,NO,NU,23)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,T2N,13)
      DO 302 I=1,NU
      CALL RDVPP(I,NO,NU,V)
         CALL TRANT3(V,NU,5)
         CALL CCMATMUL(V,T2(1,1,1,I),T2N,NU2,NO2,NU,0,0)
 302  CONTINUE
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
CCCX      CALL ZCLOCK(1)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13) !NO,NO,NU,NU
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL CCMATMUL(O2,T2,VOE,NOU,NOU,NOU,1,0)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL DESM21(O2,NO,NU,NU,NO,23)
      CALL RINTVO(2,NO,NU,TI,T2)
      CALL VECMUL(T2,NO2U2,HALF)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL CCMATMUL(O2,T2,VOE,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      DO 303 I=1,NU
      CALL RDVPP(I,NO,NU,V)
      CALL CCMATMUL(VOE,V,T2N(1,1,1,I),NO2,NU,NU2,0,0)
 303  CONTINUE
      CALL CCMATMUL(O2,T2,VOE,NOU,NOU,NOU,1,1)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      DO 304 I=1,NU
      CALL RDVPP(I,NO,NU,V)
      CALL TRANT3(V,NU,2)
      CALL CCMATMUL(VOE,V,T2N(1,1,1,I),NO2,NU,NU2,0,0)
 304  CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13) !NU,NO,NO,NU
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,VOE,TI,OEH,OEP)!T2N NO,NO,NU,NU
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13) !NU,NO,NO,NU
CCCX      CALL ZCLOCK(1)
      CALL RINTVO(4,NO,NU,TI,T2)
      CALL TRANSQ(T2,NOU)
      CALL SYMT21(T2,NU,NO,NO,NU,23)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL CCMATMUL(T2,O2,TI,NU,NU,NO2U,1,1)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL CCMATMUL(O2,TI,T2N,NO2U,NU,NU,0,0)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
CCCX      CALL ZCLOCK(1)
      GOTO 1100
CCCX      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
CCCX      CALL TRANSQ(O2,NOU)
CCCX      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
CCCX 112       CONTINUE
CCCX      CALL TRANMD(O2,NU,NU,NO,NO,12)
CCCX      GOTO 1200
 1100 CONTINUE
      CALL RO2(1,NO,NU,O2)
      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
      CALL TRANMD(O2,NU,NU,NO,NO,12)
      CALL RO2(1,NO,NU,VOE)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL VECCOP(NO2U2,VO2,VOE)
      CALL SYMT21(VO2,NU,NU,NO,NO,12)
      CALL RO2(1,NO,NU,T2)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,T2N,13)
      DO 133 IA=1,NU
      CALL RDVPP(IA,NO,NU,V)
      CALL TRANT3(V,NU,1)
         CALL ZEROMA(O4,1,NU3)
         DO 132 I=1,NO
         DO 132 J=1,NO
            CALL CCMATMUL(O2(1,1,I,J),V,TI,NU,NU2,NU,1,0)
            CALL TRANT3(TI,NU,3)
            CALL CCMATMUL(VOE(1,1,I,J),TI,O4,NU,NU2,NU,0,0)
            CALL TRANT3(TI,NU,1)
            CALL CCMATMUL(VOE(1,1,J,I),TI,O4,NU,NU2,NU,0,0)
            CALL TRANT3(TI,NU,3)
            CALL CCMATMUL(VO2(1,1,J,I),TI,O4,NU,NU2,NU,0,1)
 132     CONTINUE
         CALL TRANT3(O4,NU,3)
         CALL CCMATMUL(O4,T2(1,1,1,IA),T2N,NU2,NO2,NU,0,0)
 133  CONTINUE
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
CCCX 1200 CONTINUE
CCCX      CALL ZCLOCK(1)
      CALL TRANMD(O2,NU,NU,NO,NO,12)
      CALL INSITU(NU,NU,NO,NO,TI,O2,13)
      CALL RINTVO(4,NO,NU,TI,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2,12)
      CALL VECMUL(T2,NO2U2,TWO)
      CALL CCMATMUL(T2,O2,VOE,NOU,NOU,NOU,1,0)
      CALL VECMUL(T2,NO2U2,HALF)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL CCMATMUL(T2,O2,VOE,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,O2,VOE,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,12)
      CALL CCMATMUL(O2,VOE,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL CCMATMUL(O2,VOE,T2N,NOU,NOU,NOU,0,1)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL CCMATMUL(T2,O2,VOE,NOU,NOU,NOU,1,0)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,12)
      CALL CCMATMUL(O2,VOE,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,VOE,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,VOE,TI,OEH,OEP)
CCCX      CALL ZCLOCK(1)
      CALL RINTVO(1,NO,NU,TI,VOE)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      DO 311 I=1,NU
      CALL RDVPP(I,NO,NU,V)
      CALL TRANT3(V,NU,1)
      CALL TRANT3(V,NU,3)
      CALL CCMATMUL(VOE,V,T2(1,1,1,I),NO2,NU,NU2,1,0)
 311  CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL INSITU(NU,NU,NO,NO,TI,T2,23)
      CALL TRANSQ(T2,NOU)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,0)
      CALL DESM21(O2,NO,NU,NU,NO,23)
      DO 312 I=1,NU
      CALL RDVPP(I,NO,NU,V)
      CALL TRANT3(V,NU,1)
      CALL CCMATMUL(VOE,V,T2(1,1,1,I),NO2,NU,NU2,1,0)
 312  CONTINUE
      CALL RINTVO(2,NO,NU,TI,VOE)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      DO 313 I=1,NU
      CALL RDVPP(I,NO,NU,V)
      CALL TRANT3(V,NU,1)
      CALL TRANT3(V,NU,3)
      CALL CCMATMUL(VOE,V,T2(1,1,1,I),NO2,NU,NU2,0,0)
 313  CONTINUE
      CALL VECMUL(VOE,NO2U2,-TWO)
      DO 314 I=1,NU
      CALL RDVPP(I,NO,NU,V)
      CALL TRANT3(V,NU,1)
      CALL CCMATMUL(VOE,V,T2(1,1,1,I),NO2,NU,NU2,0,0)
 314  CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL INSITU(NU,NU,NO,NO,TI,T2,23)
      CALL TRANSQ(T2,NOU)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
CCCX      CALL ZCLOCK(1)
      RETURN
      END
C*MODULE CCQUAD  *DECK T2PPT2SQCR
      SUBROUTINE T2PPT2SQCR(NO,NU,TI,O2,T2,VOE,V,O4,VO2,T2N,OEH,OEP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B,C,E,F
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(1),O2(NU,NU,NO,NO),T2(NU,NO,NO,NU),VOE(NU,NU,NO,NO),
     *T2N(NO,NO,NU,NU),VO2(NU,NU,NO,NO),V(NU,NU,NU,NU),O4(1),OEH(NO),
     *OEP(NU)
      DATA TWO/2.0D+0/,
     *     HALF/0.5D+0/
      NO2=NO*NO
      NO3=NO*NO2
      NO4=NO*NO3
      NU2=NU*NU
      NU3=NU*NU2
      NU4=NU*NU3
      NOU=NO*NU
      NO2U=NO2*NU
      NO3U=NO3*NU
      NOU2=NO*NU2
      NOU3=NO*NU3
      NO2U2=NO2*NU2
      CALL RO2(1,NO,NU,O2)
      CALL RINTPP(1,NU,VOE)
      CALL TRANSQ( VOE,NU)
      CALL VT4CR(NU,VOE,V,O4)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL CCMATMUL(O2,O4,T2N,NO2U,NU,NU,1,0)
C
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
C  22222222222222222222222222222222222222222222222222222
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL TRANSQ(T2N,NOU)
C      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
C
CCCX      CALL ZCLOCK(1)
      CALL TRANSQ( VOE,NU)
      CALL TRANMD(O2,NO,NO,NU,NU,34)
      CALL CCMATMUL(O2,VOE,T2,NO2U,NU,NU,1,0)
      CALL TRANMD(O2,NO,NO,NU,NU,34)
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      DO 302 I=1,NU
      CALL RDVPPI(I,NU,V)
      CALL TRANT3(V,NU,1)
      CALL CCMATMUL(V,T2,T2N(1,1,1,I),NU,NO2,NU2,0,0)
 302  CONTINUE
      CALL TRANSQ(T2N,NOU)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
CCCX      CALL ZCLOCK(1)
C 33333333333333333333333333333333333333333333333333
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL CCMATMUL(O2,T2,VOE,NOU,NOU,NOU,1,0)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL DESM21(O2,NO,NU,NU,NO,23)
      CALL RINTVO(2,NO,NU,TI,T2)
      CALL VECMUL(T2,NO2U2,HALF)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL CCMATMUL(O2,T2,VOE,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL TRANSQ(T2N,NOU)
      DO 303 I=1,NU
      CALL RDVPPI(I,NU,V)
      CALL TRANT3(V,NU,1)
      CALL CCMATMUL(V,VOE,T2N(1,1,1,I),NU,NO2,NU2,0,0)
 303  CONTINUE
      CALL CCMATMUL(O2,T2,VOE,NOU,NOU,NOU,1,1)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      DO 304 I=1,NU
      CALL RDVPPI(I,NU,V)
      CALL CCMATMUL(V,VOE,T2N(1,1,1,I),NU,NO2,NU2,0,0)
 304  CONTINUE
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,VOE,TI,OEH,OEP)!T2N NO,NO,NU,NU
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13) !NU,NO,NO,NU
CCCX      CALL ZCLOCK(1)
      CALL RINTVO(4,NO,NU,TI,T2)
      CALL TRANSQ(T2,NOU)
      CALL SYMT21(T2,NU,NO,NO,NU,23)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL CCMATMUL(T2,O2,TI,NU,NU,NO2U,1,1)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL CCMATMUL(O2,TI,T2N,NO2U,NU,NU,0,0)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
CCCX      CALL ZCLOCK(1)
      GOTO 1100
CCCX      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
CCCX      CALL TRANSQ(O2,NOU)
CCCX      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
CCCX 112       CONTINUE
CCCX      CALL TRANMD(O2,NU,NU,NO,NO,12)
CCCX      GOTO 1200
 1100 CONTINUE
      CALL RO2(1,NO,NU,O2)
      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
      CALL TRANMD(O2,NU,NU,NO,NO,12)
      CALL RO2(1,NO,NU,VOE)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL VECCOP(NO2U2,VO2,VOE)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL SYMT21(VO2,NU,NU,NO,NO,12)
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL TRANMD(T2,NU,NU,NO,NO,12)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL TRANSQ(T2N,NOU)
      DO 133 IA=1,NU
      CALL RDVPPI(IA,NU,V)
      CALL TRANT3(V,NU,2)
      CALL ZEROMA(O4,1,NU3)
      DO 132 I=1,NO
      DO 132 J=1,NO
      CALL CCMATMUL(VO2(1,1,I,J),V,TI,NU,NU2,NU,1,0)
      CALL TRANT3(V,NU,3)
      CALL CCMATMUL(O2(1,1,J,I),V,TI,NU,NU2,NU,0,1)
      CALL TRANT3(V,NU,3)
      CALL TRANT3(TI,NU,1)
      CALL CCMATMUL(TI,VOE(1,1,J,I),O4,NU2,NU,NU,0,1)
 132  CONTINUE
      CALL CCMATMUL(O4,T2,T2N(1,1,1,IA),NU,NO2,NU2,0,0)
      CALL ZEROMA(O4,1,NU3)
      DO 134 I=1,NO
      DO 134 J=1,NO
      CALL TRANT3(V,NU,3)
      CALL CCMATMUL(O2(1,1,I,J),V,TI,NU,NU2,NU,1,1)
      CALL TRANT3(V,NU,3)
      CALL TRANT3(TI,NU,1)
      CALL CCMATMUL(TI,VOE(1,1,J,I),O4,NU2,NU,NU,0,1)
134   CONTINUE
      CALL TRANMD(T2,NU,NU,NO,NO,12)
      CALL CCMATMUL(O4,T2,T2N(1,1,1,IA),NU,NO2,NU2,0,0)
      CALL TRANMD(T2,NU,NU,NO,NO,12)
 133  CONTINUE
      CALL TRANSQ(T2N,NOU)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,OEH,OEP)
CCCX 1200 CONTINUE
CCCX      CALL ZCLOCK(1)
      CALL TRANMD(O2,NU,NU,NO,NO,12)
      CALL INSITU(NU,NU,NO,NO,TI,O2,13)
      CALL RINTVO(4,NO,NU,TI,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2,12)
      CALL VECMUL(T2,NO2U2,TWO)
      CALL CCMATMUL(T2,O2,VOE,NOU,NOU,NOU,1,0)
      CALL VECMUL(T2,NO2U2,HALF)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL CCMATMUL(T2,O2,VOE,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,O2,VOE,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,12)
      CALL CCMATMUL(O2,VOE,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL CCMATMUL(O2,VOE,T2N,NOU,NOU,NOU,0,1)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL CCMATMUL(T2,O2,VOE,NOU,NOU,NOU,1,0)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,12)
      CALL CCMATMUL(O2,VOE,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,VOE,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,VOE,TI,OEH,OEP)
CCCX      CALL ZCLOCK(1)
C3333333333333333333333333333333333333333333333333333333333333333333333
      CALL ZEROMA(T2,1,NO2U2)
      CALL RINTVO(1,NO,NU,TI,VOE) !3
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      CALL TRANMD(VOE,NO,NO,NU,NU,34)
      DO 311 I=1,NU
      CALL RDVPPI(I,NU,V)
      CALL TRANT3(V,NU,1)
      CALL CCMATMUL(VOE,V,T2(1,1,1,I),NO2,NU,NU2,1,0)!SZESC
 311  CONTINUE
      CALL TRANMD(VOE,NO,NO,NU,NU,34)
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANSQ(T2,NOU)    ! TERAZ NO,NU,NU,NO
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL TRANMD(T2,NO,NU,NU,NO,14)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL INSITU(NU,NU,NO,NO,TI,T2,23)
      CALL TRANSQ(T2,NOU)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
C
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,0) ! SZESC CONT.
      CALL ZEROMA(T2,1,NO2U2)
      CALL DESM21(O2,NO,NU,NU,NO,23)
      DO 312 I=1,NU
      CALL RDVPPI(I,NU,V)
      CALL CCMATMUL(VOE,V,T2(1,1,1,I),NO2,NU,NU2,1,0) !TRZY
 312  CONTINUE
      CALL RINTVO(2,NO,NU,TI,VOE)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      DO 313 I=1,NU
      CALL RDVPPI(I,NU,V)
      CALL TRANT3(V,NU,1)
      CALL CCMATMUL(VOE,V,T2(1,1,1,I),NO2,NU,NU2,0,0)
 313  CONTINUE
      CALL VECMUL(VOE,NO2U2,-TWO)
      DO 314 I=1,NU
      CALL RDVPPI(I,NU,V)
      CALL CCMATMUL(VOE,V,T2(1,1,1,I),NO2,NU,NU2,0,0)
 314  CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,T2,13) !H,N,I,A
      CALL TRANSQ(T2,NOU)               !I,A,H,N
      CALL INSITU(NO,NU,NU,NO,TI,T2,13) !H,A,I,N
      CALL INSITU(NU,NU,NO,NO,TI,T2,23) !H,I,A,N
      CALL TRANSQ(T2,NOU)               !A,N,H,I
      CALL TRANMD(T2,NU,NO,NU,NO,13)    !H,N,A,I
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,VOE,TI,OEH,OEP)
      CALL ENGY1CR(NO,NU,T2N,VOE,O2,OEH,OEP)
CCCX      CALL ZCLOCK(1)
      RETURN
      END
C*MODULE CCQUAD  *DECK T2WT2SQ
      SUBROUTINE T2WT2SQ(NO,NU,FHH,FPP,TI,O2,T2,VOE,T2N,OEH,OEP,CNS,ISE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/RENOQ/XO1,XO2,XO3,XO4
CCCX      INTEGER A,B,C,E,F
CCCX      COMMON/NEWTAPE/NT2T4,NT4INT
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(NU,NU,NO),O2(NO,NU,NU,NO),T2(NO,NU,NU,NO),
     *VOE(NO,NO,NU,NU),T2N(NO,NU,NU,NO),OEH(NO),OEP(NU),FHH(NO,NO),
     *FPP(NU,NU)
      DATA TWO/2.0D+0/,
     *     HALF/0.5D+0/
      CALL RO2(1,NO,NU,T2N)
      CALL RO2(1,NO,NU,O2)
      CALL RO2HPP(1,NO,NU,TI,VOE)
      CALL VECCOP(NO2U2,T2,O2)
      IF(ISE.EQ.2)THEN
      CALL ZEROMA(T2,1,NO2U2)
      CALL ZEROMA(O2,1,NO2U2)
      ENDIF
      CALL RO1(1,NO,NU,TI)
      IF(ISE.GE.1)THEN
      CALL ADT12(1,NO,NU,TI,T2,6)
      CALL ADT12(1,NO,NU,TI,O2,6)
      ENDIF
CCCX 298  CONTINUE
      CALL T2DEN(VOE,OEH,OEP,NO,NU)
      CALL OVRL(NO,NU,T2N,O2,XO1)
      CALL OVRL(NO,NU,VOE,T2,XO2)
      CALL OVRL(NO,NU,T2N,T2,XO3)
      CALL OVRL(NO,NU,VOE,O2,XO4)
C      WRITE(6,*)'XO1,XO2,XO3,XO4:',XO1,XO2,XO3,XO4
C XO1
      CALL RO2(1,NO,NU,VOE)
      CALL VECMUL(T2,NO2U2,CNS)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL SYMT21(VOE,NO,NU,NU,NO,23)
      CALL CCMATMUL(VOE,   T2,  FHH,NO,NO,NOU2,1,0)
      CALL TRANSQ(VOE,NOU)
      CALL CCMATMUL(T2,    VOE, FPP,NU, NU,NO2U,1,1)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL TRANSQ( FPP,NU)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL CCMATMUL(O2,FPP,T2N,NO2U,NU,NU,1,0)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
      CALL CCMATMUL(O2,FHH,T2N,NOU2,NO,NO,0,1)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
      CALL CCMATMUL(VOE,   O2,  FHH,NO,NO,NOU2,1,0)
      CALL TRANSQ(VOE,NOU)
      CALL CCMATMUL(O2,    VOE, FPP,NU, NU,NO2U,1,1)
      CALL TRANSQ(VOE,NOU)
      CALL DESM21(VOE,NO,NU,NU,NO,23)
      CALL INSITU(NU,NU,NO,NO,TI,O2,13)
      CALL TRANSQ( FPP,NU)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2,13)
      CALL CCMATMUL(T2,FPP,T2N,NO2U,NU,NU,0,0)
CC
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
      CALL CCMATMUL(T2,FHH,T2N,NOU2,NO,NO,0,1)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,12)
      CALL VECMUL(T2,NO2U2,TWO)
      CALL CCMATMUL(T2,VOE,FPP,NOU,NOU,NOU,1,0)
      CALL VECMUL(T2,NO2U2,HALF)
      CALL TRANMD(VOE,NU,NO,NU,NO,13)
      CALL CCMATMUL(T2,VOE,FPP,NOU,NOU,NOU,0,1)
      CALL TRANMD(VOE,NU,NO,NU,NO,13)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,VOE,FPP,NOU,NOU,NOU,0,1)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL CCMATMUL(FPP,O2,T2N,NOU,NOU,NOU,0,0)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL TRANMD(O2,NU,NO,NU,NO,24)
      CALL CCMATMUL(FPP,O2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NU,NO,NU,NO,24)
      CALL TRANMD(VOE,NU,NO,NU,NO,24)
      CALL CCMATMUL(T2,VOE,FPP,NOU,NOU,NOU,1,1)
      CALL TRANMD(VOE,NU,NO,NU,NO,24)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL CCMATMUL(FPP,O2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NU,NO,NU,NO,24)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(FPP,O2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL TRANMD(O2,NU,NO,NU,NO,24)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL INSITU(NO,NU,NU,NO,TI,T2N,13)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL INSITU(NU,NO,NU,NO,TI,VOE,12)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      CALL TRANMD(VOE,NO,NO,NU,NU,34)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
      CALL TRANMD(O2,NU,NU,NO,NO,34)
      CALL CCMATMUL(VOE,T2,FPP,NO2,NO2,NU2,1,0)
      CALL VECMUL(FPP,NO4,TWO)
      CALL CCMATMUL(O2,FPP ,T2N,NU2,NO2,NO2,0,0)
      CALL TRANMD(O2,NU,NU,NO,NO,34)
      CALL VECMUL(VOE,NO2U2,TWO)
      CALL TRANMD(VOE,NO,NO,NU,NU,34)
      CALL INSITU(NO,NO,NU,NU,TI,VOE,13)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL INSITU(NU,NU,NO,NO,TI,O2,13)
      CALL SYMETR(T2N,NO,NU)
      CALL ENGY3(NO,NU,T2N,T2,TI,OEH,OEP,ISE)
      RETURN
      END
C*MODULE CCQUAD  *DECK T2WWT3
      SUBROUTINE T2WWT3(NO,NU,T1,TI,V,VOE,VE,T2N,OEH,OEP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B,C,E,F
CCCX      COMMON/NEWTAPE/NT2T4,NT4INT
CCCX      COMMON/ECCCONT/CONECC(20)
      COMMON/EN51/EC1,EC2
      COMMON/ET3/ET3A,ET3B
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T1(1),TI(1),VE(1),OEH(NO),OEP(NU),
     *V(NU,NU,NU,NO),VOE(NO,NU,NU,NO),T2N(NO,NU,NU,NO)
      DATA TWO/2.0D+0/,
     *     HALF/0.5D+0/
      L46=78
      CALL RO2NN(1,NO,NU,VOE)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL ZEROMA(T2N,1,NO2U2)
      CALL ZEROMA(T1,1,NOU)
      CALL T1WT3INT(NO,NU,TI,T1,VOE)
      CALL RDVEM4(0,NO,NU,TI,V)
      CALL CCMATMUL(T1,V,T2N,NO,NOU2,NU,0,0)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,OEH,OEP)
      CALL RDVEM4(1,NU,NO,TI,V)
      CALL TRANMD(V,NO,NO,NO,NU,12)
      CALL TRT1(NO,NU,TI,T1)
      CALL TRANSQ(T2N,NOU)
      CALL CCMATMUL(T1,V,T2N,NU,NO2U,NO,0,1)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,OEH,OEP)
      CALL RDVEM4(0,NO,NU,TI,V)
      CALL SYMT21(V,NU,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL CCMATMUL(V,VOE,T1,NU,NO,NOU2,1,0)
      CALL INSITU(NU,NU,NO,NO,TI,VOE,13)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      CALL TRT1(NU,NO,TI,T1)
      CALL RDVEM4(1,NU,NO,TI,V)
      CALL SYMT21(V,NO,NO,NO,NU,23)
      CALL CCMATMUL(V,VOE,T1,NO,NU,NO2U,0,1)
      CALL TRT1(NO,NU,TI,T1)
      CALL VECMUL(T1,NOU,HALF)
      CALL INSITU(NO,NU,NU,NO,TI,T2N,13)
      CALL TRANMD(T2N,NU,NU,NO,NO,12)
      CALL T2FT3INT(NO,NU,T2N,TI,T1)
      CALL TRANMD(T2N,NU,NU,NO,NO,12)
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,OEH,OEP)
      CALL RDVEM4(0,NO,NU,TI,V)
      CALL TRANMD(V,NU,NU,NU,NO,13)
      CALL CCMATMUL(VOE,V,VE,NO2,NOU,NU2,1,0)
      CALL TRANMD(VE,NO,NO,NU,NO,14)
      CALL TRANMD(VE,NO,NO,NU,NO,12)
      CALL RDVEM4(1,NU,NO,TI,V)
      CALL INSITU(NO,NO,NU,NU,TI,VOE,13)
      CALL TRANSQ(VOE,NOU)
      CALL SYMT21(VOE,NO,NU,NU,NO,23)
      CALL CCMATMUL(V,VOE,VE,NO2,NOU,NOU,0,0)
      CALL DESM21(VOE,NO,NU,NU,NO,23)
      CALL TRANMD(V,NO,NO,NO,NU,23)
      CALL CCMATMUL(V,VOE,VE,NO2,NOU,NOU,0,1)
      CALL TRANMD(VOE,NO,NU,NU,NO,23)
      CALL TRANMD(VE,NO,NO,NU,NO,14)
      CALL CCMATMUL(V,VOE,VE,NO2,NOU,NOU,0,1)
      CALL INSITU(NO,NO,NU,NO,TI,VE,23)
      CALL TRANMD(VE,NO,NU,NO,NO,13)
      CALL T2WT3H(NO,NU,T2N,TI,VE)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,OEH,OEP)
      CALL TRANMD(VOE,NO,NU,NU,NO,23)
      CALL ZEROMA(VE,1,NO3U)
      CALL RDVEM3X(1,NU,NO,TI,VE) !06/23/2004 QUADRUPLES
      CALL TRANMD(VE,NO,NO,NU,NO,14)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL CCMATMUL(VOE,VE,V,NU2,NOU,NO2,1,0)
      CALL TRANMD(V,NU,NU,NU,NO,13)
CCCX      INREC=1
      DO 1 I=1,NO
         CALL WW(L46,I,NU3,V(1,1,1,I))
 1    CONTINUE
CCCX      NREC=INREC-1
      CALL RDVEM4(0,NO,NU,TI,V)
      CALL INSITU(NU,NU,NO,NO,TI,VOE,23)
      CALL TRANMD(VOE,NU,NO,NU,NO,13)
CCCX      NREAD=1
CCCX      NWRIT=1
      DO 80 I=1,NO
      CALL RR(L46,I,NU3,VE)
      CALL SYMT21(VOE(1,1,1,I),NU,NO,NU,1,13)
      CALL CCMATMUL(V,VOE(1,1,1,I),VE,NU2,NU,NOU,0,0)
      CALL DESM21(VOE(1,1,1,I),NU,NO,NU,1,13)
      CALL TRANMD(V,NU,NU,NU,NO,13)
      CALL CCMATMUL(V,VOE(1,1,1,I),VE,NU2,NU,NOU,0,1)
      CALL TRANMD(VOE(1,1,1,I),NU,NO,NU,1,13)
      CALL TRANT3(VE,NU,1)
      CALL CCMATMUL(V,VOE(1,1,1,I),VE,NU2,NU,NOU,0,1)
      CALL TRANT3(VE,NU,1)
      CALL TRANMD(V,NU,NU,NU,NO,13)
      CALL WW(L46,I+NO,NU3,VE)
CCCX      NWRIT=NWRIT+IRC
 80   CONTINUE
CCCX      NREAD=1+NREC
      DO 3 I=1,NO
         CALL RR(L46,I+NO,NU3,V(1,1,1,I))
 3    CONTINUE
      CALL INSITU(NO,NU,NU,NO,TI,T2N,13)
      CALL T2WT3P(NO,NU,T2N,TI,V)
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,OEH,OEP)
      CALL TRANMD(VOE,NU,NO,NU,NO,13)
      CALL INSITU(NU,NO,NU,NO,TI,VOE,12)
      CALL ZEROMA(VE,1,NO3U)
      CALL VMWT3(NO,NU,VE,TI,VOE)
      CALL ZEROMA(V,1,NOU3)
      CALL RDVEM3X(0,NO,NU,TI,V)  !06/23/2004 QUADRUPLES
      CALL TRANMD(V,NU,NU,NO,NU,14)
      CALL INSITU(NO,NU,NU,NO,TI,T2N,13)
      CALL CCMATMUL(V,VE,T2N,NU2,NO2,NOU,0,1)
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,OEH,OEP)
      CALL RDVEM3X(1,NU,NO,TI,V)  !06/23/2004 QUADRUPLES
      CALL VECMUL(V,NO3U,TWO)
      CALL TRANMD(VE,NO,NU,NO,NO,13)
      CALL CCMATMUL(VE,V,T2N,NOU,NOU,NO2,0,1)
      CALL VECMUL(V,NO3U,HALF)
      CALL TRANMD(V,NO,NO,NU,NO,14)
      CALL CCMATMUL(VE,V,T2N,NOU,NOU,NO2,0,0)
      CALL TRANMD(V,NO,NO,NU,NO,14)
      CALL TRANMD(VE,NO,NU,NO,NO,14)
      CALL CCMATMUL(VE,V,T2N,NOU,NOU,NO2,0,0)
      CALL TRANMD(V,NO,NO,NU,NO,14)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(VE,V,T2N,NOU,NOU,NO2,0,0)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,OEH,OEP)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL ZEROMA(V,1,NOU3)
      CALL VEWT3(NO,NU,V,TI,VOE)
      CALL TRANMD(V,NU,NU,NU,NO,13)
      CALL RDVEM3X(1,NU,NO,TI,VE)  !06/23/2004 QUADRUPLES
      CALL INSITU(NO,NO,NU,NO,TI,VE,13)
      CALL TRANMD(VE,NU,NO,NO,NO,34)
      CALL INSITU(NO,NU,NU,NO,TI,T2N,13)
      CALL CCMATMUL(V,VE,T2N,NU2,NO2,NOU,0,1)
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
CCCX      INREC=1
      DO 4 I=1,NO
         CALL WW(L46,I,NU3,V(1,1,1,I))
 4    CONTINUE
CCCX      NREC=INREC-1
      CALL RDVEM3X(0,NO,NU,TI,V)   !06/23/2004 QUADRUPLES
      CALL INSITU(NU,NU,NO,NU,TI,V,13)
      CALL TRANMD(V,NO,NU,NU,NU,24)
CCCX      NREAD=1
CCCX      NWRIT=1
      DO 90 I=1,NO
      CALL RR(L46,I,NU3,VE)
      CALL TRANT3(VE,NU,3)
      CALL VECMUL(VE,NU3,TWO)
      CALL CCMATMUL(V,VE,T2N(1,1,1,I),NOU,NU,NU2,0,1)
      CALL VECMUL(VE,NU3,HALF)
      CALL TRANMD(V,NO,NU,NU,NU,23)
      CALL CCMATMUL(V,VE,T2N(1,1,1,I),NOU,NU,NU2,0,0)
      CALL TRANMD(V,NO,NU,NU,NU,23)
      CALL TRANT3(VE,NU,1)
      CALL CCMATMUL(V,VE,T2N(1,1,1,I),NOU,NU,NU2,0,0)
      CALL TRANMD(V,NO,NU,NU,NU,23)
      CALL TRANMD(T2N(1,1,1,I),NO,NU,NU,1,23)
      CALL CCMATMUL(V,VE,T2N(1,1,1,I),NOU,NU,NU2,0,0)
      CALL TRANMD(V,NO,NU,NU,NU,23)
      CALL TRANMD(T2N(1,1,1,I),NO,NU,NU,1,23)
 90   CONTINUE
      CALL SYMETR(T2N,NO,NU)
      CALL ENGY1(NO,NU,V,T2N,VOE,OEH,OEP)
      CALL ZEROMA(T2N,1,NO2U2)
      ET3A=EC1
      ET3B=EC2
      RETURN
      END
C*MODULE CCQUAD  *DECK T2HPT2SQ
      SUBROUTINE T2HPT2SQ(NO,NU,FPP,TI,O2,T2,VO2,V,VOE,VO,T2N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B,C,E,F
CCCX      COMMON/NEWTAPE/NT2T4,NT4INT
CCCX      COMMON/ECCCONT/CONECC(20)
      COMMON/VRINPI/IFIRST(512)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(1),O2(1),T2(NO,NO,NU,NU),VO2(NO,NO,NU,NU),V(1),
     *T2N(NO,NO,NU,NU),FPP(1),VOE(NO,NO,NU,NU),VO(NU,NO,NO,NU)
      DATA ONE/1.0D+0/TWO/2.0D+0/,FOUR/4.0D+0/,
     *     HALF/0.5D+0/
        L46=61
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
      CALL RO2(1,NO,NU,O2)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL RO2HPP(1,NO,NU,TI,VOE)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      CALL TRANMD(VOE,NO,NO,NU,NU,12)
      CALL RO2HPP(2,NO,NU,TI,VO)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VO,13)
      CALL TRANMD(VO,NO,NO,NU,NU,12)
      CALL RINTHH(1,NO,V)
      CALL VECMUL(VO,NO2U2,TWO)
      CALL VECSUB(VO,VOE,NO2U2)
      CALL CCMATMUL(V,VO,FPP,1,NU2,NO2,1,1)
      CALL VECADD(VO,VOE,NO2U2)
      CALL VECMUL(VO,NO2U2,HALF)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL CCMATMUL(O2,FPP,T2N,NO2U,NU,NU,0,0)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL TRANMD(VOE,NO,NO,NU,NU,12)
      CALL VECMUL(VOE,NO2U2,TWO)
      CALL VECSUB(VOE,VO,NO2U2)
      CALL TRANSQ(V,NO)
      CALL CCMATMUL(V,VOE,T2,NO,NOU2,NO,1,1)
      CALL VECADD(VOE,VO,NO2U2)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NO,NO,NU,NU,TI,O2,23)
      CALL TRANMD(O2,NO,NU,NO,NU,13)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,0)
      CALL CCMATMUL(V,VOE,T2,NO,NOU2,NO,1,1)
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANSQ(T2,NOU)
      CALL TRANMD(O2,NO,NU,NO,NU,13)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL CCMATMUL(V,VO,T2,NO,NOU2,NO,1,1)
      CALL INSITU(NO,NO,NU,NU,TI,T2,13)
      CALL TRANSQ(T2,NOU)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,EH,EP)
      CALL INSITU(NO,NU,NO,NU,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL RINTHH(3,NO2,V)
      CALL MTRANSQ(V,NO,2)
      CALL SYMT21(V,NO,NO,NO,NO,13)
      CALL CCMATMUL(V,VO,T2,NO2,NU2,NO2,1,0)
      CALL DESM21(V,NO,NO,NO,NO,13)
      CALL CCMATMUL(V,VOE,T2,NO2,NU2,NO2,0,1)
      CALL INSITU(NO,NO,NU,NU,TI,T2,23)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL VECMUL(V,NO4,TWO)
      CALL MTRANSQ(V,NO,8)
      CALL CCMATMUL(V,VOE,VO2,NO2,NU2,NO2,1,0)
      CALL VECMUL(V,NO4,HALF)
      CALL INSITU(NO,NO,NU,NU,TI,VO2,23)
      CALL VECADD(T2,VO2,NO2U2)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,0)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,1)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL INSITU(NO,NO,NU,NU,TI,VO,13)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NO,NO,NU,NU,TI,VOE,13)
      CALL TRANSQ(VOE,NOU)
      CALL MTRANSQ(V,NO,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL CCMATMUL(V,O2,T2,NO2,NU2,NO2,1,0)
      CALL INSITU(NO,NO,NU,NU,TI,T2,23)
      CALL CCMATMUL(T2,VOE,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL VECMUL(VOE,NO2U2,TWO)
      CALL VECSUB(VOE,VO,NO2U2)
      CALL CCMATMUL(T2,VOE,T2N,NOU,NOU,NOU,0,0)
      CALL VECADD(VOE,VO,NO2U2)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,VO,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VO,13)
      CALL TRANMD(VO,NU,NU,NO,NO,12)
      CALL TRANMD(T2,NU,NO,NO,NU,23)
      CALL CCMATMUL(VO,T2,FPP,NU,NU,NO2U,1,0)
      CALL RINTVO(2,NO,NU,TI,VO2)
      CALL TRANSQ(VO2,NOU)
      CALL TRANMD(VO2,NU,NO,NO,NU,23)
      CALL VECMUL(VO2,NO2U2,HALF)
      CALL VECSUB(T2,VO2,NO2U2)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL VECMUL(VOE,NO2U2,TWO)
      CALL CCMATMUL(VOE,T2,FPP,NU,NU,NO2U,0,1)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL VECMUL(VO2,NO2U2,FOUR)
      CALL CCMATMUL(VO,VO2,FPP,NU,NU,NO2U,0,1)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(T2N,NOU)
      CALL CCMATMUL(O2,FPP,T2N,NO2U,NU,NU,0,0)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,EH,EP)
      CALL RINTVO(1,NO,NU,TI,V)
      CALL  TRANMD(V,NO,NU,NU,NO,14)
      CALL RINTVO(2,NO,NU,TI,T2)
      CALL VECMUL(T2,NO2U2,HALF)
      CALL  TRANMD(T2,NO,NU,NU,NO,14)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL INSITU(NU,NU,NO,NO,TI,VO,23)
      CALL INSITU(NU,NU,NO,NO,TI,VOE,23)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL TRANMD(VOE,NU,NO,NU,NO,13)
      CALL VECSUB(VO,VOE,NO2U2)
      CALL CCMATMUL(V,VO,VO2,NOU,NOU,NOU,1,1)
      CALL VECADD(VO,VOE,NO2U2)
      CALL VECMUL(VOE,NO2U2,FOUR)
      CALL VECSUB(VOE,VO,NO2U2)
      CALL CCMATMUL(T2,VOE,VO2,NOU,NOU,NOU,0,1)
      CALL VECADD(VOE,VO,NO2U2)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL  TRANMD(VO2,NO,NU,NU,NO,14)
      CALL VECMUL(O2,NO2U2,TWO)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,0)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL CCMATMUL(V,VO,VO2,NOU,NOU,NOU,1,1)
      CALL VECMUL(VOE,NO2U2,TWO)
      CALL CCMATMUL(T2,VOE,VO2,NOU,NOU,NOU,0,1)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL  TRANMD(VO2,NO,NU,NU,NO,14)
      CALL  TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL CCMATMUL(V,VOE,VO2,NOU,NOU,NOU,1,1)
      CALL VECMUL(VO,NO2U2,TWO)
      CALL CCMATMUL(T2,VO,VO2,NOU,NOU,NOU,0,1)
      CALL VECMUL(VO,NO2U2,HALF)
      CALL  TRANMD(VO2,NO,NU,NU,NO,14)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,1)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL INSITU(NU,NO,NU,NO,TI,VO,12)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VO,13)
      CALL VECCOP(NO2U2,O2,VO)
      CALL VECMUL(VO,NO2U2,TWO)
      CALL INSITU(NU,NO,NU,NO,TI,VOE,12)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      CALL VECSUB(VO,VOE,NO2U2)
      CALL RINTVO(2,NO,NU,TI,VO2)
      CALL INSITU(NO,NU,NU,NO,TI,VO2,13)
      CALL VECCOP(NO2U2,FPP,T2)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2,13)
      CALL INSITU(NU,NU,NO,NO,TI,VO2,13)
      CALL TRANSQ(VO2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VO2,13)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
      CALL INSITU(NO,NO,NU,NU,TI,VO,13)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VO,13)
      CALL RO2(1,NO,NU,TI)
      CALL TRANMD(TI,NO,NU,NU,NO,23)
      CALL TRANSQ(TI,NOU)
      CALL INSITU(NU,NO,NO,NU,V,TI,13)
      CALL TRANMD(T2N,NO,NO,NU,NU,34)
      DO 300 I=1,NU
      CALL CCMATMUL(O2,T2(1,1,1,I) ,V,NU2,NU,NO2,1,0)
      CALL CCMATMUL(VO,VO2(1,1,1,I),V,NU2,NU,NO2,0,1)
      CALL TRANT3(V,NU,3)
      CALL CCMATMUL(FPP,VOE(1,1,1,I),V,NU2,NU,NO2,0,0)
      CALL TRANT3(V,NU,1)
      CALL CCMATMUL(TI,V,T2N(1,1,1,I),NO2,NU,NU2,0,0)
 300  CONTINUE
      CALL RO2(1,NO,NU,O2)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANMD(T2N,NO,NO,NU,NU,34)
      CALL INSITU(NU,NU,NO,NO,TI,VO,13)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VO,13)
      CALL VECADD(VO,VOE,NO2U2)
      CALL VECMUL(VO,NO2U2,HALF)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL  TRANSQ(O2,NOU)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL SYMT21(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,VO2,NOU,NOU,NOU,1,0)
      CALL DESM21(O2,NO,NU,NU,NO,23)
      CALL RINTVO(2,NO,NU,TI,T2)
      CALL TRANSQ(T2,NOU)
      CALL CCMATMUL(O2,T2,VO2,NOU,NOU,NOU,0,1)
      CALL INSITU(NO,NU,NO,NU,TI,VO2,12)
      CALL TRANSQ(VO2,NOU)
      CALL TRANMD(VO2,NO,NU,NU,NO,14)
      CALL INSITU(NO,NO,NU,NU,TI,VO,13)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VO,12)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,VO,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL INSITU(NO,NO,NU,NU,TI,VOE,13)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,12)
      CALL TRANMD(VOE,NU,NO,NU,NO,13)
      CALL CCMATMUL(VO2,VOE,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,VO2,NOU,NOU,NOU,1,1)
      CALL INSITU(NO,NU,NO,NU,TI,VO2,12)
      CALL TRANSQ(VO2,NOU)
      CALL TRANMD(VO2,NO,NU,NU,NO,14)
      CALL VECMUL(VOE,NO2U2,TWO)
      CALL VECSUB(VO,VOE,NO2U2)
      CALL CCMATMUL(VO2,VO,T2N,NOU,NOU,NOU,0,1)
      CALL VECADD(VO,VOE,NO2U2)
      CALL VECMUL(VOE,NO2U2,HALF)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL RINTVO(8,NO,NU,TI,T2)
      CALL VECMUL(T2,NO2U2,-TWO)
      CALL RINTVO(-7,NO,NU,TI,T2)
      CALL RINTVO(-6,NO,NU,TI,T2)
      CALL VECMUL(T2,NO2U2,-ONE)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL SYMT21(O2,NU,NO,NU,NO,13)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,O2,VO2,NOU,NOU,NOU,1,0)
      CALL DESM21(O2,NU,NO,NU,NO,13)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,12)
      CALL CCMATMUL(O2,VO2,T2N,NOU,NOU,NOU,0,0)
      CALL INSITU(NO,NU,NO,NU,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL CCMATMUL(T2,O2,VO2,NOU,NOU,NOU,1,0)
      CALL RINTVO(8,NO,NU,TI,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(T2,O2,VO2,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,12)
      CALL TRANMD(O2,NO,NU,NO,NU,13)
      CALL CCMATMUL(O2,VO2,T2N,NOU,NOU,NOU,0,1)
      CALL RINTVO(6,NO,NU,TI,T2)
      CALL RINTVO(-7,NO,NU,TI,T2)
      CALL INSITU(NO,NU,NO,NU,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,O2,VO2,NOU,NOU,NOU,1,0)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,12)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,VO2,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL  TRANMD(T2,NO,NU,NU,NO,14)
      CALL INSITU(NU,NO,NU,NO,TI,VO,12)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NU,NO,NU,NO,TI,VO,12)
      CALL INSITU(NU,NO,NU,NO,TI,VOE,12)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,12)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL TRANMD(VOE,NO,NU,NO,NU,13)
      CALL VECSUB(VO,VOE,NO2U2)
      CALL CCMATMUL(VO,T2,VO2,NOU,NOU,NOU,1,1)
      CALL VECADD(VO,VOE,NO2U2)
      CALL RINTVO(2,NO,NU,TI,T2)
      CALL VECMUL(T2,NO2U2,HALF)
      CALL  TRANMD(T2,NO,NU,NU,NO,14)
      CALL VECMUL(VOE,NO2U2,FOUR)
      CALL VECSUB(VOE,VO,NO2U2)
      CALL CCMATMUL(VOE,T2,VO2,NOU,NOU,NOU,0,1)
      CALL VECADD(VOE,VO,NO2U2)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL  TRANMD(VO2,NO,NU,NU,NO,14)
      CALL INSITU(NO,NU,NO,NU,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL VECMUL(VO2,NO2U2,TWO)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,0)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL  TRANMD(T2,NO,NU,NU,NO,14)
      CALL CCMATMUL(VO,T2,VO2,NOU,NOU,NOU,1,1)
      CALL RINTVO(2,NO,NU,TI,T2)
      CALL  TRANMD(T2,NO,NU,NU,NO,14)
      CALL CCMATMUL(VOE,T2,VO2,NOU,NOU,NOU,0,1)
      CALL  TRANMD(VO2,NO,NU,NU,NO,14)
      CALL  TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL  TRANMD(T2,NO,NU,NU,NO,14)
      CALL CCMATMUL(VOE,T2,VO2,NOU,NOU,NOU,1,1)
      CALL RINTVO(2,NO,NU,TI,T2)
      CALL  TRANMD(T2,NO,NU,NU,NO,14)
      CALL CCMATMUL(VO,T2,VO2,NOU,NOU,NOU,0,1)
      CALL  TRANMD(VO2,NO,NU,NU,NO,14)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,T2N,NOU,NOU,NOU,0,1)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL INSITU(NO,NU,NO,NU,TI,VO,23)
      CALL INSITU(NO,NU,NO,NU,TI,VOE,23)
      CALL TRANMD(VOE,NO,NO,NU,NU,12)
      CALL CCMATMUL(VO,T2,V,NO2,NO2,NU2,1,0)
      CALL MTRANSQ(V,NO,8)
      CALL CCMATMUL(VOE,T2,V,NO2,NO2,NU2,0,0)
      CALL MTRANSQ(V,NO,8)
      CALL RINTVO(2,NO,NU,TI,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL VECMUL(VO,NO2U2,TWO)
      CALL VECSUB(VO,VOE,NO2U2)
      CALL CCMATMUL(VO,T2,V,NO2,NO2,NU2,0,1)
      CALL VECADD(VO,VOE,NO2U2)
      CALL VECMUL(VO,NO2U2,HALF)
      CALL MTRANSQ(V,NO,7)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
      CALL CCMATMUL(V,O2,T2N,NO2,NU2,NO2,0,0)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL RINTVO(1,NO,NU,TI,T2)
      CALL RINTVO(2,NO,NU,TI,VO2)
      CALL VECMUL(VO2,NO2U2,HALF)
      CALL VECSUB(T2,VO2,NO2U2)
      CALL INSITU(NO,NO,NU,NU,TI,VOE,13)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL CCMATMUL(T2,VOE,FPP,NO,NO,NOU2,1,1)
      CALL VECADD(T2,VO2,NO2U2)
      CALL VECMUL(VO2,NO2U2,TWO)
      CALL INSITU(NO,NO,NU,NU,TI,VO,13)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VO,13)
      CALL CCMATMUL(VO2,VO,FPP,NO,NO,NOU2,0,1)
      CALL VECMUL(FPP,NO2,TWO)
      CALL CCMATMUL(T2,VO,FPP,NO,NO,NOU2,0,0)
      CALL TRANSQ(FPP,NO)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,FPP,T2N,NOU2,NO,NO,0,0)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,EH,EP)
      CALL RINTPP(1,NU,V)
      CALL TRANSQ(V,NU)
      CALL INSITU(NU,NU,NO,NO,TI,VO,13)
      CALL TRANSQ(VO,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VO,13)
      CALL VECMUL(VO,NO2U2,TWO)
      CALL INSITU(NU,NU,NO,NO,TI,VOE,13)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      CALL TRANMD(VOE,NO,NO,NU,NU,12)
      CALL VECSUB(VO,VOE,NO2U2)
      CALL CCMATMUL(VO,V,FPP,NO2,1,NU2,1,1)
      CALL VECADD(VO,VOE,NO2U2)
      CALL VECMUL(VO,NO2U2,HALF)
      CALL CCMATMUL(O2,FPP,T2N,NOU2,NO,NO,0,1)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL INSITU(NO,NO,NU,NU,TI,VO,23)
      CALL INSITU(NO,NO,NU,NU,TI,VOE,23)
      CALL VECMUL(VOE,NO2U2,TWO)
      CALL VECSUB(VOE,VO,NO2U2)
      CALL CCMATMUL(VOE,V,T2,NO2U,NU,NU,1,0)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,0)
      CALL VECADD(VOE,VO,NO2U2)
      CALL VECMUL(VOE,NO2U2,HALF)
      CALL CCMATMUL(VOE,V,T2,NO2U,NU,NU,1,0)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL CCMATMUL(VO,V,T2,NO2U,NU,NU,1,0)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(T2,O2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL RINTVO(6,NO,NU,TI,T2)
      CALL RINTVO(-7,NO,NU,TI,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL CCMATMUL(O2,T2,V,NO2,NO2,NU2,1,0)
      CALL RINTVO(8,NO,NU,TI,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL CCMATMUL(O2,T2,V,NO2,NO2,NU2,0,0)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL TRANSQ(T2N,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2N,13)
      CALL CCMATMUL(V,O2,T2N,NO2,NU2,NO2,0,0)
      CALL INSITU(NO,NO,NU,NU,TI,T2N,13)
      CALL TRANSQ(T2N,NOU)
CCCX      CALL ENGY2(NO,NU,T2N,T2,TI,EH,EP)
      CALL INSITU(NO,NU,NO,NU,TI,VO,12)
      CALL TRANMD(VO,NU,NO,NO,NU,23)
      CALL ZEROMA(T2,1,NO2U2)
      DO 301 I=1,NU
         IRC=IFIRST(I)
         CALL RDVV(L46,NU3,IRC,V)
         CALL SYMT21(V,NU,NU,NU,1,13)
         CALL CCMATMUL(V,VO(1,1,1,I),T2,NU2,NO2,NU,0,1)
 301  CONTINUE
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL INSITU(NO,NO,NU,NU,TI,O2,23)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NO,NU,NO,NU,13)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL TRANMD(O2,NO,NU,NO,NU,13)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NO,NU,TI,VOE,12)
      CALL ZEROMA(T2,1,NO2U2)
      CALL HPVVOE(0,NO,NU,V,VOE,T2)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,1)
      CALL ZEROMA(T2,1,NO2U2)
      CALL HPVVOE(1,NO,NU,V,VOE,T2)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL TRANMD(O2,NO,NU,NO,NU,13)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,0)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
      CALL ZEROMA(T2,1,NO2U2)
      CALL HPVVOE(2,NO,NU,V,VOE,T2)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL CCMATMUL(O2,T2,T2N,NOU,NOU,NOU,0,0)
CCCX      CALL ENGY2(NO,NU,T2N,V,TI,EH,EP)
CCCX 999   CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK RANK1
      SUBROUTINE RANK1(NO,NU,TI,O2,VO2,V)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(1),O2(NO,NO,NU,NU),V(1),VO2(NO,NO,NU,NU)
      COMMON/NEWIO/L46,NHH,NPP,NTVO,NVT
      COMMON/VRINPI/IFIRST(512)
      DATA HALF/0.5D+0/
      L46=61
      NO2=NO*NO
      NO3=NO*NO2
      NO4=NO*NO3
      NU2=NU*NU
      NU3=NU*NU2
      NU4=NU*NU3
      NOU=NO*NU
      NO2U=NO2*NU
      NO3U=NO3*NU
      NOU2=NO*NU2
      NOU3=NO*NU3
      NO2U2=NO2*NU2
CCCX      NNO2=NU*(NU+1)/2
      CALL RO2(1,NO,NU,VO2)
      CALL VECMUL(VO2,NO2U2,HALF)
      CALL RO2(1,NO,NU,O2)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
CCCX 19    CONTINUE
C
      CALL SYMT21(O2,NO,NO,NU,NU,12)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL CCMATMUL(O2,VO2,V,NO,NO,NOU2,1,0)
      CALL VRINTHH(1,NO,V)
      CALL TRANSQ(VO2,NOU)
      CALL CCMATMUL(VO2,O2,V,NU,NU,NO2U,1,1)
      CALL VRINTPP(1,NU,V)
      CALL TRANSQ(VO2,NOU)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,0)
C
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL DESM21(O2,NO,NO,NU,NU,12)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
C
      CALL TRANMD(VO2,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,0,1)
      CALL TRANMD(V,NO,NU,NU,NO,1234)
      CALL VRINTVO(1,NO,NU,TI,V)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,1)
      CALL TRANMD(V,NO,NU,NU,NO,1234)
      CALL VRINTVO(2,NO,NU,TI,V)
      CALL TRANMD(VO2,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,0)
      CALL TRANMD(V,NO,NU,NU,NO,1234)
      CALL VRINTVO(3,NO,NU,TI,V)
      CALL FLSHBF(6)
      CALL INSITU(NO,NU,NU,NO,TI,VO2,13)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL CCMATMUL(O2,VO2,V,NO2,NO2,NU2,1,0)
      CALL VRINTHH(3,NO2,V)
      CALL INSITU(NU,NU,NO,NO,TI,VO2,13)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(VO2,NOU)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VO2,13)
      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
      CALL TRANMD(O2,NU,NU,NO,NO,12)
      CALL TRANMD(VO2,NO,NO,NU,NU,12)
      IFIRST(1)=1
      DO 101 I=1,NU
      CALL CCMATMUL(O2,VO2(1,1,1,I),V,NU2,NU,NO2,1,0)
      CALL TRANT3(V,NU,5)
      IRC=IFIRST(I)
      CALL WWP(L46,NU3,IRC,V)
      IF(I.NE.NU)IFIRST(I+1)=IRC+IFIRST(I)
 101  CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,VO2,13)
      CALL TRANMD(VO2,NU,NO,NO,NU,14)
      CALL ZEROMA(O2,1,NO2U2)
      DO 102 I=1,NU
        CALL RDVPP(I,NO,NU,V)
         CALL CCMATMUL(V,VO2(1,1,1,I),O2,NU2,NO2,NU,0,0)
 102  CONTINUE
      CALL TRANMD(VO2,NU,NO,NO,NU,14)
      CALL TRANSQ(VO2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VO2,13)
      CALL INSITU(NU,NU,NO,NO,TI,O2,13)
      CALL VRINTVO(4,NO,NU,TI,O2)
      CALL FLSHBF(6)
      CALL RDOV4(1,NU,NO,TI,V)
      CALL CCMATMUL(VO2,V,O2,NU2,NO2,NO2,1,0)
      CALL INSITU(NU,NU,NO,NO,TI,O2,13)
      CALL VRINTVO(5,NO,NU,TI,O2)
      CALL FLSHBF(6)
      CALL INSITU(NU,NU,NO,NO,TI,VO2,13)
      CALL TRANMD(VO2,NO,NU,NU,NO,23)
      CALL RO2HPP(1,NO,NU,TI,O2)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL SYMT21(VO2,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,0)
      CALL DESM21(VO2,NO,NU,NU,NO,23)
      CALL VRINTVO(6,NO,NU,TI,V)
      CALL RO2HPP(2,NO,NU,TI,O2)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,1)
      CALL VRINTVO(7,NO,NU,TI,V)
      CALL TRANMD(VO2,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,1)
      CALL VRINTVO(8,NO,NU,TI,V)
      END
C*MODULE CCQUAD  *DECK RANK1CR
      SUBROUTINE RANK1CR(NO,NU,TI,O2,VO2,V,OEH,OEP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(1),O2(1),V(NU,NU,NU,NU),VO2(NO,NO,NU,NU),OEH(NO),
     *OEP(NU)
CCCX      COMMON/NEWIO/NPP1,NHH,NPP,NTVOE,NTO3,NO1,NU1
      COMMON/VRINPI/IFIRST(512)
      DATA HALF/0.5D+0/
      NO2=NO*NO
      NU2=NU*NU
      NO2U2=NO2*NU2
      L46=61
CCCX      NNO2=NU*(NU+1)/2
      CALL RO2HPP(1,NO,NU,TI,VO2)
      CALL ADDDEN(NO,NU,VO2,OEH,OEP)
      CALL VECMUL(VO2,NO2U2,HALF)
      CALL RO2(1,NO,NU,O2)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL SYMT21(O2,NO,NO,NU,NU,12)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL CCMATMUL(O2,VO2,V,NO,NO,NOU2,1,0)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL DESM21(O2,NO,NO,NU,NU,12)
C      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL VRINTHH(2,NO,V)
C
      CALL INSITU(NO,NU,NU,NO,TI,VO2,13)! PPHH
      CALL CCMATMUL(O2,VO2,V,NO2,NO2,NU2,1,0)
      CALL VRINTHH(4,NO2,V)
C
C      CALL TRANMD(O2,NO,NO,NU,NU,12)
      CALL SYMT21(O2,NO,NO,NU,NU,12)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
C
      CALL RO2(1,NO,NU,VO2)
      CALL VECMUL(VO2,NO2U2,HALF)
      CALL CCMATMUL(O2,VO2,V,NO,NO,NOU2,1,0)
      CALL VRINTHH(1,NO,V)
      CALL TRANSQ(VO2,NOU)
      CALL CCMATMUL(VO2,O2,V,NU,NU,NO2U,1,1)
      CALL VRINTPP(1,NU,V)
      CALL TRANSQ(VO2,NOU)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,0)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL DESM21(O2,NO,NO,NU,NU,12)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL TRANMD(VO2,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,0,1)
      CALL TRANMD(V,NO,NU,NU,NO,1234)
      CALL VRINTVO(1,NO,NU,TI,V)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,1)
      CALL TRANMD(V,NO,NU,NU,NO,1234)
      CALL VRINTVO(2,NO,NU,TI,V)
CXX
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL SYMT21(O2,NO,NO,NU,NU,12)
C
      CALL RO2HPP(1,NO,NU,TI,VO2)
      CALL ADDDEN(NO,NU,VO2,OEH,OEP)
      CALL VECMUL(VO2,NO2U2,HALF)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,0)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL DESM21(O2,NO,NO,NU,NU,12)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL TRANMD(VO2,NO,NU,NU,NO,23)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,0,1)
      CALL TRANMD(V,NO,NU,NU,NO,1234)
      CALL VRINTVO(5,NO,NU,TI,V)
      CALL TRANMD(O2,NU,NO,NU,NO,13)
      CALL CCMATMUL(VO2,O2,V,NOU,NOU,NOU,1,1)
      CALL TRANMD(V,NO,NU,NU,NO,1234)
      CALL VRINTVO(6,NO,NU,TI,V)
C
      CALL RO2(1,NO,NU,VO2)
      CALL VECMUL(VO2,NO2U2,HALF)
C      CALL TRANMD(VO2,NO,NU,NU,NO,23)
      CALL TRANMD(V,NO,NU,NU,NO,1234)
      CALL INSITU(NO,NU,NU,NO,TI,VO2,13)
      CALL INSITU(NU,NO,NU,NO,TI,O2,12)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL CCMATMUL(O2,VO2,V,NO2,NO2,NU2,1,0)
      CALL VRINTHH(3,NO2,V)
      CALL INSITU(NU,NU,NO,NO,TI,VO2,13)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13)
      CALL TRANSQ(VO2,NOU)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VO2,13)
      CALL INSITU(NO,NU,NU,NO,TI,O2,13)
      CALL TRANMD(O2,NU,NU,NO,NO,12)
      CALL TRANMD(VO2,NO,NO,NU,NU,12)
      IFIRST(1)=1
      DO 101 I=1,NU
      CALL CCMATMUL(O2,VO2(1,1,1,I),V,NU2,NU,NO2,1,0)
      CALL TRANT3(V,NU,5)
      IRC=IFIRST(I)
      CALL WWP(L46,NU3,IRC,V)
      IF(I.NE.NU)IFIRST(I+1)=IRC+IFIRST(I)
 101  CONTINUE
      CALL ZEROMA(O2,1,NO2U2)
      DO 102 IA=1,NU
      CALL RDVPPI(IA,NU,V)
      CALL TRANT3(V,NU,1)
      CALL CCMATMUL(VO2(1,1,1,IA),V,O2,NO2,NU2,NU,0,0) !O2:HHPP
 102  CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,VO2,13)
      CALL TRANMD(VO2,NU,NO,NO,NU,14)
      CALL TRANMD(VO2,NU,NO,NO,NU,14)
      CALL TRANSQ(VO2,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VO2,13)
      CALL INSITU(NO,NO,NU,NU,TI,O2,13) !NU,NO,NO,NU
      CALL TRANSQ(O2,NOU)
      CALL TRANMD(O2,NO,NU,NU,NO,23)
      CALL VRINTVO(4,NO,NU,TI,O2)
      RETURN
      END
C*MODULE CCQUAD  *DECK INTQUAT2Q
      SUBROUTINE INTQUAT2Q(NO,NU,O1,TI,O2,T2,VE,V,NOU)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION O1(NOU),TI(*),O2(NO,NO,NU,NU),T2(*),
     *          VE(NU,NU,NO,NU),V(NU,NU,NU)
C
      DATA HALF/0.5D+00/
C
C        PREPARE I^{AB}_{CD}, I^{IA}_{JB}, AND I^{IA}_{BJ} INTERMEDIATES
C
      NO2   = NO*NO
      NOU=NO*NU
      NU2   = NU*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
      NOU3  = NO*NU*NU*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL RO1(1,NO,NU,O1)
C      CALL ZEROMA(O1,1,NOU)
      CALL RDVEM3X(0,NO,NU,TI,VE)   !06/23/2004 QUADRUPLES
      CALL RDVE3(1,NO,NU,TI,VE)
      CALL VECMUL(VE,NOU3,HALF)
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL TRANMD(T2,NU,NU,NO,NO,12)
      CALL RO2HPP(1,NO,NU,TI,O2)
      CALL TRANSQ(O2,NOU)!PHHP
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
C
      DO I=1,NU
         CALL RDVPP(I,NO,NU,V)
         CALL CCMATMUL(T2,O2(1,1,1,I),V,NU2,NU,NO2,0,0)
         CALL TRANT3(V,NU,1)
         CALL CCMATMUL(VE(1,1,1,I),O1,V,NU2,NU,NO,0,1)
         CALL TRT1(NO,NU,TI,O1)
         CALL INSITU(NU,NU,NO,NU,TI,VE,13)
         CALL TRANMD(VE,NO,NU,NU,NU,24)
         CALL CCMATMUL(O1,VE(1,1,1,I),V,NU,NU2,NO,0,1)
         CALL TRT1(NU,NO,TI,O1)
         CALL TRANMD(VE,NO,NU,NU,NU,24)
         CALL INSITU(NO,NU,NU,NU,TI,VE,13)
C         CALL TRANT3(V,NU,1)
         CALL WRVPP(I,NU,V)
      ENDDO
C
      CALL RO2HPP(1,NO,NU,TI,T2)
      CALL RDVE(1,NO,NU,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,12)
C      CALL ZEROMA(O1,1,NOU)
      CALL CCMATMUL(O1,VE,T2,NO,NOU2,NU,0,0)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL TRANSQ(T2,NOU)
      CALL RDVEM4(1,NU,NO,TI,VE)
      CALL TRT1(NO,NU,TI,O1)
      CALL CCMATMUL(O1,VE,T2,NU,NO2U,NO,0,1)
      CALL TRANSQ(T2,NOU)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL VECCOP(NO2U2,V,T2)
      CALL RO2(1,NO,NU,O2)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,12)
      CALL RO2HPP(1,NO,NU,TI,VE)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL SYMT21(O2,NO,NU,NO,NU,13)
      CALL CCMATMUL(O2,VE,T2,NOU,NOU,NOU,0,0)
      CALL DESM21(O2,NO,NU,NO,NU,13)
      CALL TRANMD(VE,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,VE,T2,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL VECCOP(NO2U2,VE,V)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL VECSUB(T2,VE,NO2U2)
      CALL VECADD(VE,T2,NO2U2)
      CALL VECADD(VE,T2,NO2U2)
      CALL WO2(6,NO,NU,VE)
      CALL RO2HPP(2,NO,NU,TI,T2)
      CALL TRANSQ(T2,NOU)
      CALL RDVEM4(1,NU,NO,TI,VE)
      CALL TRANMD(VE,NO,NO,NO,NU,13)
      CALL RO1(1,NO,NU,O1)
C      CALL ZEROMA(O1,1,NOU)
      CALL CCTMATMUL(O1,VE,T2,NU,NO2U,NO,0,1)
      CALL TRANSQ(T2,NOU)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL TRANMD(O2,NO,NU,NO,NU,13)
      CALL RO2HPP(1,NO,NU,TI,VE)
      CALL TRANMD(VE,NO,NU,NU,NO,23)
      CALL ZEROMA(V,1,NO2U2)
      CALL CCMATMUL(O2,VE,V,NOU,NOU,NOU,1,1)
      CALL VECADD(T2,V,NO2U2)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL RDVE(1,NO,NU,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,13)
      CALL RO1(1,NO,NU,O1)
C      CALL ZEROMA(O1,1,NOU)
      CALL CCMATMUL(O1,VE,T2,NO,NOU2,NU,0,0)
      CALL TRANMD(T2,NO,NU,NU,NO,14)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL VECADD(T2,V,NO2U2)
      CALL WO2(7,NO,NU,T2)
      CALL RDVM(3,NO,NU,VE)
      CALL RO1(3,NO,NU,O1)
C      CALL ZEROMA(O1,1,NOU)
      CALL RO2(1,NO,NU,O2)
      CALL TRANSQ(O2,NOU)
C      CALL CCMATMUL(O1,O2,VE,NO,NO2U,NU,0,0)
      CALL WRVM(3,NO,NU,VE)
      RETURN
      END
C*MODULE CCQUAD  *DECK HPVVOE
      SUBROUTINE HPVVOE(IPT,NO,NU,V,VOE,T2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      COMMON/VRINPI/IFIRST(512)
      DIMENSION V(1),VOE(NU,NO,NO,NU),T2(NU,NU,NO,NO)
        L46=61
      DO 302 I=1,NU
         IRC=IFIRST(I)
         CALL RDVV(L46,NU3,IRC,V)
C         CALL RINTPPI(NU,NU2,V,I)
         IF (IPT.EQ.1)GOTO 10
         CALL TRANT3(V,NU,3)
         IF (IPT.EQ.2)GOTO 10
         CALL SYMT21(V,NU,NU,NU,1,13)
 10      CONTINUE
         CALL CCMATMUL(V,VOE(1,1,1,I),T2,NU2,NO2,NU,0,1)
 302  CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK VT4
      SUBROUTINE VT4(NO,NU,FPP,V,T4)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION FPP(NU,NU),V(NU,NU,NU),T4(NU,NU)
        NU3=NU*NU*NU
        NU2=NU*NU
      DO 301 I=1,NU
         CALL RDVPP(I,NO,NU,V)
         CALL TRANT3(V,NU,1)
         CALL SYMT21(V,NU,NU,NU,1,13)
         CALL CCMATMUL(FPP,V,T4(1,I),1,NU,NU2,1,1)
 301  CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK VT4CR
      SUBROUTINE VT4CR(NU,FPP,V,T4)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION FPP(NU,NU),V(NU,NU,NU,NU),T4(NU,NU)
        NU2=NU*NU
        NU3=NU*NU*NU
      DO 301 I=1,NU
         CALL RDVPPI(I,NU,V)
         CALL SYMT21(V,NU,NU,NU,1,23)
         CALL CCMATMUL(FPP,V,T4(1,I),1,NU,NU2,1,1)
C         CALL DESM21(V(1,1,1,I),NU,NU,NU,1,23)
 301  CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK DRINTRI2
      SUBROUTINE DRINTRI2(NO,NU,MODE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*21 STRINGS(0:1)
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      COMMON /FMCOM / X(1)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA CHECK/8HCHECK   /
      DATA STRINGS/'NONITERATIVE TRIPLES ', 'EOMCCSD INTERMEDIATES'/
C
      NO2   = NO*NO
      NO3   = NO*NO2
      NU2   = NU*NU
      NU3   = NU*NU2
      NO3U  = NO3*NU
      NOU3  = NO*NU3
      NO2U2 = NO2*NU2
C
      LNU3=NU3
      IF(NO3U.GT.NU3) LNU3=NO3U
C
      CALL GOTFM(NGOTMX)
      IF(MEM.LT.NGOTMX) NGOTMX=MEM
C
      CALL VALFM(LOADFM)
C
      LTI   = LOADFM + 1
      LT2   = LTI    + LNU3
      LVM   = LT2    + NO2U2
      LVE   = LVM    + NO3U
      LAST1 = LVE    + NOU3
      NEED1 = LAST1 - LOADFM - 1
      WRITE(6,992) STRINGS(MODE),NEED1
C
      CALL GETFM(NEED1)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL INTRIP2(NO,NU,X(LTI),X(LT2),X(LVM),X(LVE))
C
  800 CONTINUE
      CALL RETFM(NEED1)
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + LNU3
      I3   = I2     + NO2U2
      I4   = I3     + NO3U
      I5   = I4     + NO3U
      LAST = I5     + NOU3
      NEED = LAST - LOADFM - 1
      WRITE(6,993) STRINGS(MODE),NEED
      CALL FLSHBF(6)
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 850
C
      CALL INTRIH2(NO,NU,X(I1),X(I2),X(I3),X(I4),X(I5))
C
  850 CONTINUE
      CALL RETFM(NEED)
      RETURN
C
  992 FORMAT(1X,'MEMORY REQUIRED FOR ',A21,' (INTRIP)',
     *          ' IS ',I12,' WORDS.')
  993 FORMAT(1X,'MEMORY REQUIRED FOR ',A21,' (INTRIH )',
     *          ' IS ',I12,' WORDS.')
      END
C*MODULE CCQUAD  *DECK INTRIH2
      SUBROUTINE INTRIH2(NO,NU,TI,T2,VM,VM1,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(1),T2(1),VE(1),VM(1),VM1(1)
      DATA ZERO/0.0D+0/,ONE/1.0D+0/,OM/-1.0D+0/
      NO2   = NO*NO
      NO3   = NO*NO2
      NO4   = NO*NO3
      NU2   = NU*NU
      NU3   = NU*NU2
      NU4   = NU*NU3
      NOU   = NO*NU
      NO2U  = NO2*NU
      NO3U  = NO3*NU
      NOU2  = NO*NU2
      NOU3  = NO*NU3
      NO2U2 = NO2*NU2
      CALL RO2(1,NO,NU,T2)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2,12)
      CALL RDVEM4(1,NU,NO,TI,VM1)
      CALL VECCOP(NO3U,VM,VM1)
      CALL SYMT21(T2,NO,NU,NO,NU,13)
      CALL DGEMM('N','N',NO2,NOU,NOU,ONE,VM,NO2,T2,NOU,ONE,VM1,NO2)
      CALL DESM21(T2,NO,NU,NO,NU,13)
      CALL TRANMD(VM,NO,NO,NO,NU,23)
      CALL DGEMM('N','N',NO2,NOU,NOU,OM,VM,NO2,T2,NOU,ONE,VM1,NO2)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL TRANMD(VM1,NO,NO,NO,NU,13)
      CALL DGEMM('N','N',NO2,NOU,NOU,OM,VM,NO2,T2,NOU,ONE,VM1,NO2)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL TRANMD(VM,NO,NO,NO,NU,23)
      CALL TRANMD(VM1,NO,NO,NO,NU,231)
      CALL INSITU(NO,NU,NO,NU,TI,T2,23)
      CALL RDVEM4(0,NO,NU,TI,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,13)
      CALL DGEMM('N','N',NO2,NOU,NU2,ONE,T2,NO2,VE,NU2,ZERO,VM,NO2)
      CALL VMCP(NO,NU,VM1,VM)
      CALL TRANMD(VM1,NO,NO,NO,NU,231)
      CALL WRVM(4,NO,NU,VM1)
      RETURN
      END
C*MODULE CCQUAD  *DECK INTRIP2
      SUBROUTINE INTRIP2(NO,NU,TI,T2,VM,VE1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION TI(1),T2(NU,NU,NO,NO),VM(1),VE1(1)
      DATA ON/1.0D+0/,OM/-1.0D+0/
      NO2   = NO*NO
      NO3   = NO*NO2
      NO4   = NO*NO3
      NU2   = NU*NU
      NU3   = NU*NU2
      NU4   = NU*NU3
      NOU   = NO*NU
      NO2U  = NO2*NU
      NO3U  = NO3*NU
      NOU2  = NO*NU2
      NOU3  = NO*NU3
      NO2U2 = NO2*NU2
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL RDVEM4(0,NO,NU,TI,VE1)
      CALL WRVE(2,NO,NU,VE1)
      DO I=1,NO
      CALL RDVVE(I,2,NO,NU,TI)
      CALL SYMT21(T2(1,1,1,I),NU,NU,NO,1,12)
      CALL DGEMM('N','N',NU2,NOU,NU,ON,TI,NU2,T2(1,1,1,I),NU,ON,VE1,NU2)
      CALL DESM21(T2(1,1,1,I),NU,NU,NO,1,12)
      CALL TRANT3(TI,NU,1)
      CALL DGEMM('N','N',NU2,NOU,NU,OM,TI,NU2,T2(1,1,1,I),NU,ON,VE1,NU2)
      ENDDO
      CALL TRANMD(T2,NU,NU,NO,NO,12)
      CALL TRANMD(VE1,NU,NU,NU,NO,13)
      DO I=1,NO
      CALL RDVVE(I,2,NO,NU,TI)
      CALL TRANT3(TI,NU,1)
      CALL DGEMM('N','N',NU2,NOU,NU,OM,TI,NU2,T2(1,1,1,I),NU,ON,VE1,NU2)
      ENDDO
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
C      CALL RDVM(2,NO,NU,TI)
      CALL RDVEM4(1,NU,NO,VM,TI)
      CALL VMCP2(NO,NU,VM,TI)
      CALL TRANMD(VM,NO,NO,NU,NO,14)
      CALL DGEMM('N','N',NU2,NOU,NO2,ON,T2,NU2,VM,NO2,ON,VE1,NU2)
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
      CALL WRVE(4,NO,NU,VE1)
      RETURN
      END
C
C*MODULE CCQUAD  *DECK DRWT1T3
      SUBROUTINE DRWT1T3(NO,NU,CR,NEED)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CR(1)
      NOU=NO*NU
      NU3=NU*NU*NU
      NO2U2=NOU*NOU
      NO3U=NOU*NO*NO
      NOU3=NO*NU3
      LNU3=NOU3
      IF(NO3U.GT.NOU3)LNU3=NO3U
      I1=1         !T2N
      I2=I1+NO2U2  !T1
      I3=I2+NOU    !TI
      I4=I3+LNU3   !VOE
      I5=I4+NO2U2  !T3
      I6=I5+NU3    !T1A
      ITOT=I6+NOU
      IF(ITOT.GT.NEED) THEN
         WRITE(6,*) 'TOO MUCH MEMORY FOR WR1T3'
         CALL ABRT
      END IF
C
      CALL WT1T3(NO,NU,CR(I1),CR(I2),CR(I3),CR(I4),CR(I5),CR(I6))
      RETURN
      END
C
C*MODULE CCQUAD  *DECK WT1T3
      SUBROUTINE WT1T3(NO,NU,T2N,T1,TI,VOE,T3,T1A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B,C,D,E,F
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T1(1),TI(1),VOE(1),T1A(1),T2N(1),T3(1)
      DATA HALF/0.5D+00/
     *FOURTH/0.25D+0/
      NOU=NO*NU
      NO2U=NOU*NO
      NOU2=NOU*NU
      NU3=NU*NU*NU
      NO2U2=NOU*NOU
      CALL RO1(1,NO,NU,T1)
      CALL RO2(1,NO,NU,VOE)
      CALL ZEROMA(T2N,1,NO2U2)
      CALL SYMT21(VOE,NO,NU,NU,NO,23)
      CALL CCMATMUL(T1,VOE,T1A,1,NOU,NOU,1,0)
      CALL DESM21(VOE,NO,NU,NU,NO,23)
      CALL VECMUL(T1A,NOU,FOURTH)
      CALL T2FT3Q(NO,NU,T2N,T3,T1A)
      CALL INSITU(NU,NU,NO,NO,T3,T2N,13)
      CALL TRANMD(T2N,NO,NU,NU,NO,23)
CCCX      CALL ENGY2(NO,NU,T2N,TI,T3,OEH,OEP)
      CALL VECMUL(T1,NOU,HALF)
      CALL INSITU(NO,NU,NU,NO,T3,VOE,13)
      CALL CCMATMUL(T1,VOE,TI,NO,NO2U,NU,1,0)
      CALL INSITU(NU,NU,NO,NO,T3,VOE,13)
      CALL T2WT3HQ(NO,NU,T2N,T3,TI)
CCCX      CALL ENGY2(NO,NU,T2N,TI,T3,OEH,OEP)
      CALL CCTMATMUL(T1,VOE,TI,NU,NOU2,NO,1,1)
      CALL INSITU(NO,NU,NU,NO,T3,T2N,13)
      CALL T2WT3PQ(NO,NU,T2N,T3,TI)
      CALL INSITU(NU,NU,NO,NO,T3,T2N,13)
CCCX      CALL ENGY2(NO,NU,T2N,TI,T3,OEH,OEP)
      CALL ZEROMA(T1A,1,NOU)
      CALL T1WT3Q(NO,NU,TI,T1A,VOE)
      CALL CCMATMUL(T1,T1A,T2N,NOU,NOU,1,0,0)
CCCX      CALL ENGY2(NO,NU,T2N,TI,T3,OEH,OEP)
      RETURN
      END
C
C*MODULE CCQUAD  *DECK DRINTHM
      SUBROUTINE DRINTHM(NO,NU,O1,MAXMEM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(1)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
CCCX      COMMON/NEWOPT/NOPT(6)
CCCX      COMMON/ITRAT/ICYCLE,MX,ICN
CCCX      COMMON/TOTMEM/MEM
      I1=1           !TI
      I2=I1+NOU2     !T2PP
      I3=I2+NO2U2    !T2VO
      I4=I3+NO2U2    !VOE
      I5=I4+NO2U2    !VO
      I6=I5+NO2U2    !PZ
      I7=I6+NO4      !VT
      IT=I7+NO2U2
C
      IF(IT.GT.MAXMEM) THEN
         WRITE(6,*) 'TOO MUCH MEMORY IN DRINTHM'
         CALL ABRT
      END IF
C
      CALL INTH4P2M(NO,NU,O1,O1(I2),O1(I3),O1(I4),O1(I5),O1(I6),O1(I7))
      RETURN
      END
C*MODULE CCQUAD  *DECK INTH4P2M
      SUBROUTINE INTH4P2M(NO,NU,TI,T2PP,T2VO,VOE,VO,PZ,VT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C      COMMON/NVTAP/NTITER,NQ2,NVT
      COMMON/NEWIO/L46,NHHQ,NPPQ,NTVO,NVT
      DIMENSION TI(NU,NU,NU),T2PP(NU,NU,NO,NO),VO(NU,NU,NO,NO),
     *PZ(NO,NO,NO,NO),VT(NU,NU,NO,NO),T2VO(NO,NU,NU,NO),
     *VOE(NU,NU,NO,NO)
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DATA HALF/0.5D+0/
      NO2=NO*NO
      NO3=NO*NO2
      NO4=NO*NO3
      NU2=NU*NU
      NU3=NU*NU2
      NU4=NU*NU3
      NOU=NO*NU
      NOU2=NO*NU2
      NOU3=NO*NU3
      NO2U=NO2*NU
      NO3U=NO3*NU
      NO2U2=NO2*NU2
      CALL RO2(1,NO,NU,T2VO)
      CALL RO2(1,NO,NU,T2PP)
      CALL INSITU(NO,NU,NU,NO,TI,T2PP,13)
      CALL TRANMD(T2PP,NU,NU,NO,NO,12)
      CALL TRANMD(T2VO,NO,NU,NU,NO,23)
      CALL RO2(6,NO,NU,VO)
      CALL INSITU(NO,NU,NU,NO,TI,VO,13)
      CALL TRANMD(VO,NU,NU,NO,NO,34)
      CALL RO2(7,NO,NU,VOE)
      CALL INSITU(NO,NU,NU,NO,TI,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,34)
      NHH=85
      CALL RCCFL(NHH,3,NO4,PZ)
      CALL MTRANSQ(PZ,NO,11)
      CALL MTRANSQ(PZ,NO,12)
      CALL VECMUL(PZ,NO4,HALF)
      KKK=0
      DO 123 I=1,NO
      DO 123 J=1,NO
      CALL CCMATMUL(T2VO(1,1,1,I),VO(1,1,1,J),VT,NOU,NOU,NU,1,0)
      CALL INSITU(NO,NU,NU,NO,TI,VT,13)
      CALL TRANMD(VT,NU,NU,NO,NO,34)
      CALL CCMATMUL(T2PP(1,1,J,I),VOE,VT,NU,NO2U,NU,0,0)
      CALL CCMATMUL(T2PP(1,1,1,I),PZ(1,1,1,J),VT,NU2,NO2,NO,0,1)
      CALL TRANMD(VT,NU,NU,NO,NO,12)
      KKK=NO*(J-1)+I
      CALL WRGEN(NVT,KKK,NO2U2,VT)
C      DO 123 K=1,NO
C      KKK=NO2*(J-1)+NO*(I-1)+K
C      CALL WRGEN(NVT,KKK,NOU2,VT(1,1,1,K))
 123  CONTINUE
      CALL SYMVT(NO,NU,T2PP,T2VO)
      RETURN
      END
C*MODULE CCQUAD  *DECK T2HHVT
      SUBROUTINE T2HHVT(NO,NU,TI,VH,VHA,VHB,VHC,VHD,O2,O2A,VO,VOA,VT,
     *VO2,T2N,T2NN,OEH,OEP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(1),VH(1),VHA(NO,NO,NO,NO),VHB(NO,NO,NO,NO),
     *VHC(NO,NO,NO,NO),VHD(NO,NO,NO,NO),O2(1),O2A(1),VO(1),VOA(1),
     *VT(1),VO2(1),T2N(NU,NU,NO,NO),T2NN(NU,NU,NO,NO),OEH(1),OEP(1)
      DATA TWO/2.0D+0/
      NO2=NO*NO
      NU2=NU*NU
CCCX      NOU=NO*NU
      NO2U=NO2*NU
      NO2U2=NO2*NU2
      CALL TRANDS(NO,NU,TI)
      CALL ZEROMA(T2N,1,NO2U2)
      CALL ZEROMA(T2NN,1,NO2U2)
      CALL RINTHH(2,NO,VH)
      CALL RINTHH(3,NO2,VHA)
      CALL MTRANSQ(VHA,NO,10)
      CALL SYMT21(VHA,NO,NO,NO,NO,14)
      CALL MTRANSQ(VHA,NO,1)
      CALL RINTHH(3,NO2,VHB)
      CALL MTRANSQ(VHB,NO,7)
      CALL RINTHH(4,NO2,VHC)
      CALL MTRANSQ(VHC,NO,10)
      CALL SYMT21(VHC,NO,NO,NO,NO,14)
      CALL MTRANSQ(VHC,NO,1)
      CALL RINTHH(4,NO2,VHD)
      CALL MTRANSQ(VHD,NO,7)
      CALL RINTVO(1,NO,NU,TI,VO)
      CALL RINTVO(5,NO,NU,TI,VOA)
      CALL RINTVO(2,NO,NU,TI,O2)
      CALL RINTVO(6,NO,NU,TI,O2A)
      CALL INSITU(NO,NU,NU,NO,TI,VO,12)
      CALL INSITU(NO,NU,NU,NO,TI,O2,12)
      CALL INSITU(NO,NU,NU,NO,TI,VOA,12)
      CALL INSITU(NO,NU,NU,NO,TI,O2A,12)
      CALL RINTHH(1,NO,TI)
      DO 9 J=1,NO
      DO 9 I=1,NO
      CALL RDVTIJ(1,NO,NU,I,J,VO2)
      CALL CCMATMUL(VO2,VHB(1,1,1,J),T2N(1,1,1,I),NU2,NO,NO2,0,1)
      CALL CCMATMUL(VO2,VHD(1,1,1,J),T2NN(1,1,1,I),NU2,NO,NO2,0,1)
      CALL TRNS(NO,NU,VO2,VT)
      CALL SYMT21Q(VT,NO,NU,NO,NU,24)
      CALL CCMATMUL(VO,VT,T2N(1,1,I,J),NU,NU,NO2U,0,1)
      CALL CCMATMUL(VOA,VT,T2NN(1,1,I,J),NU,NU,NO2U,0,1)
      CALL DESM21Q(VT,NO,NU,NO,NU,24)
      CALL CCMATMUL(O2,VT,T2N(1,1,I,J),NU,NU,NO2U,0,0)
      CALL CCMATMUL(O2A,VT,T2NN(1,1,I,J),NU,NU,NO2U,0,0)
      CALL TRANMD(VT,NO,NU,NO,NU,24)
      CALL CCTMATMULT(VT,O2,T2N(1,1,I,J),NU,NU,NO2U,0,0)
      CALL CCTMATMULT(VT,O2A,T2NN(1,1,I,J),NU,NU,NO2U,0,0)
      CALL RDVTIJ(0,NO,NU,I,J,VT)
      CALL CCMATMUL(VT,VHA(1,1,1,I),T2N(1,1,1,J),NU2,NO,NO2,0,0)
      CALL CCMATMUL(VT,VHC(1,1,1,I),T2NN(1,1,1,J),NU2,NO,NO2,0,0)
      CALL VECSUB(VO2,VT,NO2U2)
      CALL CCMATMUL(VO2,TI,T2N(1,1,I,J),NU2,1,NO2,0,0)
      CALL CCMATMUL(VO2,VH,T2NN(1,1,I,J),NU2,1,NO2,0,0)
      CALL TRNS(NO,NU,VT,VO2)
      CALL CCMATMUL(VO,VO2,T2N(1,1,I,J),NU,NU,NO2U,0,0)
      CALL CCMATMUL(VOA,VO2,T2NN(1,1,I,J),NU,NU,NO2U,0,0)
      CALL VECMUL(VO2,NO2U2,TWO)
      CALL CCMATMUL(O2,VO2,T2N(1,1,I,J),NU,NU,NO2U,0,1)
      CALL CCMATMUL(O2A,VO2,T2NN(1,1,I,J),NU,NU,NO2U,0,1)
   9  CONTINUE
      CALL TRANMD(T2N,NU,NU,NO,NO,12)
      CALL INSITU(NU,NU,NO,NO,TI,T2N,13)
      CALL TRANMD(T2NN,NU,NU,NO,NO,12)
      CALL INSITU(NU,NU,NO,NO,TI,T2NN,13)
      CALL ENGY1CRA(NO,NU,T2N,T2NN,VT)
      CALL ENGY1CR(NO,NU,T2N,T2NN,VT,OEH,OEP)
      RETURN
      END
C*MODULE CCQUAD  *DECK DRT3WT2P
      SUBROUTINE DRT3WT2P(NH,NP,EH,EP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION EH(NH),EP(NP)
      COMMON /FMCOM/ X(1)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA CHECK/8HCHECK   /
C
      NO    = NH
      NU    = NP
      NO2   = NO*NO
      NO3   = NO*NO2
      NU2   = NU*NU
      NU3   = NU*NU2
      NOU   = NO*NU
      NO3U  = NO3*NU
      NOU3  = NO*NU3
      NO2U2 = NO2*NU2
C
      CALL GOTFM(NGOTMX)
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + NO2U2
      I4   = I3     + NO3U
      I5   = I4     + NOU3
      I6   = I5     + NU3
      I7   = I6     + NU3
      LAST = I7     + NO2U2
      NEED = LAST - LOADFM - 1
      WRITE(6,90) NEED
      CALL FLSHBF(6)
C
      IF(NEED.GT.NGOTMX) THEN
         WRITE(6,91) NEED,NGOTMX
         CALL ABRT
      END IF
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL T3WT2P(NH,NP,X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),X(I7),
     *            EH,EP)
C
  800 CONTINUE
      CALL RETFM(NEED)
 90   FORMAT(1X,'MEMORY REQUIRED FOR NONITERATIVE TRIPLES (T3WT2N )',
     *           ' IS ',I12,' WORDS.')
 91   FORMAT(1X,'INSUFFICIENT MEMORY FOR NONITERATIVE TRIPLES'/
     *       1X,'REQUIRED:',I12,'     AVAILABLE:',I12)
      RETURN
      END
C*MODULE CCQUAD  *DECK DRT3WT2P
      SUBROUTINE T3WT2P(NO,NU,O1,T2,VM,VE,V3,T3,VOE,EH,EP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(1),T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),VOE(1),V3(1),
     *          T3(1),VE(NU,NU,NU,NO),EH(NO),EP(NU)
CCCX      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
CCCX     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      COMMON/T4TOT/ETT2,ETS2,EQ1A,EQ1B,EQ2A,EQ2B,EQ3A,EQ3B,EQ4A,
     *EQ4B,O4A,O4B,ECORQ(8),ETOTQ(8)
      DATA ZERO/0.0D+00/, ONE/1.0D+00/, OM/-1.0D+00/
      ETT2=ZERO
      ETS2=ZERO
      NU2   = NU*NU
      NU3   = NU*NU2
C      ETTM=ZERO
C      ESD_TM=ZERO
CCCX      NOU3=NO*NU*NU*NU
CCCX      NO3U=NO*NO*NO*NU
C
      CALL ZEROMA(V3,1,NU3)
      CALL RO2HPP(1,NO,NU,V3,VOE)
      CALL INSITU(NO,NU,NU,NO,V3,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL RDVE(4,NO,NU,VE)
C      CALL CHKSUMSK('VENEW   ',VE,NOU3)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL RDVM(4,NO,NU,T2)
C      CALL CHKSUMSK('VMNEW   ',T2,NO3U)
      CALL VMCP1(NO,NU,VM,T2)
      CALL TRANMD(VM,NO,NU,NO,NO,13)
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,V3,T2,13)
      CALL RO1(1,NO,NU,O1)
C
      DO 351 I=1,NO
         I1=I-1
      DO 351 J=1,I1
         J1=J-1
      DO 351 K=1,J1
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,K,J),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,K),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,K,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,K),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,5)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,5)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,K),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,K),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,5)
      CALL ZEROT3(V3,NU)
C     IF TQF ADD SAK
CCCX      KK=IT3(I,J,K)
C      CALL WRT3Q(KK,NO,NU,V3)
C  END OF ADD.
      CALL T3SQUAP(I,J,K,NO,NU,O1,VOE,V3,T3,EH,EP)
 351  CONTINUE
      DO 352 I=1,NO
         I1=I-1
      DO 352 J=1,I1
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,J),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,2)
      CALL SYMT311(V3,NU,23)
      CALL ZEROT3(V3,NU)
C     IF TQF ADD SAK
CCCX      KK=IT3(I,J,J)
C      CALL WRT3Q(KK,NO,NU,V3)
C  END OF ADD.
      CALL T3SQUAP(I,J,J,NO,NU,O1,VOE,V3,T3,EH,EP)
 352  CONTINUE
      DO 353 I=1,NO
         I1=I-1
      DO 353 J=1,I1
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,I),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL SYMT311(V3,NU,12)
      CALL ZEROT3(V3,NU)
C     IF TQF ADD SAK
CCCX      KK=IT3(I,I,J)
C      CALL WRT3Q(KK,NO,NU,V3)
C  END OF ADD.
      CALL T3SQUAP(I,I,J,NO,NU,O1,VOE,V3,T3,EH,EP)
 353  CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK T3SQUAP
      SUBROUTINE T3SQUAP(I,J,K,NO,NU,T1,T2,T3,O3,EH,EP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL IEJ,JEK
      INTEGER A,B,C
      DIMENSION T1(NO,NU),T2(NU,NU,NO,NO),T3(NU,NU,NU),EH(NO),EP(NU),
     *          O3(NU,NU,NU)
CCCX      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
CCCX     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      COMMON/T4TOT/ETT2,ETS2,EQ1A,EQ1B,EQ2A,EQ2B,EQ3A,EQ3B,EQ4A,
     *EQ4B,O4A,O4B,ECORQ(8),ETOTQ(8)
      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,ZERO/0.0D+00/,
     *     HALF/0.5D+00/,ONE/1.0D+00/
C
      DIJK=EH(I)+EH(J)+EH(K)
      KK=IT3(I,J,K)
      CALL RDT3(KK,NU,O3)
      X1=ZERO
      X2=ZERO
      DO 150 A=1,NU
      DO 150 B=1,NU
      DO 150 C=1,NU
      IF (A.EQ.B.AND.B.EQ.C)GOTO 150
      DABC=EP(A)+EP(B)+EP(C)
      DENOM=DIJK-DABC
      XT21=T1(I,A)*T2(B,C,J,K)+T1(J,B)*T2(A,C,I,K)+T1(K,C)*T2(A,B,I,J)
      D1=  T3(A,B,C)
      D2=  T3(A,C,B)+T3(C,B,A)+T3(B,A,C)
      D3=  T3(B,C,A)+T3(C,A,B)
      F=D1*EIGHT-FOUR*D2+D3*TWO
      X2=X2+F*O3(A,B,C)
      X1=X1+F*XT21/DENOM
 150  CONTINUE
      CF=ONE
      IEJ=I.EQ.J
      JEK=J.EQ.K
      IF(IEJ.OR.JEK) CF=HALF
C      ESD_TM=ESD_TM+CF*X1
C      ETTM=ETTM+CF*X2
      ETS2=ETS2+CF*X1
      ETT2=ETT2+CF*X2
C      IF(I.EQ.NO.AND.J.EQ.NO.AND.K.EQ.NO-1)
C     *WRITE(6,*)'T3SQUAP,ETT2,ETS2:',ETT2,ETS2
      RETURN
      END
C*MODULE CCQUAD  *DECK T3WT2
      SUBROUTINE T3WT2Q(NO,NU,T1,T2,VM,VE,V3,T3,VOE,O1,EH,EP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T1(1),T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),VOE(1),
     *          V3(1),T3(1),VE(NU,NU,NU,NO),EH(NO),EP(NU),O1(1)
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
CCCX      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      DATA ZERO/0.0D+00/, OM/-1.0D+00/, ONE/1.0D+00/
C
      NU2   = NU*NU
      NU3   = NU*NU2
      NOU   = NO*NU
C
      CALL ZEROMA(V3,1,NU3)
      OTS=ZERO
      OTD=ZERO
      ETD=ZERO
      ETTM=ZERO
      ESD_TM=ZERO
      CALL ZEROMA(T1,1,NOU)
      CALL RO2HPP(1,NO,NU,V3,VOE)
      CALL INSITU(NO,NU,NU,NO,V3,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL RDVEM4(0,NO,NU,V3,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL RDVEM4(1,NU,NO,V3,T2)
      CALL VMCP1(NO,NU,VM,T2)
      CALL TRANMD(VM,NO,NU,NO,NO,13)
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,V3,T2,13)
      CALL RO1(1,NO,NU,O1)
C
      KK=0
      DO 351 I=1,NO
         I1=I-1
      DO 351 J=1,I1
         J1=J-1
      DO 351 K=1,J1
         KK=IT3(I,J,K)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,K,J),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,K),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,K,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,K),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,5)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,5)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,K),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,K),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,5)
      CALL ZEROT3(V3,NU)
C      CALL WRT3Q(KK,NO,NU,V3)
      CALL T3SQUA(I,J,K,NO,NU,O1,T2,V3,EH,EP)
      DEH=EH(I)+EH(J)+EH(K)
      CALL ADT3DEN(NU,DEH,V3,EP)
C      IF(IDISC.EQ.0.AND.MET.GT.4) THEN
      CALL WRT3(KK,NU,V3)
C      END IF
      ITMP=I
      JTMP=J
      KTMP=K
      CALL DRT1WT3IJK(ITMP,JTMP,KTMP,NO,NU,T1,VOE,V3,T3)
 351  CONTINUE
C
      DO 352 I=1,NO
         I1=I-1
      DO 352 J=1,I1
      KK=IT3(I,J,J)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,J),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,2)
      CALL SYMT311(V3,NU,23)
      CALL ZEROT3(V3,NU)
      CALL T3SQUA(I,J,J,NO,NU,O1,T2,V3,EH,EP)
      DEH=EH(I)+EH(J)+EH(J)
      CALL ADT3DEN(NU,DEH,V3,EP)
      CALL WRT3(KK,NU,V3)
      ITMP=I
      JTMP=J
      CALL DRT1WT3IJ(ITMP,JTMP,NO,NU,T1,VOE,V3,T3)
 352  CONTINUE
C
      DO 353 I=1,NO
         I1=I-1
      DO 353 J=1,I1
      KK=IT3(I,I,J)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,I),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL SYMT311(V3,NU,12)
      CALL ZEROT3(V3,NU)
      CALL T3SQUA(I,I,J,NO,NU,O1,T2,V3,EH,EP)
      DEH=EH(I)+EH(I)+EH(J)
      CALL ADT3DEN(NU,DEH,V3,EP)
      CALL WRT3(KK,NU,V3)
      ITMP=I
      JTMP=J
      CALL DRT1WT3JK(ITMP,JTMP,NO,NU,T1,VOE,V3,T3)
 353  CONTINUE
      CALL TRT1(NU,NO,T3,T1)
      CALL T1SQ(NO,NU,T3,T1)
      CALL ADDDEN1(NO,NU,T1,EH,EP)
      CALL WO1(4,NO,NU,T1)
      RETURN
      END
C*MODULE CCQUAD  *DECK T3WT2N
      SUBROUTINE T3WT2NQ(NO,NU,O1,T2,VM,VE,V3,T3,VOE,EH,EP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL QDR,QDCR
      DIMENSION O1(1),T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),VOE(1),V3(1),
     *          T3(1),VE(NU,NU,NU,NO),EH(NO),EP(NU)
      COMMON/QUADRUPLE/QDR,QDCR
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      DATA ZERO/0.0D+00/, ONE/1.0D+00/, OM/-1.0D+00/
C
      NU2   = NU*NU
      NU3   = NU*NU2
      ETTM=ZERO
      ESD_TM=ZERO
CCCX        NOU3=NO*NU*NU*NU
CCCX        NO3U=NO*NO*NO*NU
C
      CALL ZEROMA(V3,1,NU3)
      CALL RO2HPP(1,NO,NU,V3,VOE)
      CALL INSITU(NO,NU,NU,NO,V3,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
      CALL RDVE(3,NO,NU,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL RDVM(3,NO,NU,T2)
      CALL VMCP1(NO,NU,VM,T2)
      CALL TRANMD(VM,NO,NU,NO,NO,13)
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,V3,T2,13)
      CALL RO1(1,NO,NU,O1)
C
      DO 351 I=1,NO
         I1=I-1
      DO 351 J=1,I1
         J1=J-1
      DO 351 K=1,J1
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,K,J),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,K),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,K,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,K),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,5)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,5)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,K),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,K),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,5)
      CALL ZEROT3(V3,NU)
C     IF TQF ADD SAK
      KK=IT3(I,J,K)
      CALL WRT3Q(KK,NO,NU,V3)
C  END OF ADD.
        IF(QDCR)THEN
      CALL T3SQUANQ(I,J,K,NO,NU,O1,VOE,V3,T3,EH,EP)
        ENDIF
 351  CONTINUE
      DO 352 I=1,NO
         I1=I-1
      DO 352 J=1,I1
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,J),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,2)
      CALL SYMT311(V3,NU,23)
      CALL ZEROT3(V3,NU)
C     IF TQF ADD SAK
      KK=IT3(I,J,J)
      CALL WRT3Q(KK,NO,NU,V3)
C  END OF ADD.
        IF(QDCR)THEN
      CALL T3SQUANQ(I,J,J,NO,NU,O1,VOE,V3,T3,EH,EP)
        ENDIF
 352  CONTINUE
      DO 353 I=1,NO
         I1=I-1
      DO 353 J=1,I1
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,J,I),NO,
     *ZERO,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,VM(1,1,I,I),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL TRANT3(V3,NU,3)
      CALL SYMT311(V3,NU,12)
      CALL ZEROT3(V3,NU)
C     IF TQF ADD SAK
      KK=IT3(I,I,J)
      CALL WRT3Q(KK,NO,NU,V3)
C  END OF ADD.
        IF(QDCR)THEN
      CALL T3SQUANQ(I,I,J,NO,NU,O1,VOE,V3,T3,EH,EP)
        ENDIF
 353  CONTINUE
      RETURN
      END
C*MODULE CCQUAD  *DECK T3SQUANQ
      SUBROUTINE T3SQUANQ(I,J,K,NO,NU,T1,T2,T3,O3,EH,EP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL IEJ,JEK
      INTEGER A,B,C
      DIMENSION T1(NO,NU),T2(NU,NU,NO,NO),T3(NU,NU,NU),EH(NO),EP(NU),
     *          O3(NU,NU,NU)
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,ZERO/0.0D+00/,
     *     HALF/0.5D+00/,ONE/1.0D+00/
C
      DIJK=EH(I)+EH(J)+EH(K)
      KK=IT3(I,J,K)
      CALL RDT3(KK,NU,O3)
      X1=ZERO
      X2=ZERO
      DO 150 A=1,NU
      DO 150 B=1,NU
      DO 150 C=1,NU
      IF (A.EQ.B.AND.B.EQ.C)GOTO 150
      DABC=EP(A)+EP(B)+EP(C)
      DENOM=DIJK-DABC
      XT21=T1(I,A)*T2(B,C,J,K)+T1(J,B)*T2(A,C,I,K)+T1(K,C)*T2(A,B,I,J)
      D1=  T3(A,B,C)
      D2=  T3(A,C,B)+T3(C,B,A)+T3(B,A,C)
      D3=  T3(B,C,A)+T3(C,A,B)
      F=D1*EIGHT-FOUR*D2+D3*TWO
C      X1=X1+F*XT21
      X2=X2+F*O3(A,B,C)
      X1=X1+F*XT21/DENOM
C      X2=X2+F*O3(A,B,C)/DENOM
 150  CONTINUE
      CF=ONE
      IEJ=I.EQ.J
      JEK=J.EQ.K
      IF(IEJ.OR.JEK) CF=HALF
      ESD_TM=ESD_TM+CF*X1
      ETTM=ETTM+CF*X2
      RETURN
      END
C*MODULE CCQUAD  *DECK DRT3WT2Q
      SUBROUTINE DRT3WT2Q(NO,NU,EH,EP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION EH(NO),EP(NU)
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      COMMON /FMCOM/ X(1)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA CHECK/8HCHECK   /
C
      NO2   = NO*NO
      NO3   = NO*NO2
      NU2   = NU*NU
      NU3   = NU*NU2
      NOU   = NO*NU
      NO3U  = NO3*NU
      NOU3  = NO*NU3
      NO2U2 = NO2*NU2
C
      CALL GOTFM(NGOTMX)
      IF(MEM.LT.NGOTMX) NGOTMX=MEM
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + NO2U2
      I4   = I3     + NO3U
      I5   = I4     + NOU3
      I6   = I5     + NU3
      I7   = I6     + NU3
      I8   = I7     + NO2U2
      LAST = I8     + NOU
      NEED = LAST - LOADFM - 1
      WRITE(6,90) NEED
      CALL FLSHBF(6)
C
      IF(NEED.GT.NGOTMX) THEN
         WRITE(6,91) NEED,NGOTMX
         CALL ABRT
      END IF
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL T3WT2Q(NH,NP,X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),X(I7),X(I8),
     *           EH,EP)
C
  800 CONTINUE
      CALL RETFM(NEED)
      RETURN
C
 90   FORMAT(/1X,'MEMORY REQUIRED FOR NONITERATIVE TRIPLES (T3WT2  )',
     *           ' IS ',I12,' WORDS.')
 91   FORMAT(1X,'INSUFFICIENT MEMORY FOR NONITERATIVE TRIPLES'/
     *       1X,'REQUIRED:',I12,'     AVAILABLE:',I12)
      END
C*MODULE CCQUAD  *DECK DRT3WT2NQ
      SUBROUTINE DRT3WT2NQ(NH,NP,EH,EP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION EH(NH),EP(NP)
      COMMON /FMCOM/ X(1)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA CHECK/8HCHECK   /
C
      NO    = NH
      NU    = NP
      NO2   = NO*NO
      NO3   = NO*NO2
      NU2   = NU*NU
      NU3   = NU*NU2
      NOU   = NO*NU
      NO3U  = NO3*NU
      NOU3  = NO*NU3
      NO2U2 = NO2*NU2
C
      CALL GOTFM(NGOTMX)
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + NO2U2
      I4   = I3     + NO3U
      I5   = I4     + NOU3
      I6   = I5     + NU3
      I7   = I6     + NU3
      LAST = I7     + NO2U2
      NEED = LAST - LOADFM - 1
      WRITE(6,90) NEED
      CALL FLSHBF(6)
C
      IF(NEED.GT.NGOTMX) THEN
         WRITE(6,91) NEED,NGOTMX
         CALL ABRT
      END IF
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL T3WT2NQ(NH,NP,X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),X(I7),
     *            EH,EP)
C
  800 CONTINUE
      CALL RETFM(NEED)
 90   FORMAT(1X,'MEMORY REQUIRED FOR NONITERATIVE TRIPLES (T3WT2N )',
     *           ' IS ',I12,' WORDS.')
 91   FORMAT(1X,'INSUFFICIENT MEMORY FOR NONITERATIVE TRIPLES'/
     *       1X,'REQUIRED:',I12,'     AVAILABLE:',I12)
      RETURN
      END
C*MODULE CCQUAD  *DECK DRINTRI
      SUBROUTINE DRINTRIQ(NO,NU,MODE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*21 STRINGS(0:1)
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /FMCOM / X(1)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA CHECK/8HCHECK   /
      DATA STRINGS/'NONITERATIVE TRIPLES ', 'EOMCCSD INTERMEDIATES'/
C 06/23/2004 QUADRUPLES ----
C ORIGINAL VERSION
CCCX      NO2   = NO*NO
CCCX      NO3   = NO*NO2
CCCX      NU2   = NU*NU
CCCX      NU3   = NU*NU2
CCCX      NOU   = NO*NU
CCCX      NO3U  = NO3*NU
CCCX      NOU3  = NO*NU3
CCCX      NO2U2 = NO2*NU2
C
      NO2=NO*NO
      NO3=NO*NO2
CCCX      NO4=NO*NO3
      NU2=NU*NU
      NU3=NU*NU2
CCCX      NU4=NU*NU3
      NOU=NO*NU
CCCX      NO2U=NO2*NU
      NO3U=NO3*NU
      NOU2=NO*NU2
      NOU3=NO*NU3
      NO2U2=NO2*NU2
C --------------------------
C
      LNU3=NU3
      IF(NO3U.GT.NU3) LNU3=NO3U
C
      CALL GOTFM(NGOTMX)
      IF(MEM.LT.NGOTMX) NGOTMX=MEM
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + LNU3
      I4   = I3     + NO2U2
      LAST = I4     + NOU3
      NEED = LAST - LOADFM - 1
      WRITE(6,991) STRINGS(MODE),NEED
      CALL FLSHBF(6)
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL INTQUA(NO,NU,X(I1),X(I2),X(I3),X(I4))
C
  800 CONTINUE
      CALL RETFM(NEED)
C
C         MEMORY ALLOCATION FOR ???STEPNAME???
C
C
C          WRITE A NULL RECORD ON SOME DISK FILE
C
C
C
C        THERE ARE TWO ALGORITHMS DEPENDING ON MEMORY FOR -VM- OR -VE-
C
      CALL VALFM(LOADFM)
      LTI   = LOADFM + 1
      LFPH  = LTI    + LNU3
      LT2   = LFPH   + NOU
      LVE1  = LT2    + NO2U2
      LVM   = LVE1   + NOU3
      LVE   = LVM
      LAST1 = LVM    + NOU3
      LAST2 = LVE    + NO3U
      NEED1 = LAST1 - LOADFM - 1
      NEED2 = LAST2 - LOADFM - 1
      WRITE(6,992) STRINGS(MODE),NEED1
      WRITE(6,993) STRINGS(MODE),NEED2
C
      IF(NEED1.LE.NGOTMX) THEN
         CALL GETFM(NEED1)
         WRITE(6,997)
         CALL FLSHBF(6)
         IF(EXETYP.NE.CHECK)
     *   CALL INTRIPL(NO,NU,X(LTI),X(LFPH),X(LT2),X(LVE),X(LVE1))
         CALL RETFM(NEED1)
      ELSE IF(NEED2.LE.NGOTMX) THEN
         CALL GETFM(NEED2)
         WRITE(6,998)
         CALL FLSHBF(6)
         IF(EXETYP.NE.CHECK)
     *   CALL INTRIP(NO,NU,X(LTI),X(LFPH),X(LT2),X(LVM),X(LVE1))
         CALL RETFM(NEED2)
      ELSE
         WRITE(6,91) STRINGS(MODE),NEED2,NGOTMX
         CALL ABRT
      END IF
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + LNU3
      I3   = I2     + NOU
      I4   = I3     + NO2U2
      I5   = I4     + NO3U
      I6   = I5     + NO3U
      LAST = I6     + NOU3
      NEED = LAST - LOADFM - 1
      WRITE(6,994) STRINGS(MODE),NEED
      CALL FLSHBF(6)
C
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 850
C
      CALL INTRIH(NO,NU,X(I1),X(I2),X(I3),X(I4),X(I5),X(I6))
C
  850 CONTINUE
      CALL RETFM(NEED)
CC
C
C
C
C         MEMORY ALLOCATION FOR ???STEPNAME???
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1   = LOADFM+1
      I2   = I1    + NOU                     ! O1
      I3   = I2    + MAX(NOU,NOU2,NO3,NU3)   ! TI
      I4   = I3    + NO2U2                   ! VOE
      LAST = I4    + MAX(NO3U,NOU3)          ! VE
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9090) '      WDEX',NEED,NGOTMX
      CALL FLSHBF(IW)
C
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK)
     *    CALL WDEX(NO,NU,X(I1),X(I2),X(I3),X(I4))
      CALL RETFM(NEED)
C
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + MAX(NU3,NO3,NOU2)
      I4   = I3     + NO2U2
      I5   = I4     + NO2U2
      I6   = I5     + MAX(NOU3,NO3U,NO2U2)
      LAST = I6     + MAX(NU3,NO2U2)
      NEED = LAST - LOADFM - 1
C
 9090 FORMAT(1X,'MEMORY USAGE BY ',A10,':',I10,' NEEDED,',I10,
     *          ' AVAILABLE')
      WRITE(IW,9090) '  INTQUAT2Q',NEED,NGOTMX
      CALL FLSHBF(IW)
C
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK)
     *    CALL INTQUAT2Q(NO,NU,X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),NOU)
      CALL RETFM(NEED)
      RETURN
C
  991 FORMAT(1X,'MEMORY REQUIRED FOR ',A21,' (INTQUA )',
     *          ' IS ',I12,' WORDS.')
  992 FORMAT(1X,'MEMORY REQUIRED FOR ',A21,' (INTRIPL)',
     *          ' IS ',I12,' WORDS.')
  993 FORMAT(1X,'MEMORY REQUIRED FOR ',A21,' (INTRIP )',
     *          ' IS ',I12,' WORDS.')
  994 FORMAT(1X,'MEMORY REQUIRED FOR ',A21,' (INTRIH )',
     *          ' IS ',I12,' WORDS.')
  997 FORMAT(1X,'THERE IS ENOUGH MEMORY TO RUN THE MORE EFFICIENT',
     *          ' INTRIPL INSTEAD OF INTRIP.')
  998 FORMAT(1X,'THERE IS NOT ENOUGH MEMORY TO RUN INTRIPL, CHOOSING',
     *          ' INTRIP INSTEAD.')
   91 FORMAT(1X,'INSUFFICIENT MEMORY FOR ',A21/
     *       1X,'REQUIRED:',I12,'     AVAILABLE:',I12)
      END
