C  7 DEC 07 - MWS - CHANGE PRINTING OF SOME REFERENCES
C 28 AUG 07 - PP  - CHANGE THE PRINTING FORMATS, AGAIN
C 20 AUG 07 - MWS - XT3WT2NNN: DON'T PRINT THAT TYPE A IS FOR GRADIENTS
C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C 22 FEB 06 - MWS - EXTEND PRINTING OF BEST CR-CCL ENERGY.
C  2 FEB 06 - MWS - SYNCH COMMON BLOCK EOMWFE
C 17 JAN 06 - MW  - IMPLEMENT CR-CCSD(T)_L METHOD
C 19 SEP 05 - MWS - ADD TRUE NUCLEAR CHARGE ARRAY TO INFOA COMMON
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 30 APR 05 - KK  - SMALL CHANGES FOR LEFT EIGENVECTOR COMPUTATION
C  3 JUN 04 - MWS - WRITEEX1: CHANGED PRINTOUT FORMAT
C  7 APR 04 - KK,PP - NEW MODULE FOR TRIPLES CORRECTIONS TO EOM-CCSD
C
C*MODULE MM23   *DECK MMDRV
      SUBROUTINE MMDRV(ESCF,ECCSD,BESTEOM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 VECREP,REP
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                MXCCIT,MXRLEIT,NWRDCC,ICCCNV,ICCRST,IDSKCC
      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 /EOMINF/ ISPACE,IHSPACE,JCISPACE,ICIMET,IOPTMM,
     *                NROOT,NOA,NUA,MAXITEOM
      COMMON /EOMPAR/ CVGCI,CVGEOM,GRPEOM,NSTEOM(8),NOACT,NUACT,
     *                MOACTCC(MXAO),MTHTRIP,MTHCI,MTHEOM,MTHINIT,
     *                MAXCI,MAXEOM,MICCI,MICEOM,IROOTCC(2),
     *                IPROPCC,IPROPCCE
      COMMON /EOMSYM/ IG,NRE(4),MC(8,8,4),ISORB(MXAO),REP(8)
C
C     /EOMTRP/ IS INTERMEDIATES FOR TRIPLES CORRECTIONS
C            10 - MAXIMUM NUMBER OF STATES PER IRREP
C       XM1,XD1 - R3 DEN(EH-EP)
C       XM2,XD2 - R3 DEN(FH-FP)
C       XM3,XD3 - R3 DEN(12BODY)
C           YD1 - R3/(ALL)
C           YD2 - R3/(12BODY)
C           YD3 - R3/(EH-EP)
C           YD4 - R3/(FH-FP)
C      XGRCORR  - (P+Q123)EXP(T12)(1+T3)|PHI> T3(ALL)
C      XGRCORR1 - (P+Q123)EXP(T12)(1+T3)|PHI> T3(EH-EP)
C      XGRCORR2 - (P+Q123)EXP(T12)(1+T3)|PHI> T3(FH-FP)
C      XGRCORR3 - (P+Q123)EXP(T12)(1+T3)|PHI> T3(12BODY)
C      XGRCORR4 - (P+Q12)EXP(T12)+T3|PHI> T3(ALL)
C      XGRCORR5 - (P+Q12)EXP(T12)+T3|PHI> T3(12BODY)
C      XGRCORR6 - (P+Q12)EXP(T12)+T3|PHI> T3(EH-EP)
C      XGRCORR7 - (P+Q12)EXP(T12)+T3|PHI> T3(FH-FP)
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
C           /EOMWFE/ IS EOM-CCSD WAVEFUNCTION/ENERGY INFORMATION
C    IT IS SET IN PART IN EOMCC.SRC AND IN PART HERE, AND USED HEREIN.
C
C             100 - TOTAL NO. OF STATES IN ALL IRREPS, OK, SINCE WE
C                   LIMIT OURSELVES TO 8 IRREPS WITH 10 STATES EACH,
C                   WHICH EXPLAINS THE 80 IN THE SORTING CALLS.
C          EOMSDE - TABLE OF EOM-CCSD EXCITATION ENERGIES
C           EOMR0 - GROUND STATE AMPLITUDE (R0) IN EACH EOM-CCSD STATE
C          EOMR0L - SAME THING IN LEFT EIGENSTATE
C          XDELWB - UNKNOWN
C          XKKEOM - UNKNOWN
C        CRXXXXXX - RESULTS OF VARIOUS TRIPLES TERMS
C          KVGEOM - 0 FOR UNCONVERGED, 1 FOR CONVERGED EOM-CCSD STATES
C            IUST - INDEXES A SORTING PERMUTATION
C            IREL - FIRST INUMEOM ENTRIES SHOULD BE READ AS:
C  IREL(I)=J THE CLOSEST CISD VECTOR FOR I-TH EOMCCSD IS THE J-TH CISD.
C  IREL(J)=0 MEANS NO CISD HAS BEEN ATTRIBUTED TO A GIVEN J-TH EOMSD.
C  KKTRIM,KKTRIML - UNKNOWN
C         INUMEOM - NUMBER OF CONVERGED AND DISTINCT EOM-CCSD STATES,
C                   NAMELY IT DOES NOT INCLUDE THE GROUND STATE.
C         NTOTEOM - INPUT REQUESTED NUMBER OF EOM-CCSD STATES
C         NBADEOM - NUMBER OF EOM-CCSD STATES THAT ARE UNCONVERGED
C        NTOTCISD - NUMBER OF CISD STATES SOUGHT, NTOTEOM + 1 FOR G.S.
C        NCVGCISD - NUMBER OF CONVERGED CISD STATES FOUND
C         IVSYMAD - NUMBER OF EOM EXITED STATES REQUESTED, PLUS ONE MORE
C                   IN THE TOTALLY SYMMETRIC IRREP (THE GROUND STATE)
C          VECREP - STATE SYMMETRIES (CHARACTER*3 TYPE!)
C
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
      COMMON /FMCOM / XX(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,NFTJK,NFTJKT,IDAF,NAV,IODA(950)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /CCNEWL/ METHL
C
      IF (METHL.EQ.1) THEN
         WRITE(IW,9011)
      ELSE
         WRITE(IW,9010)
      ENDIF
C
      NO    = NCCOCC-NCCFZC
      NU    = NCCTOT-NCCFZV-NCCOCC
      NOA   = NOACT
      NUA   = NUACT
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
CCCX      NO3U  = NO*NO*NO*NU
CCCX      NU3   = NU*NU*NU
C
      NROOT = 0
      DO I=1,8
         NROOT = NROOT + NSTEOM(I)
      ENDDO
      INISTART = MTHINIT
      IHSPACE  = MICEOM
      ISPACE   = MTHEOM
      MAXITEOM = MAXEOM
      IF(IHSPACE.EQ.0) IHSPACE=MAXITEOM
C
      ICIMET   = MTHCI
      JCISPACE = MICCI
      IOPTMM   = MTHTRIP
C
C  R0-ZEROING
C
       DO I=1,10
          XNUM(I)=0.0D+00
          R0(I)=0.0D+00
          ENESD(I)=0.0D+00
          DI1(I)=0.0D+00
          DI2(I)=0.0D+00
          DI3(I)=0.0D+00
          DI4(I)=0.0D+00
          DI5(I)=0.0D+00
          DI6(I)=0.0D+00
          XM1(I)=0.0D+00
          XM2(I)=0.0D+00
          XM3(I)=0.0D+00
          XD1(I)=0.0D+00
          XD2(I)=0.0D+00
          XD3(I)=0.0D+00
          YD1(I)=0.0D+00
          YD2(I)=0.0D+00
          YD3(I)=0.0D+00
          YD4(I)=0.0D+00
          XNC3(I)=0.0D+00
          DC3(I)=0.0D+00
      ENDDO
C
C          OPEN FILES FOR CI STATES
C
      JCISD=   92
      JCISDNX= 93
      KCIF=    94
C
CCCX      LNU3=NU3
      LCISD=(1+NOU+NO2U2)
C
      CALL CCOPEN(JCISD  ,LCISD ,'MMCIVEC')
      CALL CCOPEN(JCISDNX,LCISD ,'MMCIVC1')
      CALL CCOPEN(KCIF   ,LCISD ,'MMCIITR')
C
C          OPEN THE OTHER FILES FOR MM(2,3)
C
      NEXM=   95
      NEXE=   96
      NREXM=  97
      NREXE=  98
C
CCCX      LNU3 = NU3
CCCX      LVM = NO3U
C
C FILES FOR INTERMEDIATES
C
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
CCCX      CALL CCOPEN(NEXM ,LVM   ,'MMNEXM')
CCCX      CALL CCOPEN(NEXE ,LNU3  ,'MMNEXE')
CCCX      CALL CCOPEN(NREXM,LVM   ,'MMNREXM')
CCCX      CALL CCOPEN(NREXE,LNU3  ,'MMNREXE')
C ----------------------------------------
C
C        OBTAIN OCCUPIED AND VIRTUAL EIGENVALUES
C
      CALL VALFM(LOADFM)
      LEH  = LOADFM + 1
      LEP  = LEH    + NO
      LAST = LEP    + NU
      NDEIG= LAST-LOADFM-1
      CALL GETFM(NDEIG)
C
      LWRK = LAST
      LAST = LWRK + NUM
      NEED = NUM
      CALL GETFM(NEED)
      CALL EOMEIG(XX(LEH),XX(LEP),XX(LAST),NUM,NO,NU,NCCFZC)
      CALL RETFM(NEED)
C
      IF(IOPTMM.GT.1) THEN
         CALL DRDIAGH(IW,EXETYP,INISTART,MAXCI,CVGCI,ESCF,NO,NU,
     *                XX(LEH),XX(LEP))
      END IF
C
C        GENERATE AND PRINT CISD-EOMCCSD VECTORS DIAGNOSTIC
C
      CALL DREOMCI(IW,EXETYP,NO,NU)
C
C        MAIN LOOP, START AT 0 TO DO GROUND STATE, TOO
C
      ISY=0
      BEST = 0.0D+00
      WRITE(IW,9020) INUMEOM+1
      DO 500 I=0,INUMEOM
C
         II = I
         WRITE(IW,9030) II
C
         XNUM(1)=0.0D+00
         XDENOM(1)=0.0D+00
         DI1(1)=0.0D+00
         DI2(1)=0.0D+00
         DI3(1)=0.0D+00
         DI4(1)=0.0D+00
         DI5(1)=0.0D+00
         DI6(1)=0.0D+00
         XM1(1)=0.0D+00
         XM2(1)=0.0D+00
         XM3(1)=0.0D+00
         XD1(1)=0.0D+00
         XD2(1)=0.0D+00
         XD3(1)=0.0D+00
         XNC3(1)=0.0D+00
         DC3(1)=0.0D+00
C
         CALL TSECND(T0)
         CALL DRINITR12(EXETYP,II,NO,NU)
         CALL DRXINTRI(IW,EXETYP,II,NO,NU)
         CALL DRXT3WT2(IW,ESCF,ECCSD,BEST,EXETYP,
     *                 II,NO,NU,XX(LEH),XX(LEP))
C
         IF(II.EQ.0) THEN
            IF(IROOTCC(2).EQ.0) BESTEOM=BEST
         ELSE
            IF(VECREP(IUST(II)).EQ.REP(IROOTCC(1))) THEN
               ISY=ISY+1
               IF(IROOTCC(2).EQ.ISY) BESTEOM=BEST
            END IF
         END IF
C
         CALL TSECND(T1)
         WRITE(IW,9040) T1-T0
  500 CONTINUE
C
C         PRINT RESULTS FOR THE MMCC(2,3) EXCITATION ENRGIES
C
      CALL WRITEEX(IW,IOPTMM)
      CALL WRITEEX1(IW,IOPTMM)
      CALL RETFM(NDEIG)
      RETURN
C
 9010 FORMAT(/1X,35(1H-),5X,21(1H-)/
     *        1X,'MMCC(2,3) METHOD OF MOMENTS PROGRAM',5X,
     *           'K.KOWALSKI, P.PIECUCH'/
     *        1X,35(1H-),5X,21(1H-))
 9011 FORMAT(/1X,18(1H-),5X,19(1H-)/
     *        1X,'CR-CC(2,3) PROGRAM',5X,
     *           'M. WLOCH, P.PIECUCH'/
     *        1X,18(1H-),5X,19(1H-))
 9020 FORMAT(/1X,'A TOTAL OF',I3,' STATES WILL BE TRIPLES CORRECTED')
 9030 FORMAT(/1X,'BEGINNING TRIPLES CORRECTION FOR STATE',I3)
 9040 FORMAT(1X,'CPU TIME FOR TRIPLES CORRECTION FOR THIS STATE=',F10.1)
      END
C
C*MODULE MM23    *DECK WRITEEX
      SUBROUTINE WRITEEX(IW,IOPTMM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 VECREP
C
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      DATA FEV/27.2113957D+00/
C
C        PRINT EXCITATION ENERGY RESULTS
C
      IF(INUMEOM.EQ.0) RETURN
C
      WRITE(IW,99) FEV
C
      IF(IOPTMM.EQ.2.OR.IOPTMM.EQ.4) THEN
        WRITE(IW,102)
        DO I=1,INUMEOM
         IF(CRCI3(I).NE.1000.0D+00) THEN
          WRITE(IW,103) VECREP(IUST(I)),EOMSDE(I)*FEV,CR1D1A(I)*FEV,
     &    CR2D1A(I)*FEV,CR1D1B(I)*FEV,CR2D1B(I)*FEV,CRCI3(I)*FEV,
     &    XDELWB(I)*FEV
         ELSE
          WRITE(IW,1103) VECREP(IUST(I)),EOMSDE(I)*FEV,CR1D1A(I)*FEV,
     &    CR2D1A(I)*FEV,CR1D1B(I)*FEV,CR2D1B(I)*FEV,XDELWB(I)*FEV
         END IF
        ENDDO
      END IF
C
 102  FORMAT(1X,'STATE    EOMCCSD ','  ID/IA ','    IID/IA ',
     &'   ID/IB ','    IID/IB ',
     &'   III  ','    (T)/R')
 103  FORMAT(3X,A3,2X,7(F7.3,3X))
 1103 FORMAT(3X,A3,2X,5(F7.3,3X),10X,F7.3,3X)
C
      IF(IOPTMM.EQ.1) THEN
        WRITE(IW,202)
        DO I=1,INUMEOM
         WRITE(IW,203) VECREP(IUST(I)),EOMSDE(I)*FEV,CR1D1A(I)*FEV,
     *                 CR2D1A(I)*FEV,CR1D1B(I)*FEV,CR2D1B(I)*FEV,
     *                 XDELWB(I)*FEV
        ENDDO
      END IF
C
 202  FORMAT(1X,'STATE  EOMCCSD ','    ID/IA ','     IID/IA ',
     *          '    ID/IB ','    IID/IB    (T)/R')
 203  FORMAT(3X,A3,1X,6(F7.3,4X))
C
      IF(IOPTMM.EQ.3) THEN
        WRITE(IW,302)
        DO 3 I=1,INUMEOM
         IF(CRCI3(I).NE.1000.0D+00) THEN
            WRITE(IW,303) VECREP(IUST(I)),EOMSDE(I)*FEV,CRCI3(I)*FEV
         ELSE
            WRITE(IW,1303) VECREP(IUST(I)),EOMSDE(I)*FEV
         END IF
  3     CONTINUE
      END IF
C
 302  FORMAT(17X,'STATE  EOMCCSD      III ')
 303  FORMAT(19X,A3,1X,2(F7.3,4X))
 1303 FORMAT(19X,A3,1X,F7.3,4X)
C
      RETURN
C
   99 FORMAT(/7X,'SUMMARY OF CR-EOMCCSD(T) RESULTS FOR ALL STATES'/
     *        7X,'EXCITATION ENERGIES IN EV, 1 H =',F10.6,' EV'/)
      END
C
C*MODULE MM23   *DECK WRITEEX1
      SUBROUTINE WRITEEX1(IW,IOPTMM)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      CHARACTER*3 VECREP
C
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      DATA FEV/27.2113957D+00/
C
C        PRINT EXCITATION ENERGY RESULTS
C
      IF(INUMEOM.EQ.0) RETURN
C
      WRITE(IW,100)
C
      IF(IOPTMM.EQ.2.OR.IOPTMM.EQ.4) THEN
        WRITE(IW,102)
        DO 1,I=1,INUMEOM
         IF(CREX3(I).NE.1000.0D+00) THEN
          WRITE(IW,103) VECREP(IUST(I)),EOMSDE(I)*FEV,CR1A(I)*FEV,
     &    CR1B(I)*FEV,CR1C(I)*FEV,CR1D(I)*FEV,CR2A(I)*FEV,
     &    CR2B(I)*FEV,CREX3(I)*FEV
          WRITE(IW,104) CR2C(I)*FEV,CR2D(I)*FEV
         ELSE
          WRITE(IW,103) VECREP(IUST(I)),EOMSDE(I)*FEV,CR1A(I)*FEV,
     &    CR1B(I)*FEV,CR1C(I)*FEV,CR1D(I)*FEV,CR2A(I)*FEV,
     &    CR2B(I)*FEV
          WRITE(IW,104) CR2C(I)*FEV,CR2D(I)*FEV
         END IF
 1      CONTINUE
      END IF
C
  102 FORMAT(3X,'STATE  EOMCCSD DEL(IA) DEL(IB) ',
     &          ' DEL(IC)  DEL(ID)  DEL(IIA) DEL(IIB) DEL(III)'/
     &      53X,'DEL(IIC) DEL(IID)')
  103 FORMAT(3X,A3,2X,8(F7.3,2X))
  104 FORMAT(53X,F7.3,2X,F7.3)
C
      IF(IOPTMM.EQ.1) THEN
        WRITE(IW,202)
        DO 2,I=1,INUMEOM
         WRITE(IW,203) VECREP(IUST(I)),EOMSDE(I)*FEV,CR1A(I)*FEV,
     &    CR1B(I)*FEV,CR1C(I)*FEV,CR1D(I)*FEV,CR2A(I)*FEV,
     &    CR2B(I)*FEV,CR2C(I)*FEV,CR2D(I)*FEV
 2      CONTINUE
      END IF
C
  202 FORMAT(3X,'STATE  EOMCCSD DEL(IA) DEL(IB) ',
     &          ' DEL(IC)  DEL(ID)  DEL(IIA) DEL(IIB)'  /
     &      53X,'DEL(IIC) DEL(IID)')
  203 FORMAT(3X,A3,2X,7(F7.3,2X)/53X,F7.3,2X,F7.3)
C
      IF(IOPTMM.EQ.3) THEN
        WRITE(IW,302)
        DO 3,I=1,INUMEOM
         IF(CREX3(I).NE.1000.0D+00) THEN
         WRITE(IW,303)VECREP(IUST(I)),EOMSDE(I)*FEV,CREX3(I)*FEV
         ELSE
         WRITE(IW,303)VECREP(IUST(I)),EOMSDE(I)*FEV
         END IF
  3     CONTINUE
      END IF
C
  302 FORMAT(17X,'STATE  EOMCCSD  DEL(III)')
  303 FORMAT(19X,A3,1X,2(F7.3,4X))
C
      WRITE(IW,110)
      RETURN
  100 FORMAT(/,7X,' EXCITATION ENERGIES (IN EV; 1 H = 27.2113957 EV)'/
     *       7X,'        DELTA-CR-EOMCCSD(T) METHODS'/)
  110 FORMAT(/7X,'IF DEGENERATE STATES OF DIFFERENT SYMMETRIES'/
     *       7X,'ARE CALCULATED IN A SINGLE EOM-CCSD RUN, ONLY ONE'/
     *       7X,'OF THESE TWO STATES WILL BE LISTED HERE; IN ORDER'/
     *       7X,'TO SEE THE CR-EOMCCSD(T) ENERGIES OF ALL DEGENERATE'/
     *       7X,'STATES, YOU MUST RUN CALCULATIONS FOR DIFFERENT'/
     *       7X,'SYMMETRIES SEPARATELY.')
      END
C
C       THIS WAS CC.F SOURCE FILE
C
C*MODULE MM23    *DECK DRINITR12
      SUBROUTINE DRINITR12(EXETYP,II,NO,NU)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /FMCOM / XX(1)
C
      DATA CHECK/8HCHECK   /
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU + NO2U2
      I3   = I2     + NOU
      LAST = I3     + NO2U2
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL ZEROMA(XX(I1),1,NEED)
      CALL INITR12(II,NO,NU,XX(I1),XX(I2),XX(I3))
C
  800 CONTINUE
      CALL RETFM(NEED)
      RETURN
      END
C
C*MODULE MM23    *DECK INITR12
      SUBROUTINE INITR12(II,NO,NU,ALL,R1,R2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 VECREP
C
      DIMENSION ALL(*),R1(*),R2(*)
C
      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 /EOMINF/ ISPACE,IHSPACE,JCISPACE,ICIMET,IOPTMM,
     *                NROOT,NOA,NUA,MAXITEOM
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
C
      IF(II.EQ.0) THEN
         R0(1)=1.0D+00
         ENESD(1)=0.0D+00
      ELSE
         R0(1)=EOMR0(II)
         ENESD(1)=EOMSDE(II)
      END IF
C
      LNOU=NOU+NO2U2
C
      IF(II.EQ.0) THEN
         DO J=1,NOU
           R1(J)=0.0D+00
         ENDDO
         DO J=1,NO2U2
           R2(J)=0.0D+00
         ENDDO
         CALL WRR1(NO,NU,R1)
         CALL WRR2(NO,NU,R2)
         GO TO 100
      ELSE
         IREOM=IUST(II)
         IF(ISPACE.NE.2) THEN
            CALL RCCFL(NAX,IREOM+2,LNOU,ALL)
         ELSE
            CALL RCCFL(NAX,IREOM,LNOU,ALL)
         END IF
         DO J=1,NOU
            R1(J)=ALL(J)
         ENDDO
         DO J=1,NO2U2
            R2(J)=ALL(J+NOU)
         ENDDO
         CALL WRR1(NO,NU,R1)
         CALL WRR2(NO,NU,R2)
      END IF
C
  100 CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK DREOMCI
      SUBROUTINE DREOMCI(IW,EXETYP,NO,NU)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      COMMON /FMCOM / XX(1)
C
      DATA CHECK/8HCHECK   /
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      IDIM  = 1+NOU+NO2U2
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1      = LOADFM  + 1
      I2      = I1      + IDIM   ! CISD VECTOR
      I3      = I2      + IDIM   ! EOMSD VECTOR
      I4      = I3      + NOU    ! T1 AMPLITUDES
      LDDOVER = I4      + NO2U2  ! T2 AMPLITUDES
      LAST    = LDDOVER + 100*100
      NEED = LAST - LOADFM - 1
C
      IF(NEED.GT.NGOTMX) THEN
        WRITE(IW,9010) NEED,NGOTMX
        CALL ABRT
      END IF
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 800
C
      CALL EOMCI(IW,NO,NU,IDIM,XX(I1),XX(I2),XX(I3),XX(I4),XX(LDDOVER))
C
  800 CONTINUE
      CALL RETFM(NEED)
      RETURN
C
 9010 FORMAT(1X,'*** MEMORY REQUIRED FOR EOM-CI-DIAGNOSTIC:',I12/
     *       1X,'AVAILABLE MEMORY IS JUST',I12)
      END
C
C*MODULE MM23    *DECK EOMCI
      SUBROUTINE EOMCI(IW,NO,NU,IDIM,XCISD,XEOMSD,T1,T2,DDOVER)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 VECREP,REP
C
      PARAMETER (MXAO=8192)
      PARAMETER (DTOL=0.60D+00)
C
      DIMENSION XCISD(IDIM),XEOMSD(IDIM),T1(*),T2(*),DDOVER(100,100)
      DIMENSION ISTACK(100),WORK(100)
C
      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 /EOMINF/ ISPACE,IHSPACE,JCISPACE,ICIMET,IOPTMM,
     *                NROOT,NOA,NUA,MAXITEOM
      COMMON /EOMPAR/ CVGCI,CVGEOM,GRPEOM,NSTEOM(8),NOACT,NUACT,
     *                MOACTCC(MXAO),MTHTRIP,MTHCI,MTHEOM,MTHINIT,
     *                MAXCI,MAXEOM,MICCI,MICEOM,IROOTCC(2),
     *                IPROPCC,IPROPCCE
      COMMON /EOMSYM/ IG,NRE(4),MC(8,8,4),ISORB(MXAO),REP(8)
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
C
      CTOL= CVGEOM
C
C FOR RCCFL PROCEDURE
C
      LNOU=NOU+NO2U2
C
C DDOVER  - OVERLAP MATRIX BETWEEN CISD AND EOMSD VECTORS
C
      DO I=1,100
        ISTACK(I) = 0
        IREL(I)=0
        DO J=1,100
          DDOVER(I,J)=0.0D+00
        ENDDO
      ENDDO
C
C WCZYTANIE ZBIORU Z R0,ENESD & LICZBA + UPORZADKOWANIE
C
      ILALL = NTOTEOM
C
C          ISAVE IS THE STATE WHOSE ENERGY WE WISH TO SAVE (0 IS G.S.)
C
      IF(ILALL.GT.0) WRITE(IW,9010)
      ISY=0
      DO I=1,ILALL
         WRITE(IW,9020) EOMSDE(I),EOMR0(I),VECREP(I)
         IF(VECREP(I).EQ.REP(IROOTCC(1))) THEN
            ISY=ISY+1
            IF(ISY.EQ.IROOTCC(2)) ISAVE = I
         END IF
      ENDDO
      IF(IROOTCC(2).EQ.0) ISAVE=0
C
      DO I=ILALL+1,100
         EOMSDE(I)=1000.0D+00+I*100.0D+00
      ENDDO
C
C  UNCONVERGED VECTORS ARE ELIMINATED
C
      DO IJK=1,ILALL
         IF(KVGEOM(IJK).EQ.0) EOMSDE(IJK)=6113.0D+00+IJK*100.0D+00
      ENDDO
C
C COUNTING THE NUMBER OF REPETITIONS OF THE EOMCCSD ROOTS
C
      IREP=0
      DO 103 I=1,ILALL-1
        DO 104 J=I+1,ILALL
          XXX=ABS(EOMSDE(I)-EOMSDE(J))
          IF(XXX.LT.CTOL) THEN
            IREP=IREP+1
            EOMSDE(J)=2000.0D+00+J*100.0D+00
C
C              IF J IS TO BE ELIMINATED BECAUSE IT IS DEGENERATE
C              WITH STATE I, WE MUST CHANGE -IROOTCC- TO HAVE THE
C              IRREP NUMBER -K- AND STATE -NST- OF STATE I ITSELF.
C
            IF(J.EQ.ISAVE) THEN
              IRT1=IROOTCC(1)
              IRT2=IROOTCC(2)
              DO K=1,NRE(IG)
                IF(VECREP(I).EQ.REP(K)) IROOTCC(1) = K
              ENDDO
              NST=0
              DO K=1,I
                IF(VECREP(I).EQ.VECREP(K)) NST=NST+1
              ENDDO
              IROOTCC(2) = NST
              WRITE(IW,9030) IRT1,IRT2,IROOTCC
            END IF
C
          END IF
 104    CONTINUE
 103  CONTINUE
C
C---  WRITE(IW,1)
C---  DO I=1,ILALL
C---     WRITE(IW,9020) EOMSDE(I),EOMR0(I),VECREP(I)
C---  ENDDO
C---1 FORMAT(1X,'EOM-CCSD ENERGIES AFTER SIFTING FOR DEGENERACIES')
C
C DUPLICATE ENERGIES AND UNCONVERGED VECTORS ARE ELIMINATED.
C NOTE THAT INUMEOM DOES NOT INCLUDE THE GROUND STATE ITSELF.
C
      INUMEOM = NTOTEOM - IREP - NBADEOM
C
C        N.B. AT THIS POINT THE ENERGIES ARE SORTED INTO ASCENDING ORDER
C        THE GROUND STATE AMPLITUDES -EOMR0- ARE REORDERED ACCORDINGLY,
C        BUT THE STATE SYMMETRIES -VECREP- AND CONVERGENCE FLAG -KVGEOM-
C        ARE NOT REORDERD (BUT THE REORDERING -IUST- IS SAVED TO REUSE)
C
      CALL INDEXX(ILALL,EOMSDE,IUST,80,ISTACK,100)
      CALL DCOPY(ILALL,EOMSDE,1,WORK,1)
      DO I=1,INUMEOM
        EOMSDE(I) = WORK(IUST(I))
      ENDDO
      CALL DCOPY(ILALL,EOMR0,1,WORK,1)
      DO I=1,INUMEOM
        EOMR0(I) = WORK(IUST(I))
      ENDDO
C
      IF(INUMEOM.GT.0) WRITE(IW,9040)
      DO I=1,INUMEOM
         WRITE(IW,9020) EOMSDE(I),EOMR0(I),VECREP(IUST(I))
      ENDDO
      CALL FLSHBF(IW)
C
      IF(IOPTMM.GT.1) THEN    ! CISD/EOMSD
C
      DO 2,I=1,NCVGCISD
      DO 3,J=1,INUMEOM+1
       IF(J.EQ.1) THEN
        CALL RCCFL(JCISD,I,IDIM,XCISD)
        CALL ZEROMA(XEOMSD,1,IDIM)
        XEOMSD(1)=1.0D+00
        CALL RO1(1,NO,NU,T1)
        CALL RO2(1,NO,NU,T2)
        CALL GLUE2(NO,NU,1.0D+00,T1,T2,XEOMSD(1+1),XEOMSD(1+NOU+1))
        CALL RO1(1,NO,NU,XEOMSD(1+1))
         ZEOM=1.0D+00
         ZEOM=ZEOM+C1HCN(NO,NU,XEOMSD(1+1))
         ZEOM=ZEOM+C2HCN(NO,NU,XEOMSD(1+NOU+1))
         ZEOM=(1.0D+00)/SQRT(ZEOM)
         CALL VECMUL(XEOMSD,IDIM,ZEOM)
        DDOVER(I,J)=DDOVER(I,J)+XCISD(1)*XEOMSD(1)
        DDOVER(I,J)=DDOVER(I,J)+C1HC(NO,NU,XCISD(1+1),XEOMSD(1+1))
        CALL GETC2HC(C2HC,NO,NU,XCISD(1+NOU+1),XEOMSD(1+NOU+1))
        DDOVER(I,J)=DDOVER(I,J)+C2HC
       ELSE
        CALL ZEROMA(XEOMSD,1,IDIM)
        CALL RCCFL(JCISD,I,IDIM,XCISD)
        XEOMSD(1)=EOMR0(J-1)
        CALL RO1(1,NO,NU,T1)
        CALL RO2(1,NO,NU,T2)
        IF(ISPACE.NE.2) THEN
        CALL RCCFL(NAX,IUST(J-1)+2,LNOU,XEOMSD(1+1))
        ELSE
        CALL RCCFL(NAX,IUST(J-1),LNOU,XEOMSD(1+1))
        END IF
        CALL VOOCP1(NO,NU,XEOMSD(1+1),T1,EOMR0(J-1))
        CALL GLUE2(NO,NU,EOMR0(J-1),T1,T2,XEOMSD(1+1),XEOMSD(1+NOU+1))
         ZEOM=EOMR0(J-1)*EOMR0(J-1)
         ZEOM=ZEOM+C1HCN(NO,NU,XEOMSD(1+1))
         ZEOM=ZEOM+C2HCN(NO,NU,XEOMSD(1+NOU+1))
         ZEOM=(1.0D+00)/SQRT(ZEOM)
         CALL VECMUL(XEOMSD,IDIM,ZEOM)
        DDOVER(I,J)=DDOVER(I,J)+XCISD(1)*XEOMSD(1)
        DDOVER(I,J)=DDOVER(I,J)+C1HC(NO,NU,XCISD(1+1),XEOMSD(1+1))
        CALL GETC2HC(C2HC,NO,NU,XCISD(1+NOU+1),XEOMSD(1+NOU+1))
        DDOVER(I,J)=DDOVER(I,J)+C2HC
       END IF
 3    CONTINUE
 2    CONTINUE
C
C MATRIX IREL
C
      UGR=ABS(DDOVER(1,1))
      IF(UGR.GT.DTOL) THEN
       DO 4,I=1,INUMEOM
          XMAX=0.0D+00
          IMAX=0
           DO 5,J=2,NTOTCISD
            XXX=ABS(DDOVER(J,I+1))
            IF(XXX.GT.XMAX) THEN
             XMAX=XXX
             IMAX=J
            END IF
 5         CONTINUE
          IF(XMAX.GT.DTOL) THEN
           IREL(I)=IMAX
          ELSE
           IREL(I)=0
          END IF
 4     CONTINUE
      ELSE
       WRITE(IW,9050)
      END IF
C
       WRITE(IW,9055)
       DO 477 IWS=1,INUMEOM
        IJKFF=IREL(IWS)
        IF(IJKFF.NE.0) THEN
          WRITE(IW,9060) IWS,VECREP(IUST(IWS)),IUST(IWS)+1,IREL(IWS)
        ELSE
          WRITE(IW,9070) IWS,VECREP(IUST(IWS)),IUST(IWS)+1
        END IF
 477   CONTINUE
C
      WRITE(IW,9080) INUMEOM+1
      CALL PRSQ(DDOVER,INUMEOM+1,NCVGCISD,100)
C
      END IF    !CISD / EOMSD
C
      CALL FLSHBF(IW)
      RETURN
C
 9010 FORMAT(/1X,'EOM-CCSD EXCITATION ENERGIES BEFORE ORDERING'/
     *       1X,'      ENERGY     R0 AMPLITUDE   SYMMETRY')
 9020 FORMAT(1X,F12.6,2X,F12.6,8X,A3)
 9030 FORMAT(/1X,'THE DESIRED STATE IROOT=',I2,',',I2,
     *          ' IS DEGENERATE WITH ANOTHER STATE,'/
     *       1X,'ENERGY WILL BE SAVED FOR ITS DEGENERATE STATE IROOT=',
     *          I2,',',I2,' INSTEAD.'/)
 9040 FORMAT(1X,'EOM-CCSD EXCITATION ENERGIES AFTER SORTING,',
     *          ' AND ELIMINATING ANY DEGENERACIES')
 9050 FORMAT(/1X,'THERE ARE PROBLEMS WITH THE MAPPING OF THE GROUND'/
     *        1X,'STATES OF THE CISD AND EOMSD METHODS')
 9055 FORMAT(3X,'EOM-CCSD STATE      -->   CISD STATE    MAPPINGS ARE'/
     *       3X,'SORTED    ORIG              ORIG')
 9060 FORMAT(1X,I4,1X,A3,3X,I4,'    ------>   ',I4)
 9070 FORMAT(1X,I4,1X,A3,3X,I4,'    ------>   ','CISD VECTOR NOT FOUND')
 9080 FORMAT(/1X,'OVERLAP MATRIX <CISD|EOMCCSD> BETWEEN STATES.'/
     *       1X,'CISD STATES ARE ROWS, GROUND STATE CCSD IS COLUMN 1'/
     *       1X,'REORDERED EOM-CCSD STATES ARE COLUMNS 2-',I3)
      END
C
C       THIS WAS HIRAO.F SOURCE FILE
C
C*MODULE MM23    *DECK DRDIAGH
      SUBROUTINE DRDIAGH(IW,EXETYP,INISTART,MAXCI,CVGCI,
     *                   ESCF,NO,NU,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION EH(NO),EP(NU)
C
      CHARACTER*3 VECREP
      CHARACTER*1 SMALLD
C
      COMMON /FMCOM / XX(1)
      COMMON /EOMINF/ ISPACE,IHSPACE,JCISPACE,ICIMET,IOPTMM,
     *                NROOT,NOA,NUA,MAXITEOM
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
C
      DATA CHECK/8HCHECK   /
C
C        LOWER CASE D IS 100 IN ASCII COLLATING SEQUENCE
C
      SMALLD=CHAR(100)
C
C     PERFORM INITIAL GUESS FOR THE CISD TO FOLLOW.
C     THIS MAY BE CIS,LITTLE-D (INISTART=1) OR CIS (INISTART=2)
C     ACTUALLY THE GUESS IS THE SAME, WITH CIS BRUTALLY TRUNCATING
C     THE RANGE OF 'ACTIVE' ORBITALS SO THERE'S NO DOUBLES.
C
      NO2   = NO*NO
      NO4   = NO*NO*NO*NO
      NU2   = NU*NU
      NU3   = NU*NU*NU
      NOU   = NO*NU
      NO3U  = NO*NO*NO*NU
      NOU3  = NO*NU*NU*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL TSECND(T0)
      IF(INISTART.NE.1  .AND.  INISTART.NE.2) INISTART=1
      IF(INISTART.EQ.2) THEN
        NOA=1
        NUA=1
      END IF
C
      IF(INISTART.EQ.1) THEN
         WRITE(IW,9010) SMALLD,NOA,NUA
      ELSE
         WRITE(IW,9020)
      END IF
C
      IDIM=NO*NU+NOA*NOA*NUA*NUA+1
      IDIM2=IDIM*IDIM
      IDIX=NOA*NOA*NUA*NUA
C
      CALL VALFM(LOADFM)
      I1     = LOADFM + 1
      I2     = I1     + NO2                ! FHH(I1)
      I3     = I2     + NU2                ! FPP(I2)
      I4     = I3     + NOU                ! FHP(I3)
      I5     = I4     + NO4                ! HHHH(I4)
      I6     = I5     + NO3U               ! HHHP(I5)
      I7     = I6     + NO2U2              ! HPPH(I6)
      I8     = I7     + NOU3               ! PPPH(I7)
      I9     = I8     + NU3                ! VPPP(I8)
      I10    = I9     + 1+NOU+NO2U2        ! TRANS(I9)
      I11    = I10    + IDIM2              ! HM(I10)
      I12    = I11    + IDIM               ! WR(I11)
      I13    = I12    + IDIM               ! WI(I12)
      I14    = I13    + IDIM2              ! VR(I13)
      I15    = I14    + 4*IDIM             ! WORK(I14)
      I16    = I15    + 2*NOU              ! IPL1(I15)    -INT. MATRIX
      I17    = I16    + (4*IDIX)/NWDVAR +1 ! IPL2(I16)    -INT. MATRIX
      I18    = I17    + NOU                ! INDEX1(I17)  -INT. MATRIX
      I20    = I18    + NO2U2/NWDVAR +1    ! INDEX2(I18)  -INT. MATRIX
      LAST   = I20    + NO+NU              ! IACTIVE(I20) -INT. MATRIX
      NEED = LAST - LOADFM -1
C
      WRITE(IW,9030) NEED
      CALL FLSHBF(IW)
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 100
C
      CALL CIINIT(NO,NU,NOA,NUA,XX(I1),XX(I2),XX(I3),XX(I4),
     *            XX(I5),XX(I6),XX(I7),XX(I8),XX(I9),XX(I10),
     *            XX(I11),XX(I12),XX(I13),XX(I14),XX(I15),
     *            XX(I16),XX(I17),XX(I18),XX(I20),
     *            EH,EP,INISTART)
C
  100 CONTINUE
      CALL RETFM(NEED)
C
      CALL TSECND(T1)
      TIME = T1-T0
      WRITE(IW,9040) TIME
      T0 = T1
C
C        CISD SOLVER METHOD NUMBER 1...ONE STATE AT A TIME
C
      IF(ICIMET.EQ.1) THEN
      WRITE(IW,9050) JCISPACE,CVGCI,NTOTCISD
      TOL = CVGCI
      IDIM=1+NOU+NO2U2
      NCVGCISD=0
C
      CALL VALFM(LOADFM)
      I1  = LOADFM + 1
      I2  = I1     + 3*IDIM             ! C-MATRIX
      I3  = I2     + JCISPACE*JCISPACE  ! AT-MATRIX
      I4  = I3     + JCISPACE           ! WR-VEC
      I5  = I4     + JCISPACE           ! WI-VEC
      I6  = I5     + JCISPACE*JCISPACE  ! VL-MATRIX
      I7  = I6     + JCISPACE*JCISPACE  ! VR-MATRIX
      I8  = I7     + JCISPACE*4         ! WORK
      I9  = I8     + NOU                ! FHP
      I10 = I9     + NO2                ! FHH
      I11 = I10    + NU2                ! FPP
      I12 = I11    + NO4                ! VHHHH
      I13 = I12    + NO3U               ! VHHHP
      I14 = I13    + NO2U2              ! VHPPH
      I15 = I14    + NOU3               ! VPPPH
      I16 = I15    + NO2U2              ! AUX2
      I17 = I16    + NU3                ! TI
      I18 = I17    + 2*NU2              ! HAPP
      I19 = I18    + 2*NO2              ! HAHH
      I20 = I19    + 2*NOU              ! HAHP
      LAST= I20    + JCISPACE*JCISPACE  ! ATAUX
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9060) NEED
      CALL FLSHBF(IW)
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 200
C
      DO IJK=1,NTOTCISD
         IJKDUM = IJK
         CALL ZEROMA(XX(I1),1,NEED)
         CALL DIAGS(IW,NO,NU,JCISPACE,IDIM,TOL,MAXCI,
     *              XX(I1),XX(I2),XX(I3),XX(I4),XX(I5),XX(I6),
     *              XX(I7),XX(I8),XX(I9),XX(I10),XX(I11),XX(I12),
     *              XX(I13),XX(I14),XX(I15),XX(I16),XX(I17),
     *              XX(I18),XX(I19),XX(I20),EH,EP,ESCF,IJKDUM)
      ENDDO
C
  200 CONTINUE
      CALL RETFM(NEED)
      END IF
C
C        CISD SOLVER METHOD NUMBER 2:
C        MULTIROOT, MULTIDIMENSIONAL ITERATIVE SPACE
C
      IF(ICIMET.EQ.2) THEN
C
      ICONT=0
      IF(JCISPACE.LE.1) THEN
         JCISPACE=3
         WRITE(IW,*) 'DIMENSION OF THE ITERATIVE SPACE HAS BEEN'
         WRITE(IW,*) 'CHANGED TO 3!!!'
      END IF
      IF(JCISPACE.EQ.2) THEN
         JCISPACE=3
         WRITE(IW,*) 'DIMENSION OF THE ITERATIVE SPACE HAS BEEN'
         WRITE(IW,*) 'CHANGED FROM 2 TO 3!!!'
      END IF
C
      TOL = CVGCI
      NC=JCISPACE      !MICROCYCLE LENGTH
      IDIM=1+NOU+NO2U2
C
      NCVGCISD=0
C
      IF(IVSYMAD(1).EQ.1) THEN
         KLOOP=2
      ELSE
         KLOOP=1
      END IF
C
C MAIN CISD LOOP - ALL ROOTS TOGETHER
C
      DO 350 IDP=1,KLOOP
         IDIM=1+NOU+NO2U2
         IF(IVSYMAD(1).GT.1) THEN
            NROOT=NTOTCISD
         ELSE
            IF(IDP.EQ.1) THEN
               NROOT=1
            ELSE
               NROOT=NTOTCISD-1
            END IF
         END IF
         ISH=NC*NROOT
         NSTACK = 10*ISH
         NWORK = 4*ISH
C
         WRITE(IW,9070) NC,CVGCI,NROOT
C
         CALL VALFM(LOADFM)
         I1   = LOADFM + 1
         I2   = I1     + NROOT        ! EIGENVAL MATRIX
         I3   = I2     + IDIM*ISH     ! B MATRIX
         I4   = I3     + ISH*ISH      ! AT MATRIX
         I6   = I4     + ISH          ! ATEIG MATRIX
         I7   = I6     + ISH*ISH      ! C MATRIX
         I8   = I7     + IDIM         ! SORTH MATRIX
C
C DGEEV-TYPE MATRICES
C
         I9   = I8     + ISH          ! WR MATRIX
         I10  = I9     + ISH          ! WI MATRIX
         I11  = I10    + ISH*ISH      ! VL MATRIX
         I12  = I11    + ISH*ISH      ! VR MATRIX
         I13  = I12    + NWORK        ! WORK MATRIX
C
C MATRICES USED BY PROCEDURES HC0,HC1,HC2
C
         I14  = I13    + NOU          ! FHP
         I15  = I14    + NO2          ! FHH
         I16  = I15    + NU2          ! FPP
         I17  = I16    + NO4          ! VHHHH
         I18  = I17    + NO3U         ! VHHHP
         I19  = I18    + NO2U2        ! VHPPH
         I20  = I19    + NOU3         ! VPPPH
         I21  = I20    + NO2U2        ! AUX2
         I22  = I21    + NU3          ! TI
         I23  = I22    + ISH*ISH      ! ATAUX
C
C SORTING MATRIX
C
         LAST = I23    + NSTACK       ! ISTACK
         NEED = LAST - LOADFM - 1
C
         WRITE(IW,9080) NEED
         CALL FLSHBF(IW)
         CALL GETFM(NEED)
C
         IF(EXETYP.EQ.CHECK) GO TO 300
C
         CALL ZEROMA(XX(I1),1,NEED)
         CALL DIAGHNN(IW,NO,NU,IDIM,XX(I1),TOL,NROOT,NC,MAXCI,
     *                XX(I2),XX(I3),XX(I4),XX(I6),XX(I7),
     *                XX(I8),XX(I9),XX(I10),XX(I11),XX(I12),XX(I13),
     *                XX(I14),XX(I15),XX(I16),XX(I17),XX(I18),
     *                XX(I19),XX(I20),XX(I21),XX(I22),EH,EP,ESCF,IDP,
     *                XX(I23),NSTACK,NWORK,ISH,ICONT,INISTART)
C
  300    CONTINUE
         CALL RETFM(NEED)
  350 CONTINUE
      END IF
      CALL TSECND(T1)
      TIME = T1-T0
      WRITE(IW,9090) TIME
      RETURN
C
 9010 FORMAT(/1X,'INITIAL VECTORS FOR CISD ARE GENERATED BY',
     *           ' THE CIS',A1,' METHOD'/
     *        1X,'ACTIVE ORBITALS FOR DOUBLES ARE OCC=',I4,' VIRT=',I4)
 9020 FORMAT(/1X,'INITIAL VECTORS FOR CISD ARE GENERATED BY',
     *           ' THE CIS METHOD')
 9030 FORMAT(1X,'MEMORY FOR INITIAL GUESS CI IS',I10,' WORDS')
 9040 FORMAT(1X,'CPU TIME FOR INITIAL GUESS OF CI STATES IS',F10.1)
C
 9050 FORMAT(/1X,'CHOOSING ONE ROOT AT A TIME CISD SOLVER (MCI=1) ...'/
     *       5X,'DIMENSION OF CISD ITERATIVE SPACE:',I4/
     *       5X,'            CONVERGENCE THRESHOLD:',1P,E10.2/
     *       5X,' NUMBER OF CISD ROOTS TO BE FOUND:',I4)
 9060 FORMAT(1X,'CISD METHOD 1 MEMORY NEEDED IS',I10,' WORDS'/)
 9070 FORMAT(/1X,'CHOOSING MULTIROOT CISD SOLVER (MCI=2) ...'/
     *       5X,'DIMENSION OF CISD ITERATIVE SPACE:',I4/
     *       5X,'            CONVERGENCE THRESHOLD:',1P,E10.2/
     *       5X,' NUMBER OF CISD ROOTS TO BE FOUND:',I4)
 9080 FORMAT(1X,'CISD METHOD 2 MEMORY NEEDED IS',I10,' WORDS'/)
 9090 FORMAT(1X,'CPU TIME TO GENERATE CISD STATES IS',F10.1)
      END
C
C*MODULE MM23    *DECK MMNORM
      SUBROUTINE MMNORM(Q,ZNORM,IDIM,NROOT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION Q(IDIM,NROOT)
C
      ZNORM=0.0D+00
      DO 1,I=1,IDIM
      DO 2,J=1,NROOT
       ZNORM=ZNORM+Q(I,J)*Q(I,J)
 2    CONTINUE
 1    CONTINUE
      ZNORM=SQRT(ZNORM)
      RETURN
      END
C
C*MODULE MM23    *DECK MVALVEC
      SUBROUTINE MVALVEC(IDIM,A,B,EIG)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(IDIM),B(IDIM)
C
      DO 1,I=1,IDIM
       A(I)=A(I)-EIG*B(I)
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK DENDIV0
      SUBROUTINE DENDIV0(Q,EIG)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(SHIFT=-0.10D+00,TOL=1.0D-10)
      XXX=ABS(EIG)
      IF(XXX.GT.TOL) THEN
       Q=Q/EIG
      ELSE
       Q=Q/(EIG+SHIFT)
      END IF
      RETURN
      END
C
C*MODULE MM23    *DECK DENDIV1
      SUBROUTINE DENDIV1(NO,NU,Q,EIG,EH,EP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION EH(NO),EP(NU),Q(NO,NU)
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
       XDEN=EIG+EH(I)-EP(IA)
        Q(I,IA)=Q(I,IA)/XDEN
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK DENDIV2
      SUBROUTINE DENDIV2(NO,NU,Q,EIG,EH,EP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION Q(NO,NU,NU,NO),EH(NO),EP(NU)
C
      DO 1 I=1,NO
      DO 2 J=1,NO
      DO 3 IA=1,NU
      DO 4 IB=1,NU
       XDEN=EIG+EH(I)+EH(J)-EP(IA)-EP(IB)
       Q(I,IA,IB,J)=Q(I,IA,IB,J)/XDEN
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK GLUE2
      SUBROUTINE GLUE2(NO,NU,R0,C1,C2,R1,W2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION C1(NO,NU),C2(NO,NU,NU,NO),
     *          R1(NO,NU),W2(NO,NU,NU,NO)
C
      DO 1,I=1,NO
      DO 2,J=1,NO
      DO 3,IA=1,NU
      DO 4,IB=1,NU
       W2(I,IA,IB,J)=W2(I,IA,IB,J)+R0*(C1(I,IA)*C1(J,IB)+C2(I,IA,IB,J))
     &              +C1(I,IA)*R1(J,IB)+C1(J,IB)*R1(I,IA)
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK HC0
      SUBROUTINE HC0(NO,NU,C1,C2,HC0V,FHP,VHPPH,TI)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION C1(*),C2(*),FHP(*),VHPPH(*),TI(*)
C
      DATA ZERO/0.0D+00/, TWO/2.0D+00/
C
      NOU = NO*NU
      NO2U2 = NO*NO*NU*NU
C
      HC0V=ZERO
      CALL XRF(NO,NU,FHP)
      HC0V=HC0V+TWO*DDOT(NOU,FHP,1,C1,1)
      CALL RO2HPP(1,NO,NU,TI,VHPPH)
      HC0V=HC0V+TWO*DDOT(NO2U2,C2,1,VHPPH,1)
      CALL TRANMD(VHPPH,NO,NU,NU,NO,23)
      HC0V=HC0V-DDOT(NO2U2,C2,1,VHPPH,1)
      RETURN
      END
C
C*MODULE MM23    *DECK HC1
      SUBROUTINE HC1(NO,NU,C0,C1,C2,HC1V,FHP,FHH,FPP,VHPPH,VHHHP,
     &               VPPPH,TI,EH,EP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION C1(*),C2(*),HC1V(*),FHP(*),FHH(*),FPP(*),
     *          VHPPH(*),VHHHP(*),VPPPH(*),TI(*),EH(NO),EP(NU)
C
      DATA ONE/1.0D+00/, OM/-1.0D+00/, TWO/2.0D+00/
C
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
C
      CALL ZEROMA(HC1V,1,NOU)
      CALL XRF(NO,NU,FHP)
      CALL VOOCP1(NO,NU,HC1V,FHP,C0)
C DIAG. A - C0*FHP
C DIAG. FOCK-MATRIX ELEM (EP-EH)C1 DIAG.L
      CALL EHPDIAG1(NO,NU,HC1V,C1,EH,EP)
C
      CALL RO2HPP(1,NO,NU,TI,VHPPH)
      CALL TRT1(NO,NU,TI,C1)   !=>C1(NU,NO)
C DIAG B
      CALL DGEMM('N','N',NOU,1,NOU,TWO,VHPPH,NOU,C1,NOU,ONE,HC1V,NOU)
      CALL RO2HPP(2,NO,NU,TI,VHPPH)
C DIAG C
      CALL DGEMM('N','N',NOU,1,NOU,OM,VHPPH,NOU,C1,NOU,ONE,HC1V,NOU)
C DIAG J
      CALL RFHH(NO,NU,FHH)
      CALL TRT1(NU,NO,TI,C1)    !=>C1(NO,NU)
      CALL DGEMM('N','N',NO,NU,NO,OM,FHH,NO,C1,NO,ONE,HC1V,NOU)
C
      CALL TRT1(NO,NU,TI,HC1V)  !=>HC1V(NU,NO)
C DIAG K
      CALL RFPP(NO,NU,FPP)
      CALL TRT1(NO,NU,TI,C1)    !=>C1(NU,NO)
      CALL DGEMM('N','N',NU,NO,NU,ONE,FPP,NU,C1,NU,ONE,HC1V,NU)
      CALL TRT1(NU,NO,TI,C1)    !=>C1(NO,NU)
C DIAG H+I
      CALL SYMT21(C2,NO,NU,NU,NO,23) !C2(IABJ)=2C_{IJ}^{AB}-C_{IJ}^{BA}
      CALL DGEMM('N','N',1,NOU,NOU,ONE,FHP,1,C2,NOU,ONE,HC1V,1)
      CALL DESM21(C2,NO,NU,NU,NO,23) !C2(IABJ)=C_{IJ}^{AB}
C
      CALL RDVEM4(0,NO,NU,TI,VPPPH)
      CALL SYMT21(VPPPH,NU,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,C2,13) !C2(ABIJ)=C_{IJ}^{BA}
C DIAG D+E
      CALL DGEMM('N','N',NU,NO,NOU2,ONE,VPPPH,NU,C2,NOU2,ONE,HC1V,NU)
      CALL INSITU(NU,NU,NO,NO,TI,C2,13) !C2(IABJ)=C_{IJ}^{AB}
      CALL TRT1(NU,NO,TI,HC1V)               !=>HC1V(NO,NU)
      CALL RDVEM4(1,NU,NO,TI,VHHHP)
      CALL SYMT21(VHHHP,NO,NO,NO,NU,23)
      CALL TRANSQ(C2,NOU)  !C2(AIJB)=C_{JI}^{BA}=C_{IJ}^{AB}
      CALL INSITU(NU,NO,NO,NU,TI,C2,13) !C2(IJAB)=C_{IJ}^{BA}
C DIAG F+G
      CALL DGEMM('N','N',NO,NU,NO2U,OM,VHHHP,NO,C2,NO2U,ONE,HC1V,NO)
      CALL INSITU(NO,NO,NU,NU,TI,C2,13) !C2(AIJB)=C_{IJ}^{AB}
      CALL TRANSQ(C2,NOU)      !C2(IABJ)=C_{JI}^{BA}=C_{IJ}^{AB}
C
      RETURN
      END
C
C*MODULE MM23    *DECK HC2
      SUBROUTINE HC2(NO,NU,C0,C1,C2,HC2V,FHP,FHH,FPP,VHHHH,VHHHP,
     &               VHPPH,VPPPH,AUX2,TI,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION C1(*),C2(*),HC2V(*),FHP(*),FHH(*),FPP(*),VHHHH(*),
     *          VHHHP(*),VHPPH(*),VPPPH(*),TI(*),EH(NO),EP(NU),
     *          AUX2(*)
C
      DATA ZERO/0.0D+00/,HALF/0.5D+00/,ONE/1.0D+00/,OM/-1.0D+00/
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL ZEROMA(HC2V,1,NO2U2)
      CALL ZEROMA(AUX2,1,NO2U2)
C DIAG L+K
      CALL RFHH(NO,NU,FHH)
      CALL RFPP(NO,NU,FPP)
      CALL DGEMM('N','N',NO,NOU2,NO,OM,FHH,NO,C2,NO,ONE,HC2V,NO)
      CALL INSITU(NO,NU,NU,NO,TI,C2,12) !C2(AIBJ)=C_{IJ}^{AB}
      CALL DGEMM('N','N',NU,NO2U,NU,ONE,FPP,NU,C2,NU,ZERO,AUX2,NU)
      CALL INSITU(NU,NO,NU,NO,TI,AUX2,12)
      CALL VOOCP2(NO,NU,HC2V,AUX2,ONE)
      CALL INSITU(NU,NO,NU,NO,TI,C2,12)!C2(IABJ)=C_{IJ}^{AB}
C
      CALL TRT1(NO,NU,TI,C1)       !=>C1(NU,NO)
      CALL XRF(NO,NU,FHP)
      CALL DGEMM('N','N',NOU,NOU,1,ONE,FHP,NOU,C1,1,ONE,HC2V,NOU)
      CALL RDVEM4(1,NU,NO,TI,VHHHP)
      CALL DGEMM('N','N',NU,NO2U,NO,OM,C1,NU,VHHHP,NO,ZERO,AUX2,NU)
      CALL TRANSQ(AUX2,NOU)
      CALL TRANMD(AUX2,NO,NU,NU,NO,23)
      CALL TRANMD(AUX2,NO,NU,NU,NO,14)
      CALL VOOCP2(NO,NU,HC2V,AUX2,ONE)
      CALL TRT1(NU,NO,TI,C1)       !=>C1(NO,NU)
      CALL RDVEM4(0,NO,NU,TI,VPPPH)
      CALL DGEMM('N','N',NO,NOU2,NU,ONE,C1,NO,VPPPH,NU,ONE,HC2V,NO)
C DIAG G+H
      CALL RO2HPP(1,NO,NU,TI,VHPPH)
      CALL TRANSQ(VHPPH,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VHPPH,12)
      CALL SYMT21(C2,NO,NU,NU,NO,14)!C2(IABJ)=2C_{IJ}^{AB}-C_{JI}^{AB}
      CALL DGEMM('N','N',NOU,NOU,NOU,ONE,VHPPH,NOU,C2,NOU,ONE,HC2V,NOU)
      CALL DESM21(C2,NO,NU,NU,NO,14)!C2(IABJ)=C_{IJ}^{AB}
C DIAG J
      CALL RO2HPP(2,NO,NU,TI,VHPPH)
      CALL TRANSQ(VHPPH,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VHPPH,12)
      CALL DGEMM('N','N',NOU,NOU,NOU,OM,VHPPH,NOU,C2,NOU,ONE,HC2V,NOU)
C DIAG I
      CALL TRANMD(C2,NO,NU,NU,NO,23)!C2(I,A,B,J)=C_{IJ}^{BA}
      CALL DGEMM('N','N',NOU,NOU,NOU,OM,VHPPH,NOU,C2,NOU,ZERO,AUX2,NOU)
      CALL TRANMD(AUX2,NO,NU,NU,NO,14)
      CALL VOOCP2(NO,NU,HC2V,AUX2,ONE)
      CALL TRANMD(C2,NO,NU,NU,NO,23)!C2(IABJ)=C_{IJ}^{AB}
C DIAG E(HHHH)+F(PPPP)
      CALL RDOV4(1,NU,NO,TI,VHHHH)
      CALL TRANSQ(C2,NOU) !C2(A,I,J,B)=C2_{JI}^{BA}=C2_{IJ}^{AB}
      CALL INSITU(NU,NO,NO,NU,TI,C2,13) !C2(I,J,A,B)=C2_{JI}^{AB}
      CALL TRANMD(C2,NO,NO,NU,NU,34) !C2(I,J,A,B)=C2_{IJ}^{AB}
      CALL DGEMM('N','N',NO2,NU2,NO2,HALF,VHHHH,
     *           NO2,C2,NO2,ZERO,AUX2,NO2)
      CALL INSITU(NO,NO,NU,NU,TI,AUX2,13)
      CALL TRANSQ(AUX2,NOU)
      CALL TRANMD(AUX2,NO,NU,NU,NO,23)
      CALL VOOCP2(NO,NU,HC2V,AUX2,ONE)
      CALL ZEROMA(AUX2,1,NO2U2)
C
      CALL VIRT4(NO,NU,C2,TI,AUX2)
C      DO 1,I=1,NU
C       CALL RDVPP(I,NO,NU,TI)
C       CALL DGEMM('N','N',NO2,NU,NU2,HALF,C2,NO2,TI,NU2,ONE,
C     &            AUX2(1,1,1,I),NO2)
C 1    CONTINUE
C
C
      CALL INSITU(NO,NO,NU,NU,TI,AUX2,13)
      CALL TRANSQ(AUX2,NOU)
      CALL TRANMD(AUX2,NO,NU,NU,NO,23)
      CALL VOOCP2(NO,NU,HC2V,AUX2,ONE)
C
C C2 DO WEJSCIOWEJ POSTACI
      CALL TRANMD(C2,NO,NO,NU,NU,34)
      CALL INSITU(NO,NO,NU,NU,TI,C2,13)
      CALL TRANSQ(C2,NOU)
C SYMETRYZACJA
      CALL SYMETR(HC2V,NO,NU)
C
      CALL EHPDIAG2(NO,NU,HC2V,C2,EH,EP)
      CALL RO2HPP(1,NO,NU,TI,VHPPH)
      CALL VOOCP2(NO,NU,HC2V,VHPPH,C0)
      RETURN
      END
C
C*MODULE MM23    *DECK VIRT4
      SUBROUTINE VIRT4(NO,NU,C2,TI,AUX2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION C2(NO,NO,NU,NU),TI(NU,NU,NU),AUX2(NO,NO,NU,NU)
C
      DATA HALF/0.5D+00/, ONE/1.0D+00/
C
      NO2   = NO*NO
      NU2   = NU*NU
C
      DO I=1,NU
         CALL RDVPP(I,NO,NU,TI)
         CALL DGEMM('N','N',NO2,NU,NU2,HALF,C2,NO2,TI,NU2,ONE,
     *               AUX2(1,1,1,I),NO2)
      ENDDO
      RETURN
      END
C
C*MODULE MM23    *DECK EHPDIAG1
      SUBROUTINE EHPDIAG1(NO,NU,HC1V,C1,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION HC1V(NO,NU),C1(NO,NU),EH(NO),EP(NU)
C
      DO 1,I=1,NO
      DO 1,IA=1,NU
       DE0=EP(IA)-EH(I)
       HC1V(I,IA)=HC1V(I,IA)+DE0*C1(I,IA)
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK EHPDIAG2
      SUBROUTINE EHPDIAG2(NO,NU,HC2V,C2,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION HC2V(NO,NU,NU,NO),C2(NO,NU,NU,NO),EH(NO),EP(NU)
C
      DO 1,I=1,NO
      DO 1,J=1,NO
      DO 1,IA=1,NU
      DO 1,IB=1,NU
       DE0=EP(IA)+EP(IB)-EH(I)-EH(J)
       HC2V(I,IA,IB,J)=HC2V(I,IA,IB,J)+DE0*C2(I,IA,IB,J)
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK VOOCP1
      SUBROUTINE VOOCP1(NO,NU,HC1V,FHP,C0)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION HC1V(NO,NU),FHP(NO,NU)
C
      DO 1,I=1,NO
      DO 1,IA=1,NU
       HC1V(I,IA)=HC1V(I,IA)+C0*FHP(I,IA)
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK VOOCP2
      SUBROUTINE VOOCP2(NO,NU,HC2V,VHPPH,C0)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION HC2V(NO,NU,NU,NO),VHPPH(NO,NU,NU,NO)
C
       DO 1,I=1,NO
       DO 1,J=1,NO
       DO 1,IA=1,NU
       DO 1,IB=1,NU
        HC2V(I,IA,IB,J)=HC2V(I,IA,IB,J)+C0*VHPPH(I,IA,IB,J)
 1     CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK VOOCPX
      SUBROUTINE VOOCPX(IDIM,HC2V,VHPPH,C0)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION HC2V(IDIM),VHPPH(IDIM)
C
       DO 1,I=1,IDIM
        HC2V(I)=HC2V(I)+C0*VHPPH(I)
 1     CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK C1HC
      DOUBLE PRECISION FUNCTION C1HC(NO,NU,B,HC1V)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION B(*),HC1V(*)
C
      DATA TWO/2.0D+00/
C
      NOU = NO*NU
      C1HC=0.0D+00
      C1HC=C1HC+TWO*DDOT(NOU,B,1,HC1V,1)
      RETURN
      END
C
C*MODULE MM23    *DECK C2HC
      SUBROUTINE GETC2HC(C2HC,NO,NU,B,HC2V)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION B(*),HC2V(*)
C
      DATA TWO/2.0D+00/
C
      NO2U2 = NO*NO*NU*NU
C
      C2HC=0.0D+00
      C2HC=C2HC+TWO*DDOT(NO2U2,HC2V,1,B,1)
      CALL TRANMD(B,NO,NU,NU,NO,23)
      C2HC=C2HC-DDOT(NO2U2,HC2V,1,B,1)
      CALL TRANMD(B,NO,NU,NU,NO,23)
      RETURN
      END
C
C*MODULE MM23    *DECK C1HCN
      DOUBLE PRECISION FUNCTION C1HCN(NO,NU,B)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION B(NO,NU)
C
      DATA TWO/2.0D+00/
C
      C1HCN=0.0D+00
      DO 1,I=1,NO
      DO 1,IA=1,NU
       C1HCN=C1HCN+TWO*B(I,IA)*B(I,IA)
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK C2HCN
      DOUBLE PRECISION FUNCTION C2HCN(NO,NU,B)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION B(NO,NU,NU,NO)
C
      DATA TWO/2.0D+00/
C
      C2HCN=0.0D+00
      DO 1 I=1,NO
      DO 1 J=1,NO
      DO 1 IA=1,NU
      DO 1 IB=1,NU
       C2HCN=C2HCN+(TWO*B(I,IA,IB,J)-B(I,IB,IA,J))*B(I,IA,IB,J)
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK DENDIV0NN
      SUBROUTINE DENDIV0NN(EPSI,EIG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      EPSI=EPSI/EIG
      RETURN
      END
C
C*MODULE MM23    *DECK DENDIV1NN
      SUBROUTINE DENDIV1NN(NO,NU,EPSI,EIG,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION EH(NO),EP(NU),EPSI(NO,NU)
CCC      DIMENSION HAHP(NO,NU,2)
C
      DO 1,I=1,NO
      DO 2,IA=1,NU
CCC       XDEN=EIG+EH(I)-EP(IA)-(2.0D+00)*HAHP(I,IA,2)+HAHP(I,IA,1)
        XDEN=EIG+EH(I)-EP(IA)
        EPSI(I,IA)=EPSI(I,IA)/XDEN
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK DENDIV2NN
      SUBROUTINE DENDIV2NN(NO,NU,EPSI,EIG,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION EPSI(NO,NU,NU,NO),EH(NO),EP(NU)
CCC      DIMENSION HAHH(NO,NU,2),HAHP(NO,NU,2),HAPP(NU,NU,2)
C
      DO 1,I=1,NO
      DO 2,J=1,NO
      DO 3,IA=1,NU
      DO 4,IB=1,NU
CCC       XDEN=EIG+EH(I)+EH(J)-EP(IA)-EP(IB)-HAHH(I,J,1)-HAPP(IA,IB,1)
CCC     & -(2.0D+00)*(HAHP(I,IA,2)+HAHP(J,IB,2))
CCC     & +HAHP(I,IB,1)+HAHP(J,IA,1)
CCC     & +HAHP(I,IA,1)+HAHP(J,IB,1)
CCC       IF(I.EQ.J.AND.IA.NE.IB) THEN
CCC         XDEN=XDEN+HAHP(I,IB,2)+HAHP(I,IA,2)
CCC       END IF
CCC       IF(I.NE.J.AND.IA.EQ.IB) THEN
CCC         XDEN=XDEN+HAHP(I,IA,2)+HAHP(J,IA,2)
CCC       END IF
CCC       IF(I.EQ.J.AND.IA.EQ.IB) THEN
CCC         XDEN=XDEN+(2.0D+00)*HAHP(I,IA,2)
CCC       END I
        XDEN=EIG+EH(I)+EH(J)-EP(IA)-EP(IB)
        EPSI(I,IA,IB,J)=EPSI(I,IA,IB,J)/XDEN
 4    CONTINUE
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK GPROD
      SUBROUTINE GPROD(PROD,NO,NU,A,B)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(*),B(*)
C
      NOU   = NO*NU
C
      PROD=0.0D+00
      PROD=PROD+A(1)*B(1)
      PROD=PROD+C1HC(NO,NU,A(1+1),B(1+1))
      CALL GETC2HC(C2HC,NO,NU,A(1+NOU+1),B(1+NOU+1))
      PROD=PROD+C2HC
      RETURN
      END
C
C*MODULE MM23    *DECK GPRODN
      DOUBLE PRECISION FUNCTION GPRODN(NO,NU,A)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(*)
C
      NOU = NO*NU
      GPRODN=0.0D+00
      GPRODN=GPRODN+A(1)*A(1)
      GPRODN=GPRODN+C1HCN(NO,NU,A(1+    1))
      GPRODN=GPRODN+C2HCN(NO,NU,A(1+NOU+1))
      RETURN
      END
C
C*MODULE MM23    *DECK CIINIT
      SUBROUTINE CIINIT(NO,NU,NOA,NUA,
     *                  FHH,FPP,FHP,HHHH,HHHP,HPPH,PPPH,VPPP,TRANS,
     *                  HM,WR,WI,VR,WORK,IPL1,IPL2,INDEX1,INDEX2,
     *                  IACTIVE,EH,EP,INISTART)
C
C NO - NUMBER OF CORRELATED OCCUPIED ORBITALS
C NU - NUMBER OF CORRELATED UNOCCUPIED ORBITALS
C NOA - NUMBER OF ACTIVE OCCUPIED CORRELATED ORBITALS
C NUA - NUMBER OF ACTIVE UNOCCUPIED CORRELATED ORBITALS
C IACTIVE - SPECIFICATION OF ACTIVENESS (INTEGER VECTOR)
C ISORB - INTEGER VECTOR WITH ORBITAL SYMMETRIES
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL ABELPT
      CHARACTER*3 GR,REP
      CHARACTER*3 VECREP
C
      DIMENSION IACTIVE(NO+NU)    !0-INACT.ORB. 1-ACT.ORB.
      DIMENSION INDEXX(100)        !ORDERING OF THE ENERGIES
C
      DIMENSION IPL1(NO*NU,2),IPL2(NOA*NOA*NUA*NUA,4)
      DIMENSION INDEX1(NO,NU),INDEX2(NO,NU,NU,NO)
C
      DIMENSION FHH(NO,NO),FPP(NU,NU),FHP(NO,NU)
      DIMENSION HHHH(NO,NO,NO,NO),HHHP(NO,NO,NO,NU)
      DIMENSION HPPH(NO,NU,NU,NO),PPPH(NU,NU,NU,NO)
      DIMENSION VPPP(NU,NU,NU)
      DIMENSION EH(NO),EP(NU)
C
C DECLARATIONS OF VARIABLES USED BY PROCEDURE DGEEV
C  HM - MATRIX TO BE DIAGONALIZED
C
      DIMENSION HM(1+NO*NU+NOA*NOA*NUA*NUA,1+NO*NU+NOA*NOA*NUA*NUA)
      CHARACTER*1 JOBVL,JOBVR
      DIMENSION WR(1+NO*NU+NOA*NOA*NUA*NUA)
      DIMENSION WI(1+NO*NU+NOA*NOA*NUA*NUA)
      DIMENSION VR(1+NO*NU+NOA*NOA*NUA*NUA,1+NO*NU+NOA*NOA*NUA*NUA)
      DIMENSION WORK(4*(1+NO*NU+NOA*NOA*NUA*NUA))
C
C  TRANS - USED TO STORE A SINGLE INITIAL VECTOR IN THE FORM
C          CONSISTENT WITH S.A.K. CONVENTION
      DIMENSION TRANS(1+NO*NU+NO*NO*NU*NU)
C
      PARAMETER (MXAO=8192)
C
      COMMON /EOMPAR/ CVGCI,CVGEOM,GRPEOM,NSTEOM(8),NOACT,NUACT,
     *                MOACTCC(MXAO),MTHTRIP,MTHCI,MTHEOM,MTHINIT,
     *                MAXCI,MAXEOM,MICCI,MICEOM,IROOTCC(2),
     *                IPROPCC,IPROPCCE
      COMMON /EOMSYM/ IG,NRE(4),MC(8,8,4),ISORB(MXAO),REP(8)
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
      COMMON /IOFILE/ IR,IW,IP,NFTJK,NFTJKT,IDAF,NAV,IODA(950)
C
C         MOST OF SYMMETRY INFO IS SET UP IN /EOMSYM/ ALREADY,
C         BUT WE NEED TO DO A LITTLE BIT MORE
C
      WRITE(UNIT=GR,FMT='(A3)') GRPEOM
      IF(.NOT.ABELPT()) GR='C1 '
      WRITE(IW,9010) GR
C
C     A CLOSED SHELL GROUND STATE MUST BE TOTALLY SYMMETRIC,
C     BUT IT IS NOT IN THE INPUT ARRAY, SO WE FORCE IT IN HERE
C
      DO I=1,8
         IVSYMAD(I) = NSTEOM(I)
      ENDDO
      IVSYMAD(1) = IVSYMAD(1) + 1
      IF(IVSYMAD(1).GT.10) THEN
         WRITE(IW,*) 'GROUND STATE + NSTEOM(1)=10 DOES NOT WORK'
         CALL ABRT
      ENDIF
C
C     COUNT TOTAL STATES NEEDED FROM THE CISD
C
      NTOTCISD=0
      DO I=1,NRE(IG)
         NTOTCISD=NTOTCISD+IVSYMAD(I)
      ENDDO
C
C     SET THE RANGE OF ACTIVE ORBITALS FROM THE INPUT
C
      DO I=1,NO+NU
         IACTIVE(I) = MOACTCC(I)
      ENDDO
C
      JOBVL='N'
      JOBVR='V'
      LWORK=4*(1+NO*NU+NOA*NOA*NUA*NUA)
      IDIM=1+NO*NU+NOA*NOA*NUA*NUA
C
C MAIN LOOP FOR CISD INITIAL GUESS ROUTINE
C
      IPREV=0
      DO 100 I=1,NRE(IG)
       IF(IVSYMAD(I).EQ.0) GO TO 100
       IROOT=IVSYMAD(I)
C
       DO IJK1=1,IDIM
          WR(IJK1)=0.0D+00
          WI(IJK1)=0.0D+00
          DO IJK2=1,IDIM
             VR(IJK1,IJK2)=0.0D+00
          ENDDO
       ENDDO
C
       CALL XLIST12(NO,NU,NOA,NUA,MC,NRE,I,IG,ISORB,IACTIVE,
     *              IPL1,IPL2,ILC1,ILC2,INISTART)
       CALL GINDEX12(NO,NU,NOA,NUA,ILC1,ILC2,IPL1,IPL2,INDEX1,INDEX2,
     *               INISTART)
C
       IF(INISTART.EQ.1) THEN
          CALL XHFILL(NO,NU,NOA,NUA,ILC1,ILC2,IPL1,IPL2,INDEX1,INDEX2,
     *                HM,FHH,FPP,FHP,HHHH,HHHP,HPPH,PPPH,VPPP,EH,EP)
       ELSE
          CALL XCISFILL(NO,NU,NOA,NUA,ILC1,IPL1,INDEX1,HM,
     *                 FHH,FPP,FHP,HPPH,VPPP,EH,EP)
       END IF
C
       IDIM=1+NO*NU+NOA*NOA*NUA*NUA
       NORDER=1+ILC1+ILC2
       WRITE(IW,9020) REP(I),NORDER
C
       CALL DGEEV(JOBVL,JOBVR,NORDER,HM,IDIM,WR,WI,VL,IDIM,VR,IDIM,
     &            WORK,LWORK,INFO)
C
       IF(INFO.EQ.0) THEN
          WRITE(IW,9030) IROOT,REP(I)
          CALL FLSHBF(IW)
       ELSE
          WRITE(IW,*) 'INITIAL DIAGONALIZATION ERROR INFO:',INFO
          CALL ABRT
       END IF
C
       CALL XEORDER(IW,NO,NU,NOA,NUA,NORDER,IROOT,I,WR,WI,INDEXX,INFO1)
C
       IF(INFO1.EQ.0) THEN
          WRITE(IW,9040)
          WRITE(IW,9050) REP(I)
          DO IJK=1,IROOT
             WRITE(IW,9060) WR(INDEXX(IJK))
          ENDDO
       ELSE
          WRITE(IW,*) 'PROBLEMS WITH INITIAL EIGENVAL. ORDERING'
          CALL ABRT
       END IF
C
       CALL STOREINX(NO,NU,NOA,NUA,INDEX1,INDEX2,VR,TRANS,
     *               IROOT,IPREV,INDEXX,INISTART)
       IPREV=IPREV+IROOT
 100  CONTINUE
      RETURN
C
 9010 FORMAT(1X,'THE EOM-CCSD POINT GROUP IS ',A3)
 9020 FORMAT(1X,'SIZE OF THE INITIAL GUESS HAMILTONIAN',
     *          ' WITHIN ',A3,' SYMMETRY IS',I6)
 9030 FORMAT(1X,'INITIAL GUESS HAS FOUND',I3,' CI STARTING VECTORS OF ',
     *           A3,' SYMMETRY')
 9040 FORMAT(1X,'ORDERING OF THE INITIAL EIGENVALUES WAS SUCCESSFUL')
 9050 FORMAT(1X,'INITIAL EIGENVALUES OF ',A3,' SYMMETRY:')
 9060 FORMAT(5X,F20.10)
      END
C
C*MODULE MM23    *DECK XHFILL
      SUBROUTINE XHFILL(NO,NU,NOA,NUA,ILC1,ILC2,IPL1,IPL2,INDEX1,INDEX2,
     &                  HM,FHH,FPP,FHP,HHHH,HHHP,HPPH,PPPH,VPPP,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION FHH(NO,NO),FPP(NU,NU),FHP(NO,NU)
      DIMENSION HHHH(NO,NO,NO,NO),HHHP(NO,NO,NO,NU)
      DIMENSION HPPH(NO,NU,NU,NO),PPPH(NU,NU,NU,NO)
      DIMENSION VPPP(NU,NU,NU)
      DIMENSION EH(NO),EP(NU)
      DIMENSION IPL1(NO*NU,2),IPL2(NOA*NOA*NUA*NUA,4)
      DIMENSION INDEX1(NO,NU),INDEX2(NO,NU,NU,NO)
      DIMENSION HM(1+NO*NU+NOA*NOA*NUA*NUA,1+NO*NU+NOA*NOA*NUA*NUA)
C
      IDIM=1+NO*NU+NOA*NOA*NUA*NUA
      DO 1,I=1,IDIM
      DO 2,J=1,IDIM
        HM(I,J)=0.0D+00
 2    CONTINUE
 1    CONTINUE
      CALL RFHH(NO,NU,FHH)
      CALL RFPP(NO,NU,FPP)
      CALL XRF(NO,NU,FHP)
      CALL RDOV4(1,NU,NO,VPPP,HHHH)
      CALL RDVEM4(1,NU,NO,VPPP,HHHP)
      CALL RDVEM4(0,NO,NU,VPPP,PPPH)
      CALL RO2HPP(1,NO,NU,VPPP,HPPH)
C SINGLES
      DO 3,IR=2,ILC1+1
       I=IPL1(IR-1,1)
       IA=IPL1(IR-1,2)
C FIRST ROW AND COLUMN
       HM(1,IR)=HM(1,IR)+(2.0D+00)*FHP(I,IA)
       HM(IR,1)=HM(IR,1)+FHP(I,IA)
C
       HM(IR,IR)=HM(IR,IR)+EP(IA)-EH(I)
       DO 4,M=1,NO
        ICOL=INDEX1(M,IA)
        IF(ICOL.EQ.0) GO TO 4
        HM(IR,ICOL)=HM(IR,ICOL)-FHH(M,I)
 4     CONTINUE
       DO 5,IE=1,NU
        ICOL=INDEX1(I,IE)
        IF(ICOL.EQ.0) GO TO 5
        HM(IR,ICOL)=HM(IR,ICOL)+FPP(IE,IA)
 5     CONTINUE
       DO 6,M=1,NO
       DO 7,IE=1,NU
        ICOL=INDEX2(M,IE,IA,I)
        IF(ICOL.EQ.0) GO TO 8
        HM(IR,ICOL)=HM(IR,ICOL)+(2.0D+00)*FHP(M,IE)
 8      ICOL=INDEX2(I,IE,IA,M)
        IF(ICOL.EQ.0) GO TO 7
        HM(IR,ICOL)=HM(IR,ICOL)-FHP(M,IE)
 7     CONTINUE
 6     CONTINUE
       DO 9,M=1,NO
       DO 10,N=1,NO
       DO 11,IE=1,NU
        ICOL=INDEX2(M,IE,IA,N)
        IF(ICOL.EQ.0) GO TO 12
        HM(IR,ICOL)=HM(IR,ICOL)-(2.0D+00)*HHHP(I,N,M,IE)
 12     ICOL=INDEX2(M,IA,IE,N)
        IF(ICOL.EQ.0) GO TO 11
        HM(IR,ICOL)=HM(IR,ICOL)+HHHP(I,N,M,IE)
 11    CONTINUE
 10    CONTINUE
 9     CONTINUE
       DO 13,M=1,NO
       DO 14,IE=1,NU
       DO 15,IFF=1,NU
        ICOL=INDEX2(M,IE,IFF,I)
        IF(ICOL.EQ.0) GO TO 16
        HM(IR,ICOL)=HM(IR,ICOL)+(2.0D+00)*PPPH(IA,IFF,IE,M)
 16     ICOL=INDEX2(I,IE,IFF,M)
        IF(ICOL.EQ.0) GO TO 15
        HM(IR,ICOL)=HM(IR,ICOL)-PPPH(IA,IFF,IE,M)
 15    CONTINUE
 14    CONTINUE
 13    CONTINUE
       DO 17,M=1,NO
       DO 18,IE=1,NU
        ICOL=INDEX1(M,IE)
        IF(ICOL.EQ.0) GO TO 18
        HM(IR,ICOL)=HM(IR,ICOL)+(2.0D+00)*HPPH(I,IA,IE,M)
 18    CONTINUE
 17    CONTINUE
 3    CONTINUE
      CALL RO2HPP(2,NO,NU,VPPP,HPPH)
      DO 19,IR=2,ILC1+1
       I=IPL1(IR-1,1)
       IA=IPL1(IR-1,2)
       DO 20,M=1,NO
       DO 21,IE=1,NU
        ICOL=INDEX1(M,IE)
        IF(ICOL.EQ.0) GO TO 21
        HM(IR,ICOL)=HM(IR,ICOL)-HPPH(I,IA,IE,M)
 21    CONTINUE
 20    CONTINUE
 19   CONTINUE
C
C DOUBLES
C
      CALL RDVEM4(1,NU,NO,VPPP,HHHP)
      CALL RDVEM4(0,NO,NU,VPPP,PPPH)
      DO 22,IPP=1,ILC2
       IR=IPP+ILC1+1
       I=IPL2(IPP,1)
       J=IPL2(IPP,2)
       IA=IPL2(IPP,3)
       IB=IPL2(IPP,4)
       HM(IR,IR)=HM(IR,IR)+EP(IA)+EP(IB)-EH(I)-EH(J)
       DO 23,IE=1,NU
        ICOL=INDEX2(I,IE,IB,J)
        IF(ICOL.EQ.0) GO TO 24
        HM(IR,ICOL)=HM(IR,ICOL)+FPP(IE,IA)
 24     ICOL=INDEX2(J,IE,IA,I)
        IF(ICOL.EQ.0) GO TO 23
        HM(IR,ICOL)=HM(IR,ICOL)+FPP(IE,IB)
 23    CONTINUE
       DO 25,M=1,NO
        ICOL=INDEX2(M,IA,IB,J)
        IF(ICOL.EQ.0) GO TO 26
        HM(IR,ICOL)=HM(IR,ICOL)-FHH(M,I)
 26     ICOL=INDEX2(M,IB,IA,I)
        IF(ICOL.EQ.0) GO TO 25
        HM(IR,ICOL)=HM(IR,ICOL)-FHH(M,J)
 25    CONTINUE
       DO 27,M=1,NO
       DO 28,N=1,NO
        ICOL=INDEX2(M,IA,IB,N)
        IF(ICOL.EQ.0) GO TO 29
        HM(IR,ICOL)=HM(IR,ICOL)+(0.50D+00)*HHHH(I,J,M,N)
 29     ICOL=INDEX2(M,IB,IA,N)
        IF(ICOL.EQ.0) GO TO 28
        HM(IR,ICOL)=HM(IR,ICOL)+(0.50D+00)*HHHH(J,I,M,N)
 28    CONTINUE
 27   CONTINUE
      DO 30,M=1,NO
      DO 31,IE=1,NU
       ICOL=INDEX2(M,IE,IB,J)
       IF(ICOL.EQ.0) GO TO 32
       HM(IR,ICOL)=HM(IR,ICOL)-HPPH(I,IA,IE,M)
 32    ICOL=INDEX2(M,IE,IA,I)
       IF(ICOL.EQ.0) GO TO 33
       HM(IR,ICOL)=HM(IR,ICOL)-HPPH(J,IB,IE,M)
 33    ICOL=INDEX2(M,IA,IE,J)
       IF(ICOL.EQ.0) GO TO 34
       HM(IR,ICOL)=HM(IR,ICOL)-HPPH(I,IB,IE,M)
 34    ICOL=INDEX2(M,IB,IE,I)
       IF(ICOL.EQ.0) GO TO 31
       HM(IR,ICOL)=HM(IR,ICOL)-HPPH(J,IA,IE,M)
 31   CONTINUE
 30   CONTINUE
      DO 35,IE=1,NU
       ICOL=INDEX1(I,IE)
       IF(ICOL.EQ.0) GO TO 36
       HM(IR,ICOL)=HM(IR,ICOL)+PPPH(IE,IA,IB,J)
 36    ICOL=INDEX1(J,IE)
       IF(ICOL.EQ.0) GO TO 35
       HM(IR,ICOL)=HM(IR,ICOL)+PPPH(IE,IB,IA,I)
 35   CONTINUE
      DO 37,M=1,NO
       ICOL=INDEX1(M,IA)
       IF(ICOL.EQ.0) GO TO 38
       HM(IR,ICOL)=HM(IR,ICOL)-HHHP(M,I,J,IB)
 38    ICOL=INDEX1(M,IB)
       IF(ICOL.EQ.0) GO TO 37
       HM(IR,ICOL)=HM(IR,ICOL)-HHHP(M,J,I,IA)
 37   CONTINUE
 22   CONTINUE
C
      CALL RO2HPP(1,NO,NU,VPPP,HPPH)
      DO 39,IPP=1,ILC2
       IR=IPP+ILC1+1
       I=IPL2(IPP,1)
       J=IPL2(IPP,2)
       IA=IPL2(IPP,3)
       IB=IPL2(IPP,4)
C FIRST ROW AND COLUMN
       HM(1,IR)=HM(1,IR)+(2.0D+00)*HPPH(I,IA,IB,J)-HPPH(I,IB,IA,J)
       HM(IR,1)=HM(IR,1)+HPPH(I,IA,IB,J)
C
       DO 40,M=1,NO
       DO 41,IE=1,NU
        ICOL=INDEX2(M,IE,IA,I)
        IF(ICOL.EQ.0) GO TO 42
        HM(IR,ICOL)=HM(IR,ICOL)+(2.0D+00)*HPPH(J,IB,IE,M)
 42     ICOL=INDEX2(M,IE,IB,J)
        IF(ICOL.EQ.0) GO TO 43
        HM(IR,ICOL)=HM(IR,ICOL)+(2.0D+00)*HPPH(I,IA,IE,M)
 43     ICOL=INDEX2(I,IE,IA,M)
        IF(ICOL.EQ.0) GO TO 44
        HM(IR,ICOL)=HM(IR,ICOL)-HPPH(J,IB,IE,M)
 44     ICOL=INDEX2(J,IE,IB,M)
        IF(ICOL.EQ.0) GO TO 41
        HM(IR,ICOL)=HM(IR,ICOL)-HPPH(I,IA,IE,M)
 41    CONTINUE
 40    CONTINUE
 39   CONTINUE
C
      DO 45,IFF=1,NU
       CALL RDVPP(IFF,NO,NU,VPPP)
       DO 46,IPP=1,ILC2
        IR=IPP+ILC1+1
        I=IPL2(IPP,1)
        J=IPL2(IPP,2)
        IA=IPL2(IPP,3)
        IB=IPL2(IPP,4)
        DO 47,IE=1,NU
         ICOL=INDEX2(I,IE,IFF,J)
         IF(ICOL.EQ.0) GO TO 48
         HM(IR,ICOL)=HM(IR,ICOL)+(0.50D+00)*VPPP(IA,IB,IE)
 48      ICOL=INDEX2(J,IE,IFF,I)
         IF(ICOL.EQ.0) GO TO 47
         HM(IR,ICOL)=HM(IR,ICOL)+(0.50D+00)*VPPP(IB,IA,IE)
 47     CONTINUE
 46    CONTINUE
 45   CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK XCISFILL
      SUBROUTINE XCISFILL(NO,NU,NOA,NUA,ILC1,IPL1,INDEX1,HM,
     &                    FHH,FPP,FHP,HPPH,VPPP,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION FHH(NO,NO),FPP(NU,NU),FHP(NO,NU)
      DIMENSION HPPH(NO,NU,NU,NO)
      DIMENSION VPPP(NU,NU,NU)
      DIMENSION EH(NO),EP(NU)
      DIMENSION IPL1(NO*NU,2)
      DIMENSION INDEX1(NO,NU)
      DIMENSION HM(1+NO*NU+NOA*NOA*NUA*NUA,1+NO*NU+NOA*NOA*NUA*NUA)
C
      IDIM=1+NO*NU+NO*NU+NOA*NOA*NUA*NUA
      DO 1,I=1,IDIM
      DO 2,J=1,IDIM
        HM(I,J)=0.0D+00
 2    CONTINUE
 1    CONTINUE
C
      CALL RFHH(NO,NU,FHH)
      CALL RFPP(NO,NU,FPP)
      CALL XRF(NO,NU,FHP)
      CALL RO2HPP(1,NO,NU,VPPP,HPPH)
C FIRST ROW & COLUMN
      DO 100,IR=2,ILC1+1
       I=IPL1(IR-1,1)
       IA=IPL1(IR-1,2)
       HM(1,IR)=(2.0D+00)*FHP(I,IA)
       HM(IR,1)=FHP(I,IA)
 100  CONTINUE
C SINGLES
      DO 3,IR=2,ILC1+1
       I=IPL1(IR-1,1)
       IA=IPL1(IR-1,2)
       HM(IR,IR)=HM(IR,IR)+EP(IA)-EH(I)
       DO 4,M=1,NO
        ICOL=INDEX1(M,IA)
        IF(ICOL.EQ.0) GO TO 4
        HM(IR,ICOL)=HM(IR,ICOL)-FHH(M,I)
 4     CONTINUE
       DO 5,IE=1,NU
        ICOL=INDEX1(I,IE)
        IF(ICOL.EQ.0) GO TO 5
        HM(IR,ICOL)=HM(IR,ICOL)+FPP(IE,IA)
 5     CONTINUE
       DO 17,M=1,NO
       DO 18,IE=1,NU
        ICOL=INDEX1(M,IE)
        IF(ICOL.EQ.0) GO TO 18
        HM(IR,ICOL)=HM(IR,ICOL)+(2.0D+00)*HPPH(I,IA,IE,M)
 18    CONTINUE
 17    CONTINUE
 3    CONTINUE
      CALL RO2HPP(2,NO,NU,VPPP,HPPH)
      DO 19,IR=2,ILC1+1
       I=IPL1(IR-1,1)
       IA=IPL1(IR-1,2)
       DO 20,M=1,NO
       DO 21,IE=1,NU
        ICOL=INDEX1(M,IE)
        IF(ICOL.EQ.0) GO TO 21
        HM(IR,ICOL)=HM(IR,ICOL)-HPPH(I,IA,IE,M)
 21    CONTINUE
 20    CONTINUE
 19   CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK XLIST12
      SUBROUTINE XLIST12(NO,NU,NOA,NUA,MC,NRE,ISKK,IG,ISORB,IACTIVE,
     &                  IPL1,IPL2,ILC1,ILC2,INISTART)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION NRE(4),MC(8,8,4),ISORB(NO+NU),IACTIVE(NO+NU),
     *          IPL1(NO*NU,2),IPL2(NOA*NOA*NUA*NUA,4)
C
      ILC1=0
      ILC2=0
      DO 1,I=1,NO*NU
       IPL1(I,1)=0
       IPL1(I,2)=0
 1    CONTINUE
C
C INISTART
C
      IF(INISTART.EQ.1) THEN
      DO 2,I=1,NOA*NOA*NUA*NUA
       IPL2(I,1)=0
       IPL2(I,2)=0
       IPL2(I,3)=0
       IPL2(I,4)=0
 2    CONTINUE
      END IF
C SINGLES
      DO 4,I=1,NO
      DO 5,IA=1,NU
C       IF(ISMALLSD.EQ.1) THEN
C         IACTSD=IACTIVE(I)+IACTIVE(IA)
C         IF(IACTSD.NE.2) GO TO 5
C       END IF
         IDIFF=0
         DO 6,K=1,NRE(IG)
          IPROD=MC(K,ISORB(I),IG)*MC(K,ISORB(NO+IA),IG)
          ISFIX=MC(K,ISKK,IG)
          IDIFF=ABS(IPROD-ISFIX)
          IF(IDIFF.GT.0) GO TO 5
 6       CONTINUE
         ILC1=ILC1+1
         IPL1(ILC1,1)=I
         IPL1(ILC1,2)=IA
 5    CONTINUE
 4    CONTINUE
C INISTART
      IF(INISTART.EQ.1) THEN
C DOUBLES (I<J,AB)
      DO 7,I=1,NO
      DO 8,J=I+1,NO
      DO 9,IA=1,NU
      DO 10,IB=1,NU
       IACTIND=IACTIVE(I)+IACTIVE(J)+IACTIVE(IA+NO)+IACTIVE(IB+NO)
         IF(IACTIND.NE.4) GO TO 10
         IDIFF=0
         DO 11,K=1,NRE(IG)
          IPROD=MC(K,ISORB(I),IG)*MC(K,ISORB(J),IG)*
     &             MC(K,ISORB(IA+NO),IG)*MC(K,ISORB(IB+NO),IG)
          ISFIX=MC(K,ISKK,IG)
          IDIFF=ABS(IPROD-ISFIX)
          IF(IDIFF.GT.0) GO TO 10
 11      CONTINUE
         ILC2=ILC2+1
         IPL2(ILC2,1)=I
         IPL2(ILC2,2)=J
         IPL2(ILC2,3)=IA
         IPL2(ILC2,4)=IB
 10   CONTINUE
 9    CONTINUE
 8    CONTINUE
 7    CONTINUE
C DOUBLES (I=J, A<=B)
      DO 12,I=1,NO
      DO 13,IA=1,NU
      DO 14,IB=IA,NU
       IACTIND=2*IACTIVE(I)+IACTIVE(IA+NO)+IACTIVE(IB+NO)
         IF(IACTIND.NE.4) GO TO 14
         IDIFF=0
         DO 15,K=1,NRE(IG)
          IPROD=MC(K,ISORB(IA+NO),IG)*MC(K,ISORB(IB+NO),IG)
          ISFIX=MC(K,ISKK,IG)
          IDIFF=ABS(IPROD-ISFIX)
          IF(IDIFF.GT.0) GO TO 14
 15       CONTINUE
         ILC2=ILC2+1
         IPL2(ILC2,1)=I
         IPL2(ILC2,2)=I
         IPL2(ILC2,3)=IA
         IPL2(ILC2,4)=IB
 14   CONTINUE
 13   CONTINUE
 12   CONTINUE
C INISTART
      END IF
      RETURN
      END
C
C*MODULE MM23    *DECK GINDEX12
      SUBROUTINE GINDEX12(NO,NU,NOA,NUA,ILC1,ILC2,IPL1,IPL2,
     *                    INDEX1,INDEX2,INISTART)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION IPL1(NO*NU,2),IPL2(NOA*NOA*NUA*NUA,4),
     *          INDEX1(NO,NU),INDEX2(NO,NU,NU,NO)
C
      DO 10,I=1,NO
      DO 11,IA=1,NU
       INDEX1(I,IA)=0
 11   CONTINUE
 10   CONTINUE
C
C
C INISTART
      IF(INISTART.EQ.1) THEN
      DO 12,I=1,NO
      DO 13,IA=1,NU
      DO 14,IB=1,NU
      DO 15,J=1,NO
       INDEX2(I,IA,IB,J)=0
 15   CONTINUE
 14   CONTINUE
 13   CONTINUE
 12   CONTINUE
      END IF
C
      DO 1,I=1,ILC1
       I1=IPL1(I,1)
       IA1=IPL1(I,2)
       INDEX1(I1,IA1)=I+1
 1    CONTINUE
C INISTART
      IF(INISTART.EQ.1) THEN
      DO 2,I=1,ILC2
       I1=IPL2(I,1)
       I2=IPL2(I,2)
       IA1=IPL2(I,3)
       IA2=IPL2(I,4)
       INDEX2(I1,IA1,IA2,I2)=I+ILC1+1
       INDEX2(I2,IA2,IA1,I1)=I+ILC1+1
 2    CONTINUE
      END IF
C
      RETURN
      END
C
C*MODULE MM23    *DECK STOREINX
      SUBROUTINE STOREINX(NO,NU,NOA,NUA,INDEX1,INDEX2,VR,TRANS,
     *                    IROOT,IPREV,INDEXX,INISTART)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION INDEX1(NO,NU),INDEX2(NO,NU,NU,NO),
     *          VR(1+NO*NU+NOA*NOA*NUA*NUA,1+NO*NU+NOA*NOA*NUA*NUA),
     *          TRANS(1+NO*NU+NO*NO*NU*NU)
      DIMENSION INDEXX(10)
C
      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
C
      DO 1,IR=1,IROOT
        ICOL=INDEXX(IR)
        CALL ZEROMA(TRANS,1,1+NO*NU+NO*NO*NU*NU)
C REFERENCE
        TRANS(1)=VR(1,ICOL)
C SINGLES
        INE=1
        DO 2,IA=1,NU
        DO 3,I=1,NO
         IPOS=INDEX1(I,IA)
         IF(IPOS.EQ.0) THEN
            INE=INE+1
            TRANS(INE)=0.0D+00
         ELSE
            INE=INE+1
            TRANS(INE)=VR(IPOS,ICOL)
         END IF
 3      CONTINUE
 2      CONTINUE
C DOUBLES
C INISTART
        IF(INISTART.EQ.1) THEN
        DO 4,J=1,NO
        DO 5,IB=1,NU
        DO 6,IA=1,NU
        DO 7,I=1,NO
         IPOS=INDEX2(I,IA,IB,J)
         IF(IPOS.EQ.0) THEN
            INE=INE+1
            TRANS(INE)=0.0D+00
         ELSE
            INE=INE+1
            TRANS(INE)=VR(IPOS,ICOL)
         END IF
 7      CONTINUE
 6      CONTINUE
 5      CONTINUE
 4      CONTINUE
        END IF
      IDIM=1+NO*NU+NO*NO*NU*NU
      CALL WCCFL(JCISD,IR+IPREV,IDIM,TRANS)
 1    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK XEORDER
      SUBROUTINE XEORDER(IW,NO,NU,NOA,NUA,NORDER,IROOT,IXXX,
     &                   WR,WI,INDEXX,INFO1)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION WR(1+NO*NU+NOA*NOA*NUA*NUA),
     *          WI(1+NO*NU+NOA*NOA*NUA*NUA)
      DIMENSION INDEXX(100)
C
      INFO1=0
      TOL=1.0D-07
      DO 1 I=1,100
       INDEXX(I)=0
 1    CONTINUE
C
      IF(IROOT.GT.NORDER) THEN
       WRITE(IW,*) 'TOO MANY INITIAL CI VECTORS REQUESTED'
       INFO1=1
       RETURN
      END IF
C      DO 2,I=1,NORDER
C       XXX=ABS(WI(I))
C       IF(XXX.GT.TOL) THEN
C        WR(I)=0.0D+00
C       END IF
C 2    CONTINUE
C  WR->WI
      DO 10,I=1,NORDER
       WI(I)=WR(I)
 10   CONTINUE
      DO 11 I=1,NORDER
       XXX=ABS(WR(I))
       IF(XXX.LT.TOL.AND.IXXX.NE.1) THEN
         WI(I)=1000.0D+00
       END IF
 11   CONTINUE
      DO 3 I=1,IROOT
       XMIN=1.0D+10
       IMIN=0
       DO 4 J=1,NORDER
        IF(WI(J).EQ.1000.0D+00) GO TO 4
        IF(WI(J).LT.XMIN) THEN
         XMIN=WI(J)
         IMIN=J
        END IF
 4     CONTINUE
       INDEXX(I)=IMIN
       WI(IMIN)=1000.0D+00
 3    CONTINUE
      RETURN
      END
C
C*MODULE MM23    *DECK DIAGHNN
      SUBROUTINE DIAGHNN(IW,NO,NU,IDIM,EIGENVAL,TOL,NROOT,NC,
     *                   MAXITCI,B,AT,ATEIG,C,SORTH,WR,WI,VL,VR,WORK,
     *                   FHP,FHH,FPP,VHHHH,VHHHP,VHPPH,VPPPH,AUX2,
     *                   TI,ATAUX,EH,EP,ESCF,IDXX,
     *                   ISTACK,NSTACK,NWORK,NCNROOT,ICONT,INISTART)
C
C DIAGONALIZATION PROCEDURE BASED ON THE HIRAO - NAKATSUJI
C ALGORITHM FOR DIAGONALIZATION OF NONHERMITIAN MATRICES
C (J. COMP. PHYS. 45, 246 (1982))
C
C IDIM - DIMENSION OF THE MATRIX A
C
C NITER - MAXIMUM NUMBER OF ITERATION
C
C EIGENVAL - VECTOR OF EIGENVALUES (EIGENVAL(NROOT,NROOT))
C
C TOL - CONVERGENCE TOLERANCY FOR EIGENVECTORS!
C
C NROOT - THE NUMBER OF EIGENVECTORS TO BE FOUND
C
C NC - NUMBER OF MICROITERATION
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 VECREP
C
      DIMENSION ISTACK(NSTACK)    ! 10*NC*NROOT
C MATRIX OF BASIS VECTOR (COLUMNS) SPANNING THE LINEAR SPACE WHICH
C APPROXIMATES THE TRUE LINEAR SPACE SPANNED BY EXACT EIGENVECTORS
C OF MATRIX A (IS CHANGED AFTER EACH MICROITERATION)
      DIMENSION B(IDIM,NCNROOT)
C INTERACTION MATRIX
      DIMENSION AT(NCNROOT,NCNROOT)
      DIMENSION ATAUX(NCNROOT,NCNROOT)
C VECTOR OF EIGENVALUES OF INTERACTION MATRIX AT => ATEIG
C (LOWEST NROOT ENERGIES)
      DIMENSION ATEIG(NCNROOT)
C ORDERING OF THE EIGENVALUES
C--   DIMENSION INDX(NCNROOT)
C TRANSFORMATION MATRIX
      DIMENSION C(NCNROOT,NCNROOT)
C VECTOR OF NROOT EIGENVALUES OF A
      DIMENSION EIGENVAL(NROOT)
C AUXILIARY VECTOR FOR ORTHOGONALIZATION PROCEDURE
      DIMENSION SORTH(IDIM)
C
C VARIABLES NECESSEARY FOR SOLVING SMALL NON-SYMMETRIC EIGEN-PROBLEM
C FOR INTERACTION MATRIX (USING ROUTINE DGEEV)
C
      CHARACTER*1 JOBVL,JOBVR
      DIMENSION WR(NCNROOT),WI(NCNROOT)
      DIMENSION VL(NCNROOT,NCNROOT),VR(NCNROOT,NCNROOT)
      DIMENSION WORK(NWORK)
C
      DIMENSION FHP(*),FHH(*),FPP(*),VHHHH(*),VHHHP(*),VHPPH(*),
     *          VPPPH(*),AUX2(*),TI(*),EH(NO),EP(NU)
      DIMENSION VERROR(100),EXCON(100),R0CON(100)
C
      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 /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      DATA ZERO/0.0D+00/, ONE/1.0D+00/, OM/-1.0D+00/
C
      NOU   = NO*NU
C
      DO I=1,100
         EXCON(I)=ZERO
         R0CON(I)=ZERO
         VERROR(I)=ZERO
      ENDDO
      DO I=1,NSTACK
         ISTACK(I)=0
      ENDDO
C
      MICROTOT=0
      TOLMAX=1.0D+04
      TIME=0.0D+00
      JOBVL='N'
      JOBVR='V'
      LWORK=4*NC*NROOT
C
      CALL ZEROMA(C,1,NC*NC*NROOT*NROOT)
C
C
C
C
C MAIN LOOP (LABEL:1000)
C
      ITER=0
      ITERTOT=0
      WRITE(IW,9010)
C
 1000 CONTINUE
       CALL ZEROMA(B,1,IDIM*NC*NROOT)
       CALL ZEROMA(AT,1,NC*NC*NROOT*NROOT)
       CALL ZEROMA(ATAUX,1,NC*NC*NROOT*NROOT)
C
       IF(ITER.EQ.0) THEN
        IF(IVSYMAD(1).GT.1) THEN
         DO 4433,ICOL=1,NROOT
         CALL RCCFL(JCISD,ICOL,IDIM,B(1,ICOL))
 4433    CONTINUE
        ELSE
          IF(IDXX.EQ.1) THEN
           ICOL=1
           CALL RCCFL(JCISD,ICOL,IDIM,B(1,ICOL))
          ELSE
           DO 4422,ICOL=1,NROOT
            CALL RCCFL(JCISD,ICOL+1,IDIM,B(1,ICOL))
 4422      CONTINUE
          END IF
        END IF
       ELSE
        DO 5,J=1,NROOT
         CALL RCCFL(KCIF,J,IDIM,B(1,J))
 5      CONTINUE
       END IF
C
       IF(ITER.EQ.0.AND.INISTART.EQ.2.AND.IDXX.EQ.1) THEN
        ICOLX=1
        B(1,ICOLX)=1.0D+00
        CALL RO1(1,NO,NU,B(2,ICOLX))
        CALL RO2(1,NO,NU,B(1+NO*NU+1,ICOLX))
       END IF
C
C INITIAL ORTHONORMALIZATION
C
      DO 150,J=1,NROOT
       XB=ZERO
       XB=GPRODN(NO,NU,B(1,J))
       XB=ONE/(SQRT(XB))
       CALL VECMUL(B(1,J),IDIM,XB)
 150  CONTINUE
C
C
      IF(NROOT.GT.1) THEN
      DO 153,ICOL=1,NROOT
         CALL ZEROMA(SORTH,1,IDIM)
         DO 155,IPRC=1,ICOL-1
C SCALAR PRODUCT <B(*,IPRC)|B(*,ICOL)>
          CALL GPROD(PROD,NO,NU,B(1,IPRC),B(1,ICOL))
C SORTH(*)=SORTH(*)+PROD*B(*,IPRC)
          CALL VOOCPX(IDIM,SORTH,B(1,IPRC),PROD)
 155     CONTINUE
         CALL VOOCPX(IDIM,B(1,ICOL),SORTH,OM)
         ZV=GPRODN(NO,NU,B(1,ICOL))
         ZV=ONE/SQRT(ZV)
         CALL VECMUL(B(1,ICOL),IDIM,ZV)
 153    CONTINUE
       END IF
C
C MICROITERATION LOOP (LABEL:2000)
C
       CALL TSECND(TIME1)
C
       DO 2000,IMICRO=1,NC-1
        ITERTOT=ITERTOT+1
        MICROTOT=MICROTOT+1
C
C CONSTRUCTING INTERACTION MATRIX AT=B^(+) A B
C
         ILIM=(IMICRO-1)*NROOT
        DO 7 I=1,IMICRO*NROOT
        DO 71 L=I,IMICRO*NROOT
         IF(I.GT.ILIM.OR.L.GT.ILIM) THEN
          CALL HC0(NO,NU,B(1+1,L),B(1+NOU+1,L),SORTH(1),
     *             FHP,VHPPH,TI)
          CALL HC1(NO,NU,B(1,L),B(1+1,L),B(1+NOU+1,L),SORTH(1+1),
     *             FHP,FHH,FPP,VHPPH,VHHHP,VPPPH,TI,EH,EP)
          CALL HC2(NO,NU,B(1,L),B(1+1,L),B(1+NOU+1,L),SORTH(1+NOU+1),
     *             FHP,FHH,FPP,VHHHH,VHHHP,VHPPH,VPPPH,AUX2,TI,EH,EP)
          CALL GPROD(AT(I,L),NO,NU,B(1,I),SORTH(1))
          AT(L,I)=AT(I,L)
         END IF
 71     CONTINUE
 7      CONTINUE
C
        DO 511,IJK1=1,NC*NROOT
        DO 512,IJK2=1,NC*NROOT
          ATAUX(IJK1,IJK2)=AT(IJK1,IJK2)
 512    CONTINUE
 511    CONTINUE
C
C DIAGONALIZATION OF THE INTERACTION MATRIX AT
C AND CONSTRUCTING THE MATRIX C (USING ROUTINE DGEEV)
C
        CALL DGEEV(JOBVL,JOBVR,NC*NROOT,ATAUX,NC*NROOT,WR,WI,
     &             VL,NC*NROOT,VR,NC*NROOT,WORK,LWORK,INFO)
C
        CALL ZEROMA(ATEIG,1,NC*NROOT)
        CALL ZEROMA(C,1,NC*NC*NROOT*NROOT)
C
C ORDERING OF THE EIGENVALUES
C
CCCX        IF(IDXX.EQ.1) THEN
CCCX           CALL INDEXX(NC*NROOT,WR,INDX,3*NC*NROOT,ISTACK,NSTACK)
CCCX           ILOWEST=1
CCCX           I=1
CCCX 42        IF(ABS(WI(INDX(I))).LT.1.0D-12.AND.
CCCX     &        ABS(WR(INDX(I))).GT.1.0D-10) THEN
CCCX              ATEIG(ILOWEST)=WR(INDX(I))
CCCX              DO 41,J=1,NC*NROOT
CCCX                 C(J,ILOWEST)=VR(J,INDX(I))
CCCX 41           CONTINUE
CCCX              IF(ILOWEST.EQ.NROOT) GO TO 50
CCCX              ILOWEST=ILOWEST+1
CCCX           END IF
CCCX           I=I+1
CCCX           IF(I.GT.NC*NROOT.OR.ILOWEST.GT.NROOT) GO TO 50
CCCX           GO TO 42
CCCX 50        CONTINUE
CCCX           DO 51 I=1,NROOT
CCCX              EIGENVAL(I)=ATEIG(I)
CCCX 51        CONTINUE
CCCX        ELSE
           DO 455 I=1,NROOT
              ZMAX=ZERO
              JMAX=1
              DO 456,J=1,NC*NROOT
                 XXX=ABS(VR(I,J))
CCCX                 YYY=ABS(WR(J))
CCCX                 IF(XXX.GT.ZMAX.AND.YYY.GT.0.00001) THEN
                 IF(XXX.GT.ZMAX) THEN
                    ZMAX=XXX
                    JMAX=J
                 END IF
 456          CONTINUE
              ATEIG(I)=WR(JMAX)
              EIGENVAL(I)=ATEIG(I)
              DO 457 J=1,NC*NROOT
                 C(J,I)=VR(J,JMAX)
 457          CONTINUE
 455       CONTINUE
CCCX        END IF
C
C CONSTRUCTION OF THE MATRIX XNEW=B*C
C
C
      ZNORM=ZERO
      DO 1009 K=1,NROOT
          CALL ZEROMA(SORTH,1,IDIM)
          DO I=1,IDIM
            DO J=1,IMICRO*NROOT
              SORTH(I)=SORTH(I)+B(I,J)*C(J,K)
            ENDDO
          ENDDO
C
          CALL WCCFL(KCIF,K,IDIM,SORTH)
C
       ICOL=K+IMICRO*NROOT
      CALL HC0(NO,NU,SORTH(1+1),SORTH(1+NOU+1),B(1,ICOL),
     *         FHP,VHPPH,TI)
      CALL HC1(NO,NU,SORTH(1),SORTH(1+1),SORTH(1+NOU+1),B(1+1,ICOL),
     *         FHP,FHH,FPP,VHPPH,VHHHP,VPPPH,TI,EH,EP)
      CALL HC2(NO,NU,SORTH(1),SORTH(1+1),SORTH(1+NOU+1),
     *         B(1+NOU+1,ICOL),FHP,FHH,FPP,VHHHH,VHHHP,VHPPH,VPPPH,
     *         AUX2,TI,EH,EP)
      CALL MVALVEC(IDIM,B(1,ICOL),SORTH(1),ATEIG(K))
C
C CHECKING FOR THE NORM OF THE MATRIX Q
C
         ZNORM1=ZERO
         CALL MMNORM(B(1,ICOL),ZNORM1,IDIM,1)
         VERROR(K)=ZNORM1
C
C
C
C ** ADDED BY KK --- SPUST UZBIEZNIONYCH
C **************************************
        ISREP=0
        XXX=ZNORM1
        IF(XXX.LT.TOL) THEN
           XENE=ATEIG(K)
           XR0=ABS(SORTH(1))
           IF(ICONT.EQ.0) THEN
            ICONT=1
            EXCON(ICONT)=XENE
            R0CON(ICONT)=SORTH(1)
            CALL WCCFL(JCISDNX,ICONT,IDIM,SORTH(1))
           ELSE
            IF(IDXX.EQ.1) THEN
            DO 651,ILL=1,ICONT
             XEDIFF=ABS(XENE-EXCON(ILL))
             XRDIFF=ABS(XR0-ABS(R0CON(ILL)))
             IF(XRDIFF.LT.TOL.AND.XEDIFF.LT.TOL) ISREP=1
 651        CONTINUE
            ELSE
            DO 1651,ILL=2,ICONT
             XEDIFF=ABS(XENE-EXCON(ILL))
             XRDIFF=ABS(XR0-ABS(R0CON(ILL)))
             IF(XRDIFF.LT.TOL.AND.XEDIFF.LT.TOL) ISREP=1
 1651       CONTINUE
            END IF
            IF(ISREP.EQ.0) THEN
             ICONT=ICONT+1
             EXCON(ICONT)=XENE
             R0CON(ICONT)=SORTH(1)
             CALL WCCFL(JCISDNX,ICONT,IDIM,SORTH(1))
            END IF
           END IF
        END IF
C
C *****************
C
C CONSTRUCTION OF THE MATRIX EPSI
C
       ICOL=K+IMICRO*NROOT
       CALL DENDIV0(B(1,ICOL),ATEIG(K))
       CALL DENDIV1(NO,NU,B(1+1,ICOL),ATEIG(K),EH,EP)
       CALL DENDIV2(NO,NU,B(1+NOU+1,ICOL),ATEIG(K),EH,EP)
C
 1009  CONTINUE
C
C ORTHOGONALIZATION OF THE CORRECTION VECTORS EPSI TO THE
C BASIS DEFINED BY MATRIX B AFTER IMICRO-TH ITERATION
C
C
         DO 21,ICOL=1,NROOT
         CALL ZEROMA(SORTH,1,IDIM)
         DO 22,IPRC=1,IMICRO*NROOT+ICOL-1
C SCALAR PRODUCT <B(*,IPRC)|B(*,IMICRO*NROOT+ICOL)>
         CALL GPROD(PROD,NO,NU,B(1,IPRC),B(1,IMICRO*NROOT+ICOL))
C B(*,IMICRO*NROOT+ICOL)=B(*,IMICRO*NROOT+ICOL)-PROD*B(*,IPRC)
         CALL VOOCPX(IDIM,SORTH,B(1,IPRC),PROD)
 22      CONTINUE
         CALL VOOCPX(IDIM,B(1,IMICRO*NROOT+ICOL),SORTH,OM)
         ZV=ZERO
         IPP1=IMICRO*NROOT+ICOL
         ZV=ZV+GPRODN(NO,NU,B(1,IPP1))
         ZV=ONE/SQRT(ZV)
         CALL VECMUL(B(1,IPP1),IDIM,ZV)
 21      CONTINUE
C
          ZNORM=ZERO
          DO 4111,IJK=1,NROOT
           XXX1=ABS(VERROR(IJK))
           IF(XXX1.GT.ZNORM) ZNORM=XXX1
 4111     CONTINUE
C
          WRITE(IW,9020) ITER+1,IMICRO,ZNORM,(ATEIG(I123),I123=1,NROOT)
          CALL FLSHBF(IW)
C
C TEST FOR CONVERGENCE, PRINT, AND EXIT
C
          IF(ZNORM.LT.TOL) THEN
             NCVGCISD=NCVGCISD+NROOT
             WRITE(IW,9030) MICROTOT
             DO I=1,NROOT
              WRITE(IW,9040) I,ESCF+ATEIG(I)
             ENDDO
C
             DO 577,ICOL=1,NROOT
                CALL RCCFL(KCIF,ICOL,IDIM,SORTH(1))
                PROD=ZERO
                PROD=GPRODN(NO,NU,SORTH(1))
                PROD=ONE/SQRT(PROD)
                CALL VECMUL(SORTH(1),IDIM,PROD)
                IF(IVSYMAD(1).GT.1) THEN   !GROUND-STATE SYMM.
                 CALL WCCFL(JCISD,ICOL,IDIM,SORTH(1))
                ELSE
                   IF(IDXX.EQ.1) THEN
                     CALL WCCFL(JCISD,ICOL,IDIM,SORTH(1))
                   ELSE
                     CALL WCCFL(JCISD,ICOL+1,IDIM,SORTH(1))
                   END IF
                END IF
  577        CONTINUE
             GO TO 3000
          END IF
C
C                RESIDUAL VECTOR TOO BIG TO CONTINUE
C
          IF(ZNORM.GT.TOLMAX.OR.ITERTOT.GT.MAXITCI) THEN
           IF(IDXX.EQ.1) THEN
             IF(ZNORM.GT.TOLMAX) THEN
                WRITE(IW,9050)
                WRITE(IW,9060) ICONT
             END IF
             IF(ITERTOT.GT.MAXITCI) THEN
                WRITE(IW,9080)
                WRITE(IW,9060) ICONT
             END IF
             DO II=1,ICONT
                WRITE(IW,9070) EXCON(II)
             ENDDO
           ELSE
             IF(ZNORM.GT.TOLMAX) THEN
                WRITE(IW,9050)
             END IF
             IF(ITERTOT.GT.MAXITCI) THEN
                WRITE(IW,9080)
             END IF
             WRITE(IW,9060) ICONT-1
             DO II=2,ICONT
                WRITE(IW,9070) EXCON(II)
             ENDDO
           ENDIF
C
             NCVGCISD=NCVGCISD+ICONT
             IF(NCVGCISD.GT.NTOTCISD) NCVGCISD=NTOTCISD
             DO 1501,ICOL=1,ICONT
                CALL RCCFL(JCISDNX,ICOL,IDIM,SORTH(1))
                PROD=ZERO
                PROD=GPRODN(NO,NU,SORTH(1))
                PROD=ONE/SQRT(PROD)
                CALL VECMUL(SORTH(1),IDIM,PROD)
                IF(IVSYMAD(1).GT.1) THEN   !GROUND-STATE SYMM.
                   CALL WCCFL(JCISD,ICOL,IDIM,SORTH(1))
                ELSE
                   IF(IDXX.EQ.1) THEN
                     CALL WCCFL(JCISD,ICOL,IDIM,SORTH(1))
                   ELSE
                     CALL WCCFL(JCISD,ICOL+1,IDIM,SORTH(1))
                   END IF
                END IF
 1501           CONTINUE
             GO TO 3000
          END IF
C
C            END OF MICROITERATION LOOP
C
 2000  CONTINUE
C
       CALL TSECND(TIME2)
       TIME=TIME + (TIME2-TIME1)
C
C  CONVERGENCE TEST
C
          ITER=ITER+1
C
C       CHECK MAXIMUM NUMBER OF MACROITERATIONS
C
CCCX          IF(ITER.GT.NITER-1) THEN
          IF(ITERTOT.GT.MAXITCI) THEN
             IF(IDXX.EQ.1) THEN
             WRITE(IW,9080)
             WRITE(IW,9060) ICONT
             DO II=1,ICONT
                WRITE(IW,9070) EXCON(II)
             ENDDO
             ELSE
             WRITE(IW,9080)
             WRITE(IW,9060) ICONT-1
             DO II=2,ICONT
                WRITE(IW,9070) EXCON(II)
             ENDDO
             END IF
C
C
             NCVGCISD=NCVGCISD+ICONT
             IF(NCVGCISD.GT.NTOTCISD) NCVGCISD=NTOTCISD
             DO 4501,ICOL=1,ICONT
             CALL RCCFL(JCISDNX,ICOL,IDIM,SORTH(1))
             PROD=ZERO
             PROD=GPRODN(NO,NU,SORTH(1))
             PROD=ONE/SQRT(PROD)
             CALL VECMUL(SORTH(1),IDIM,PROD)
             IF(IVSYMAD(1).GT.1) THEN   !GROUND-STATE SYMM.
                CALL WCCFL(JCISD,ICOL,IDIM,SORTH(1))
             ELSE
                IF(IDXX.EQ.1) THEN
                  CALL WCCFL(JCISD,ICOL,IDIM,SORTH(1))
                ELSE
                  CALL WCCFL(JCISD,ICOL+1,IDIM,SORTH(1))
                END IF
             END IF
 4501        CONTINUE
             GO TO 3000
          ELSE
             IF(ABS(ZNORM).GT.TOL  .AND.
     *          ABS(ZNORM).LT.TOLMAX) GO TO 1000
          END IF
C
 3000 CONTINUE
      CALL FLSHBF(IW)
      RETURN
C
 9010 FORMAT(1X,'ITER MICRO  MAX CI CHANGE    CISD CORRELATION ENERGY')
 9020 FORMAT(1X,I3,I5,F14.7,4F14.9/(23X,4F14.9))
 9030 FORMAT(/1X,'CISD CONVERGED AFTER',I3,' TOTAL CYCLES,',
     *           ' THE CISD EIGENVALUES ARE')
 9040 FORMAT(5X,'E(',I3,')=',F20.10)
 9050 FORMAT(1X,'THE NORM OF THE RESIDUAL VECTOR IS TOO LARGE')
 9060 FORMAT(1X,I3,' CONVERGED VECTORS ARE STORED IN FILE CISDVEC,'/
     *       1X,' AND CAN FURTHER BE USED BY MMEOM(2,3) PROGRAM.')
 9070 FORMAT(1X,'THE CONVERGED STATES HAVE CISD CORREL. ENERGY =',
     *           F17.10)
 9080 FORMAT(1X,'TOO MANY ITERATIONS, NOT CONVERGED')
      END
C
C*MODULE MM23    *DECK DIAGS
      SUBROUTINE DIAGS(IW,NO,NU,IHSPACE,IDIM,TOL,MAXITCI,C,
     *                 AT,WR,WI,VL,VR,WORK,FHP,FHH,FPP,VHHHH,VHHHP,
     *                 VHPPH,VPPPH,AUX2,TI,HAPP,HAHH,HAHP,ATAUX,
     *                 EH,EP,ESCF,IXY)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 VECREP
C
      DIMENSION C(IDIM,3),AT(IHSPACE,IHSPACE),ATAUX(IHSPACE,IHSPACE)
      DIMENSION FHP(*),FHH(*),FPP(*)
      DIMENSION VHHHH(*),VHHHP(*),VHPPH(*),VPPPH(*),AUX2(*),TI(*)
      DIMENSION HAHH(NO,NO,2),HAHP(NO,NU,2),HAPP(NU,NU,2)
      DIMENSION EH(NO),EP(NU)
      DIMENSION WR(IHSPACE),WI(IHSPACE)
      DIMENSION VL(IHSPACE,IHSPACE),VR(IHSPACE,IHSPACE)
      DIMENSION WORK(4*IHSPACE)
C
      CHARACTER*1 JOBVL,JOBVR
C
      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 /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      DATA ZERO/0.0D+00/, ONE/1.0D+00/, OM/-1.0D+00/
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
C
      TOLMAX=1.0D+05
      JOBVL='N'
      JOBVR='V'
      LWORK=4*IHSPACE
      CALL RCCFL(ITAPP,6,2*NU2,HAPP)
      CALL RCCFL(ITAPP,7,2*NO2,HAHH)
      CALL RCCFL(ITAPP,8,2*NOU,HAHP)
      CALL RCCFL(JCISD,IXY,IDIM,C(1,1))
C
C INITIAL NORMALIZATION
C
      PROD=GPRODN(NO,NU,C(1,1))
      PROD=ONE/SQRT(PROD)
      CALL VECMUL(C(1,1),IDIM,PROD)
C
C MACROITERATION LOOP
C
      WRITE(IW,9000)
      IMACRO=1
      ITERTOT=0
 1000 CONTINUE
         CALL ZEROMA(AT(1,1),1,IHSPACE*IHSPACE)
         CALL ZEROMA(ATAUX(1,1),1,IHSPACE*IHSPACE)
         DO I=2,3
            CALL ZEROMA(C(1,I),1,IDIM)
         ENDDO
         CALL VOOCPX(IDIM,C(1,2),C(1,1),ONE)
         CALL WCCFL(KCIF,1,IDIM,C(1,2))
         CALL HC0(NO,NU,C(1+1,2),C(1+NOU+1,2),
     &            C(1,3),FHP,VHPPH,TI)
         CALL HC1(NO,NU,C(1,2),C(1+1,2),C(1+NOU+1,2),
     &            C(1+1,3),FHP,FHH,FPP,VHPPH,VHHHP,VPPPH,TI,EH,EP)
         CALL HC2(NO,NU,C(1,2),C(1+1,2),C(1+NOU+1,2),
     &            C(1+NOU+1,3),FHP,FHH,FPP,VHHHH,VHHHP,VHPPH,VPPPH,
     *            AUX2,TI,EH,EP)
C
C MICROITERATION LOOP
C
         DO 500 II=1,IHSPACE
         ITERTOT=ITERTOT+1
C                   FORMING AT-MATRIX
            CALL GPROD(AT(II,II),NO,NU,C(1,2),C(1,3))
            IF(II.GT.1) THEN
               DO IY=1,II-1
                  CALL RCCFL(KCIF,IY,IDIM,C(1,2))
                  CALL GPROD(XXX,NO,NU,C(1,2),C(1,3))
                  AT(IY,II)=XXX
                  AT(II,IY)=XXX
               ENDDO
            END IF
C
C AT ==> ATAUX
C
            DO IX=1,IHSPACE
               DO IY=1,IHSPACE
                  ATAUX(IX,IY)=AT(IX,IY)
               ENDDO
            ENDDO
C
C SOLVING "SMALL" EIGENVALUE PROBLEM
C
            CALL DGEEV(JOBVL,JOBVR,IHSPACE,ATAUX,IHSPACE,WR,WI,VL,
     *                 IHSPACE,VR,IHSPACE,WORK,LWORK,INFO)
C
C LARGEST OVERLAP PRINCIPLE
C
            XMAX=ZERO
            IMAX=0
            DO IY=1,IHSPACE
               XXX=ABS(VR(1,IY))
               IF(XXX.GT.XMAX) THEN
                  XMAX=XXX
                  IMAX=IY
               END IF
            ENDDO
            ENERGY=WR(IMAX)
C
C NEW APPROXIMATION TO EIGENVECTOR
C
            CALL ZEROMA(C(1,1),1,IDIM)
            DO IY=1,II
              CALL RCCFL(KCIF,IY,IDIM,C(1,2))
              CALL VOOCPX(IDIM,C(1,1),C(1,2),VR(IY,IMAX))
            ENDDO
C
C RESIDUAL VECTOR (H*C(*,1)-ENERGY*C(*,1)) ==>C(*,2)
C
            CALL HC0(NO,NU,C(1+1,1),C(1+NOU+1,1),
     &               C(1,2),FHP,VHPPH,TI)
            CALL HC1(NO,NU,C(1,1),C(1+1,1),C(1+NOU+1,1),
     &               C(1+1,2),FHP,FHH,FPP,VHPPH,VHHHP,VPPPH,TI,EH,EP)
            CALL HC2(NO,NU,C(1,1),C(1+1,1),C(1+NOU+1,1),
     &               C(1+NOU+1,2),FHP,FHH,FPP,VHHHH,VHHHP,VHPPH,VPPPH,
     *               AUX2,TI,EH,EP)
            CALL VOOCPX(IDIM,C(1,2),C(1,1),OM*ENERGY)
C
C TEST FOR CONVERGENCE
C
            XXX=GPRODN(NO,NU,C(1,2))
            ZNORM=SQRT(XXX)
C
C    MESSAGE
C
            WRITE(IW,9010) IMACRO,II,ZNORM,ENERGY
            CALL FLSHBF(6)
            IF(ZNORM.LT.TOL) THEN
                NCVGCISD=NCVGCISD+1
                WRITE(IW,9030) NCVGCISD,ENERGY+ESCF
                CALL WCCFL(JCISD,NCVGCISD,IDIM,C(1,1))
                GO TO  3000
            END IF
            IF(ZNORM.GT.TOLMAX) THEN
               WRITE(IW,9040)
               GO TO 3000
            END IF
            IF(ITERTOT.GT.MAXITCI) GO TO 6050
C
C CORRECTION VECTOR
C
            CALL DENDIV0NN(C(1,2),ENERGY)
            CALL DENDIV1NN(NO,NU,C(1+1,2),ENERGY,EH,EP)
            CALL DENDIV2NN(NO,NU,C(1+NOU+1,2),ENERGY,EH,EP)
C
C ORTHONORMALIZATION OF THE CORRECTION VECTOR
C
            DO IY=1,II
               CALL RCCFL(KCIF,IY,IDIM,C(1,3))
               CALL GPROD(PROD,NO,NU,C(1,3),C(1,2))
               CALL VOOCPX(IDIM,C(1,2),C(1,3),OM*PROD)
            ENDDO
            PROD=GPRODN(NO,NU,C(1,2))
            PROD=ONE/SQRT(PROD)
            CALL VECMUL(C(1,2),IDIM,PROD)
C
C STORING NEXT BASIS VECTOR
C
            CALL WCCFL(KCIF,II+1,IDIM,C(1,2))
C
C H*(NEW BASIS VECTOR)
C
            CALL HC0(NO,NU,C(1+1,2),C(1+NOU+1,2),
     *               C(1,3),FHP,VHPPH,TI)
            CALL HC1(NO,NU,C(1,2),C(1+1,2),C(1+NOU+1,2),
     *               C(1+1,3),FHP,FHH,FPP,VHPPH,VHHHP,VPPPH,TI,EH,EP)
            CALL HC2(NO,NU,C(1,2),C(1+1,2),C(1+NOU+1,2),
     *               C(1+NOU+1,3),FHP,FHH,FPP,VHHHH,VHHHP,VHPPH,VPPPH,
     *               AUX2,TI,EH,EP)
  500   CONTINUE
C
C BOTTOM OF MICROITERATION LOOP
C
         IMACRO=IMACRO+1
CCCX         IF(IMACRO.LT.NITER) GO TO 1000
        IF(ITERTOT.LT.MAXITCI) GO TO 1000
C
C BOTTOM OF MACROITERATION LOOP
C
 6050 CONTINUE
      WRITE(IW,9050)
C
 3000 CONTINUE
      CALL FLSHBF(IW)
      RETURN
C
 9000 FORMAT(/1X,'ITER MICRO  MAX CI CHANGE    CISD CORRELATION ENERGY')
 9010 FORMAT(1X,I3,I5,F14.7,2X,F15.10)
 9030 FORMAT(1X,'CISD CONVERGED, THE CISD ENERGY FOR STATE',I3,
     *          ' =',F20.10)
 9040 FORMAT(1X,'DIAGS: MAX. ALLOWED NORM OF RESIDUAL MATRIX HAS',
     *          ' BEEN EXCEEDED')
 9050 FORMAT(1X,'CISD ITERATIONS NOT CONVERGED')
      END
C
C       THIS WAS INTT3.F SOURCE FILE
C
C*MODULE MM23    *DECK DRXINTRI
      SUBROUTINE DRXINTRI(IW,EXETYP,IXY,NO,NU)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /FMCOM / XX(1)
C
      DATA CHECK/8HCHECK   /
C
      NU3   = NU*NU*NU
      NOU   = NO*NU
      NO3U  = NO*NO*NO*NU
      NOU3  = NO*NU*NU*NU
      NO2U2 = NO*NO*NU*NU
C
      LNU3=NU3
      IF(NO3U.GT.NU3) LNU3=NO3U
C
      CALL VALFM(LOADFM)
C
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + LNU3
      I4   = I3     + NO2U2
      I5   = I4     + NOU3
      I6   = I5     + NOU
      I7   = I6     + NO2U2
      I8   = I7     + NOU3
      LAST = I8     + NO3U
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9010) ' XINTQUA',NEED
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 200
      CALL FLSHBF(IW)
C
      CALL ZEROMA(XX(I1),1,NEED)
      CALL XINTQUA(IXY,NO,NU,XX(I1),XX(I2),XX(I3),XX(I4),XX(I5),
     *             XX(I6),XX(I7),XX(I8))
C
  200 CONTINUE
      CALL RETFM(NEED)
C
      I1   = LOADFM + 1
      I2   = I1     + LNU3
      I3   = I2     + NOU
      I5   = I3     + NO2U2
      I6   = I5     + NOU3
      I7   = I6     + NOU3
      I8   = I7     + NOU
      I9   = I8     + NO2U2
      LAST = I9     + NOU
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9010) 'XINTRIPL',NEED
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 300
      CALL FLSHBF(IW)
C
      CALL ZEROMA(XX(I1),1,NEED)
      CALL XINTRIPL(IXY,NO,NU,XX(I1),XX(I2),XX(I3),XX(I5),XX(I6),
     *              XX(I7),XX(I8),XX(I9))
C
  300 CONTINUE
      CALL RETFM(NEED)
C
      I1   = LOADFM + 1
      I2   = I1     + LNU3
      I3   = I2     + NOU
      I4   = I3     + NO2U2
      I5   = I4     + NO3U
      I6   = I5     + NO3U
      I7   = I6     + NOU3
      I8   = I7     + NOU
      I9   = I8     + NO2U2
      LAST = I9     + NO3U
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9010) ' XINTRIH',NEED
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 400
C
      CALL ZEROMA(XX(I1),1,NEED)
      CALL XINTRIH(IXY,NO,NU,XX(I1),XX(I2),XX(I3),XX(I4),XX(I5),
     *             XX(I6),XX(I7),XX(I8),XX(I9))
C
  400 CONTINUE
      CALL RETFM(NEED)
      RETURN
C
 9010 FORMAT(1X,'MEMORY REQUIRED FOR ',A9,'=',I12)
      END
C
C*MODULE MM23     *DECK XINTRIH
      SUBROUTINE XINTRIH(IXY,NO,NU,TI,FHP,T2,VM,VM1,VE,R1,R2,ZXX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION TI(*),T2(*),FHP(*),VE(*),VM(*),VM1(*),R1(*),R2(*),
     *          ZXX(*)
C
      DATA ZERO/0.0D+00/, ONE/1.0D+00/, OM/-1.0D+00/
C
      NO2   = NO*NO
      NO3   = NO*NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NO3U  = NO*NO*NO*NU
C
C THIS PART IS TO BE MULTIPLIED BY (R_0*T_2+R_2) I.E. ONLY T1 & T2
C CLUSTER AMPLITUDES ENTER THIS PART OF THE CODE
       IF(IXY.EQ.0) THEN
      CALL RO2(1,NO,NU,T2)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2,12)
      CALL RDVM(2,NO,NU,VM)
      CALL RDVEM4(1,NU,NO,TI,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 RDVE(2,NO,NU,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 RO1(1,NO,NU,FHP)
      CALL RO2(3,NO,NU,T2)
      CALL TRANSQ(T2,NOU)
      CALL TRANMD(VM1,NO,NO,NO,NU,12)
      CALL DGEMM('N','N',NO,NO2U,NU,ONE,FHP,NO,T2,NU,ONE,VM1,NO)
      CALL TRANMD(VM1,NO,NO,NO,NU,231)
      CALL RO2(4,NO,NU,T2)
      CALL TRANSQ(T2,NOU)
      CALL DGEMM('N','N',NO,NO2U,NU,ONE,FHP,NO,T2,NU,ONE,VM1,NO)
      CALL TRANMD(VM1,NO,NO,NO,NU,312)
      CALL RDOV4(1,NU,NO,TI,VM)
      CALL TRANMD(VM1,NO,NO,NO,NU,12)
      CALL MTRANS(VM,NO,7)
      CALL DGEMM('N','N',NO3,NU,NO,OM,VM,NO3,FHP,NO,ONE,VM1,NO3)
      CALL WRVM(3,NO,NU,VM1)
       END IF
C
C THIS PART IS TO BE MULTIPLIED BY T2 I.E. R_1 & R_2 AMPLITUDES
C ARE USED HERE
C C ***
CCC
CCCX      I=1
CCC
      CALL RR1(NO,NU,R1)
      CALL RR2(NO,NU,R2)
      CALL RO2(1,NO,NU,T2)
      CALL TRANSQ(R2,NOU)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,R2,12)
      CALL INSITU(NU,NO,NO,NU,TI,T2,12)
      CALL RDVM(2,NO,NU,VM)
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL EXRDVM(4,NO,NU,ZXX)
C ----------------------------------------
CCC THIS TERM IS OMMITED
CCC      CALL RDVEM4(1,NU,NO,TI,VM1)
      CALL ZEROMA(VM1,1,NO3U)
      CALL SYMT21(R2,NO,NU,NO,NU,13)
      CALL SYMT21(T2,NO,NU,NO,NU,13)
CCC DIAGRAM:V-G,V-H,III-I,III-J
      CALL DGEMM('N','N',NO2,NOU,NOU,ONE,VM,NO2,R2,NOU,ONE,VM1,NO2)
      CALL DGEMM('N','N',NO2,NOU,NOU,ONE,ZXX,NO2,T2,NOU,ONE,VM1,NO2)
CCC
      CALL DESM21(R2,NO,NU,NO,NU,13)
      CALL DESM21(T2,NO,NU,NO,NU,13)
      CALL TRANMD(VM,NO,NO,NO,NU,23)
      CALL TRANMD(ZXX,NO,NO,NO,NU,23)
CCC DIAGRAM:V-I,III-K
      CALL DGEMM('N','N',NO2,NOU,NOU,OM,VM,NO2,R2,NOU,ONE,VM1,NO2)
      CALL DGEMM('N','N',NO2,NOU,NOU,OM,ZXX,NO2,T2,NOU,ONE,VM1,NO2)
CCC
      CALL TRANMD(R2,NO,NU,NO,NU,13)
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL TRANMD(VM1,NO,NO,NO,NU,13)
CCC DIAGRAM:V-J,III-L
      CALL DGEMM('N','N',NO2,NOU,NOU,OM,VM,NO2,R2,NOU,ONE,VM1,NO2)
      CALL DGEMM('N','N',NO2,NOU,NOU,OM,ZXX,NO2,T2,NOU,ONE,VM1,NO2)
CCC
      CALL TRANMD(T2,NO,NU,NO,NU,13)
      CALL TRANMD(R2,NO,NU,NO,NU,13)
      CALL TRANMD(VM,NO,NO,NO,NU,23)
      CALL TRANMD(ZXX,NO,NO,NO,NU,23)
      CALL TRANMD(VM1,NO,NO,NO,NU,231)
      CALL INSITU(NO,NU,NO,NU,TI,R2,23)
      CALL RDVE(2,NO,NU,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,13)
CCC DIAGRAM:V-F,IV-E
      CALL DGEMM('N','N',NO2,NOU,NU2,ONE,R2,NO2,VE,NU2,ZERO,VM,NO2)
      CALL VMCP(NO,NU,VM1,VM)
CCC
      CALL INSITU(NO,NU,NO,NU,TI,T2,23)
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL EXRDVE(4,NO,NU,VE)
C ----------------------------------------
      CALL TRANMD(VE,NU,NU,NU,NO,13)
      CALL DGEMM('N','N',NO2,NOU,NU2,ONE,T2,NO2,VE,NU2,ZERO,ZXX,NO2)
      CALL VMCP(NO,NU,VM1,ZXX)
      CALL TRANMD(VM1,NO,NO,NO,NU,231)
CCC
CCC
CCC
CCC
CCC
CCC
CCC
CCC R1 ALREADY IN
CCC      CALL RO1(1,NO,NU,FHP)
CCC      CALL RO2(3,NO,NU,T2)
      CALL RO2(3,NO,NU,T2)
      CALL TRANSQ(T2,NOU)
      CALL TRANMD(VM1,NO,NO,NO,NU,12)
CCC DIAGRAMS:III-B,III-C,III-F,III-H
      CALL DGEMM('N','N',NO,NO2U,NU,ONE,R1,NO,T2,NU,ONE,VM1,NO)
CCC DIAGRAM IV-B
       CALL R4B(NO,NU,T2)
       CALL TRANSQ(T2,NOU)
       CALL RO1(1,NO,NU,FHP)
       CALL DGEMM('N','N',NO,NO2U,NU,ONE,FHP,NO,T2,NU,ONE,VM1,NO)
CCC DIAGRAM IV-D
       CALL R4D(NO,NU,T2)
       CALL TRANSQ(T2,NOU)
       CALL RO1(1,NO,NU,FHP)
       CALL DGEMM('N','N',NO,NO2U,NU,ONE,FHP,NO,T2,NU,ONE,VM1,NO)
CCC
CCC
      CALL TRANMD(VM1,NO,NO,NO,NU,231)
CCC
CCC
CCC DIAGRAMS:III-A,III-D,III-E,III-G
      CALL RO2(6,NO,NU,T2)
C *** IMPORTANT - LAST MODIFICATION
      CALL TRANMD(T2,NO,NU,NU,NO,14)
C ****
      CALL TRANSQ(T2,NOU)
      CALL DGEMM('N','N',NO,NO2U,NU,ONE,R1,NO,T2,NU,ONE,VM1,NO)
CCC DIAGRAM: IV-C
       CALL R4C(NO,NU,T2)
       CALL TRANSQ(T2,NOU)
       CALL RO1(1,NO,NU,FHP)
       CALL DGEMM('N','N',NO,NO2U,NU,ONE,FHP,NO,T2,NU,ONE,VM1,NO)
CCC
CCC
CCC DIAGRAM: IV-A
      CALL TRANMD(VM1,NO,NO,NO,NU,312)
      CALL RDOV4(1,NU,NO,TI,VM)
      CALL TRANMD(VM1,NO,NO,NO,NU,12)
      CALL MTRANS(VM,NO,7)
      CALL DGEMM('N','N',NO3,NU,NO,OM,VM,NO3,R1,NO,ONE,VM1,NO3)
CCC VM1 WPISUJE NA TO CO TRZEBA
CCC
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL WREXXVM(5,NO,NU,VM1)
C ----------------------------------------
      RETURN
      END
C
C*MODULE MM23     *DECK XINTQUA
      SUBROUTINE XINTQUA(IXY,NO,NU,O1,TI,VOE,VE,R1,EXVOE,EXVE,ZXX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION TI(*),VOE(*),VE(*),O1(*),EXVOE(*),EXVE(*),ZXX(*),R1(*)
C
      DATA ONE/1.0D+00/, OM/-1.0D+00/, ZERO/0.0D+00/
C
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
C
C DIAGRAMS: IV-A AND II-A COMPUTED DIRECTLY IN INTRIH AND INTRIPL!
C
C CHI^{IJ}_{KA}=V^{IJ}_{KA}+T^{E}_{K}*V^{IJ}_{EA}:
C USED IN DIAGRAMS: II-E,V-F,V-G,V-H,V-I,V-J
C
      CALL RO1(1,NO,NU,O1)
      CALL RO2HPP(1,NO,NU,TI,VOE)
      CALL TRANSQ(VOE,NOU)
      CALL RDVEM4(1,NU,NO,TI,VE)
      CALL DGEMM('N','N',NO,NO2U,NU,ONE,O1,NO,VOE,NU,ONE,VE,NO)
      CALL WRVM(2,NO,NU,VE)
C GAMMA^{IJ}_{KA}(IEX)=R^{E}_{K}(IEX)*V^{IJ}_{EA}
C USED IN DIAGRAMS:III-I,III-J,III-K,III-L
CCCX      I=1
       CALL RR1(NO,NU,R1)
       CALL DGEMM('N','N',NO,NO2U,NU,ONE,R1,NO,VOE,NU,ZERO,EXVE,NO)
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
       CALL EXWRVM(4,NO,NU,EXVE)
C ----------------------------------------
C
C CHI^{AI}_{BC}=V^{AI}_{BC}-T^{A}_{M}*V^{MI}_{BC}
C USED IN DIAGRAMS: IV-E,V-A,V-B,V-C,V-D,V-E
C                   I-H,I-J,I-K,I-L
      CALL TRANSQ(VOE,NOU)
      CALL RDVEM4(0,NO,NU,TI,VE)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,O1,NO,VOE,NO,ONE,VE,NU)
      CALL WRVE(2,NO,NU,VE)
C DELTA^{AI}_{BC}(IEX)=-R^{A}_{M}(IEX)*V^{MI}_{BC}
CCCX       I=1
       CALL RR1(NO,NU,R1)
       CALL DGEMM('T','N',NU,NOU2,NO,OM,R1,NO,VOE,NO,ZERO,EXVE,NU)
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
       CALL EXWRVE(4,NO,NU,EXVE)
C ----------------------------------------
C
C
C
C INTERMEDIATE B1+(A2+B2)+B3+(A4+B4) USED BY S.A.K.(3)
C PERTAINS ALSO DIAGRAMS:I-A',I-C,I-D',I-F
C                        III-B,III-C,III-F,III-H
C
      CALL TRANMD(VE,NU,NU,NU,NO,12)
      CALL DGEMM('N','N',NO,NOU2,NU,ONE,O1,NO,VE,NU,ONE,VOE,NO)
      CALL TRANMD(VOE,NO,NU,NU,NO,1234)
      CALL TRANSQ(VOE,NOU)
      CALL RDVEM4(1,NU,NO,TI,VE)
      CALL DGEMM('T','N',NU,NO2U,NO,OM,O1,NO,VE,NO,ONE,VOE,NU)
      CALL TRANSQ(VOE,NOU)
      CALL TRANMD(VOE,NO,NU,NU,NO,1234)
      CALL WO2(3,NO,NU,VOE)
C
C
C INTERMEDIATE A1(4)+A2(4) USED BY S.A.K.
C
      CALL RO2HPP(2,NO,NU,TI,VOE)
      CALL TRANSQ(VOE,NOU)
      CALL TRANMD(VE,NO,NO,NO,NU,13)
      CALL DGEMM('T','N',NU,NO2U,NO,OM,O1,NO,VE,NO,ONE,VOE,NU)
      CALL TRANMD(VE,NO,NO,NO,NU,13)
      CALL TRANSQ(VOE,NOU)
      CALL TRANMD(VOE,NO,NU,NU,NO,1234)
      CALL WO2(4,NO,NU,VOE)
C
C
C INTERMEDIATE A1(5)+A3(5) USED BY S.A.K.
C
      CALL RO2HPP(2,NO,NU,TI,VOE)
      CALL RDVEM4(0,NO,NU,TI,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,13)
      CALL DGEMM('N','N',NO,NOU2,NU,ONE,O1,NO,VE,NU,ONE,VOE,NO)
      CALL WO2(5,NO,NU,VOE)
C
C DIAGRAM: 0-C
C
      CALL RO2HPP(1,NO,NU,TI,VOE)
CCCX      I=1
       CALL RR1(NO,NU,R1)
       CALL TRT1(NO,NU,TI,R1)
       CALL SYMT21(VOE,NO,NU,NU,NO,23)
       CALL DGEMM('N','N',NOU,1,NOU,ONE,VOE,NOU,R1,NOU,ZERO,O1,NOU)
       CALL WOO1(NO,NU,O1)
C
C NO R1 AMPLITUDES ARE REQUIRED HERE
C INT.II
C A1(5)+2*A2+A3(5)+2*A4 DIAG:I-A,I-C',I-B,I-G
C                       DIAG:III-A,III-D,III-E,III-G
C
        IF(IXY.EQ.0) THEN
       CALL RO1(1,NO,NU,O1)
       CALL RO2HPP(2,NO,NU,TI,VOE)
       CALL RDVEM4(0,NO,NU,TI,VE)
       CALL TRANMD(VE,NU,NU,NU,NO,13)
       CALL DGEMM('N','N',NO,NOU2,NU,ONE,O1,NO,VE,NU,ONE,VOE,NO)
       CALL RDVEM4(1,NU,NO,TI,ZXX)
       CALL TRANMD(ZXX,NO,NO,NO,NU,23)
       CALL RO2HPP(1,NO,NU,TI,EXVOE)
C *** ODWYRTKA W V
           CALL TRANMD(EXVOE,NO,NU,NU,NO,23)
C *************
       CALL TRANSQ(EXVOE,NOU)
       CALL DGEMM('N','N',NO,NO2U,NU,ONE,O1,NO,EXVOE,NU,ONE,ZXX,NO)
       CALL TRANMD(ZXX,NO,NO,NO,NU,312)
       CALL TRANSQ(VOE,NOU)
       CALL DGEMM('T','N',NU,NO2U,NO,OM,O1,NO,ZXX,NO,ONE,VOE,NU)
       CALL TRANSQ(VOE,NOU)
CCC COMMENTED BY KK - COMPATIBLE WITH WO2(REC=5)
CCC           CALL TRANMD(VOE,NO,NU,NU,NO,14)
        CALL TRANMD(VOE,NO,NU,NU,NO,23)
       CALL WO2(6,NO,NU,VOE)
         END IF
C
C R1-REQURED, DIAGRAM: II-C
       CALL RDVEM4(0,NO,NU,TI,VE)
       CALL TRANMD(VE,NU,NU,NU,NO,23)
CCCX       I=1
        CALL RR1(NO,NU,R1)
        CALL DGEMM('N','N',NO,NOU2,NU,ONE,R1,NO,VE,NU,ZERO,VOE,NO)
C COMMENTED BY KK - COMPATIBLE WITH WO2(REC=3)
C###    CALL TRANMD(VOE,NO,NU,NU,NO,14)
        CALL TRANMD(VOE,NO,NU,NU,NO,23)
C ***
        CALL W2C(NO,NU,VOE)
C R1-REQUIRED, DIAGRAM:IV-C
       CALL RDVEM4(1,NU,NO,TI,ZXX)
       CALL TRANMD(ZXX,NO,NO,NO,NU,231)
CCCX       I=1
        CALL RR1(NO,NU,R1)
        CALL DGEMM('T','N',NU,NO2U,NO,OM,R1,NO,ZXX,NO,ZERO,VOE,NU)
        CALL TRANSQ(VOE,NOU)
        CALL TRANMD(VOE,NO,NU,NU,NO,23)
C BY KK - COMPATIBLE WITH RO2(4)
        CALL TRANMD(VOE,NO,NU,NU,NO,14)
        CALL W4C(NO,NU,VOE)
C R1-REQUIRED, DIAGRAM:IV-D
        CALL RO2HPP(1,NO,NU,TI,VOE)
        CALL TRANSQ(VOE,NOU)
C ADDED BY KK
        CALL TRANMD(VOE,NU,NO,NO,NU,14)
        CALL RO1(1,NO,NU,O1)
        CALL DGEMM('N','N',NO,NO2U,NU,ONE,O1,NO,VOE,NU,ZERO,ZXX,NO)
        CALL TRANMD(ZXX,NO,NO,NO,NU,13)
CCCX        I=1
         CALL RR1(NO,NU,R1)
         CALL DGEMM('T','N',NU,NOU2,NO,OM,R1,NO,ZXX,NO,ZERO,EXVOE,NU)
         CALL TRANSQ(EXVOE,NOU)
C COMMENTED BY KK - COMPATIBLE WITH RO2(3)
C         CALL TRANMD(EXVOE,NO,NU,NU,NO,14)
         CALL TRANMD(EXVOE,NO,NU,NU,NO,23)
         CALL W4D(NO,NU,EXVOE)
C
C
C R1-REQUIRED, DIAGRAMS:II-B,II-D
       CALL RDVEM4(0,NO,NU,TI,VE)
       CALL TRANMD(VE,NU,NU,NU,NO,23)
       CALL RO2HPP(1,NO,NU,TI,EXVOE)
       CALL TRANMD(EXVOE,NO,NU,NU,NO,23)
       CALL DGEMM('T','N',NU,NOU2,NO,OM,O1,NO,EXVOE,NO,ONE,VE,NU)
       CALL TRANMD(VE,NU,NU,NU,NO,12)
CCCX       I=1
        CALL RR1(NO,NU,R1)
        CALL DGEMM('N','N',NO,NOU2,NU,ONE,R1,NO,VE,NU,ZERO,VOE,NO)
C COMMENTED BY KK - COMPATIBLE WITH WO2(REC=5)
C###        CALL TRANMD(VOE,NO,NU,NU,NO,14)
          CALL TRANMD(VOE,NO,NU,NU,NO,23)
        CALL W2BD(NO,NU,VOE)
C
C
C R1-REQUIRED, DIAGRAM: IV-B
       CALL RDVEM4(1,NU,NO,TI,ZXX)
CCCX       I=1
        CALL RR1(NO,NU,R1)
        CALL DGEMM('T','N',NU,NO2U,NO,OM,R1,NO,ZXX,NO,ZERO,VOE,NU)
        CALL TRANSQ(VOE,NOU)
        CALL TRANMD(VOE,NO,NU,NU,NO,23)
C ADED BY KK - COMPATIBLE WITH WO2(REC=3)
        CALL TRANMD(VOE,NO,NU,NU,NO,14)
        CALL W4B(NO,NU,VOE)
C
      RETURN
      END
C
C*MODULE MM23    *DECK XINTRIPL
      SUBROUTINE XINTRIPL(IXY,NO,NU,TI,FPH,T2,VE,VE1,R1,R2,O1)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION TI(*),FPH(NO,NU),T2(*),VE(NU,NU,NU,NO),VE1(*),
     *          R1(NO,NU),R2(*),O1(*)
C
      DATA ONE/1.0D+00/,OM/-1.0D+00/
C
      NO2   = NO*NO
      NU2   = NU*NU
      NU3   = NU*NU*NU
      NOU   = NO*NU
      NOU2  = NO*NU*NU
      NOU3  = NO*NU*NU*NU
C
CC UWAGA TI MOZE ZASTEPOWAC VM
CC INTERMEDIATE J(I,A) - IN CCSD PROGRAM STORED ON THE DISC
C
      CALL XRF(NO,NU,FPH)
      CALL RO1(1,NO,NU,O1)
      CALL RO2HPP(1,NO,NU,TI,T2)
      CALL TRT1(NO,NU,TI,O1)
      CALL SYMT21(T2,NO,NU,NU,NO,23)
      CALL DGEMM('N','N',NOU,1,NOU,ONE,T2,NOU,O1,NOU,ONE,FPH,NOU)
CCC FOR DIAGRAM VI-A
      CALL WO1(2,NO,NU,FPH)
CC
CC THIS PART IS TO BE MULTIPLIED BY (R_0*T_2+R_2) I.E. ONLY T1 & T2
CC CLUSTER AMPLITUDES ENTER THIS PART OF THE CODE
        IF(IXY.EQ.0) THEN
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL RDVE(2,NO,NU,VE)
      CALL RDVEM4(0,NO,NU,TI,VE1)
      CALL SYMT21(T2,NU,NO,NU,NO,13)
      CALL DGEMM('N','N',NU2,NOU,NOU,ONE,VE,NU2,T2,NOU,ONE,VE1,NU2)
      CALL DESM21(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL DGEMM('N','N',NU2,NOU,NOU,OM,VE,NU2,T2,NOU,ONE,VE1,NU2)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE1,NU,NU,NU,NO,13)
      CALL DGEMM('N','N',NU2,NOU,NOU,OM,VE,NU2,T2,NOU,ONE,VE1,NU2)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
      CALL INSITU(NU,NO,NU,NO,TI,T2,23)
      CALL RDVM(2,NO,NU,TI)
      CALL VMCP2(NO,NU,VE,TI)
      CALL TRANMD(VE,NO,NO,NU,NO,14)
      CALL DGEMM('N','N',NU2,NOU,NO2,ONE,T2,NU2,VE,NO2,ONE,VE1,NU2)
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
      CALL RO2(1,NO,NU,T2)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,FPH,NO,T2,NO,ONE,VE1,NU)
      CALL RO1(1,NO,NU,FPH)
      CALL RO2(3,NO,NU,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL TRANMD(VE1,NU,NU,NU,NO,12)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,FPH,NO,T2,NO,ONE,VE1,NU)
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
      CALL RO2(5,NO,NU,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,FPH,NO,T2,NO,ONE,VE1,NU)
        DO I=1,NU
      CALL RDVPPT(I,NO,NU,TI)
      CALL DGEMM('N','N',NU3,NO,1,ONE,TI,NU3,FPH(1,I),1,ONE,VE1,NU3)
      ENDDO
      CALL TRANMD(VE1,NU,NU,NU,NO,13)
CCC
      CALL WRVE(3,NO,NU,VE1)
        END IF
C
C***
CCC
CCC THIS PART IS TO BE MULTIPLIED BY T2 I.E. R_1 & R_2 AMPLITUDES
CCC ARE USED HERE
CCC
      I=1
CCC
      CALL RR1(NO,NU,R1)
      CALL RR2(NO,NU,R2)
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL INSITU(NO,NU,NU,NO,TI,R2,12)
      CALL RDVE(2,NO,NU,VE)
CCC
      CALL ZEROMA(VE1,1,NOU3)
      CALL SYMT21(R2,NU,NO,NU,NO,13)
      CALL SYMT21(T2,NU,NO,NU,NO,13)
CCC DIAGRAMS:V-A,V-B,I-H,I-J - #####
      CALL DGEMM('N','N',NU2,NOU,NOU,ONE,VE,NU2,R2,NOU,ONE,VE1,NU2)
      CALL DESM21(R2,NU,NO,NU,NO,13)
      CALL DESM21(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
CCC DIAGRAM: V-C,I-K
      CALL DGEMM('N','N',NU2,NOU,NOU,OM,VE,NU2,R2,NOU,ONE,VE1,NU2)
      CALL TRANMD(R2,NU,NO,NU,NO,13)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE1,NU,NU,NU,NO,13)
CCC DIAGRAM: V-D, I-L - ####
      CALL DGEMM('N','N',NU2,NOU,NOU,OM,VE,NU2,R2,NOU,ONE,VE1,NU2)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL TRANMD(R2,NU,NO,NU,NO,13)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
      CALL INSITU(NU,NO,NU,NO,TI,R2,23)
      CALL INSITU(NU,NO,NU,NO,TI,T2,23)
      CALL RDVM(2,NO,NU,TI)
      CALL VMCP2(NO,NU,VE,TI)
      CALL TRANMD(VE,NO,NO,NU,NO,14)
CCC DIAGRAM: V-E
      CALL DGEMM('N','N',NU2,NOU,NO2,ONE,R2,NU2,VE,NO2,ONE,VE1,NU2)
C
C
C
C VE1 DO POZYCJI POCZATKOWEJ+ZAMIANA ZXX=>VE
      CALL TRANMD(VE1,NU,NU,NU,NO,23)
      CALL ZEROMA(VE,1,NOU3)
      CALL RR1(NO,NU,R1)
      CALL RR2(NO,NU,R2)
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL INSITU(NO,NU,NU,NO,TI,R2,12)
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL EXRDVE(4,NO,NU,VE)
C ----------------------------------------
CCC
      CALL SYMT21(R2,NU,NO,NU,NO,13)
      CALL SYMT21(T2,NU,NO,NU,NO,13)
CCC DIAGRAMS:V-A,V-B,I-H,I-J - #####
      CALL DGEMM('N','N',NU2,NOU,NOU,ONE,VE,NU2,T2,NOU,ONE,VE1,NU2)
      CALL DESM21(R2,NU,NO,NU,NO,13)
      CALL DESM21(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
CCC DIAGRAM: V-C,I-K
      CALL DGEMM('N','N',NU2,NOU,NOU,OM,VE,NU2,T2,NOU,ONE,VE1,NU2)
      CALL TRANMD(R2,NU,NO,NU,NO,13)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE1,NU,NU,NU,NO,13)
CCC DIAGRAM: V-D, I-L - ####
      CALL DGEMM('N','N',NU2,NOU,NOU,OM,VE,NU2,T2,NOU,ONE,VE1,NU2)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL TRANMD(R2,NU,NO,NU,NO,13)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
      CALL INSITU(NU,NO,NU,NO,TI,R2,23)
      CALL INSITU(NU,NO,NU,NO,TI,T2,23)
CCC
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL EXRDVM(4,NO,NU,TI)
C ----------------------------------------
      CALL VMCP2(NO,NU,VE,TI)
      CALL TRANMD(VE,NO,NO,NU,NO,14)
CCC DIAGRAM: II-E
      CALL DGEMM('N','N',NU2,NOU,NO2,ONE,T2,NU2,VE,NO2,ONE,VE1,NU2)
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
CCC
CCC
CCC ONE-BODY INTERMEDIATE
CCC DIAGRAM:0-C
      CALL RO2(1,NO,NU,T2)
      CALL ROO1(NO,NU,FPH)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,FPH,NO,T2,NO,ONE,VE1,NU)
CCC DIAGRAM:VI-A
      CALL RR2(NO,NU,R2)
      CALL RO1(2,NO,NU,FPH)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,FPH,NO,R2,NO,ONE,VE1,NU)
CCC
CCC    DIAGRAMS:I-A',I-C,I-D',I-F (2)
CCC    DIAGRAM: II-C
      CALL RR1(NO,NU,R1)
      CALL RO2(3,NO,NU,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL TRANMD(VE1,NU,NU,NU,NO,12)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,R1,NO,T2,NO,ONE,VE1,NU)
      CALL R2C(NO,NU,T2)
      CALL RO1(1,NO,NU,FPH)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,FPH,NO,T2,NO,ONE,VE1,NU)
      CALL TRANMD(VE1,NU,NU,NU,NO,231)
C
C
CC DIAGRAMS: I-A,I-C',I-B,I-G (1)
CC           II-B,II-D
      CALL RR1(NO,NU,R1)
      CALL RO2(6,NO,NU,T2)
C *** IMPORTANT - LAST MODIFICATION
      CALL TRANMD(T2,NO,NU,NU,NO,23)
C ****
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,R1,NO,T2,NO,ONE,VE1,NU)
      CALL RO1(1,NO,NU,FPH)
      CALL R2BD(NO,NU,T2)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL DGEMM('T','N',NU,NOU2,NO,OM,FPH,NO,T2,NO,ONE,VE1,NU)
CCC
CCC
CC DIAGRAM: II-A
      CALL RR1(NO,NU,R1)
      DO IK=1,NU
      CALL RDVPPT(IK,NO,NU,TI)
      CALL DGEMM('N','N',NU3,NO,1,ONE,TI,NU3,R1(1,IK),1,ONE,VE1,NU3)
      ENDDO
      CALL TRANMD(VE1,NU,NU,NU,NO,13)
CC
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL WREXXVE(5,NO,NU,VE1)
C ----------------------------------------
      RETURN
      END
C
C       THIS WAS T3WT2.F SOURCE FILE, USED IN MM(2,3) PROGRAM
C
C*MODULE MM23     *DECK DRXT3WT2
      SUBROUTINE DRXT3WT2(IW,ESCF,ECCSD,BESTEOM,EXETYP,IXY,NO,NU,EH,EP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 VECREP
C
      DIMENSION EH(NO),EP(NU)
C
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
      COMMON /FMCOM / XX(1)
      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 /EOMINF/ ISPACE,IHSPACE,JCISPACE,ICIMET,IOPTMM,
     *                NROOT,NOA,NUA,MAXITEOM
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      DATA ONE/1.0D+00/
      DATA CHECK/8HCHECK   /
C
      NO2   = NO*NO
      NU2   = NU*NU
      NU3   = NU*NU*NU
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NO3U  = NO*NO*NO*NU
      NOU2  = NO*NU*NU
      NOU3  = NO*NU*NU*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
C
C     ---- THIS IS METHOD 1 ----
C
      IF(IOPTMM.EQ.1) THEN
C
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + NO2U2
      I4   = I3     + NOU
      LAST = I4     + NO2U2
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9010) '  DEN12CR',NEED,IOPTMM
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 100
C
      CALL FLSHBF(IW)
      CALL ZEROMA(XX(I1),1,NEED)
      CALL DEN12CR(NO,NU,XX(I1),XX(I2),XX(I3),XX(I4))
C
  100 CONTINUE
      CALL RETFM(NEED)
      END IF
C
C     ---- THIS IS COMBINED SETUP FOR METHOD 2,3,4 ----
C     METHOD 1 DOES NOT PERFORM THE CI-SD, AND SO IS DIFFERENT
C
      IF(IOPTMM.GT.1) THEN
C
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + NO2U2
      I4   = I3     + NOU
      I5   = I4     + NO2U2
      I6   = I5     + 1
      I7   = I6     + NOU
      LAST = I7     + NO2U2
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9010) '   DEN12N',NEED,IOPTMM
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 200
C
      CALL ZEROMA(XX(I1),1,NEED)
C
      IF(IXY.EQ.0) THEN
         ICIREC=1
      ELSE
         ICIREC=IREL(IXY)
      END IF
      IF(ICIREC.NE.0) THEN
         CALL RCCFL(JCISD,ICIREC,1+NOU+NO2U2,XX(I5))
      ELSE
C--      WRITE(IW,9030)
      END IF
C
      CALL FLSHBF(IW)
      CALL DEN12N(NO,NU,XX(I1),XX(I2),XX(I3),XX(I4),XX(I5),
     *            XX(I6),XX(I7))
C
  200 CONTINUE
      CALL RETFM(NEED)
      END IF
C
C     ---- THIS IS METHOD 2 ----
C     NAMELY, CR-CCSD(T) + CI3
C
      IF(IOPTMM.EQ.2) THEN
C
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + NO2U2
      I4   = I3     + NO3U
      I5   = I4     + NOU3
      I6   = I5     + NU3
      I7   = I6     + NU3
      I8   = I7     + NO2U2
      I9   = I8     + NOU
      I10  = I9     + NO2U2
      I11  = I10    + NO2U2
      I12  = I11    + NOU3
      I13  = I12    + NO3U
      I14  = I13    + NO2U2
      I15  = I14    + NU3
      I16  = I15    + NO
      I17  = I16    + NU
      I18  = I17    + 2*NU2
      I19  = I18    + 2*NO2
      I20  = I19    + 2*NOU
      I21  = I20    + 2*NOU2
      I22  = I21    + 2*NO2U
      I23  = I22    + NO3U
      I24  = I23    + NOU3
      I25  = I24    + 2*NU2
      I26  = I25    + 2*NO2
      I27  = I26    + 2*NOU
      LAST = I27    + NOU
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9010) ' XT3WT2N',NEED,IOPTMM
      IF(NEED.GT.NGOTMX) THEN
        WRITE(IW,9020)
        IOPTMM=4
        GO TO 4554
      END IF
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 300
C
      CALL ZEROMA(XX(I1),1,NEED)
      IF(IXY.EQ.0) THEN
         ICIREC=1
      ELSE
         ICIREC=IREL(IXY)
      END IF
      IF(ICIREC.NE.0) THEN
         CALL RCCFL(JCISD,ICIREC,1+NOU+NO2U2,XX(I1))
         CALL WCCFL(NT2,7,NO2U2,XX(I1+NOU+1))
         CALL VOOCPX(NOU,XX(I27),XX(I1+1),ONE)
      ELSE
         WRITE(IW,9030)
      END IF
C
      CALL FLSHBF(IW)
      CALL XT3WT2N(ESCF,ECCSD,BESTEOM,NO,NU,
     *             XX(I1),XX(I2),XX(I3),XX(I4),XX(I5),XX(I6),
     *             XX(I7),XX(I8),XX(I9),XX(I10),XX(I11),XX(I12),
     *             XX(I13),XX(I14),XX(I15),XX(I16),XX(I17),XX(I18),
     *             XX(I19),XX(I20),XX(I21),XX(I22),XX(I23),XX(I24),
     *             XX(I25),XX(I26),XX(I27),EH,EP,IXY)
C
  300 CONTINUE
      CALL RETFM(NEED)
      END IF
C
C     ---- THIS IS METHOD 4, AND ALSO METHOD 1 AGAIN  ----
C     NAMELY, CR-CCSD(T) - LOW MEMORY
C
 4554 CONTINUE
      IF(IOPTMM.EQ.1.OR.IOPTMM.EQ.4) THEN
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + NO2U2
      I4   = I3     + NO3U
      I5   = I4     + NOU3
      I7   = I5     + NU3
      I8   = I7     + NOU
      I9   = I8     + NO2U2
      I10  = I9     + NOU3
      I11  = I10    + NO3U
      I12  = I11    + NO2U2
      I13  = I12    + NU3
      I14  = I13    + NO
      I15  = I14    + NU
      I16  = I15    + 2*NU2
      I17  = I16    + 2*NO2
      I18  = I17    + 2*NOU
      I19  = I18    + 2*NOU2
      I20  = I19    + 2*NO2U
      I21  = I20    + NOU
      I22  = I21    + NO2U2
      I23  = I22    + NU3
      I24  = I23    + NOU3
      I26  = I24    + NO3U
      I27  = I26    + NOU
      LAST = I27    + NO2U2
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9010) 'XT3WT2NNN',NEED,IOPTMM
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 400
C
      CALL FLSHBF(IW)
      CALL ZEROMA(XX(I1),1,NEED)
      CALL XT3WT2NNN(ESCF,ECCSD,BESTEOM,NO,NU,
     *               XX(I1),XX(I2),XX(I3),XX(I4),XX(I5),XX(I7),
     *               XX(I8),XX(I9),XX(I10),XX(I11),XX(I12),XX(I13),
     *               XX(I14),XX(I15),XX(I16),XX(I17),XX(I18),XX(I19),
     *               XX(I20),XX(I21),XX(I22),XX(I23),XX(I24),
     *               XX(I26),XX(I27),EH,EP,IXY)
C
  400 CONTINUE
      CALL RETFM(NEED)
      END IF
C
C     ---- THIS IS METHOD 3, AND METHOD 4 AGAIN ----
C     NAMELY, CI3 - LOW MEMORY
C
      IF(IOPTMM.EQ.3.OR.IOPTMM.EQ.4) THEN
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + NO2U2
      I4   = I3     + NO3U
      I5   = I4     + NOU3
      I6   = I5     + NU3
      I7   = I6     + NU3
      I8   = I7     + NO2U2
      I9   = I8     + NOU
      I10  = I9     + NO2U2
      I11  = I10    + NO2U2
      I12  = I11    + NO2U2
      I13  = I12    + NU3
      I14  = I13    + NO
      I15  = I14    + NU
      I16  = I15    + 2*NU2
      I17  = I16    + 2*NO2
      I18  = I17    + 2*NOU
      I19  = I18    + 2*NOU2
      I20  = I19    + 2*NO2U
      I21  = I20    + NO3U
      I22  = I21    + NOU3
      I23  = I22    + 2*NU2
      I24  = I23    + 2*NO2
      I25  = I24    + 2*NOU
      LAST = I25    + NOU
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9010) ' XT3WT2NN',NEED,IOPTMM
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 500
C
      CALL ZEROMA(XX(I1),1,NEED)
      IF(IXY.EQ.0) THEN
         ICIREC=1
      ELSE
         ICIREC=IREL(IXY)
      END IF
      IF(ICIREC.NE.0) THEN
         CALL RCCFL(JCISD,ICIREC,1+NOU+NO2U2,XX(I1))
         CALL WCCFL(NT2,7,NO2U2,XX(I1+NOU+1))
         CALL VOOCPX(NOU,XX(I25),XX(I1+1),ONE)
      ELSE
         WRITE(IW,9030)
      END IF
      CALL FLSHBF(IW)
C
      CALL XT3WT2NN(ESCF,ECCSD,BESTEOM,NO,NU,
     *              XX(I1),XX(I2),XX(I3),XX(I4),XX(I5),XX(I6),
     *              XX(I7),XX(I8),XX(I9),XX(I10),XX(I11),XX(I12),
     *              XX(I13),XX(I14),XX(I15),XX(I16),XX(I17),XX(I18),
     *              XX(I19),XX(I20),XX(I21),XX(I22),XX(I23),XX(I24),
     *              XX(I25),EH,EP,IXY)
C
  500 CONTINUE
      CALL RETFM(NEED)
      END IF
C
      RETURN
C
 9010 FORMAT(1X,'MEMORY REQUIRED FOR ',A9,'=',I12,' MTRIP=',I2)
 9020 FORMAT(1X,'       THE AVAILABLE MEMORY=',I12/
     *       1X,'THE PROGRAM WILL TRY USING MTHTRIP=4 CODE INSTEAD')
 9030 FORMAT(1X,'NO CISD ROOT HAS BEEN FOUND TO DESCRIBE',
     *          ' THE GIVEN EOMSD ROOT')
      END
C
C*MODULE MM23     *DECK XT3WT2N
      SUBROUTINE XT3WT2N(ESCF,ECCSD,BESTEOM,NO,NU,O1,T2,VM,VE,V3,T3,VOE,
     *                   R1,R2,GT2,EXVE,EXVM,AUXR2,U3,
     *                   AH,AP,APP,AHH,AHP,AX,BX,
     *                   GVM,GVE,HAPP,HAHH,HAHP,C1,EH,EP,IXY)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*3 VECREP
C
      DIMENSION O1(*),T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),VOE(*),V3(*),
     *          T3(*),VE(NU,NU,NU,NO),EH(NO),EP(NU),C1(*),
     *          GVM(NO,NU,NO,NO),GVE(NU,NU,NU,NO),
     *          EXVE(NU,NU,NU,NO),EXVM(NO,NU,NO,NO),
     *          R1(*),R2(NU,NU,NO,NO),GT2(NU,NU,NO,NO),
     *          AUXR2(NO,NU,NU,NO),U3(NU,NU,NU),
     *          AH(NO),AP(NU),
     *          AHH(NO,NO,2),AHP(NO,NU,2),APP(NU,NU,2),
     *          HAHH(NO,NO,2),HAHP(NO,NU,2),HAPP(NU,NU,2),
     *          AX(NU,NU,NO,2),BX(NU,NO,NO,2)
C
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
      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 /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      DATA ZERO/0.0D+00/, ONE/1.0D+00/, OM/-1.0D+00/
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
      NO2U2 = NO*NO*NU*NU
C
C     IMPORTANT FOR CI3 DENOMINATOR
C
      XSTEER=ONE
C
      CALL RO2HPP(1,NO,NU,V3,VOE)
      CALL INSITU(NO,NU,NU,NO,V3,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
C
      CALL RDVEM4(0,NO,NU,V3,GVE)
      CALL TRANMD(GVE,NU,NU,NU,NO,23)
      CALL RDVEM4(1,NU,NO,V3,T2)
      CALL VMCP1(NO,NU,GVM,T2)
      CALL TRANMD(GVM,NO,NU,NO,NO,13)
C
      CALL RCCFL(ITAPP,1,NO,AH)
      CALL RCCFL(ITAPP,2,NU,AP)
      CALL RCCFL(ITAPP,3,2*NU2,APP)
      CALL RCCFL(ITAPP,4,2*NO2,AHH)
      CALL RCCFL(ITAPP,5,2*NOU,AHP)
      CALL RCCFL(ITAPP,6,2*NU2,HAPP)
      CALL RCCFL(ITAPP,7,2*NO2,HAHH)
      CALL RCCFL(ITAPP,8,2*NOU,HAHP)
      CALL RCCFL(IFAX,1,2*NOU2,AX)
      CALL RCCFL(IFAX,2,2*NO2U,BX)
C
      CALL RDVE(3,NO,NU,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL RDVM(3,NO,NU,GT2)
      CALL VMCP1(NO,NU,VM,GT2)
      CALL TRANMD(VM,NO,NU,NO,NO,13)
C
C MAIN LOOP OVER ALL EXCITED STATES
C
      II=1
C ON R2 VECTOR WE KEEP R2(EOMCCSD)+R_0(EOMCCSD)*T2
      CALL RR1(NO,NU,R1)
      CALL RR2(NO,NU,R2)
      CALL RR2(NO,NU,AUXR2)
      CALL INSITU(NO,NU,NU,NO,V3,R2,13)
C
      CALL RO2(1,NO,NU,GT2)
      CALL RO1(1,NO,NU,O1)
      CALL INSITU(NO,NU,NU,NO,V3,GT2,13)
      CALL VECMUL(GT2,NO2U2,R0(II))
      CALL VECADD(R2,GT2,NO2U2)
C
C
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,V3,T2,13)
C
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL REXXVE(5,NO,NU,EXVE)
C ----------------------------------------
      CALL TRANMD(EXVE,NU,NU,NU,NO,23)
C
      CALL ZEROMA(GT2,1,NO2U2)
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL REXXVM(5,NO,NU,GT2)
C ----------------------------------------
      CALL VMCP1(NO,NU,EXVM,GT2)
      CALL TRANMD(EXVM,NO,NU,NO,NO,13)
CC
CC
      CALL RCCFL(NT2,7,NO2U2,GT2)
      CALL INSITU(NO,NU,NU,NO,V3,GT2,13)
CC
CC READING UNTRANSFORMED H-INTEGRALS NECCESSEARY IN
CC CONSTRUCTING H_TD C2 BLOCK
CC
CC
CC MOMENTS(R,I)*T2 (T2 COMBINED WITH EXVM OR EXVE)
CC AND
CC MOMENTS(T)*(R2+R_0*T2) (COMBINED WITH VM OR VE)
CC
CC COMMENTED BY KK ASIGNMENTS
CC
      DO 351 I=1,NO
         I1=I-1
      DO 351 J=1,I1
         J1=J-1
      DO 351 K=1,J1
C        KK=IT3(I,J,K)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,K,J),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,K,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,K,J),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,J,K),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,J,K),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,K),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,NU,4)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,EXVM(1,1,K,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,K,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,K,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,EXVM(1,1,I,K),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,I,K),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,K),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,NU,5)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,EXVM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,K),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,K),NU2,GVM(1,1,J,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,K),NU2,EXVM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,K),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,K),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,EXVE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,I),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,K),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,I),NU,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,K,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,K,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,NU,5)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,EXVE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,J),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,K),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,K,J),NU,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,K,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,K,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,K),NU,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,K),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,K),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,K),NU,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,K),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,K),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,NU,5)
      CALL ZEROT3(V3,NU)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,J,K,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,J,K,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
C
C
 351  CONTINUE
CC
CC
CC COMMENTED BY KK
      DO 352 I=1,NO
         I1=I-1
      DO 352 J=1,I1
C           KK=IT3(I,J,J)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,J,J),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,J,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,J),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,EXVM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,J,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,EXVM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL TRANT3(T3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,J),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,J),NU,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,2)
      CALL SYMT311(V3,NU,23)
      CALL ZEROT3(V3,NU)
      CALL TRANT3(T3,NU,2)
      CALL SYMT311(T3,NU,23)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,J,J,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,J,J,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
 352  CONTINUE
C
C
CC COMMENTED BY KK
      DO 353 I=1,NO
         I1=I-1
      DO 353 J=1,I1
C          KK=IT3(I,I,J)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,J,I),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,I),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,EXVM(1,1,I,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,I,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,NU,2)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,I),NU,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,J,I),NU,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,I),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL TRANT3(T3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,T2(1,1,I,J),NU,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL SYMT311(V3,NU,12)
      CALL ZEROT3(V3,NU)
      CALL TRANT3(T3,NU,3)
      CALL SYMT311(T3,NU,12)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,I,J,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,I,J,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
 353  CONTINUE
C
C          IXY=0 IS GROUND STATE, OTHERWISE PRINT EXCITED STATE RESULTS
C
      IF(IXY.EQ.0) THEN
        WRITE(6,488) ECCSD
        XPOT  = ZERO
        XPOT1 = ZERO
        XPOT2 = ZERO
      ELSE
        WRITE(6,499) VECREP(IUST(IXY))
C--        WRITE(6,433) ENESD(II)*PRZ
        WRITE(6,434)  ECCSD+ENESD(II)
        WRITE(6,1111) ECCSD+ENESD(II)+XM1(II)/XD1(II)
        WRITE(6,1112) ECCSD+ENESD(II)+XM2(II)/XD2(II)
        WRITE(6,1113) ECCSD+ENESD(II)+XM3(II)/XD3(II)
        WRITE(6,1114) ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
C
        XPOT1=XM1(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XPOT2=XM2(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XPOT =XM3(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        WRITE(6,1115) ECCSD+ENESD(II)+XPOT1/YD3(II)
        WRITE(6,1116) ECCSD+ENESD(II)+XPOT2/YD4(II)
        WRITE(6,1117) ECCSD+ENESD(II)+XPOT /YD2(II)
        WRITE(6,1118) ECCSD+ENESD(II)+DI6(II)/YD1(II)
        IF(IREL(IXY).NE.0) THEN
           WRITE(6,1119) ECCSD+ENESD(II)+XNC3(II)/DC3(II)
           BESTEOM = ECCSD+ENESD(II)+XNC3(II)/DC3(II)
        ELSE
           WRITE(6,1120)
           BESTEOM = ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
        END IF
      END IF
C
      CR1D1A(IXY)=ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR1
      CR2D1A(IXY)=ENESD(II)+DI6(II)/YD1(II)-XGRCORR1
      CR1D1B(IXY)=ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR2
      CR2D1B(IXY)=ENESD(II)+DI6(II)/YD1(II)-XGRCORR2
C
      CR1A(IXY)=ENESD(II)+XM1(II)/XD1(II)
      CR1B(IXY)=ENESD(II)+XM2(II)/XD2(II)
      CR1C(IXY)=ENESD(II)+XM3(II)/XD3(II)
      CR1D(IXY)=ENESD(II)+XNUM(II)/XDENOM(II)
      CR2A(IXY)=ENESD(II)+XPOT1/YD3(II)
      CR2B(IXY)=ENESD(II)+XPOT2/YD4(II)
      CR2C(IXY)=ENESD(II)+XPOT/YD2(II)
      CR2D(IXY)=ENESD(II)+DI6(II)/YD1(II)
C
      IF(IREL(IXY).NE.0) THEN
         EGRCI3=CI3GCORR+ECCSD
         CRCI3(IXY)=ECCSD+ENESD(II)+XNC3(II)/DC3(II)-EGRCI3
           CREX3(IXY)=ENESD(II)+XNC3(II)/DC3(II)
      ELSE
         CRCI3(IXY)=1000.0D+00
           CREX3(IXY)=1000.0D+00
      END IF
C #######
      WRXX=XM1(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
      XDELWB(IXY)=ENESD(II)+WRXX
C
 1111 FORMAT(1X,'CR-EOMCCSD(T)IA  TOTAL ENERGY ',F20.10,' HARTREE')
 1112 FORMAT(1X,'CR-EOMCCSD(T)IB  TOTAL ENERGY ',F20.10,' HARTREE')
 1113 FORMAT(1X,'CR-EOMCCSD(T)IC  TOTAL ENERGY ',F20.10,' HARTREE')
 1114 FORMAT(1X,'CR-EOMCCSD(T)ID  TOTAL ENERGY ',F20.10,' HARTREE')
 1115 FORMAT(1X,'CR-EOMCCSD(T)IIA TOTAL ENERGY ',F20.10,' HARTREE')
 1116 FORMAT(1X,'CR-EOMCCSD(T)IIB TOTAL ENERGY ',F20.10,' HARTREE')
 1117 FORMAT(1X,'CR-EOMCCSD(T)IIC TOTAL ENERGY ',F20.10,' HARTREE')
 1118 FORMAT(1X,'CR-EOMCCSD(T)IID TOTAL ENERGY ',F20.10,' HARTREE')
 1119 FORMAT(1X,'CR-EOMCCSD(T)III TOTAL ENERGY ',F20.10,' HARTREE')
 1120 FORMAT(1X,'NO CISD ROOT HAS BEEN FOUND')
 434  FORMAT(1X,'TOTAL EOM-CCSD ENERGY         ',F20.10,' HARTREE')
 499  FORMAT(/1X,'SYMMETRY OF THE EXCITED STATE: ',A3)
C
C      WRITE(6,*)'EOMCCSD EXCITATION ENERGY:',ENESD(II),' MH'
C      WRITE(6,433) ENESD(II)*PRZ
C 433  FORMAT('EOMCCSD EXCITATION ENERGY ',F7.3,' EV')
C      WRITE(6,434) ECCSD+ENESD(II)
C      WRITE(6,*)'      R0T1T2*M3',DI1(II)
C      WRITE(6,*)'      R0T1T1T1*M3',DI2(II)
C      WRITE(6,*)'      R1T2*M3',DI3(II)
C      WRITE(6,*)'      R1T1T1*M3',DI4(II)
C      WRITE(6,*)'      R2T1*M3',DI5(II)
C      WRITE(6,*)'      R3*M3',DI6(II)
C         SSS123=DI1(II)+DI2(II)+DI3(II)+DI4(II)+DI5(II)+DI6(II)
C      WRITE(6,*)'      ALL CONTRIBUTIONS:',SSS123
C      WRITE(6,*)'        SMALL DENOM. DIAGNOSTICS'
C      WRITE(6,*)'         SMALLEST DENOM.',SDD(II)
C      WRITE(6,455)JO1(II),JO2(II),JO3(II),
C     &            JU1(II)+NO,JU2(II)+NO,JU3(II)+NO
C      WRITE(6,*)'         TYPE',JTRACE(II)
C
C     IF(IXY.GT.0) THEN
C      WRITE(6,*)'***DIFFERENT TYPES OF MM(2,3) CORRECTIONS'
CC      WRITE(6,*)'CR-EOMCCSD(T)IA:NUMERATOR',XM1(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IA:DENOMINATOR',XD1(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IA:CORRECTION',XM1(II)/XD1(II)
C      PPP=ENESD(II)+XM1(II)/XD1(II)-XGRCORR1
C      WRITE(6,112)PPP*PRZ,ECCSD+ENESD(II)+XM1(II)/XD1(II)
C 112  FORMAT('CR-EOMCCSD(T)IA/IA EXCITATION:',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC      WRITE(6,*)'CR-EOMCCSD(T)IB:NUMERATOR',XM2(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IB:DENOMINATOR',XD2(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IB:CORRECTION',XM2(II)/XD2(II)
C      PPP=ENESD(II)+XM2(II)/XD2(II)-XGRCORR2
C      WRITE(6,212)PPP*PRZ,ECCSD+ENESD(II)+XM2(II)/XD2(II)
C 212  FORMAT('CR-EOMCCSD(T)IB/IB EXCITATION:',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC      WRITE(6,*)'CR-EOMCCSD(T)IC:NUMERATOR',XM3(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IC:DENOMINATOR',XD3(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IC:CORRECTION',XM3(II)/XD3(II)
C      PPP=ENESD(II)+XM3(II)/XD3(II)-XGRCORR3
C      WRITE(6,312)PPP*PRZ,ECCSD+ENESD(II)+XM3(II)/XD3(II)
C 312  FORMAT('CR-EOMCCSD(T)IC/IC EXCITATION:',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC      WRITE(6,*)'CR-EOMCCSD(T)ID:NUMERATOR',XNUM(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)ID:DENOMINATOR',XDENOM(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)ID:CORRECTION',XNUM(II)/XDENOM(II)
C      XXCORR=XNUM(II)/XDENOM(II)
C      WRITE(6,372)(ENESD(II)+XXCORR-XGRCORR)*PRZ,
C     &            ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
C 372  FORMAT('CR-EOMCCSD(T)ID/ID EXCITATION:',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC
CC
C      WRITE(6,*)'--------------------------------'
C      WRITE(6,*)'-- C3=(ENE-HTTDIAG)(HC2+HC1) ---'
C      WRITE(6,*)'--------------------------------'
C         IF(IREL(IXY).NE.0) THEN
CC      WRITE(6,*)'NUMERATOR',XNC3(II)
CC      WRITE(6,*)'DENOMINATOR',DC3(II)
CC      WRITE(6,*)'CORRECTION',XNC3(II)/DC3(II)
C      WRITE(6,874)ECCSD+ENESD(II)+XNC3(II)/DC3(II)
C      EGRCI3=CI3GCORR+ECCSD
C      WRITE(6,875)(ECCSD+ENESD(II)+XNC3(II)/DC3(II)-EGRCI3)*PRZ
C          ELSE
C       WRITE(6,*)'NO CISD ROOT HAS BEEN FOUND TO DESCRIBE'
C       WRITE(6,*)'GIVEN EOMSD ROOT'
C          END IF
C      WRITE(6,*)'--------------------------------'
C      WRITE(6,*)'--------------------------------'
C      WRITE(6,*)'--------------------------------'
C 874  FORMAT('TOTAL CR-EOMCCSD(T)III ENERGY',2X,F16.7,' HARTREE')
C 875  FORMAT('CR-EOMCCSD(T)III EXCITATION ENERGY:',F7.3,' EV')
CC
CC
CC
C      WRITE(6,*)'######## CROSSINGS #########'
C      WRITE(6,530)(ENESD(II)+XM1(II)/XD1(II)-XGRCORR)*PRZ,
C     &   ECCSD+ENESD(II)+XM1(II)/XD1(II)
C      WRITE(6,531)(ENESD(II)+XM1(II)/XD1(II)-XGRCORR2)*PRZ,
C     &   ECCSD+ENESD(II)+XM1(II)/XD1(II)
C      WRITE(6,532)(ENESD(II)+XM1(II)/XD1(II)-XGRCORR3)*PRZ,
C     &   ECCSD+ENESD(II)+XM1(II)/XD1(II)
CC
C      WRITE(6,533)(ENESD(II)+XM2(II)/XD2(II)-XGRCORR)*PRZ,
C     &   ECCSD+ENESD(II)+XM2(II)/XD2(II)
C      WRITE(6,534)(ENESD(II)+XM2(II)/XD2(II)-XGRCORR1)*PRZ,
C     &   ECCSD+ENESD(II)+XM2(II)/XD2(II)
C      WRITE(6,535)(ENESD(II)+XM2(II)/XD2(II)-XGRCORR3)*PRZ,
C     &   ECCSD+ENESD(II)+XM2(II)/XD2(II)
CC
C      WRITE(6,536)(ENESD(II)+XM3(II)/XD3(II)-XGRCORR)*PRZ,
C     &   ECCSD+ENESD(II)+XM3(II)/XD3(II)
C      WRITE(6,537)(ENESD(II)+XM3(II)/XD3(II)-XGRCORR1)*PRZ,
C     &   ECCSD+ENESD(II)+XM3(II)/XD3(II)
C      WRITE(6,538)(ENESD(II)+XM3(II)/XD3(II)-XGRCORR2)*PRZ,
C     &   ECCSD+ENESD(II)+XM3(II)/XD3(II)
CC
C      WRITE(6,539)(ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR1)*PRZ,
C     &   ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
C      WRITE(6,540)(ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR2)*PRZ,
C     &   ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
C      WRITE(6,541)(ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR3)*PRZ,
C     &   ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
CC
C 530  FORMAT('CR-EOMCCSD(T)IA/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 531  FORMAT('CR-EOMCCSD(T)IA/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 532  FORMAT('CR-EOMCCSD(T)IA/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
C 533  FORMAT('CR-EOMCCSD(T)IB/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 534  FORMAT('CR-EOMCCSD(T)IB/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 535  FORMAT('CR-EOMCCSD(T)IB/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
C 536  FORMAT('CR-EOMCCSD(T)IC/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 537  FORMAT('CR-EOMCCSD(T)IC/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 538  FORMAT('CR-EOMCCSD(T)IC/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
C 539  FORMAT('CR-EOMCCSD(T)ID/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 540  FORMAT('CR-EOMCCSD(T)ID/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 541  FORMAT('CR-EOMCCSD(T)ID/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC
C      WRITE(6,*)'###|PSI_K>=(P+Q12)EXP(T12)R012+R3|PHI>###'
C      WRITE(6,*)'###|PSI_0>=(P+Q123)EXP(T12)(1+T3)|PHI>###'
C      XPOT=XM3(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
C      WRITE(6,550)(ENESD(II)+XPOT/YD2(II)-XGRCORR1)*PRZ,
C     &              ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,551)(ENESD(II)+XPOT/YD2(II)-XGRCORR2)*PRZ,
C     &              ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,552)(ENESD(II)+XPOT/YD2(II)-XGRCORR3)*PRZ,
C     &              ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,553)(ENESD(II)+XPOT/YD2(II)-XGRCORR)*PRZ,
C     &              ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,554)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR1)*PRZ,
C     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,555)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR2)*PRZ,
C     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,556)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR3)*PRZ,
C     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,557)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR)*PRZ,
C     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
CC
C 550  FORMAT('CR-EOMCCSD(T)IIC/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 551  FORMAT('CR-EOMCCSD(T)IIC/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 552  FORMAT('CR-EOMCCSD(T)IIC/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 553  FORMAT('CR-EOMCCSD(T)IIC/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 554  FORMAT('CR-EOMCCSD(T)IID/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 555  FORMAT('CR-EOMCCSD(T)IID/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 556  FORMAT('CR-EOMCCSD(T)IID/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 557  FORMAT('CR-EOMCCSD(T)IID/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C
CCC      WRITE(6,*)'###|PSI_K>=(P+Q12)EXP(T12)R012+R3|PHI>###'
CCC      WRITE(6,*)'###|PSI_0>=CR-CCSD(T)###'
CCC      WRITE(6,701)(ECCSD+ENESD(II)+XPOT/YD2(II)-ECRCCSDT)*PRZ,
CCC     &              ECCSD+ENESD(II)+XPOT/YD2(II)
CCC      WRITE(6,702)(ECCSD+ENESD(II)+DI6(II)/YD1(II)-ECRCCSDT)*PRZ,
CCC     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
CCC 701  FORMAT('GR(CCSD(T)) EX(12BODY)S:   ',F7.3,' EV',' TOT(',
CCC     &       F13.6,' HARTREE)')
CCC 702  FORMAT('GR(CCSD(T)) EX(ALL)S:      ',F7.3,' EV',' TOT(',
CCC     &       F13.6,' HARTREE)')
C
C
CCC      WRITE(6,*)'###|PSI_K>=(P+Q123)EXP(T12)[R012+R3]|PHI>###'
CCC      WRITE(6,*)'###|PSI_0>=CR-CCSD(T)###'
CCC      WRITE(6,280)(ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)-ECRCCSDT)*PRZ,
CCC     &      ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
CCC 280   FORMAT('CRCCSDT-GR EX(ALL)F:    ',F7.3,' TOT(EXCITED)(',
CCC     & F13.6,' HARTREE)')
C
C
C      WRITE(6,*)'###|PSI_K>=(P+Q12)EXP(T12)R012+R3|PHI>###'
C      WRITE(6,*)'###|PSI_0>=(P+Q12)EXP(T12)+T3|PHI>###'
C      WRITE(6,560)(ENESD(II)+XPOT/YD2(II)-XGRCORR6)*PRZ,
C     &     ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,561)(ENESD(II)+XPOT/YD2(II)-XGRCORR7)*PRZ,
C     &     ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,562)(ENESD(II)+XPOT/YD2(II)-XGRCORR5)*PRZ,
C     &     ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,563)(ENESD(II)+XPOT/YD2(II)-XGRCORR4)*PRZ,
C     &     ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,564)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR6)*PRZ,
C     &     ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,565)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR7)*PRZ,
C     &     ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,566)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR5)*PRZ,
C     &     ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,567)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR4)*PRZ,
C     &     ECCSD+ENESD(II)+DI6(II)/YD1(II)
CC
C 560  FORMAT('CR-EOMCCSD(T)IIC/IIA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 561  FORMAT('CR-EOMCCSD(T)IIC/IIB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 562  FORMAT('CR-EOMCCSD(T)IIC/IIC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 563  FORMAT('CR-EOMCCSD(T)IIC/IID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 564  FORMAT('CR-EOMCCSD(T)IID/IIA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 565  FORMAT('CR-EOMCCSD(T)IID/IIB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 566  FORMAT('CR-EOMCCSD(T)IID/IIC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 567  FORMAT('CR-EOMCCSD(T)IID/IID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC
C      WRITE(6,*)'#### OMG_CCSD+DELTA_K ####'
C      WRITE(6,780)(ENESD(II)+XM1(II)/XD1(II))*27.2116
C      WRITE(6,781)(ENESD(II)+XM2(II)/XD2(II))*27.2116
C      WRITE(6,782)(ENESD(II)+XM3(II)/XD3(II))*27.2116
C      WRITE(6,783)(ENESD(II)+XNUM(II)/XDENOM(II))*27.2116
C      WRITE(6,784)(ENESD(II)+DI6(II))*27.2116
C       WRXX=XM1(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
C      WRITE(6,785)(ENESD(II)+WRXX)*PRZ
C      WRITE(6,*)'########################'
C 780  FORMAT('OMG_CCSD+DELTA(OMG-EH-EP)  ',F7.3,' EV')
C 781  FORMAT('OMG_CCSD+DELTA(OMG-FH-FP)  ',F7.3,' EV')
C 782  FORMAT('OMG_CCSD+DELTA(OMG-12BODY) ',F7.3,' EV')
C 783  FORMAT('OMG_CCSD+DELTA(OMG-ALL)    ',F7.3,' EV')
C 784  FORMAT('OMG_CCSD+R3(ALL)*M3        ',F7.3,' EV')
C 785  FORMAT('OMG_CCSD+R3(EH-EP)*M3      ',F7.3,' EV')
C     END IF
C
C         PRINT GROUND STATE RESULTS
C
      IF(IXY.EQ.0) THEN
        XGRCORR=XNUM(II)/XDENOM(II)
        XGRCORR1=XM1(II)/XD1(II)
        XGRCORR2=XM2(II)/XD2(II)
        XGRCORR3=XM3(II)/XD3(II)
        XGRCORR4=DI6(II)/YD1(II)
        XPOT4=XM3(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XGRCORR5=XPOT4/YD2(II)
        XPOT1=XM1(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XPOT2=XM2(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XGRCORR6=XPOT1/YD3(II)
        XGRCORR7=XPOT2/YD4(II)
        CI3GCORR=XNC3(II)/DC3(II)
        WRITE(6,412) XGRCORR1,XGRCORR1+ECCSD
        WRITE(6,413) XGRCORR2,XGRCORR2+ECCSD
        WRITE(6,414) XGRCORR3,XGRCORR3+ECCSD
        WRITE(6,411) XGRCORR ,XGRCORR +ECCSD
        WRITE(6,416) XGRCORR6,XGRCORR6+ECCSD
        WRITE(6,417) XGRCORR7,XGRCORR7+ECCSD
        WRITE(6,418) XGRCORR5,XGRCORR5+ECCSD
        WRITE(6,415) XGRCORR4,XGRCORR4+ECCSD
        WRITE(6,419) CI3GCORR,CI3GCORR+ECCSD
        BESTEOM = CI3GCORR+ECCSD
      END IF
C
      RETURN
C
 411  FORMAT(1X,'GROUND STATE CR-CCSD(T)ID  CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 412  FORMAT(1X,'GROUND STATE CR-CCSD(T)IA  CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 413  FORMAT(1X,'GROUND STATE CR-CCSD(T)IB  CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 414  FORMAT(1X,'GROUND STATE CR-CCSD(T)IC  CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 415  FORMAT(1X,'GROUND STATE CR-CCSD(T)IID CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 416  FORMAT(1X,'GROUND STATE CR-CCSD(T)IIA CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 417  FORMAT(1X,'GROUND STATE CR-CCSD(T)IIB CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 418  FORMAT(1X,'GROUND STATE CR-CCSD(T)IIC CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 419  FORMAT(1X,'GROUND STATE CR-CCSD(T)III CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 488  FORMAT(/1X,'GROUND STATE CCSD TOTAL ENERGY=',26X,F20.10)
C-- 420  FORMAT(1X,'TOTAL CR-CCSD(T)',F20.10,' HARTREE')
      END
C
C*MODULE MM23     *DECK XT3WT2NN
      SUBROUTINE XT3WT2NN(ESCF,ECCSD,BESTEOM,NO,NU,
     *                    O1,T2,VM,VE,V3,T3,VOE,R1,R2,GT2,
     *                    AUXR2,U3,AH,AP,APP,AHH,AHP,AX,BX,GVM,GVE,
     *                    HAPP,HAHH,HAHP,C1,EH,EP,IXY)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*3 VECREP
C
      DIMENSION O1(*),T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),VOE(*),V3(*),
     *          T3(*),VE(NU,NU,NU,NO),EH(NO),EP(NU),C1(*),
     *          GVM(NO,NU,NO,NO),GVE(NU,NU,NU,NO),
     *          R1(*),R2(NU,NU,NO,NO),GT2(NU,NU,NO,NO),
     *          AUXR2(NO,NU,NU,NO),U3(NU,NU,NU),
     *          AH(NO),AP(NU),
     *          AHH(NO,NO,2),AHP(NO,NU,2),APP(NU,NU,2),
     *          HAHH(NO,NO,2),HAHP(NO,NU,2),HAPP(NU,NU,2),
     *          AX(NU,NU,NO,2),BX(NU,NO,NO,2)
C
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
      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 /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
C
      DATA ZERO/0.0D+00/, ONE/1.0D+00/, OM/-1.0D+00/
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL RO2HPP(1,NO,NU,V3,VOE)
      CALL INSITU(NO,NU,NU,NO,V3,VOE,13)
      CALL TRANMD(VOE,NU,NU,NO,NO,12)
C
      CALL RDVEM4(0,NO,NU,V3,GVE)
      CALL TRANMD(GVE,NU,NU,NU,NO,23)
      CALL RDVEM4(1,NU,NO,V3,T2)
      CALL VMCP1(NO,NU,GVM,T2)
      CALL TRANMD(GVM,NO,NU,NO,NO,13)
C
      CALL RCCFL(ITAPP,1,NO,AH)
      CALL RCCFL(ITAPP,2,NU,AP)
      CALL RCCFL(ITAPP,3,2*NU2,APP)
      CALL RCCFL(ITAPP,4,2*NO2,AHH)
      CALL RCCFL(ITAPP,5,2*NOU,AHP)
      CALL RCCFL(ITAPP,6,2*NU2,HAPP)
      CALL RCCFL(ITAPP,7,2*NO2,HAHH)
      CALL RCCFL(ITAPP,8,2*NOU,HAHP)
      CALL RCCFL(IFAX,1,2*NOU2,AX)
      CALL RCCFL(IFAX,2,2*NO2U,BX)
C
      CALL RDVE(3,NO,NU,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,23)
      CALL RDVM(3,NO,NU,GT2)
      CALL VMCP1(NO,NU,VM,GT2)
      CALL TRANMD(VM,NO,NU,NO,NO,13)
C
C MAIN LOOP OVER ALL EXCITED STATES
C
      II=1
C ON R2 VECTOR WE KEEP R2(EOMCCSD)+R_0(EOMCCSD)*T2
      CALL RR1(NO,NU,R1)
      CALL RR2(NO,NU,R2)
      CALL RR2(NO,NU,AUXR2)
      CALL INSITU(NO,NU,NU,NO,V3,R2,13)
C
      CALL RO2(1,NO,NU,GT2)
      CALL RO1(1,NO,NU,O1)
      CALL INSITU(NO,NU,NU,NO,V3,GT2,13)
      CALL VECMUL(GT2,NO2U2,R0(II))
      CALL VECADD(R2,GT2,NO2U2)
C
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,V3,T2,13)
CC
CC
      CALL RCCFL(NT2,7,NO2U2,GT2)
      CALL INSITU(NO,NU,NU,NO,V3,GT2,13)
CC
CC READING UNTRANSFORMED H-INTEGRALS NECCESSEARY IN
CC CONSTRUCTING H_TD C2 BLOCK
CC
CC
CC MOMENTS(R,I)*T2 (T2 COMBINED WITH EXVM OR EXVE)
CC AND
CC MOMENTS(T)*(R2+R_0*T2) (COMBINED WITH VM OR VE)
CC
C     IMPORTANT FOR CI3 DENOMINATOR
C
      XSTEER=ONE
CC
CC COMMENTED BY KK
      DO 351 I=1,NO
         I1=I-1
      DO 351 J=1,I1
         J1=J-1
      DO 351 K=1,J1
C            KK=IT3(I,J,K)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,K,J),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,K,J),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,J,K),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,K),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,NU,4)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,K,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,K,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,I,K),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,K),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,NU,5)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,K),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,K),NU2,GVM(1,1,J,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,K),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,K),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,I),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,K),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,K,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,K,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,NU,5)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,J),NU,VE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,K),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,K,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,K,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,K),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,K),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,K),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,K),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,NU,5)
      CALL ZEROT3(V3,NU)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,J,K,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,J,K,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
C
C
 351  CONTINUE
CC
CC
CC COMMENTED BY KK
      DO 352 I=1,NO
         I1=I-1
      DO 352 J=1,I1
C             KK=IT3(I,J,J)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,J,J),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,J),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,J,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,NU,4)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL TRANT3(T3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,J),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,2)
      CALL SYMT311(V3,NU,23)
      CALL ZEROT3(V3,NU)
      CALL TRANT3(T3,NU,2)
      CALL SYMT311(T3,NU,23)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,J,J,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,J,J,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
 352  CONTINUE
C
C
CC COMMENTED BY KK
      DO 353 I=1,NO
         I1=I-1
      DO 353 J=1,I1
C             KK=IT3(I,I,J)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,J,I),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,I),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,J),NU2,VM(1,1,I,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,NU,2)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,I),NU,VE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,NU,1)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,J,I),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL TRANT3(T3,NU,3)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(1,1,I,J),NU,VE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL SYMT311(V3,NU,12)
      CALL ZEROT3(V3,NU)
      CALL TRANT3(T3,NU,3)
      CALL SYMT311(T3,NU,12)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,I,J,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,I,J,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
 353  CONTINUE
C
C
C
C
C
C
C
C     IMPORTAND FOR CI3 DENOMINATOR
      XSTEER=ZERO
C
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL REXXVE(5,NO,NU,VE)
C ----------------------------------------
      CALL TRANMD(VE,NU,NU,NU,NO,23)
C
      CALL ZEROMA(GT2,1,NO2U2)
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL REXXVM(5,NO,NU,GT2)
C ----------------------------------------
      CALL VMCP1(NO,NU,VM,GT2)
      CALL TRANMD(VM,NO,NU,NO,NO,13)
C
C
      CALL RCCFL(NT2,7,NO2U2,GT2)
      CALL INSITU(NO,NU,NU,NO,V3,GT2,13)
C
CC COMMENTED BY KK
      DO 1351 I=1,NO
         I1=I-1
      DO 1351 J=1,I1
         J1=J-1
      DO 1351 K=1,J1
C            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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,K,J),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,K),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,K,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,K),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,K),NU2,GVM(1,1,J,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,K),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,K),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,K,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,K),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,K,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,K),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,K),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,5)
      CALL TRANT3(T3,NU,5)
      CALL ZEROT3(V3,NU)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,J,K,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,J,K,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
C
C
 1351 CONTINUE
CC
CC
CC COMMENTED BY KK
      DO 1352 I=1,NO
         I1=I-1
      DO 1352 J=1,I1
C         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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,J),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,J,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,4)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,2)
      CALL SYMT311(V3,NU,23)
      CALL ZEROT3(V3,NU)
      CALL TRANT3(T3,NU,2)
      CALL SYMT311(T3,NU,23)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,J,J,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,J,J,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
 1352 CONTINUE
C
C
CC COMMENTED BY KK
      DO 1353 I=1,NO
         I1=I-1
      DO 1353 J=1,I1
C         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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,J,I),NO,
     *ZERO,T3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,I),NU2,GVM(1,1,I,J),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,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 DGEMM('N','N',NU2,NU,NO,OM,GT2(1,1,1,J),NU2,GVM(1,1,I,I),NO,
     *ONE,T3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,I),NU,GVE(1,1,1,J),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,1)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,J,I),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL TRANT3(T3,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 DGEMM('N','N',NU,NU2,NU,ONE,GT2(1,1,I,J),NU,GVE(1,1,1,I),NU,
     *ONE,T3,NU)
      CALL TRANT3(V3,NU,3)
      CALL SYMT311(V3,NU,12)
      CALL ZEROT3(V3,NU)
      CALL TRANT3(T3,NU,3)
      CALL SYMT311(T3,NU,12)
      CALL ZEROT3(T3,NU)
      CALL XT3SQUAN(II,I,I,J,NO,NU,O1,T2,R1,AUXR2,V3,U3,T3,VOE,C1)
      CALL XT3SQUAN2(ESCF,ECCSD,II,I,I,J,NO,NU,V3,U3,T3,AH,AP,APP,
     *               AHH,AHP,AX,BX,HAPP,HAHH,HAHP,EH,EP,XSTEER)
 1353 CONTINUE
C
C
C
C HARTREE-EV CONVERSION FACTOR
C
C****      PRZ=27.21160D+00
C
      IF(IXY.EQ.0) THEN
        WRITE(6,488) ECCSD
      ELSE
        WRITE(6,499) VECREP(IUST(IXY))
        WRITE(6,434) ECCSD+ENESD(II)
        IF(IREL(IXY).NE.0) THEN
           WRITE(6,1119) ECCSD+ENESD(II)+XNC3(II)/DC3(II)
           BESTEOM = ECCSD+ENESD(II)+XNC3(II)/DC3(II)
        ELSE
           WRITE(6,1120)
           BESTEOM = 0.0D+00
        END IF
      END IF
C
      IF(IREL(IXY).NE.0) THEN
         EGRCI3=CI3GCORR+ECCSD
         CRCI3(IXY)=ECCSD+ENESD(II)+XNC3(II)/DC3(II)-EGRCI3
         CREX3(IXY)=ENESD(II)+XNC3(II)/DC3(II)
      ELSE
         CRCI3(IXY)=1000.0D+00
         CREX3(IXY)=1000.0D+00
      END IF
C
 1119 FORMAT(1X,'CR-EOMCCSD(T)III TOTAL ENERGY ',F20.10,' HARTREE')
 1120 FORMAT(1X,'NO CISD ROOT HAS BEEN FOUND')
 434  FORMAT(1X,'TOTAL EOM-CCSD ENERGY         ',F20.10,' HARTREE')
 499  FORMAT(/1X,'SYMMETRY OF THE EXCITED STATE: ',A3)
C
C     IF(IXY.GT.0) THEN
C      WRITE(6,*)'--------------------------------'
C      WRITE(6,*)'-- C3=(ENE-HTTDIAG)(HC2+HC1) ---'
C      WRITE(6,*)'--------------------------------'
C         IF(IREL(IXY).NE.0) THEN
CC      WRITE(6,*)'NUMERATOR',XNC3(II)
CC      WRITE(6,*)'DENOMINATOR',DC3(II)
CC      WRITE(6,*)'CORRECTION',XNC3(II)/DC3(II)
C      WRITE(6,874)ECCSD+ENESD(II)+XNC3(II)/DC3(II)
C      EGRCI3=CI3GCORR+ECCSD
C      WRITE(6,875)(ECCSD+ENESD(II)+XNC3(II)/DC3(II)-EGRCI3)*PRZ
C          ELSE
C       WRITE(6,*)'NO CISD ROOT HAS BEEN FOUND TO DESCRIBE'
C       WRITE(6,*)'GIVEN EOMSD ROOT'
C          END IF
C      WRITE(6,*)'--------------------------------'
C      WRITE(6,*)'--------------------------------'
C      WRITE(6,*)'--------------------------------'
C 874  FORMAT('TOTAL CR-EOMCCSD(T)III ENERGY',2X,F16.7,' HARTREE')
C 875  FORMAT('CR-EOMCCSD(T)III EXCITATION ENERGY:',F7.3,' EV')
C     END IF
C
      IF(IXY.EQ.0) THEN
        CI3GCORR=XNC3(II)/DC3(II)
        WRITE(6,419) CI3GCORR,CI3GCORR+ECCSD
        BESTEOM = CI3GCORR+ECCSD
      END IF
      RETURN
C
 419  FORMAT(1X,'GROUND STATE CR-CCSD(T)III CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 488  FORMAT(/1X,'GROUND STATE CCSD TOTAL ENERGY=',26X,F20.10)
      END
C
C*MODULE MM23     *DECK XT3SQUAN
      SUBROUTINE XT3SQUAN(JEX,I,J,K,NO,NU,T1,T2,R1,R2,V3,U3,T3,VOE,C1)
C
C JEX-NUMBER OF EXCITED STATE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER A,B,C
C
      DIMENSION T1(NO,NU),T2(NU,NU,NO,NO),V3(NU,NU,NU),
     *          R1(NO,NU),R2(NO,NU,NU,NO),U3(NU,NU,NU),T3(NU,NU,NU),
     *          VOE(NU,NU,NO,NO),C1(NO,NU)
C
      LOGICAL IEJ,JEK
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,
     *      HALF/0.5D+00/,ONE/1.0D+00/
C
C KET VECTOR
C
       DO 149 A=1,NU
       DO 149 B=1,NU
       DO 149 C=1,NU
        U3(A,B,C)=0.0D+00
        IF (A.EQ.B.AND.B.EQ.C)GOTO 149
C T3 <= HC1(CISD)
        T3(A,B,C)=T3(A,B,C)+
     &    C1(I,A)*VOE(B,C,J,K)+
     &    C1(J,B)*VOE(A,C,I,K)+
     &    C1(K,C)*VOE(A,B,I,J)
C
C T1T2*R0
        U3(A,B,C)=U3(A,B,C)+
     &            (T1(I,A)*T2(C,B,J,K)+T1(J,B)*T2(C,A,I,K)+
     &             T1(K,C)*T2(B,A,I,J))*R0(JEX)
C T1T1T1*R0
        U3(A,B,C)=U3(A,B,C)+T1(I,A)*T1(J,B)*T1(K,C)*R0(JEX)
C R1T2
        U3(A,B,C)=U3(A,B,C)+
     &             R1(I,A)*T2(C,B,J,K)+R1(J,B)*T2(C,A,I,K)+
     &             R1(K,C)*T2(B,A,I,J)
C R1T1T1
        U3(A,B,C)=U3(A,B,C)+
     &            R1(I,A)*T1(J,B)*T1(K,C)+R1(J,B)*T1(I,A)*T1(K,C)+
     &            R1(K,C)*T1(I,A)*T1(J,B)
C R2T1
        U3(A,B,C)=U3(A,B,C)+
     &             T1(I,A)*R2(J,B,C,K)+T1(J,B)*R2(I,A,C,K)+
     &             T1(K,C)*R2(I,A,B,J)
 149   CONTINUE
C
C
C BRA VECTOR
C
C
       X1=0.0D+00
       X2=0.0D+00
C ** DEBUG ***
       Z1=0.0D+00
       Z2=0.0D+00
       Z3=0.0D+00
       Z4=0.0D+00
       Z5=0.0D+00
C
       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
C T1T2*R0
      AT21=(T1(I,A)*T2(C,B,J,K)+T1(J,B)*T2(C,A,I,K)+
     &      T1(K,C)*T2(B,A,I,J))*R0(JEX)
C T1T1T1*R0
      BT21=T1(I,A)*T1(J,B)*T1(K,C)*R0(JEX)
C R1T2
      CT21=R1(I,A)*T2(C,B,J,K)+R1(J,B)*T2(C,A,I,K)+
     &     R1(K,C)*T2(B,A,I,J)
C R1T1T1
      DT21=R1(I,A)*T1(J,B)*T1(K,C)+R1(J,B)*T1(I,A)*T1(K,C)+
     &     R1(K,C)*T1(I,A)*T1(J,B)
C R2T1
      XT21=T1(I,A)*R2(J,B,C,K)+T1(J,B)*R2(I,A,C,K)+T1(K,C)*R2(I,A,B,J)
C
      D1=U3(A,B,C)
      D2=U3(A,C,B)+U3(C,B,A)+U3(B,A,C)
      D3=U3(B,C,A)+U3(C,A,B)
C
      G1=V3(A,B,C)
      G2=V3(A,C,B)+V3(C,B,A)+V3(B,A,C)
      G3=V3(B,C,A)+V3(C,A,B)
C
C
      F=D1*EIGHT-FOUR*D2+D3*TWO
      FG=G1*EIGHT-FOUR*G2+G3*TWO
C
        X1=X1+F*AT21
        X1=X1+F*BT21
        X1=X1+F*CT21
        X1=X1+F*DT21
        X1=X1+F*XT21
C
        X2=X2+FG*AT21
        X2=X2+FG*BT21
        X2=X2+FG*CT21
        X2=X2+FG*DT21
        X2=X2+FG*XT21
C *** DEBUG ***
        Z1=Z1+FG*AT21
        Z2=Z2+FG*BT21
        Z3=Z3+FG*CT21
        Z4=Z4+FG*DT21
        Z5=Z5+FG*XT21
C ******
C
 150   CONTINUE
C
      CF=ONE
      IEJ=I.EQ.J
      JEK=J.EQ.K
        IF(IEJ.OR.JEK) CF=HALF
        XDENOM(JEX)=XDENOM(JEX)+CF*X1
        XNUM(JEX)=XNUM(JEX)+CF*X2
        XM1(JEX)=XM1(JEX)+CF*X2
        XM2(JEX)=XM2(JEX)+CF*X2
        XM3(JEX)=XM3(JEX)+CF*X2
        XD1(JEX)=XD1(JEX)+CF*X1
        XD2(JEX)=XD2(JEX)+CF*X1
        XD3(JEX)=XD3(JEX)+CF*X1
         DI1(JEX)=DI1(JEX)+CF*Z1
         DI2(JEX)=DI2(JEX)+CF*Z2
         DI3(JEX)=DI3(JEX)+CF*Z3
         DI4(JEX)=DI4(JEX)+CF*Z4
         DI5(JEX)=DI5(JEX)+CF*Z5
      RETURN
      END
C
C*MODULE MM23     *DECK XT3SQUAN2
      SUBROUTINE XT3SQUAN2(ESCF,ECCSD,JEX,I,J,K,NO,NU,V3,U3,T3,
     *                     AH,AP,APP,AHH,AHP,AX,BX,
     *                     HAPP,HAHH,HAHP,EH,EP,XSTEER)
C
C ### ORDERING I,J,K - REVERSED HERE
C JEX-NUMBER OF EXCITED STATE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER A,B,C
C
      DIMENSION U3(NU,NU,NU),T3(NU,NU,NU),
     *          V3(NU,NU,NU),EH(NO),EP(NU),AH(NO),AP(NU),
     *          AHH(NO,NO,2),AHP(NO,NU,2),APP(NU,NU,2),
     *          HAHH(NO,NO,2),HAHP(NO,NU,2),HAPP(NU,NU,2) ,
     *          AX(NU,NU,NO,2),BX(NU,NO,NO,2)
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
      DATA TWO/2.0D+00/
C
      XXTT = ECCSD - ESCF + ENESD(JEX)
C
C
C *************************************************************
C
C I>J>K
C
      IF(I.GT.J.AND.J.GT.K) THEN
         I1=K
         J1=J
         K1=I
         DO 149,A=1,NU
         DO 149,B=A,NU
         DO 149,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 149
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
        UB0=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)+HAPP(A,B,2)-HAPP(C,B,1)+HAPP(C,B,2)
     &-HAPP(A,C,1)+HAPP(A,C,2)
     &-HAHH(I1,J1,1)+HAHH(I1,J1,2)-HAHH(K1,J1,1)
     &+HAHH(K1,J1,2)-HAHH(I1,K1,1)
     &+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX0=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)+AX(C,A,K1,1)
     &+AX(B,C,K1,1)-AX(B,C,K1,2)-AX(C,B,K1,2)+AX(C,B,K1,1)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)
     &+AX(B,C,I1,1)-AX(B,C,I1,2)-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX0=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB0=ENESD(JEX)+ZA1+ZA2-AX0-BX0
       DB01=ENESD(JEX)+HA1
       DB02=ENESD(JEX)+ZA1
       DB03=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          UB1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)+HAPP(A,B,2)-HAPP(C,B,1)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)+HAHH(I1,J1,2)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX1=-AX(C,A,K1,2)-AX(C,B,K1,2)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &-AX(A,C,J1,2)-AX(B,C,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX1=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)-BX(A,K1,J1,1)
     &-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB1=ENESD(JEX)+ZA1+ZA2-AX1-BX1
       DB11=ENESD(JEX)+HA1
       DB12=ENESD(JEX)+ZA1
       DB13=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          UB2=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)-HAPP(A,C,1)+HAPP(A,C,2)
     &-HAHH(I1,J1,1)+HAHH(I1,J1,2)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)
          AX2=-AX(B,A,K1,2)-AX(B,C,K1,2)-AX(A,B,J1,2)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)
     &-AX(A,B,I1,2)+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)
     &+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX2=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB2=ENESD(JEX)+ZA1+ZA2-AX2-BX2
       DB21=ENESD(JEX)+HA1
       DB22=ENESD(JEX)+ZA1
       DB23=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)
          UB3=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)+HAPP(C,B,2)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)+HAHH(I1,J1,2)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)
          AX3=-AX(A,B,K1,2)-AX(A,C,K1,2)-AX(B,A,J1,2)-AX(C,A,J1,2)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX3=-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,K1,J1,1)
       DB3=ENESD(JEX)+ZA1+ZA2-AX3-BX3
       DB31=ENESD(JEX)+HA1
       DB32=ENESD(JEX)+ZA1
       DB33=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          UB4=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)+HAPP(A,B,2)-HAPP(C,B,1)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          UB5=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)-HAPP(A,C,1)+HAPP(A,C,2)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          UB6=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)+HAPP(C,B,2)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          UB7=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)+HAPP(A,B,2)-HAPP(C,B,1)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)+HAHH(K1,J1,2)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)
          AX7=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)
     &+AX(B,A,J1,1)-AX(A,C,J1,2)-AX(B,C,J1,2)-AX(C,A,I1,2)-AX(C,B,I1,2)
        BX7=-BX(A,I1,J1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
       DB7=ENESD(JEX)+ZA1+ZA2-AX7-BX7
       DB71=ENESD(JEX)+HA1
       DB72=ENESD(JEX)+ZA1
       DB73=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          UB8=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)-HAPP(A,C,1)+HAPP(A,C,2)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)+HAHH(K1,J1,2)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX8=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(A,B,J1,2)+AX(A,C,J1,1)-AX(A,C,J1,2)
     &-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)-AX(B,A,I1,2)-AX(B,C,I1,2)
        BX8=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB8=ENESD(JEX)+ZA1+ZA2-AX8-BX8
       DB81=ENESD(JEX)+HA1
       DB82=ENESD(JEX)+ZA1
       DB83=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          UB9=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)+HAPP(C,B,2)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)+HAHH(K1,J1,2)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX9=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(B,A,J1,2)-AX(C,A,J1,2)+AX(B,C,J1,1)
     &-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)-AX(A,B,I1,2)-AX(A,C,I1,2)
        BX9=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,I1,J1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,I1,K1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB9=ENESD(JEX)+ZA1+ZA2-AX9-BX9
       DB91=ENESD(JEX)+HA1
       DB92=ENESD(JEX)+ZA1
       DB93=ENESD(JEX)+ZA1+ZA2
C
C
C       REVERSE ORDER OF A,B,C!!!
       B0=V3(C,B,A)-V3(B,C,A)-V3(C,A,B)+V3(A,C,B)+V3(B,A,C)-V3(A,B,C)
       B1=V3(C,B,A)-V3(C,A,B)
       B2=V3(B,C,A)-V3(B,A,C)
       B3=V3(A,C,B)-V3(A,B,C)
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
       B7=V3(B,A,C)-V3(A,B,C)
       B8=V3(C,A,B)-V3(A,C,B)
       B9=V3(C,B,A)-V3(B,C,A)
C
       C0=U3(C,B,A)-U3(B,C,A)-U3(C,A,B)+U3(A,C,B)+U3(B,A,C)-U3(A,B,C)
       C1=U3(C,B,A)-U3(C,A,B)
       C2=U3(B,C,A)-U3(B,A,C)
       C3=U3(A,C,B)-U3(A,B,C)
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
       C7=U3(B,A,C)-U3(A,B,C)
       C8=U3(C,A,B)-U3(A,C,B)
       C9=U3(C,B,A)-U3(B,C,A)
C
       E0=T3(C,B,A)-T3(B,C,A)-T3(C,A,B)+T3(A,C,B)+T3(B,A,C)-T3(A,B,C)
       E1=T3(C,B,A)-T3(C,A,B)
       E2=T3(B,C,A)-T3(B,A,C)
       E3=T3(A,C,B)-T3(A,B,C)
       E4=T3(B,C,A)-T3(A,C,B)
       E5=T3(C,B,A)-T3(A,B,C)
       E6=T3(C,A,B)-T3(B,A,C)
       E7=T3(B,A,C)-T3(A,B,C)
       E8=T3(C,A,B)-T3(A,C,B)
       E9=T3(C,B,A)-T3(B,C,A)
C
C
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEX)=XNUM(JEX)+TWO*(B0*B0/DB0+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9)
       XNC3(JEX)=XNC3(JEX)+TWO*(E0*B0/UB0+E1*B1/UB1+E2*B2/UB2+
     &     E3*B3/UB3+E4*B4/UB4+E5*B5/UB5+E6*B6/UB6+E7*B7/UB7+
     &                     E8*B8/UB8+E9*B9/UB9)
       DI6(JEX)=DI6(JEX)+TWO*(B0*B0/DB0+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9)
       XM1(JEX)=XM1(JEX)+TWO*(B0*B0/DB01+B1*B1/DB11+B2*B2/DB21+
     &     B3*B3/DB31+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61+B7*B7/DB71+
     &                     B8*B8/DB81+B9*B9/DB91)
       XM2(JEX)=XM2(JEX)+TWO*(B0*B0/DB02+B1*B1/DB12+B2*B2/DB22+
     &     B3*B3/DB32+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62+B7*B7/DB72+
     &                     B8*B8/DB82+B9*B9/DB92)
       XM3(JEX)=XM3(JEX)+TWO*(B0*B0/DB03+B1*B1/DB13+B2*B2/DB23+
     &     B3*B3/DB33+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63+B7*B7/DB73+
     &                     B8*B8/DB83+B9*B9/DB93)
       XDENOM(JEX)=XDENOM(JEX)+TWO*(B0*C0/DB0+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9)
       DC3(JEX)=DC3(JEX)+TWO*(E0*C0/UB0+E1*C1/UB1+E2*C2/UB2+
     &     E3*C3/UB3+E4*C4/UB4+E5*C5/UB5+E6*C6/UB6+E7*C7/UB7+
     &                     E8*C8/UB8+E9*C9/UB9)*XSTEER
       YD1(JEX)=YD1(JEX)+TWO*(B0*C0/DB0+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9)
       XD1(JEX)=XD1(JEX)+TWO*(B0*C0/DB01+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91)
       YD3(JEX)=YD3(JEX)+TWO*(B0*C0/DB01+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91)
       XD2(JEX)=XD2(JEX)+TWO*(B0*C0/DB02+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92)
       YD4(JEX)=YD4(JEX)+TWO*(B0*C0/DB02+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92)
       XD3(JEX)=XD3(JEX)+TWO*(B0*C0/DB03+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93)
       YD2(JEX)=YD2(JEX)+TWO*(B0*C0/DB03+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93)
C       XDENOM(JEX)=XDENOM(JEX)+TWO*(B0*B0/(DB0*DB0)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+B7*B7/(DB7*DB7)+
C     &                     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9))
       GO TO 149
       END IF
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B2*B2/DB2+B3*B3/DB3+B5*B5/DB5+B6*B6/DB6+
     &                     B8*B8/DB8+B9*B9/DB9
       XNC3(JEX)=XNC3(JEX)+E2*B2/UB2+E3*B3/UB3+E5*B5/UB5+E6*B6/UB6+
     &                     E8*B8/UB8+E9*B9/UB9
       XM1(JEX)=XM1(JEX)+B2*B2/DB21+B3*B3/DB31+B5*B5/DB51+B6*B6/DB61+
     &                     B8*B8/DB81+B9*B9/DB91
       XM2(JEX)=XM2(JEX)+B2*B2/DB22+B3*B3/DB32+B5*B5/DB52+B6*B6/DB62+
     &                     B8*B8/DB82+B9*B9/DB92
       XM3(JEX)=XM3(JEX)+B2*B2/DB23+B3*B3/DB33+B5*B5/DB53+B6*B6/DB63+
     &                     B8*B8/DB83+B9*B9/DB93
       DI6(JEX)=DI6(JEX)+B2*B2/DB2+B3*B3/DB3+B5*B5/DB5+B6*B6/DB6+
     &                     B8*B8/DB8+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B2*C2/DB2+B3*C3/DB3+B5*C5/DB5+B6*C6/DB6+
     &                     B8*C8/DB8+B9*C9/DB9
       DC3(JEX)=DC3(JEX)+(E2*C2/UB2+E3*C3/UB3+E5*C5/UB5+E6*C6/UB6+
     &                     E8*C8/UB8+E9*C9/UB9)*XSTEER
       YD1(JEX)=YD1(JEX)+B2*C2/DB2+B3*C3/DB3+B5*C5/DB5+B6*C6/DB6+
     &                     B8*C8/DB8+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B2*C2/DB21+B3*C3/DB31+B5*C5/DB51+B6*C6/DB61+
     &                     B8*C8/DB81+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B2*C2/DB21+B3*C3/DB31+B5*C5/DB51+B6*C6/DB61+
     &                     B8*C8/DB81+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B2*C2/DB22+B3*C3/DB32+B5*C5/DB52+B6*C6/DB62+
     &                     B8*C8/DB82+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B2*C2/DB22+B3*C3/DB32+B5*C5/DB52+B6*C6/DB62+
     &                     B8*C8/DB82+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B2*C2/DB23+B3*C3/DB33+B5*C5/DB53+B6*C6/DB63+
     &                     B8*C8/DB83+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B2*C2/DB23+B3*C3/DB33+B5*C5/DB53+B6*C6/DB63+
     &                     B8*C8/DB83+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+
C     &     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9)
       GO TO 149
       END IF
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B4*B4/DB4+B5*B5/DB5+B7*B7/DB7+B8*B8/DB8
       XNC3(JEX)=XNC3(JEX)+E1*B1/UB1+E2*B2/UB2+
     &     E4*B4/UB4+E5*B5/UB5+E7*B7/UB7+E8*B8/UB8
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B2*B2/DB21+
     &     B4*B4/DB41+B5*B5/DB51+B7*B7/DB71+B8*B8/DB81
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B2*B2/DB22+
     &     B4*B4/DB42+B5*B5/DB52+B7*B7/DB72+B8*B8/DB82
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B2*B2/DB23+
     &     B4*B4/DB43+B5*B5/DB53+B7*B7/DB73+B8*B8/DB83
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B4*B4/DB4+B5*B5/DB5+B7*B7/DB7+B8*B8/DB8
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B4*C4/DB4+B5*C5/DB5+B7*C7/DB7+B8*C8/DB8
       DC3(JEX)=DC3(JEX)+(E1*C1/UB1+E2*C2/UB2+
     &     E4*C4/UB4+E5*C5/UB5+E7*C7/UB7+E8*C8/UB8)*XSTEER
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B4*C4/DB4+B5*C5/DB5+B7*C7/DB7+B8*C8/DB8
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B4*C4/DB41+B5*C5/DB51+B7*C7/DB71+B8*C8/DB81
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B4*C4/DB41+B5*C5/DB51+B7*C7/DB71+B8*C8/DB81
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B4*C4/DB42+B5*C5/DB52+B7*C7/DB72+B8*C8/DB82
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B4*C4/DB42+B5*C5/DB52+B7*C7/DB72+B8*C8/DB82
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B4*C4/DB43+B5*C5/DB53+B7*C7/DB73+B8*C8/DB83
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B4*C4/DB43+B5*C5/DB53+B7*C7/DB73+B8*C8/DB83
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B7*B7/(DB7*DB7)+B8*B8/(DB8*DB8)
       GO TO 149
       END IF
C
 149     CONTINUE
         GO TO 100
        END IF
C
C *********************************************************
C
C
C *********************************************************
C I=J>K
C
        IF(I.EQ.J.AND.J.GT.K) THEN
         I1=K
         J1=J
         K1=I
         DO 150,A=1,NU
         DO 150,B=A,NU
         DO 150,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 150
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          UB1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)+HAPP(A,B,2)-HAPP(C,B,1)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)+HAHH(I1,J1,2)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX1=-AX(C,A,K1,2)-AX(C,B,K1,2)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &-AX(A,C,J1,2)-AX(B,C,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX1=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)-BX(A,K1,J1,1)
     &-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB1=ENESD(JEX)+ZA1+ZA2-AX1-BX1
       DB11=ENESD(JEX)+HA1
       DB12=ENESD(JEX)+ZA1
       DB13=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          UB2=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)-HAPP(A,C,1)+HAPP(A,C,2)
     &-HAHH(I1,J1,1)+HAHH(I1,J1,2)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)
          AX2=-AX(B,A,K1,2)-AX(B,C,K1,2)-AX(A,B,J1,2)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)
     &-AX(A,B,I1,2)+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)
     &+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX2=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB2=ENESD(JEX)+ZA1+ZA2-AX2-BX2
       DB21=ENESD(JEX)+HA1
       DB22=ENESD(JEX)+ZA1
       DB23=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)
          UB3=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)+HAPP(C,B,2)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)+HAHH(I1,J1,2)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)
          AX3=-AX(A,B,K1,2)-AX(A,C,K1,2)-AX(B,A,J1,2)-AX(C,A,J1,2)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX3=-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,K1,J1,1)
       DB3=ENESD(JEX)+ZA1+ZA2-AX3-BX3
       DB31=ENESD(JEX)+HA1
       DB32=ENESD(JEX)+ZA1
       DB33=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          UB4=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)+HAPP(A,B,2)-HAPP(C,B,1)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          UB5=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)-HAPP(A,C,1)+HAPP(A,C,2)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          UB6=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)+HAPP(C,B,2)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
C
C
C       REVERSE ORDER OF A,B,C!!!
       B1=V3(C,B,A)-V3(C,A,B)
       B2=V3(B,C,A)-V3(B,A,C)
       B3=V3(A,C,B)-V3(A,B,C)
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
C
       C1=U3(C,B,A)-U3(C,A,B)
       C2=U3(B,C,A)-U3(B,A,C)
       C3=U3(A,C,B)-U3(A,B,C)
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
C
       E1=T3(C,B,A)-T3(C,A,B)
       E2=T3(B,C,A)-T3(B,A,C)
       E3=T3(A,C,B)-T3(A,B,C)
       E4=T3(B,C,A)-T3(A,C,B)
       E5=T3(C,B,A)-T3(A,B,C)
       E6=T3(C,A,B)-T3(B,A,C)
C
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6
       XNC3(JEX)=XNC3(JEX)+E1*B1/UB1+E2*B2/UB2+
     &     E3*B3/UB3+E4*B4/UB4+E5*B5/UB5+E6*B6/UB6
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B2*B2/DB21+
     &     B3*B3/DB31+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B2*B2/DB22+
     &     B3*B3/DB32+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B2*B2/DB23+
     &     B3*B3/DB33+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6
       DC3(JEX)=DC3(JEX)+(E1*C1/UB1+E2*C2/UB2+
     &     E3*C3/UB3+E4*C4/UB4+E5*C5/UB5+E6*C6/UB6)*XSTEER
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)
       GO TO 150
       END IF
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B2*B2/DB2+B6*B6/DB6
       XNC3(JEX)=XNC3(JEX)+E2*B2/UB2+E6*B6/UB6
       XM1(JEX)=XM1(JEX)+B2*B2/DB21+B6*B6/DB61
       XM2(JEX)=XM2(JEX)+B2*B2/DB22+B6*B6/DB62
       XM3(JEX)=XM3(JEX)+B2*B2/DB23+B6*B6/DB63
       DI6(JEX)=DI6(JEX)+B2*B2/DB2+B6*B6/DB6
       XDENOM(JEX)=XDENOM(JEX)+B2*C2/DB2+B6*C6/DB6
       DC3(JEX)=DC3(JEX)+(E2*C2/UB2+E6*C6/UB6)*XSTEER
       YD1(JEX)=YD1(JEX)+B2*C2/DB2+B6*C6/DB6
       XD1(JEX)=XD1(JEX)+B2*C2/DB21+B6*C6/DB61
       YD3(JEX)=YD3(JEX)+B2*C2/DB21+B6*C6/DB61
       XD2(JEX)=XD2(JEX)+B2*C2/DB22+B6*C6/DB62
       YD4(JEX)=YD4(JEX)+B2*C2/DB22+B6*C6/DB62
       XD3(JEX)=XD3(JEX)+B2*C2/DB23+B6*C6/DB63
       YD2(JEX)=YD2(JEX)+B2*C2/DB23+B6*C6/DB63
C       XDENOM(JEX)=XDENOM(JEX)+B2*B2/(DB2*DB2)+B6*B6/(DB6*DB6)
       GO TO 150
       END IF
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B5*B5/DB5
       XNC3(JEX)=XNC3(JEX)+E1*B1/UB1+E5*B5/UB5
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B5*B5/DB51
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B5*B5/DB52
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B5*B5/DB53
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B5*B5/DB5
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B5*C5/DB5
       DC3(JEX)=DC3(JEX)+(E1*C1/UB1+E5*C5/UB5)*XSTEER
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B5*C5/DB5
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B5*C5/DB51
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B5*C5/DB51
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B5*C5/DB52
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B5*C5/DB52
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B5*C5/DB53
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B5*C5/DB53
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+B5*B5/(DB5*DB5)
       GO TO 150
       END IF
C
 150   CONTINUE
         GO TO 100
        END IF
C *****************************************************
C
C
C *****************************************************
C I>J=K
C
C
C
        IF(I.GT.J.AND.J.EQ.K) THEN
         I1=K
         J1=J
         K1=I
         DO 151,A=1,NU
         DO 151,B=A,NU
         DO 151,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 151
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          UB4=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)+HAPP(A,B,2)-HAPP(C,B,1)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)
     &+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          UB5=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)-HAPP(A,C,1)+HAPP(A,C,2)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          UB6=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)+HAPP(C,B,2)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)-HAHH(I1,K1,1)+HAHH(I1,K1,2)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          UB7=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)+HAPP(A,B,2)-HAPP(C,B,1)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)+HAHH(K1,J1,2)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &-HAHP(I1,C,2)+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)
          AX7=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)
     &+AX(B,A,J1,1)-AX(A,C,J1,2)-AX(B,C,J1,2)-AX(C,A,I1,2)-AX(C,B,I1,2)
        BX7=-BX(A,I1,J1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
       DB7=ENESD(JEX)+ZA1+ZA2-AX7-BX7
       DB71=ENESD(JEX)+HA1
       DB72=ENESD(JEX)+ZA1
       DB73=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          UB8=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)-HAPP(A,C,1)+HAPP(A,C,2)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)+HAHH(K1,J1,2)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)+HAHP(I1,B,1)-HAHP(I1,B,2)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)-HAHP(J1,A,2)+HAHP(J1,B,1)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)-HAHP(K1,A,2)+HAHP(K1,B,1)
     &+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX8=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(A,B,J1,2)+AX(A,C,J1,1)-AX(A,C,J1,2)
     &-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)-AX(B,A,I1,2)-AX(B,C,I1,2)
        BX8=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB8=ENESD(JEX)+ZA1+ZA2-AX8-BX8
       DB81=ENESD(JEX)+HA1
       DB82=ENESD(JEX)+ZA1
       DB83=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
          ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          UB9=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)+XXTT
     &-HAPP(A,B,1)-HAPP(C,B,1)+HAPP(C,B,2)-HAPP(A,C,1)
     &-HAHH(I1,J1,1)-HAHH(K1,J1,1)+HAHH(K1,J1,2)-HAHH(I1,K1,1)
     &+HAHP(I1,A,1)-HAHP(I1,A,2)+HAHP(I1,B,1)+HAHP(I1,C,1)
     &+HAHP(J1,A,1)+HAHP(J1,B,1)-HAHP(J1,B,2)
     &+HAHP(J1,C,1)-HAHP(J1,C,2)+HAHP(K1,A,1)+HAHP(K1,B,1)
     &-HAHP(K1,B,2)+HAHP(K1,C,1)-HAHP(K1,C,2)
          AX9=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(B,A,J1,2)-AX(C,A,J1,2)+AX(B,C,J1,1)
     &-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)-AX(A,B,I1,2)-AX(A,C,I1,2)
        BX9=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,I1,J1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,I1,K1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB9=ENESD(JEX)+ZA1+ZA2-AX9-BX9
       DB91=ENESD(JEX)+HA1
       DB92=ENESD(JEX)+ZA1
       DB93=ENESD(JEX)+ZA1+ZA2
C
C
C
C
C       REVERSE ORDER OF A,B,C!!!
C
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
       B7=V3(B,A,C)-V3(A,B,C)
       B8=V3(C,A,B)-V3(A,C,B)
       B9=V3(C,B,A)-V3(B,C,A)
C
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
       C7=U3(B,A,C)-U3(A,B,C)
       C8=U3(C,A,B)-U3(A,C,B)
       C9=U3(C,B,A)-U3(B,C,A)
C
       E4=T3(B,C,A)-T3(A,C,B)
       E5=T3(C,B,A)-T3(A,B,C)
       E6=T3(C,A,B)-T3(B,A,C)
       E7=T3(B,A,C)-T3(A,B,C)
       E8=T3(C,A,B)-T3(A,C,B)
       E9=T3(C,B,A)-T3(B,C,A)
C
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEX)=XNUM(JEX)+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9
       XNC3(JEX)=XNC3(JEX)+E4*B4/UB4+E5*B5/UB5+E6*B6/UB6+E7*B7/UB7+
     &                     E8*B8/UB8+E9*B9/UB9
       XM1(JEX)=XM1(JEX)+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61+B7*B7/DB71+
     &                     B8*B8/DB81+B9*B9/DB91
       XM2(JEX)=XM2(JEX)+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62+B7*B7/DB72+
     &                     B8*B8/DB82+B9*B9/DB92
       XM3(JEX)=XM3(JEX)+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63+B7*B7/DB73+
     &                     B8*B8/DB83+B9*B9/DB93
       DI6(JEX)=DI6(JEX)+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9
       DC3(JEX)=DC3(JEX)+(E4*C4/UB4+E5*C5/UB5+E6*C6/UB6+E7*C7/UB7+
     &                     E8*C8/UB8+E9*C9/UB9)*XSTEER
       YD1(JEX)=YD1(JEX)+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+B7*B7/(DB7*DB7)+
C     &                     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9)
       GO TO 151
       END IF
C
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B5*B5/DB5+B9*B9/DB9
       XNC3(JEX)=XNC3(JEX)+E5*B5/UB5+E9*B9/UB9
       XM1(JEX)=XM1(JEX)+B5*B5/DB51+B9*B9/DB91
       XM2(JEX)=XM2(JEX)+B5*B5/DB52+B9*B9/DB92
       XM3(JEX)=XM3(JEX)+B5*B5/DB53+B9*B9/DB93
       DI6(JEX)=DI6(JEX)+B5*B5/DB5+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B5*C5/DB5+B9*C9/DB9
       DC3(JEX)=DC3(JEX)+(E5*C5/UB5+E9*C9/UB9)*XSTEER
       YD1(JEX)=YD1(JEX)+B5*C5/DB5+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B5*C5/DB51+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B5*C5/DB51+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B5*C5/DB52+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B5*C5/DB52+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B5*C5/DB53+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B5*C5/DB53+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B5*B5/(DB5*DB5)+B9*B9/(DB9*DB9)
       GO TO 151
       END IF
C
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B4*B4/DB4+B8*B8/DB8
       XNC3(JEX)=XNC3(JEX)+E4*B4/UB4+E8*B8/UB8
       XM1(JEX)=XM1(JEX)+B4*B4/DB41+B8*B8/DB81
       XM2(JEX)=XM2(JEX)+B4*B4/DB42+B8*B8/DB82
       XM3(JEX)=XM3(JEX)+B4*B4/DB43+B8*B8/DB83
       DI6(JEX)=DI6(JEX)+B4*B4/DB4+B8*B8/DB8
       XDENOM(JEX)=XDENOM(JEX)+B4*C4/DB4+B8*C8/DB8
       DC3(JEX)=DC3(JEX)+(E4*C4/UB4+E8*C8/UB8)*XSTEER
       YD1(JEX)=YD1(JEX)+B4*C4/DB4+B8*C8/DB8
       XD1(JEX)=XD1(JEX)+B4*C4/DB41+B8*C8/DB81
       YD3(JEX)=YD3(JEX)+B4*C4/DB41+B8*C8/DB81
       XD2(JEX)=XD2(JEX)+B4*C4/DB42+B8*C8/DB82
       YD4(JEX)=YD4(JEX)+B4*C4/DB42+B8*C8/DB82
       XD3(JEX)=XD3(JEX)+B4*C4/DB43+B8*C8/DB83
       YD2(JEX)=YD2(JEX)+B4*C4/DB43+B8*C8/DB83
C       XDENOM(JEX)=XDENOM(JEX)+B4*B4/(DB4*DB4)+B8*B8/(DB8*DB8)
       GO TO 151
       END IF
C
 151     CONTINUE
         GO TO 100
        END IF
C ************************************
C
C
C
C
C
 100  CONTINUE
      RETURN
      END
C
C*MODULE MM23     *DECK DEN12N
      SUBROUTINE DEN12N(NO,NU,T1,T2,R1,R2,C0,C1,C2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(NO,NU),T2(NO,NU,NU,NO),
     *          R1(NO,NU),R2(NO,NU,NU,NO),
     *          C1(NO,NU),C2(NO,NU,NU,NO),C0(*)
C
      INTEGER II,JJ,AA,BB
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
      DATA TWO/2.0D+00/
C
      CALL RO1(1,NO,NU,T1)
      CALL RO2(1,NO,NU,T2)
      I=1
      CALL RR1(NO,NU,R1)
      CALL RR2(NO,NU,R2)
C
      XDENOM(I)=XDENOM(I)+R0(I)*R0(I)
      DC3(I)=DC3(I)+C0(1)*R0(I)
      DO 2,II=1,NO
       DO 3,AA=1,NU
        X1=R0(I)*T1(II,AA)+R1(II,AA)
        Y1=C1(II,AA)
        XDENOM(I)=XDENOM(I)+TWO*X1*X1
        DC3(I)=DC3(I)+TWO*Y1*X1
 3     CONTINUE
 2    CONTINUE
C
C I<J  (A<B A=B)
C
      DO 4,II=1,NO
       DO 5,JJ=II+1,NO
       DO 6,AA=1,NU
       DO 7,BB=AA,NU
        X1=R0(I)*T2(II,AA,BB,JJ)+
     &     R0(I)*T1(II,AA)*T1(JJ,BB)+
     &     T1(II,AA)*R1(JJ,BB)+T1(JJ,BB)*R1(II,AA)+
     &     R2(II,AA,BB,JJ)
        X2=R0(I)*T2(II,BB,AA,JJ)+
     &     R0(I)*T1(II,BB)*T1(JJ,AA)+
     &     T1(II,BB)*R1(JJ,AA)+T1(JJ,AA)*R1(II,BB)+
     &     R2(II,BB,AA,JJ)
        Y1=C2(II,AA,BB,JJ)
        Y2=C2(II,BB,AA,JJ)
        IF(AA.EQ.BB) THEN
          XDENOM(I)=XDENOM(I)+TWO*X1*X1
          DC3(I)=DC3(I)+TWO*Y1*X1
          GO TO 7
        END IF
        XDENOM(I)=XDENOM(I)+TWO*(X1-X2)*(X1-X2)+TWO*X1*X1+TWO*X2*X2
        DC3(I)=DC3(I)+TWO*(Y1-Y2)*(X1-X2)+TWO*Y1*X1+TWO*Y2*X2
 7     CONTINUE
 6     CONTINUE
 5     CONTINUE
 4     CONTINUE
C
C I=J (A<B)
C
       DO 8,II=1,NO
       DO 9,AA=1,NU
       DO 10,BB=AA+1,NU
        X1=R0(I)*T2(II,AA,BB,II)+
     &     R0(I)*T1(II,AA)*T1(II,BB)+
     &     T1(II,AA)*R1(II,BB)+T1(II,BB)*R1(II,AA)+
     &     R2(II,AA,BB,II)
        X2=R0(I)*T2(II,BB,AA,II)+
     &     R0(I)*T1(II,BB)*T1(II,AA)+
     &     T1(II,BB)*R1(II,AA)+T1(II,AA)*R1(II,BB)+
     &     R2(II,BB,AA,II)
        Y1=C2(II,AA,BB,II)
        Y2=C2(II,BB,AA,II)
        XDENOM(I)=XDENOM(I)+X1*X1+X2*X2
        DC3(I)=DC3(I)+Y1*X1+Y2*X2
 10    CONTINUE
 9     CONTINUE
 8     CONTINUE
C
C I=J (A=B)
C
       DO 11,II=1,NO
       DO 12,AA=1,NU
        X1=R0(I)*T2(II,AA,AA,II)+
     &     R0(I)*T1(II,AA)*T1(II,AA)+
     &     TWO*T1(II,AA)*R1(II,AA)+
     &     R2(II,AA,AA,II)
        Y1=C2(II,AA,AA,II)
        XDENOM(I)=XDENOM(I)+X1*X1
        DC3(I)=DC3(I)+Y1*X1
 12    CONTINUE
 11    CONTINUE
C
      XD1(I)=XDENOM(I)
      XD2(I)=XDENOM(I)
      XD3(I)=XDENOM(I)
      YD1(I)=XDENOM(I)
      YD2(I)=XDENOM(I)
      YD3(I)=XDENOM(I)
      YD4(I)=XDENOM(I)
CDDD      DC3(I)=XDENOM(I)
CDDD  W CI3(C0,C1,C2) -> DC3(I) EXPRESSED THROUGH Y1,Y2
      RETURN
      END
C
C*MODULE MM23     *DECK DEN12CR
      SUBROUTINE DEN12CR(NO,NU,T1,T2,R1,R2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(NO,NU),T2(NO,NU,NU,NO),
     *          R1(NO,NU),R2(NO,NU,NU,NO)
C
      INTEGER II,JJ,AA,BB
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
      DATA TWO/2.0D+00/
C
      CALL RO1(1,NO,NU,T1)
      CALL RO2(1,NO,NU,T2)
      I=1
      CALL RR1(NO,NU,R1)
      CALL RR2(NO,NU,R2)
C
      XDENOM(I)=XDENOM(I)+R0(I)*R0(I)
      DO 2,II=1,NO
       DO 3,AA=1,NU
        X1=R0(I)*T1(II,AA)+R1(II,AA)
        XDENOM(I)=XDENOM(I)+TWO*X1*X1
 3     CONTINUE
 2    CONTINUE
C
C I<J  (A<B A=B)
C
       DO 4,II=1,NO
       DO 5,JJ=II+1,NO
       DO 6,AA=1,NU
       DO 7,BB=AA,NU
        X1=R0(I)*T2(II,AA,BB,JJ)+
     &     R0(I)*T1(II,AA)*T1(JJ,BB)+
     &     T1(II,AA)*R1(JJ,BB)+T1(JJ,BB)*R1(II,AA)+
     &     R2(II,AA,BB,JJ)
        X2=R0(I)*T2(II,BB,AA,JJ)+
     &     R0(I)*T1(II,BB)*T1(JJ,AA)+
     &     T1(II,BB)*R1(JJ,AA)+T1(JJ,AA)*R1(II,BB)+
     &     R2(II,BB,AA,JJ)
        IF(AA.EQ.BB) THEN
          XDENOM(I)=XDENOM(I)+TWO*X1*X1
          GO TO 7
        END IF
        XDENOM(I)=XDENOM(I)+TWO*(X1-X2)*(X1-X2)+TWO*X1*X1+TWO*X2*X2
 7     CONTINUE
 6     CONTINUE
 5     CONTINUE
 4     CONTINUE
C
C I=J (A<B)
C
       DO 8,II=1,NO
       DO 9,AA=1,NU
       DO 10,BB=AA+1,NU
        X1=R0(I)*T2(II,AA,BB,II)+
     &     R0(I)*T1(II,AA)*T1(II,BB)+
     &     T1(II,AA)*R1(II,BB)+T1(II,BB)*R1(II,AA)+
     &     R2(II,AA,BB,II)
        X2=R0(I)*T2(II,BB,AA,II)+
     &     R0(I)*T1(II,BB)*T1(II,AA)+
     &     T1(II,BB)*R1(II,AA)+T1(II,AA)*R1(II,BB)+
     &     R2(II,BB,AA,II)
        XDENOM(I)=XDENOM(I)+X1*X1+X2*X2
 10    CONTINUE
 9     CONTINUE
 8     CONTINUE
C
C I=J (A=B)
C
       DO 11,II=1,NO
       DO 12,AA=1,NU
        X1=R0(I)*T2(II,AA,AA,II)+
     &     R0(I)*T1(II,AA)*T1(II,AA)+
     &     TWO*T1(II,AA)*R1(II,AA)+
     &     R2(II,AA,AA,II)
        XDENOM(I)=XDENOM(I)+X1*X1
 12    CONTINUE
 11    CONTINUE
C
      XD1(I)=XDENOM(I)
      XD2(I)=XDENOM(I)
      XD3(I)=XDENOM(I)
      YD1(I)=XDENOM(I)
      YD2(I)=XDENOM(I)
      YD3(I)=XDENOM(I)
      YD4(I)=XDENOM(I)
      RETURN
      END
C
C*MODULE MM23     *DECK XT3WT2NNN
      SUBROUTINE XT3WT2NNN(ESCF,ECCSD,BESTEOM,NO,NU,O1,T2,VM,VE,V3,R1,
     *                     R2,EXVE,EXVM,AUXR2,U3,AH,AP,APP,AHH,AHP,
     *                     AX,BX,VL1,VL2,VL3,VE2,VM2,FHP,VOE,
     *                     EH,EP,IXY)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER CRL
C
      CHARACTER*3 VECREP
C
      DIMENSION O1(*),T2(NU,NU,NO,NO),VM(NO,NU,NO,NO),V3(*),
     *          VE(NU,NU,NU,NO),EH(NO),EP(NU),
     *          EXVE(NU,NU,NU,NO),EXVM(NO,NU,NO,NO),
     *          R1(*),R2(NU,NU,NO,NO),FHP(NU,NO),
     *          AUXR2(NO,NU,NU,NO),U3(NU,NU,NU),
     *          AH(NO),AP(NU),VE2(NU,NU,NU,NO),
     *          AHH(NO,NO,2),AHP(NO,NU,2),APP(NU,NU,2),
     *          AX(NU,NU,NO,2),BX(NU,NO,NO,2),
     *          VL1(NU,NO),VL2(NU,NU,NO,NO),
     *          VL3(NU,NU,NU),VM2(NO,NU,NO,NO),
     *          VOE(NU,NU,NO,NO)
C
      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 /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
     *                CRCI3(100),XDELWB(100),XKKEOM(100),
     *                CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
     *                KVGEOM(100),IUST(100),IREL(100),
     *                KKTRIM(100),KKTRIML(100),
     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
     *                IVSYMAD(8),VECREP(100)
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA ZERO/0.0D+00/, ONE/1.0D+00/, OM/-1.0D+00/
CC    DATA HALF/0.5D+00/
      DATA CRCCL/8HCR-CCL   /
C
      NO2   = NO*NO
      NU2   = NU*NU
      NU3   = NU*NU*NU
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
      NO2U2 = NO*NO*NU*NU
      TOLPR = 0.1D+00
C
C ZEROWANIE
C
      CALL ZEROMA(V3,1,NU3)
      CALL ZEROMA(VL3,1,NU3)
      CALL ZEROMA(T2,1,NO2U2)
      CALL ZEROMA(EXVM,1,NO2U2)
C
      CALL RCCFL(ITAPP,1,NO,AH)
      CALL RCCFL(ITAPP,2,NU,AP)
      CALL RCCFL(ITAPP,3,2*NU2,APP)
      CALL RCCFL(ITAPP,4,2*NO2,AHH)
      CALL RCCFL(ITAPP,5,2*NOU,AHP)
      CALL RCCFL(IFAX,1,2*NOU2,AX)
      CALL RCCFL(IFAX,2,2*NO2U,BX)
C
      CALL RDVE(1,NO,NU,VE2)
      CALL TRANMD(VE2,NU,NU,NU,NO,23)
      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 RDVM(1,NO,NU,T2)
      CALL VMCP1(NO,NU,VM2,T2)
      CALL TRANMD(VM2,NO,NU,NO,NO,13)
C
C MAIN LOOP OVER ALL EXCITED STATES
C
      II=1
      IIL=2
      CRL=0
      IF(CCTYP.EQ.CRCCL) CRL=1
C
      IF(CRL.EQ.1) THEN
        WRITE(6,*)'LAMBDA CORRECTION FOR ROOT NO.',IXY
        IF(IXY.EQ.0) THEN
          CALL RO1(5,NO,NU,VL1)
          CALL RO2(8,NO,NU,VL2)
        END IF
C
        CALL INSITU(NO,NU,NU,NO,V3,VL2,13)
        CALL TRT1(NO,NU,V3,VL1)
C       CALL VECMUL(VL1,NOU,HALF)
C
C         AMPLITUDE PRINTING...
C
        WRITE(6,9030)
C
      DO 560 IIIA=1,NU
       DO 561 IIII=1,NO
        XXX=ABS(VL1(IIIA,IIII))
        IF(XXX.GT.TOLPR) THEN
         WRITE(6,9040) VL1(IIIA,IIII),IIII,IIIA+NO
        END IF
  561  CONTINUE
  560 CONTINUE
C
      DO 570,JJJ=1,NU
       DO 571,JJB=1,NU
        DO 572,IIA=1,NO
         DO 573,III=1,NO
          XXX=ABS(VL2(JJJ,JJB,IIA,III))
          IF(XXX.GT.TOLPR) THEN
            WRITE(6,9050) VL2(JJJ,JJB,IIA,III),III,IIA,JJJ+NO,JJB+NO
          END IF
  573    CONTINUE
  572   CONTINUE
  571  CONTINUE
  570 CONTINUE
C
 9030 FORMAT(1X,'THE LARGEST L1 AND L2 AMPLITUDES FOR THIS ROOT ARE')!!!
 9040 FORMAT(1X,'L1=',F15.10,' FOR   I -> A   =',2I5)!!!
 9050 FORMAT(1X,'L2=',F15.10,' FOR I,J -> A,B =',4I5)!!!
C
      CALL FLSHBF(6)
      END IF  ! CLOSE OF CR-CCL COMPUTATION
C
C
C ON R2 VECTOR WE KEEP R2(EOMCCSD)+R_0(EOMCCSD)*T2
C      CALL VECMUL(VL1,NOU,HALF)
      CALL RR1(NO,NU,R1)
      CALL RR2(NO,NU,R2)
      CALL RR2(NO,NU,AUXR2)
      CALL INSITU(NO,NU,NU,NO,V3,R2,13)
      CALL RO2(1,NO,NU,T2)
      CALL RO1(1,NO,NU,O1)
      CALL RO1(3,NO,NU,FHP)
      CALL TRT1(NO,NU,V3,FHP)
CC      CALL VECMUL(FHP,NOU,HALF)
      CALL INSITU(NO,NU,NU,NO,V3,T2,13)
      CALL VECMUL(T2,NO2U2,R0(II))
      CALL VECADD(R2,T2,NO2U2)
C      CALL RO2(2,NO,NU,VOE)
      CALL RO2HPP(1,NO,NU,V3,VOE)
      CALL INSITU(NO,NU,NU,NO,V3,VOE,13)
C
C
C
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL REXXVE(5,NO,NU,EXVE)
C ----------------------------------------
      CALL TRANMD(EXVE,NU,NU,NU,NO,23)
C
      CALL ZEROMA(T2,1,NO2U2)
C 27/05/2004 LEFT EOMSD ------------------ FILES'S NUMBER REDUCTION
      CALL REXXVM(5,NO,NU,T2)
C ----------------------------------------
      CALL VMCP1(NO,NU,EXVM,T2)
      CALL TRANMD(EXVM,NO,NU,NO,NO,13)
CC
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,V3,T2,13)
CC
CC
CC MOMENTS(R,I)*T2 (T2 COMBINED WITH EXVM OR EXVE)
CC AND
CC MOMENTS(T)*(R2+R_0*T2) (COMBINED WITH VM OR VE)
CC
CC
CC COMMENTED BY KK
      DO 351 I=1,NO
         I1=I-1
      DO 351 J=1,I1
         J1=J-1
      DO 351 K=1,J1
C              KK=IT3(I,J,K)
C
        IF(CRL.EQ.1) THEN
      CALL CCMATMUL(VL2(1,1,1,I),VM2(1,1,K,J),VL3,NU2,NU,NO,1,1)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,1,I),VM2(1,1,J,K),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,4)
      CALL CCMATMUL(VL2(1,1,1,J),VM2(1,1,K,I),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,1,J),VM2(1,1,I,K),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,5)
      CALL CCMATMUL(VL2(1,1,1,K),VM2(1,1,J,I),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,1,K),VM2(1,1,I,J),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,4)
      CALL CCMATMUL(VL2(1,1,J,I),VE2(1,1,1,K),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,K,I),VE2(1,1,1,J),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,5)
      CALL CCMATMUL(VL2(1,1,I,J),VE2(1,1,1,K),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,K,J),VE2(1,1,1,I),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,4)
      CALL CCMATMUL(VL2(1,1,I,K),VE2(1,1,1,J),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,J,K),VE2(1,1,1,I),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,5)
        END IF
C
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,K,J),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,K,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,1)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,J,K),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVM(1,1,K,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVM(1,1,I,K),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,K),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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(CRL.NE.1) THEN
      CALL XT3SQCR(II,I,J,K,NO,NU,O1,T2,R1,AUXR2,V3,U3)
      CALL XT3SQ2CR(II,I,J,K,NO,NU,V3,U3,AH,AP,APP,AHH,AHP,AX,BX,EH,EP)
C
        ELSE
      CALL ZEROT3(VL3,NU)
      CALL XT3SQCRL(II,I,J,K,NO,NU,O1,T2,R1,AUXR2,V3,U3,
     *              FHP,VL2,VL1,VOE,VL3)
      CALL XT3SQ2CRL(II,I,J,K,NO,NU,V3,U3,VL3,AH,AP,APP,
     *               AHH,AHP,AX,BX,EH,EP)
        END IF
C
C
 351  CONTINUE
CC
CC
CC COMMENTED BY KK
      DO 352 I=1,NO
         I1=I-1
      DO 352 J=1,I1
C           KK=IT3(I,J,J)
CC      CALL CCMATMUL(VOE(1,1,J,I),VL1(1,J),VL3,NU2,NU,1,1,0)
CC      CALL CCMATMUL(VL2(1,1,J,I),FHP(1,J),VL3,NU2,NU,1,1,0)
CC      CALL TRANT3(VL3,NU,2)
CC      CALL CCMATMUL(VOE(1,1,I,J),VL1(1,J),VL3,NU2,NU,1,0,0)
CC      CALL CCMATMUL(VL2(1,1,I,J),FHP(1,J),VL3,NU2,NU,1,0,0)
CC      CALL TRANT3(VL3,NU,1)
CC      CALL CCMATMUL(VOE(1,1,J,J),VL1(1,I),VL3,NU2,NU,1,0,0)
CC      CALL CCMATMUL(VL2(1,1,J,J),FHP(1,I),VL3,NU2,NU,1,0,0)
CC      CALL TRANT3(VL3,NU,4)
C
C      CALL CCMATMUL(VL2(1,1,J,I),FHP(1,J),VL3,NU2,NU,1,0,0)
C      CALL TRANT3(VL3,NU,2)
C      CALL CCMATMUL(VL2(1,1,I,J),FHP(1,J),VL3,NU2,NU,1,0,0)
C      CALL TRANT3(VL3,NU,1)
C      CALL CCMATMUL(VL2(1,1,J,J),FHP(1,I),VL3,NU2,NU,1,0,0)
C      CALL TRANT3(VL3,NU,4)
C
        IF(CRL.EQ.1) THEN
      CALL CCMATMUL(VL2(1,1,1,I),VM2(1,1,J,J),VL3,NU2,NU,NO,1,1)
      CALL TRANT3(VL3,NU,2)
      CALL CCMATMUL(VL2(1,1,1,J),VM2(1,1,J,I),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,1,J),VM2(1,1,I,J),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,4)
      CALL CCMATMUL(VL2(1,1,J,I),VE2(1,1,1,J),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,3)
      CALL CCMATMUL(VL2(1,1,I,J),VE2(1,1,1,J),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,J,J),VE2(1,1,1,I),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,2)
        END IF
C
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,J,J),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),NU2,VM(1,1,J,J),NO,
     *ONE,V3,NU2)
      CALL TRANT3(V3,NU,2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,J),NU2,EXVM(1,1,J,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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)
        IF(CRL.NE.1) THEN
      CALL XT3SQCR(II,I,J,J,NO,NU,O1,T2,R1,AUXR2,V3,U3)
      CALL XT3SQ2CR(II,I,J,J,NO,NU,V3,U3,AH,AP,APP,AHH,AHP,AX,BX,EH,EP)
        ELSE
      CALL SYMT311(VL3,NU,23)
      CALL ZEROT3(VL3,NU)
      CALL XT3SQCRL(II,I,J,J,NO,NU,O1,T2,R1,AUXR2,V3,U3,
     *              FHP,VL2,VL1,VOE,VL3)
      CALL XT3SQ2CRL(II,I,J,J,NO,NU,V3,U3,VL3,AH,AP,APP,
     *               AHH,AHP,AX,BX,EH,EP)
        END IF
 352  CONTINUE
C
C
CC COMMENTED BY KK
      DO 353 I=1,NO
         I1=I-1
      DO 353 J=1,I1
        IF(CRL.EQ.1) THEN
C           KK=IT3(I,I,J)
CC      CALL CCMATMUL(VOE(1,1,I,I),VL1(1,J),VL3,NU2,NU,1,1,0)
CC      CALL CCMATMUL(VL2(1,1,I,I),FHP(1,J),VL3,NU2,NU,1,1,0)
CC      CALL TRANT3(VL3,NU,1)
CC      CALL CCMATMUL(VOE(1,1,J,I),VL1(1,I),VL3,NU2,NU,1,0,0)
CC      CALL CCMATMUL(VL2(1,1,J,I),FHP(1,I),VL3,NU2,NU,1,1,0)
CC      CALL TRANT3(VL3,NU,2)
CC      CALL CCMATMUL(VOE(1,1,I,J),VL1(1,I),VL3,NU2,NU,1,0,0)
CC      CALL CCMATMUL(VL2(1,1,I,J),FHP(1,I),VL3,NU2,NU,1,0,0)
      CALL TRANT3(VL3,NU,5)
C
C      CALL CCMATMUL(VL2(1,1,I,I),FHP(1,J),VL3,NU2,NU,1,0,0)
C      CALL TRANT3(VL3,NU,1)
C      CALL CCMATMUL(VL2(1,1,J,I),FHP(1,I),VL3,NU2,NU,1,0,0)
C      CALL TRANT3(VL3,NU,2)
C      CALL CCMATMUL(VL2(1,1,I,J),FHP(1,I),VL3,NU2,NU,1,0,0)
C      CALL TRANT3(VL3,NU,5)
C
      CALL CCMATMUL(VL2(1,1,1,I),VM2(1,1,J,I),VL3,NU2,NU,NO,1,1)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,1,I),VM2(1,1,I,J),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,2)
      CALL CCMATMUL(VL2(1,1,1,J),VM2(1,1,I,I),VL3,NU2,NU,NO,0,1)
      CALL TRANT3(VL3,NU,2)
      CALL CCMATMUL(VL2(1,1,I,I),VE2(1,1,1,J),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,1)
      CALL CCMATMUL(VL2(1,1,J,I),VE2(1,1,1,I),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,3)
      CALL CCMATMUL(VL2(1,1,I,J),VE2(1,1,1,I),VL3,NU,NU2,NU,0,0)
      CALL TRANT3(VL3,NU,3)
        END IF
C
      CALL DGEMM('N','N',NU2,NU,NO,OM,T2(1,1,1,I),NU2,EXVM(1,1,J,I),NO,
     *ZERO,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(1,1,1,I),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,I),NU2,EXVM(1,1,I,J),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVM(1,1,I,I),NO,
     *ONE,V3,NU2)
      CALL DGEMM('N','N',NU2,NU,NO,OM,R2(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,EXVE(1,1,1,J),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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,EXVE(1,1,1,I),NU,
     *ONE,V3,NU)
      CALL DGEMM('N','N',NU,NU2,NU,ONE,R2(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)
        IF(CRL.NE.1) THEN
      CALL XT3SQCR(II,I,I,J,NO,NU,O1,T2,R1,AUXR2,V3,U3)
      CALL XT3SQ2CR(II,I,I,J,NO,NU,V3,U3,AH,AP,APP,AHH,AHP,AX,BX,EH,EP)
        ELSE
      CALL SYMT311(VL3,NU,12)
      CALL ZEROT3(VL3,NU)
      CALL XT3SQCRL(II,I,I,J,NO,NU,O1,T2,R1,AUXR2,V3,U3,
     *              FHP,VL2,VL1,VOE,VL3)
      CALL XT3SQ2CRL(II,I,I,J,NO,NU,V3,U3,VL3,AH,AP,APP,
     *               AHH,AHP,AX,BX,EH,EP)
        END IF
 353  CONTINUE
C
C
C
C HARTREE-EV CONVERSION FACTOR
C
C****      PRZ=27.21160D+00
C
      IF(IXY.EQ.0) THEN
        WRITE(6,488) ECCSD
        XPOT  = ZERO
        XPOT1 = ZERO
        XPOT2 = ZERO
      ELSE
        WRITE(6,499)  VECREP(IUST(IXY))
        WRITE(6,434)  ECCSD+ENESD(II)
        WRITE(6,1111) ECCSD+ENESD(II)+XM1(II)/XD1(II)
        WRITE(6,1112) ECCSD+ENESD(II)+XM2(II)/XD2(II)
        WRITE(6,1113) ECCSD+ENESD(II)+XM3(II)/XD3(II)
        WRITE(6,1114) ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
        BESTEOM = ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
C
        XPOT1=XM1(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XPOT2=XM2(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XPOT =XM3(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        WRITE(6,1115) ECCSD+ENESD(II)+XPOT1/YD3(II)
        WRITE(6,1116) ECCSD+ENESD(II)+XPOT2/YD4(II)
        WRITE(6,1117) ECCSD+ENESD(II)+XPOT/YD2(II)
        WRITE(6,1118) ECCSD+ENESD(II)+DI6(II)/YD1(II)
      END IF
C
      CR1D1A(IXY)=ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR1
      CR2D1A(IXY)=ENESD(II)+DI6(II)/YD1(II)-XGRCORR1
      CR1D1B(IXY)=ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR2
      CR2D1B(IXY)=ENESD(II)+DI6(II)/YD1(II)-XGRCORR2
C
      CR1A(IXY)=ENESD(II)+XM1(II)/XD1(II)
      CR1B(IXY)=ENESD(II)+XM2(II)/XD2(II)
      CR1C(IXY)=ENESD(II)+XM3(II)/XD3(II)
      CR1D(IXY)=ENESD(II)+XNUM(II)/XDENOM(II)
      CR2A(IXY)=ENESD(II)+XPOT1/YD3(II)
      CR2B(IXY)=ENESD(II)+XPOT2/YD4(II)
      CR2C(IXY)=ENESD(II)+XPOT/YD2(II)
      CR2D(IXY)=ENESD(II)+DI6(II)/YD1(II)
      WRXX=XM1(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
      XDELWB(IXY)=ENESD(II)+WRXX
C
 1111 FORMAT(1X,'CR-EOMCCSD(T)IA  TOTAL ENERGY ',F20.10,' HARTREE')
 1112 FORMAT(1X,'CR-EOMCCSD(T)IB  TOTAL ENERGY ',F20.10,' HARTREE')
 1113 FORMAT(1X,'CR-EOMCCSD(T)IC  TOTAL ENERGY ',F20.10,' HARTREE')
 1114 FORMAT(1X,'CR-EOMCCSD(T)ID  TOTAL ENERGY ',F20.10,' HARTREE')
 1115 FORMAT(1X,'CR-EOMCCSD(T)IIA TOTAL ENERGY ',F20.10,' HARTREE')
 1116 FORMAT(1X,'CR-EOMCCSD(T)IIB TOTAL ENERGY ',F20.10,' HARTREE')
 1117 FORMAT(1X,'CR-EOMCCSD(T)IIC TOTAL ENERGY ',F20.10,' HARTREE')
 1118 FORMAT(1X,'CR-EOMCCSD(T)IID TOTAL ENERGY ',F20.10,' HARTREE')
 434  FORMAT(1X,'TOTAL EOM-CCSD ENERGY         ',F20.10,' HARTREE')
 499  FORMAT(/1X,'SYMMETRY OF THE EXCITED STATE: ',A3)
C
C      WRITE(6,*)'EOMCCSD EXCITATION ENERGY:',ENESD(II),' MH'
C      WRITE(6,433) ENESD(II)*PRZ
C 433  FORMAT('EOMCCSD EXCITATION ENERGY ',F7.3,' EV')
C      WRITE(6,434) ECCSD+ENESD(II)
C      WRITE(6,*)'      R0T1T2*M3',DI1(II)
C      WRITE(6,*)'      R0T1T1T1*M3',DI2(II)
C      WRITE(6,*)'      R1T2*M3',DI3(II)
C      WRITE(6,*)'      R1T1T1*M3',DI4(II)
C      WRITE(6,*)'      R2T1*M3',DI5(II)
C      WRITE(6,*)'      R3*M3',DI6(II)
C         SSS123=DI1(II)+DI2(II)+DI3(II)+DI4(II)+DI5(II)+DI6(II)
C      WRITE(6,*)'      ALL CONTRIBUTIONS:',SSS123
C      WRITE(6,*)'        SMALL DENOM. DIAGNOSTICS'
C      WRITE(6,*)'         SMALLEST DENOM.',SDD(II)
C      WRITE(6,455)JO1(II),JO2(II),JO3(II),
C     &            JU1(II)+NO,JU2(II)+NO,JU3(II)+NO
C      WRITE(6,*)'         TYPE',JTRACE(II)
C
C     IF(IXY.GT.0) THEN
C      WRITE(6,*)'***DIFFERENT TYPES OF MM(2,3) CORRECTIONS'
CC      WRITE(6,*)'CR-EOMCCSD(T)IA:NUMERATOR',XM1(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IA:DENOMINATOR',XD1(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IA:CORRECTION',XM1(II)/XD1(II)
C      PPP=ENESD(II)+XM1(II)/XD1(II)-XGRCORR1
C      WRITE(6,112)PPP*PRZ,ECCSD+ENESD(II)+XM1(II)/XD1(II)
C 112  FORMAT('CR-EOMCCSD(T)IA/IA EXCITATION:',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC      WRITE(6,*)'CR-EOMCCSD(T)IB:NUMERATOR',XM2(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IB:DENOMINATOR',XD2(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IB:CORRECTION',XM2(II)/XD2(II)
C      PPP=ENESD(II)+XM2(II)/XD2(II)-XGRCORR2
C      WRITE(6,212)PPP*PRZ,ECCSD+ENESD(II)+XM2(II)/XD2(II)
C 212  FORMAT('CR-EOMCCSD(T)IB/IB EXCITATION:',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC      WRITE(6,*)'CR-EOMCCSD(T)IC:NUMERATOR',XM3(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IC:DENOMINATOR',XD3(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)IC:CORRECTION',XM3(II)/XD3(II)
C      PPP=ENESD(II)+XM3(II)/XD3(II)-XGRCORR3
C      WRITE(6,312)PPP*PRZ,ECCSD+ENESD(II)+XM3(II)/XD3(II)
C 312  FORMAT('CR-EOMCCSD(T)IC/IC EXCITATION:',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC      WRITE(6,*)'CR-EOMCCSD(T)ID:NUMERATOR',XNUM(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)ID:DENOMINATOR',XDENOM(II)
CC      WRITE(6,*)'CR-EOMCCSD(T)ID:CORRECTION',XNUM(II)/XDENOM(II)
C      XXCORR=XNUM(II)/XDENOM(II)
C      WRITE(6,372)(ENESD(II)+XXCORR-XGRCORR)*PRZ,
C     &            ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
C 372  FORMAT('CR-EOMCCSD(T)ID/ID EXCITATION:',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC
CC
CC
CC
C      WRITE(6,*)'######## CROSSINGS #########'
C      WRITE(6,530)(ENESD(II)+XM1(II)/XD1(II)-XGRCORR)*PRZ,
C     &   ECCSD+ENESD(II)+XM1(II)/XD1(II)
C      WRITE(6,531)(ENESD(II)+XM1(II)/XD1(II)-XGRCORR2)*PRZ,
C     &   ECCSD+ENESD(II)+XM1(II)/XD1(II)
C      WRITE(6,532)(ENESD(II)+XM1(II)/XD1(II)-XGRCORR3)*PRZ,
C     &   ECCSD+ENESD(II)+XM1(II)/XD1(II)
CC
C      WRITE(6,533)(ENESD(II)+XM2(II)/XD2(II)-XGRCORR)*PRZ,
C     &   ECCSD+ENESD(II)+XM2(II)/XD2(II)
C      WRITE(6,534)(ENESD(II)+XM2(II)/XD2(II)-XGRCORR1)*PRZ,
C     &   ECCSD+ENESD(II)+XM2(II)/XD2(II)
C      WRITE(6,535)(ENESD(II)+XM2(II)/XD2(II)-XGRCORR3)*PRZ,
C     &   ECCSD+ENESD(II)+XM2(II)/XD2(II)
CC
C      WRITE(6,536)(ENESD(II)+XM3(II)/XD3(II)-XGRCORR)*PRZ,
C     &   ECCSD+ENESD(II)+XM3(II)/XD3(II)
C      WRITE(6,537)(ENESD(II)+XM3(II)/XD3(II)-XGRCORR1)*PRZ,
C     &   ECCSD+ENESD(II)+XM3(II)/XD3(II)
C      WRITE(6,538)(ENESD(II)+XM3(II)/XD3(II)-XGRCORR2)*PRZ,
C     &   ECCSD+ENESD(II)+XM3(II)/XD3(II)
CC
C      WRITE(6,539)(ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR1)*PRZ,
C     &   ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
C      WRITE(6,540)(ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR2)*PRZ,
C     &   ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
C      WRITE(6,541)(ENESD(II)+XNUM(II)/XDENOM(II)-XGRCORR3)*PRZ,
C     &   ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
CC
C 530  FORMAT('CR-EOMCCSD(T)IA/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 531  FORMAT('CR-EOMCCSD(T)IA/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 532  FORMAT('CR-EOMCCSD(T)IA/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
C 533  FORMAT('CR-EOMCCSD(T)IB/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 534  FORMAT('CR-EOMCCSD(T)IB/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 535  FORMAT('CR-EOMCCSD(T)IB/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
C 536  FORMAT('CR-EOMCCSD(T)IC/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 537  FORMAT('CR-EOMCCSD(T)IC/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 538  FORMAT('CR-EOMCCSD(T)IC/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
C 539  FORMAT('CR-EOMCCSD(T)ID/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 540  FORMAT('CR-EOMCCSD(T)ID/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 541  FORMAT('CR-EOMCCSD(T)ID/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC
C      WRITE(6,*)'###|PSI_K>=(P+Q12)EXP(T12)R012+R3|PHI>###'
C      WRITE(6,*)'###|PSI_0>=(P+Q123)EXP(T12)(1+T3)|PHI>###'
C      XPOT=XM3(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
C      WRITE(6,550)(ENESD(II)+XPOT/YD2(II)-XGRCORR1)*PRZ,
C     &              ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,551)(ENESD(II)+XPOT/YD2(II)-XGRCORR2)*PRZ,
C     &              ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,552)(ENESD(II)+XPOT/YD2(II)-XGRCORR3)*PRZ,
C     &              ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,553)(ENESD(II)+XPOT/YD2(II)-XGRCORR)*PRZ,
C     &              ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,554)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR1)*PRZ,
C     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,555)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR2)*PRZ,
C     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,556)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR3)*PRZ,
C     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,557)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR)*PRZ,
C     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
CC
C 550  FORMAT('CR-EOMCCSD(T)IIC/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 551  FORMAT('CR-EOMCCSD(T)IIC/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 552  FORMAT('CR-EOMCCSD(T)IIC/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 553  FORMAT('CR-EOMCCSD(T)IIC/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 554  FORMAT('CR-EOMCCSD(T)IID/IA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 555  FORMAT('CR-EOMCCSD(T)IID/IB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 556  FORMAT('CR-EOMCCSD(T)IID/IC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 557  FORMAT('CR-EOMCCSD(T)IID/ID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C
CCC      WRITE(6,*)'###|PSI_K>=(P+Q12)EXP(T12)R012+R3|PHI>###'
CCC      WRITE(6,*)'###|PSI_0>=CR-CCSD(T)###'
CCC      WRITE(6,701)(ECCSD+ENESD(II)+XPOT/YD2(II)-ECRCCSDT)*PRZ,
CCC     &              ECCSD+ENESD(II)+XPOT/YD2(II)
CCC      WRITE(6,702)(ECCSD+ENESD(II)+DI6(II)/YD1(II)-ECRCCSDT)*PRZ,
CCC     &              ECCSD+ENESD(II)+DI6(II)/YD1(II)
CCC 701  FORMAT('GR(CCSD(T)) EX(12BODY)S:   ',F7.3,' EV',' TOT(',
CCC     &       F13.6,' HARTREE)')
CCC 702  FORMAT('GR(CCSD(T)) EX(ALL)S:      ',F7.3,' EV',' TOT(',
CCC     &       F13.6,' HARTREE)')
C
C
CCC      WRITE(6,*)'###|PSI_K>=(P+Q123)EXP(T12)[R012+R3]|PHI>###'
CCC      WRITE(6,*)'###|PSI_0>=CR-CCSD(T)###'
CCC      WRITE(6,280)(ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)-ECRCCSDT)*PRZ,
CCC     &      ECCSD+ENESD(II)+XNUM(II)/XDENOM(II)
CCC 280   FORMAT('CRCCSDT-GR EX(ALL)F:    ',F7.3,' TOT(EXCITED)(',
CCC     & F13.6,' HARTREE)')
C
C
C      WRITE(6,*)'###|PSI_K>=(P+Q12)EXP(T12)R012+R3|PHI>###'
C      WRITE(6,*)'###|PSI_0>=(P+Q12)EXP(T12)+T3|PHI>###'
C      WRITE(6,560)(ENESD(II)+XPOT/YD2(II)-XGRCORR6)*PRZ,
C     &     ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,561)(ENESD(II)+XPOT/YD2(II)-XGRCORR7)*PRZ,
C     &     ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,562)(ENESD(II)+XPOT/YD2(II)-XGRCORR5)*PRZ,
C     &     ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,563)(ENESD(II)+XPOT/YD2(II)-XGRCORR4)*PRZ,
C     &     ECCSD+ENESD(II)+XPOT/YD2(II)
C      WRITE(6,564)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR6)*PRZ,
C     &     ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,565)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR7)*PRZ,
C     &     ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,566)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR5)*PRZ,
C     &     ECCSD+ENESD(II)+DI6(II)/YD1(II)
C      WRITE(6,567)(ENESD(II)+DI6(II)/YD1(II)-XGRCORR4)*PRZ,
C     &     ECCSD+ENESD(II)+DI6(II)/YD1(II)
CC
C 560  FORMAT('CR-EOMCCSD(T)IIC/IIA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 561  FORMAT('CR-EOMCCSD(T)IIC/IIB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 562  FORMAT('CR-EOMCCSD(T)IIC/IIC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 563  FORMAT('CR-EOMCCSD(T)IIC/IID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 564  FORMAT('CR-EOMCCSD(T)IID/IIA: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 565  FORMAT('CR-EOMCCSD(T)IID/IIB: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 566  FORMAT('CR-EOMCCSD(T)IID/IIC: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
C 567  FORMAT('CR-EOMCCSD(T)IID/IID: ',F7.3,' EV',' TOT(',
C     &       F13.6,' HARTREE)')
CC
CC
C      WRITE(6,*)'#### OMG_CCSD+DELTA_K ####'
C      WRITE(6,780)(ENESD(II)+XM1(II)/XD1(II))*27.2116
C      WRITE(6,781)(ENESD(II)+XM2(II)/XD2(II))*27.2116
C      WRITE(6,782)(ENESD(II)+XM3(II)/XD3(II))*27.2116
C      WRITE(6,783)(ENESD(II)+XNUM(II)/XDENOM(II))*27.2116
C      WRITE(6,784)(ENESD(II)+DI6(II))*27.2116
C       WRXX=XM1(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
C      WRITE(6,785)(ENESD(II)+WRXX)*PRZ
C      WRITE(6,*)'########################'
C 780  FORMAT('OMG_CCSD+DELTA(OMG-EH-EP)  ',F7.3,' EV')
C 781  FORMAT('OMG_CCSD+DELTA(OMG-FH-FP)  ',F7.3,' EV')
C 782  FORMAT('OMG_CCSD+DELTA(OMG-12BODY) ',F7.3,' EV')
C 783  FORMAT('OMG_CCSD+DELTA(OMG-ALL)    ',F7.3,' EV')
C 784  FORMAT('OMG_CCSD+R3(ALL)*M3        ',F7.3,' EV')
C 785  FORMAT('OMG_CCSD+R3(EH-EP)*M3      ',F7.3,' EV')
C     END IF
C
      IF(IXY.EQ.0) THEN
        XGRCORR=XNUM(II)/XDENOM(II)
        XGRCORR1=XM1(II)/XD1(II)
        XGRCORR2=XM2(II)/XD2(II)
        XGRCORR3=XM3(II)/XD3(II)
        XGRCORR4=DI6(II)/YD1(II)
        XPOT4=XM3(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XGRCORR5=XPOT4/YD2(II)
        XPOT1=XM1(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XPOT2=XM2(II)-DI1(II)-DI2(II)-DI3(II)-DI4(II)-DI5(II)
        XGRCORR6=XPOT1/YD3(II)
        XGRCORR7=XPOT2/YD4(II)
        IF(CRL.EQ.1) THEN
           WRITE(6,423)
           WRITE(6,420) XM1(IIL),XM1(IIL)+ECCSD
           WRITE(6,421) XM2(IIL),XM2(IIL)+ECCSD
           WRITE(6,422) XM3(IIL),XM3(IIL)+ECCSD
           WRITE(6,419) XNUM(IIL),XNUM(IIL)+ECCSD
           WRITE(6,424)
           BESTEOM = XM1(IIL)+ECCSD
C---           BESTEOM = XNUM(IIL)+ECCSD
        ELSE
           BESTEOM = XGRCORR+ECCSD
        END IF
        WRITE(6,412) XGRCORR1,XGRCORR1+ECCSD
        WRITE(6,413) XGRCORR2,XGRCORR2+ECCSD
        WRITE(6,414) XGRCORR3,XGRCORR3+ECCSD
        WRITE(6,411) XGRCORR,XGRCORR+ECCSD
        WRITE(6,416) XGRCORR6,XGRCORR6+ECCSD
        WRITE(6,417) XGRCORR7,XGRCORR7+ECCSD
        WRITE(6,418) XGRCORR5,XGRCORR5+ECCSD
        WRITE(6,415) XGRCORR4,XGRCORR4+ECCSD
        IF(CRL.EQ.1) THEN
      WRITE(6,425)
      WRITE(6,98)
      WRITE(6,426)     ECCSD,ECCSD-ESCF
      WRITE(6,427)     XM1(IIL)+ECCSD,XM1(IIL)+ECCSD-ESCF
      WRITE(6,428)     XNUM(IIL)+ECCSD,XNUM(IIL)+ECCSD-ESCF
C---      WRITE(6,429)     BESTEOM
        END IF
      END IF
      RETURN
C
 411  FORMAT(1X,'GROUND STATE CR-CCSD(T)ID  CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 412  FORMAT(1X,'GROUND STATE CR-CCSD(T)IA  CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 413  FORMAT(1X,'GROUND STATE CR-CCSD(T)IB  CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 414  FORMAT(1X,'GROUND STATE CR-CCSD(T)IC  CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 415  FORMAT(1X,'GROUND STATE CR-CCSD(T)IID CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 416  FORMAT(1X,'GROUND STATE CR-CCSD(T)IIA CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 417  FORMAT(1X,'GROUND STATE CR-CCSD(T)IIB CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 418  FORMAT(1X,'GROUND STATE CR-CCSD(T)IIC CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 419  FORMAT(1X,'GROUND STATE CR-CC(2,3),D CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 420  FORMAT(1X,'GROUND STATE CR-CC(2,3),A CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 421  FORMAT(1X,'GROUND STATE CR-CC(2,3),B CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 422  FORMAT(1X,'GROUND STATE CR-CC(2,3),C CORRECTION',F10.6,
     *    ', TOTAL E=',F20.10)
 423  FORMAT(/1X,'MAIN RESULTS: CR-CC(2,3) = CR-CC(2,3),D =',
     *           ' CR-CCSD(T)_L CALCULATIONS'/
     *      1X, '[SEE P. PIECUCH AND M. WLOCH, J. CHEM. PHYS.',
     *      ' 123, 224105 (2005);'/
     *      1X,'P. PIECUCH, M. WLOCH, J.R. GOUR, AND A. KINAL',
     *      ', CHEM. PHYS. LETT.'/
     *      1X,'418, 467-474(2006)]'/)
 424  FORMAT(/
     * 1X,'CR-CC(2,3),A ENERGY IS IDENTICAL TO THE CCSD(2)_T ENERGY.'/
     * 1X,'CR-CC(2,3),D ENERGY IS IDENTICAL TO COMPLETE CR-CC(2,3)',
     *    ' ENERGY (CR-CCSD(T)_L)'//
     * 1X,'ADDITIONAL RESULTS: GROUND-STATE CR-EOMCCSD(T)',
     *    ' CALCULATIONS'/
     * 1X,'[SEE K. KOWALSKI AND P. PIECUCH, J. CHEM. PHYS.',
     *      ' 120, 1715 (2004)]'/)
  425 FORMAT(/14X,'SUMMARY OF CR-CC(2,3) OR CR-CCSD(T)_L CALCULATIONS')
   98 FORMAT(/1X,'THE MOST ACCURATE ENERGETICS IS PROVIDED BY',
     *           ' CR-CC(2,3) = CR-CC(2,3),D')
  426 FORMAT(/1X,'CCSD                       ENERGY:',F20.10,
     *        '   CORR.E=',F15.10)
  427 FORMAT( 1X,'CR-CC(2,3),A OR CCSD(2)_T  ENERGY:',F20.10,
     *        '   CORR.E=',F15.10)
  428 FORMAT( 1X,'CR-CC(2,3) OR CR-CCSD(T)_L ENERGY:',F20.10,
     *        '   CORR.E=',F15.10)
C---  429 FORMAT(/12X,'CR-CC(2,3) ENERGY FOR DERIVATIVES:',F20.10/
C---     *        12X,'THE TYPE D ENERGY IS USUALLY THE MOST ACCURATE.')
  488 FORMAT(/1X,'GROUND STATE CCSD TOTAL ENERGY=',26X,F20.10)
      END
C
C*MODULE MM23     *DECK XT3SQCRL
      SUBROUTINE XT3SQCRL(JEX,I,J,K,NO,NU,T1,T2,R1,R2,V3,U3,
     *                    FHP,VL2,VL1,VOE,VL3)
C
C JEX-NUMBER OF EXCITED STATE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER A,B,C
C
      DIMENSION T1(NO,NU),T2(NU,NU,NO,NO),V3(NU,NU,NU),
     *          R1(NO,NU),R2(NO,NU,NU,NO),U3(NU,NU,NU),
     *          FHP(NU,NO),VL2(NU,NU,NO,NO),VL3(NU,NU,NU),
     *          VL1(NU,NO),VOE(NU,NU,NO,NO)
C
      LOGICAL IEJ,JEK
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,
     *     HALF/0.5D+00/,ONE/1.0D+00/
C
C KET VECTOR
C
C--    JEXL=2
       DO 149 A=1,NU
       DO 149 B=1,NU
       DO 149 C=1,NU
        U3(A,B,C)=0.0D+00
        IF (A.EQ.B.AND.B.EQ.C)GOTO 149
C T1T2*R0
        U3(A,B,C)=U3(A,B,C)+
     &            (T1(I,A)*T2(C,B,J,K)+T1(J,B)*T2(C,A,I,K)+
     &             T1(K,C)*T2(B,A,I,J))*R0(JEX)
C T1T1T1*R0
        U3(A,B,C)=U3(A,B,C)+T1(I,A)*T1(J,B)*T1(K,C)*R0(JEX)
C R1T2
        U3(A,B,C)=U3(A,B,C)+
     &             R1(I,A)*T2(C,B,J,K)+R1(J,B)*T2(C,A,I,K)+
     &             R1(K,C)*T2(B,A,I,J)
        VL3(A,B,C)=VL3(A,B,C)+
     *VL1(A,I)*VOE(B,C,K,J)+VL1(B,J)*VOE(A,C,K,I)+
     *VL1(C,K)*VOE(A,B,J,I)
C R1T1T1
        U3(A,B,C)=U3(A,B,C)+
     &            R1(I,A)*T1(J,B)*T1(K,C)+R1(J,B)*T1(I,A)*T1(K,C)+
     &            R1(K,C)*T1(I,A)*T1(J,B)
C R2T1
        U3(A,B,C)=U3(A,B,C)+
     &             T1(I,A)*R2(J,B,C,K)+T1(J,B)*R2(I,A,C,K)+
     &             T1(K,C)*R2(I,A,B,J)
        VL3(A,B,C)=VL3(A,B,C)+
     *FHP(A,I)*VL2(B,C,K,J)+FHP(B,J)*VL2(A,C,K,I)+
     *FHP(C,K)*VL2(A,B,J,I)
 149   CONTINUE
C
C BRA VECTOR
C
       X1=0.0D+00
       X2=0.0D+00
C ** DEBUG ***
       Z1=0.0D+00
       Z2=0.0D+00
       Z3=0.0D+00
       Z4=0.0D+00
       Z5=0.0D+00
C
       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
C          HL1=EH(I)+EH(J)+EH(K)-EP(A)-EP(B)-EP(C)
C          ZL1=AH(I)+AH(J)+AH(K)-AP(A)-AP(B)-AP(C)
C           ZL2PP=
C     &-APP(A,B,1)+(APP(A,B,2)/12)-APP(C,B,1)+(APP(C,B,2)/12)
C     &-APP(A,C,1)+(APP(A,C,2)/12)
C           ZL2HH=
C     &-AHH(I,J,1)-AHH(K,J,1)-AHH(K,I,1)
C           ZL2HP=
C     &AHP(I,A,1)+AHP(I,B,1)+AHP(I,C,1)
C     &+AHP(J,A,1)+AHP(J,B,1)
C     &+AHP(J,C,1)+AHP(K,A,1)+AHP(K,B,1)
C     &+AHP(K,C,1)
C     &-AHP(I,A,2)-AHP(I,B,2)-AHP(I,C,2)
C     &-AHP(J,A,2)-AHP(J,B,2)
C     &-AHP(J,C,2)-AHP(K,A,2)-AHP(K,B,2)
C     &-AHP(K,C,2)
C
C       ZL12=ZL1+ZL2
C T1T2*R0
      AT21=(T1(I,A)*T2(C,B,J,K)+T1(J,B)*T2(C,A,I,K)+
     &      T1(K,C)*T2(B,A,I,J))*R0(JEX)
C T1T1T1*R0
      BT21=T1(I,A)*T1(J,B)*T1(K,C)*R0(JEX)
C R1T2
      CT21=R1(I,A)*T2(C,B,J,K)+R1(J,B)*T2(C,A,I,K)+
     &     R1(K,C)*T2(B,A,I,J)
C      XL12=VL1(A,I)*VOE(B,C,K,J)+VL1(B,J)*VOE(A,C,K,I)+
C     *VL1(C,K)*VOE(A,B,J,I)
C R1T1T1
      DT21=R1(I,A)*T1(J,B)*T1(K,C)+R1(J,B)*T1(I,A)*T1(K,C)+
     &     R1(K,C)*T1(I,A)*T1(J,B)
C R2T1
      XT21=T1(I,A)*R2(J,B,C,K)+T1(J,B)*R2(I,A,C,K)+T1(K,C)*R2(I,A,B,J)
C      XL21=FHP(A,I)*VL2(B,C,K,J)+FHP(B,J)*VL2(A,C,K,I)+
C     *FHP(C,K)*VL2(A,B,J,I)
C
      D1=U3(A,B,C)
      D2=U3(A,C,B)+U3(C,B,A)+U3(B,A,C)
      D3=U3(B,C,A)+U3(C,A,B)
C
      G1=V3(A,B,C)
      G2=V3(A,C,B)+V3(C,B,A)+V3(B,A,C)
      G3=V3(B,C,A)+V3(C,A,B)
C
      F=D1*EIGHT-FOUR*D2+D3*TWO
      FG=G1*EIGHT-FOUR*G2+G3*TWO
C
        X1=X1+F*AT21
        X1=X1+F*BT21
        X1=X1+F*CT21
        X1=X1+F*DT21
        X1=X1+F*XT21
C
        X2=X2+FG*AT21
        X2=X2+FG*BT21
        X2=X2+FG*CT21
        X2=X2+FG*DT21
        X2=X2+FG*XT21
C
C        X3=X3+FG*XL21/HL1
C        X3=X3+FG*XL12/HL1
C        X4=X4+FG*XL21/ZL1
C        X4=X4+FG*XL12/ZL1
C        X5=X5+FG*XL21/ZL2PP
C        X5=X5+FG*XL12/ZL2PP
C        X6=X6+FG*XL21/ZL2HH
C        X6=X6+FG*XL12/ZL2HH
C        X7=X7+FG*XL21/ZL2HP
C        X7=X7+FG*XL12/ZL2HP
C *** DEBUG ***
        Z1=Z1+FG*AT21
        Z2=Z2+FG*BT21
        Z3=Z3+FG*CT21
        Z4=Z4+FG*DT21
        Z5=Z5+FG*XT21
C ******
C
 150   CONTINUE
C
      CF=ONE
      IEJ=I.EQ.J
      JEK=J.EQ.K
        IF(IEJ.OR.JEK) CF=HALF
        XDENOM(JEX)=XDENOM(JEX)+CF*X1
        XNUM(JEX)=XNUM(JEX)+CF*X2
        XM1(JEX)=XM1(JEX)+CF*X2
C---    XM1(JEXL)=XM1(JEXL)+CF*X3
        XM2(JEX)=XM2(JEX)+CF*X2
C---    XM2(JEXL)=XM2(JEXL)+CF*X4
        XM3(JEX)=XM3(JEX)+CF*X2
        XD1(JEX)=XD1(JEX)+CF*X1
        XD2(JEX)=XD2(JEX)+CF*X1
        XD3(JEX)=XD3(JEX)+CF*X1
        DI1(JEX)=DI1(JEX)+CF*Z1
        DI2(JEX)=DI2(JEX)+CF*Z2
        DI3(JEX)=DI3(JEX)+CF*Z3
        DI4(JEX)=DI4(JEX)+CF*Z4
        DI5(JEX)=DI5(JEX)+CF*Z5
      RETURN
      END
C
      SUBROUTINE XT3SQCR(JEX,I,J,K,NO,NU,T1,T2,R1,R2,V3,U3)
C
C JEX-NUMBER OF EXCITED STATE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER A,B,C
C
      DIMENSION T1(NO,NU),T2(NU,NU,NO,NO),V3(NU,NU,NU),
     *          R1(NO,NU),R2(NO,NU,NU,NO),U3(NU,NU,NU)
C
      LOGICAL IEJ,JEK
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
      DATA TWO/2.0D+00/,FOUR/4.0D+00/,EIGHT/8.0D+00/,
     *     HALF/0.5D+00/,ONE/1.0D+00/
C
C KET VECTOR
C
       DO 149 A=1,NU
       DO 149 B=1,NU
       DO 149 C=1,NU
        U3(A,B,C)=0.0D+00
        IF (A.EQ.B.AND.B.EQ.C)GOTO 149
C T1T2*R0
        U3(A,B,C)=U3(A,B,C)+
     &            (T1(I,A)*T2(C,B,J,K)+T1(J,B)*T2(C,A,I,K)+
     &             T1(K,C)*T2(B,A,I,J))*R0(JEX)
C T1T1T1*R0
        U3(A,B,C)=U3(A,B,C)+T1(I,A)*T1(J,B)*T1(K,C)*R0(JEX)
C R1T2
        U3(A,B,C)=U3(A,B,C)+
     &             R1(I,A)*T2(C,B,J,K)+R1(J,B)*T2(C,A,I,K)+
     &             R1(K,C)*T2(B,A,I,J)
C R1T1T1
        U3(A,B,C)=U3(A,B,C)+
     &            R1(I,A)*T1(J,B)*T1(K,C)+R1(J,B)*T1(I,A)*T1(K,C)+
     &            R1(K,C)*T1(I,A)*T1(J,B)
C R2T1
        U3(A,B,C)=U3(A,B,C)+
     &             T1(I,A)*R2(J,B,C,K)+T1(J,B)*R2(I,A,C,K)+
     &             T1(K,C)*R2(I,A,B,J)
 149   CONTINUE
C
C
C BRA VECTOR
C
C
       X1=0.0D+00
       X2=0.0D+00
C ** DEBUG ***
       Z1=0.0D+00
       Z2=0.0D+00
       Z3=0.0D+00
       Z4=0.0D+00
       Z5=0.0D+00
C
       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
C T1T2*R0
      AT21=(T1(I,A)*T2(C,B,J,K)+T1(J,B)*T2(C,A,I,K)+
     &      T1(K,C)*T2(B,A,I,J))*R0(JEX)
C T1T1T1*R0
      BT21=T1(I,A)*T1(J,B)*T1(K,C)*R0(JEX)
C R1T2
      CT21=R1(I,A)*T2(C,B,J,K)+R1(J,B)*T2(C,A,I,K)+
     &     R1(K,C)*T2(B,A,I,J)
C R1T1T1
      DT21=R1(I,A)*T1(J,B)*T1(K,C)+R1(J,B)*T1(I,A)*T1(K,C)+
     &     R1(K,C)*T1(I,A)*T1(J,B)
C R2T1
      XT21=T1(I,A)*R2(J,B,C,K)+T1(J,B)*R2(I,A,C,K)+T1(K,C)*R2(I,A,B,J)
C
      D1=U3(A,B,C)
      D2=U3(A,C,B)+U3(C,B,A)+U3(B,A,C)
      D3=U3(B,C,A)+U3(C,A,B)
C
      G1=V3(A,B,C)
      G2=V3(A,C,B)+V3(C,B,A)+V3(B,A,C)
      G3=V3(B,C,A)+V3(C,A,B)
C
C
      F=D1*EIGHT-FOUR*D2+D3*TWO
      FG=G1*EIGHT-FOUR*G2+G3*TWO
C
        X1=X1+F*AT21
        X1=X1+F*BT21
        X1=X1+F*CT21
        X1=X1+F*DT21
        X1=X1+F*XT21
C
        X2=X2+FG*AT21
        X2=X2+FG*BT21
        X2=X2+FG*CT21
        X2=X2+FG*DT21
        X2=X2+FG*XT21
C *** DEBUG ***
        Z1=Z1+FG*AT21
        Z2=Z2+FG*BT21
        Z3=Z3+FG*CT21
        Z4=Z4+FG*DT21
        Z5=Z5+FG*XT21
C ******
C
 150   CONTINUE
C
      CF=ONE
      IEJ=I.EQ.J
      JEK=J.EQ.K
        IF(IEJ.OR.JEK) CF=HALF
        XDENOM(JEX)=XDENOM(JEX)+CF*X1
        XNUM(JEX)=XNUM(JEX)+CF*X2
        XM1(JEX)=XM1(JEX)+CF*X2
        XM2(JEX)=XM2(JEX)+CF*X2
        XM3(JEX)=XM3(JEX)+CF*X2
        XD1(JEX)=XD1(JEX)+CF*X1
        XD2(JEX)=XD2(JEX)+CF*X1
        XD3(JEX)=XD3(JEX)+CF*X1
         DI1(JEX)=DI1(JEX)+CF*Z1
         DI2(JEX)=DI2(JEX)+CF*Z2
         DI3(JEX)=DI3(JEX)+CF*Z3
         DI4(JEX)=DI4(JEX)+CF*Z4
         DI5(JEX)=DI5(JEX)+CF*Z5
      RETURN
      END
C
C*MODULE MM23     *DECK XT3SQ2CR
      SUBROUTINE XT3SQ2CRL(JEX,I,J,K,NO,NU,V3,U3,VL3,
     *                    AH,AP,APP,AHH,AHP,AX,BX,EH,EP)
C
C ### ORDERING I,J,K - REVERSED HERE
C JEX-NUMBER OF EXCITED STATE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER A,B,C
C
      DIMENSION U3(NU,NU,NU),V3(NU,NU,NU),EH(NO),EP(NU),
     *          AH(NO),AP(NU),VL3(NU,NU,NU),
     *          AHH(NO,NO,2),AHP(NO,NU,2),APP(NU,NU,2),
     *          AX(NU,NU,NO,2),BX(NU,NO,NO,2)
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
      DATA TWO/2.0D+00/
        JEXL=2
C
C
C
C *************************************************************
C
C I>J>K
C
        IF(I.GT.J.AND.J.GT.K) THEN
         I1=K
         J1=J
         K1=I
         DO 149,A=1,NU
         DO 149,B=A,NU
         DO 149,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 149
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX0=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)+AX(C,A,K1,1)
     &+AX(B,C,K1,1)-AX(B,C,K1,2)-AX(C,B,K1,2)+AX(C,B,K1,1)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)
     &+AX(B,C,I1,1)-AX(B,C,I1,2)-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX0=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB0=ENESD(JEX)+ZA1+ZA2-AX0-BX0
       DB01=ENESD(JEX)+HA1
       DB02=ENESD(JEX)+ZA1
       DB03=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX1=-AX(C,A,K1,2)-AX(C,B,K1,2)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &-AX(A,C,J1,2)-AX(B,C,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX1=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)-BX(A,K1,J1,1)
     &-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB1=ENESD(JEX)+ZA1+ZA2-AX1-BX1
       DB11=ENESD(JEX)+HA1
       DB12=ENESD(JEX)+ZA1
       DB13=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX2=-AX(B,A,K1,2)-AX(B,C,K1,2)-AX(A,B,J1,2)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)
     &-AX(A,B,I1,2)+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)
     &+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX2=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB2=ENESD(JEX)+ZA1+ZA2-AX2-BX2
       DB21=ENESD(JEX)+HA1
       DB22=ENESD(JEX)+ZA1
       DB23=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)
          AX3=-AX(A,B,K1,2)-AX(A,C,K1,2)-AX(B,A,J1,2)-AX(C,A,J1,2)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX3=-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,K1,J1,1)
       DB3=ENESD(JEX)+ZA1+ZA2-AX3-BX3
       DB31=ENESD(JEX)+HA1
       DB32=ENESD(JEX)+ZA1
       DB33=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX7=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)
     &+AX(B,A,J1,1)-AX(A,C,J1,2)-AX(B,C,J1,2)-AX(C,A,I1,2)-AX(C,B,I1,2)
        BX7=-BX(A,I1,J1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
       DB7=ENESD(JEX)+ZA1+ZA2-AX7-BX7
       DB71=ENESD(JEX)+HA1
       DB72=ENESD(JEX)+ZA1
       DB73=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX8=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(A,B,J1,2)+AX(A,C,J1,1)-AX(A,C,J1,2)
     &-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)-AX(B,A,I1,2)-AX(B,C,I1,2)
        BX8=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB8=ENESD(JEX)+ZA1+ZA2-AX8-BX8
       DB81=ENESD(JEX)+HA1
       DB82=ENESD(JEX)+ZA1
       DB83=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX9=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(B,A,J1,2)-AX(C,A,J1,2)+AX(B,C,J1,1)
     &-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)-AX(A,B,I1,2)-AX(A,C,I1,2)
        BX9=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,I1,J1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,I1,K1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB9=ENESD(JEX)+ZA1+ZA2-AX9-BX9
       DB91=ENESD(JEX)+HA1
       DB92=ENESD(JEX)+ZA1
       DB93=ENESD(JEX)+ZA1+ZA2
C
C
C       REVERSE ORDER OF A,B,C!!!
       B0=V3(C,B,A)-V3(B,C,A)-V3(C,A,B)+V3(A,C,B)+V3(B,A,C)-V3(A,B,C)
       B1=V3(C,B,A)-V3(C,A,B)
       B2=V3(B,C,A)-V3(B,A,C)
       B3=V3(A,C,B)-V3(A,B,C)
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
       B7=V3(B,A,C)-V3(A,B,C)
       B8=V3(C,A,B)-V3(A,C,B)
       B9=V3(C,B,A)-V3(B,C,A)
C
       BL0=VL3(C,B,A)-VL3(B,C,A)-VL3(C,A,B)+
     * VL3(A,C,B)+VL3(B,A,C)-VL3(A,B,C)
       BL1=VL3(C,B,A)-VL3(C,A,B)
       BL2=VL3(B,C,A)-VL3(B,A,C)
       BL3=VL3(A,C,B)-VL3(A,B,C)
       BL4=VL3(B,C,A)-VL3(A,C,B)
       BL5=VL3(C,B,A)-VL3(A,B,C)
       BL6=VL3(C,A,B)-VL3(B,A,C)
       BL7=VL3(B,A,C)-VL3(A,B,C)
       BL8=VL3(C,A,B)-VL3(A,C,B)
       BL9=VL3(C,B,A)-VL3(B,C,A)
C
       C0=U3(C,B,A)-U3(B,C,A)-U3(C,A,B)+U3(A,C,B)+U3(B,A,C)-U3(A,B,C)
       C1=U3(C,B,A)-U3(C,A,B)
       C2=U3(B,C,A)-U3(B,A,C)
       C3=U3(A,C,B)-U3(A,B,C)
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
       C7=U3(B,A,C)-U3(A,B,C)
       C8=U3(C,A,B)-U3(A,C,B)
       C9=U3(C,B,A)-U3(B,C,A)
C
C       CL0=UL3(C,B,A)-UL3(B,C,A)-UL3(C,A,B)+UL3(A,C,B)+
C     * UL3(B,A,C)-UL3(A,B,C)
C       CL1=UL3(C,B,A)-UL3(C,A,B)
C       CL2=UL3(B,C,A)-UL3(B,A,C)
C       CL3=UL3(A,C,B)-UL3(A,B,C)
C       CL4=UL3(B,C,A)-UL3(A,C,B)
C       CL5=UL3(C,B,A)-UL3(A,B,C)
C       CL6=UL3(C,A,B)-UL3(B,A,C)
C       CL7=UL3(B,A,C)-UL3(A,B,C)
C       CL8=UL3(C,A,B)-UL3(A,C,B)
C       CL9=UL3(C,B,A)-UL3(B,C,A)
C
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEXL)=XNUM(JEXL)+TWO*(B0*BL0/DB0+B1*BL1/DB1+B2*BL2/DB2+
     &     B3*BL3/DB3+B4*BL4/DB4+B5*BL5/DB5+B6*BL6/DB6+B7*BL7/DB7+
     &                     B8*BL8/DB8+B9*BL9/DB9)
C       XNUM(4)=XNUM(4)+TWO*(B0*CL0/DB0+B1*CL1/DB1+B2*CL2/DB2+
C     &     B3*CL3/DB3+B4*CL4/DB4+B5*CL5/DB5+B6*CL6/DB6+B7*CL7/DB7+
C     &                     B8*CL8/DB8+B9*CL9/DB9)
       XNUM(JEX)=XNUM(JEX)+TWO*(B0*B0/DB0+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9)
       DI6(JEX)=DI6(JEX)+TWO*(B0*B0/DB0+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9)
       XM1(JEX)=XM1(JEX)+TWO*(B0*B0/DB01+B1*B1/DB11+B2*B2/DB21+
     &     B3*B3/DB31+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61+B7*B7/DB71+
     &                     B8*B8/DB81+B9*B9/DB91)
       XM1(JEXL)=XM1(JEXL)+TWO*(B0*BL0/DB01+B1*BL1/DB11+B2*BL2/DB21+
     &     B3*BL3/DB31+B4*BL4/DB41+B5*BL5/DB51+B6*BL6/DB61+
     &                    B7*BL7/DB71+ B8*BL8/DB81+B9*BL9/DB91)
C       XNUM(5)=XNUM(5)+TWO*(B0*CL0/DB01+B1*CL1/DB11+B2*CL2/DB21+
C     &     B3*CL3/DB31+B4*CL4/DB41+B5*CL5/DB51+B6*CL6/DB61+
C     &                    B7*CL7/DB71+ B8*CL8/DB81+B9*CL9/DB91)
       XM2(JEX)=XM2(JEX)+TWO*(B0*B0/DB02+B1*B1/DB12+B2*B2/DB22+
     &     B3*B3/DB32+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62+B7*B7/DB72+
     &                     B8*B8/DB82+B9*B9/DB92)
       XM2(JEXL)=XM2(JEXL)+TWO*(B0*BL0/DB02+B1*BL1/DB12+B2*BL2/DB22+
     &     B3*BL3/DB32+B4*BL4/DB42+B5*BL5/DB52+B6*BL6/DB62+
     &                    B7*BL7/DB72+ B8*BL8/DB82+B9*BL9/DB92)
C       XNUM(6)=XNUM(6)+TWO*(B0*CL0/DB02+B1*CL1/DB12+B2*CL2/DB22+
C     &     B3*CL3/DB32+B4*CL4/DB42+B5*CL5/DB52+B6*CL6/DB62+
C     &                    B7*CL7/DB72+ B8*CL8/DB82+B9*CL9/DB92)
       XM3(JEX)=XM3(JEX)+TWO*(B0*B0/DB03+B1*B1/DB13+B2*B2/DB23+
     &     B3*B3/DB33+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63+B7*B7/DB73+
     &                     B8*B8/DB83+B9*B9/DB93)
       XM3(JEXL)=XM3(JEXL)+TWO*(B0*BL0/DB03+B1*BL1/DB13+B2*BL2/DB23+
     &     B3*BL3/DB33+B4*BL4/DB43+B5*BL5/DB53+B6*BL6/DB63+
     &                    B7*BL7/DB73+B8*BL8/DB83+B9*BL9/DB93)
C
C       XNUM(3)=XNUM(3)+TWO*(B0*CL0/DB03+B1*CL1/DB13+B2*CL2/DB23+
C     &     B3*CL3/DB33+B4*CL4/DB43+B5*CL5/DB53+B6*CL6/DB63+
C     &                    B7*CL7/DB73+ B8*CL8/DB83+B9*CL9/DB93)
C
       XDENOM(JEX)=XDENOM(JEX)+TWO*(B0*C0/DB0+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9)
       YD1(JEX)=YD1(JEX)+TWO*(B0*C0/DB0+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9)
       XD1(JEX)=XD1(JEX)+TWO*(B0*C0/DB01+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91)
       YD3(JEX)=YD3(JEX)+TWO*(B0*C0/DB01+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91)
       XD2(JEX)=XD2(JEX)+TWO*(B0*C0/DB02+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92)
       YD4(JEX)=YD4(JEX)+TWO*(B0*C0/DB02+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92)
       XD3(JEX)=XD3(JEX)+TWO*(B0*C0/DB03+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93)
       YD2(JEX)=YD2(JEX)+TWO*(B0*C0/DB03+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93)
C       XDENOM(JEX)=XDENOM(JEX)+TWO*(B0*B0/(DB0*DB0)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+B7*B7/(DB7*DB7)+
C     &                     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9))
       GO TO 149
       END IF
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B2*B2/DB2+B3*B3/DB3+B5*B5/DB5+B6*B6/DB6+
     &                     B8*B8/DB8+B9*B9/DB9
       XNUM(JEXL)=XNUM(JEXL)+B2*BL2/DB2+B3*BL3/DB3+B5*BL5/DB5+
     &                     B6*BL6/DB6+B8*BL8/DB8+B9*BL9/DB9
C       XNUM(4)=XNUM(4)+B2*CL2/DB2+B3*CL3/DB3+B5*CL5/DB5+
C     &                     B6*CL6/DB6+B8*CL8/DB8+B9*CL9/DB9
       XM1(JEX)=XM1(JEX)+B2*B2/DB21+B3*B3/DB31+B5*B5/DB51+B6*B6/DB61+
     &                     B8*B8/DB81+B9*B9/DB91
       XM1(JEXL)=XM1(JEXL)+B2*BL2/DB21+B3*BL3/DB31+B5*BL5/DB51+
     &                    B6*BL6/DB61+ B8*BL8/DB81+B9*BL9/DB91
C       XNUM(5)=XNUM(5)+B2*CL2/DB21+B3*CL3/DB31+B5*CL5/DB51+
C     &                    B6*CL6/DB61+ B8*CL8/DB81+B9*CL9/DB91
       XM2(JEX)=XM2(JEX)+B2*B2/DB22+B3*B3/DB32+B5*B5/DB52+B6*B6/DB62+
     &                     B8*B8/DB82+B9*B9/DB92
       XM2(JEXL)=XM2(JEXL)+B2*BL2/DB22+B3*BL3/DB32+B5*BL5/DB52+
     &                    B6*BL6/DB62+ B8*BL8/DB82+B9*BL9/DB92
C       XNUM(6)=XNUM(6)+B2*CL2/DB22+B3*CL3/DB32+B5*CL5/DB52+
C     &                    B6*CL6/DB62+ B8*CL8/DB82+B9*CL9/DB92
       XM3(JEX)=XM3(JEX)+B2*B2/DB23+B3*B3/DB33+B5*B5/DB53+B6*B6/DB63+
     &                     B8*B8/DB83+B9*B9/DB93
       XM3(JEXL)=XM3(JEXL)+B2*BL2/DB23+B3*BL3/DB33+B5*BL5/DB53+
     &                    B6*BL6/DB63+ B8*BL8/DB83+B9*BL9/DB93
C
C       XNUM(3)=XNUM(3)+B2*CL2/DB23+B3*CL3/DB33+B5*CL5/DB53+
C     &                    B6*CL6/DB63+ B8*CL8/DB83+B9*CL9/DB93
C
       DI6(JEX)=DI6(JEX)+B2*B2/DB2+B3*B3/DB3+B5*B5/DB5+B6*B6/DB6+
     &                     B8*B8/DB8+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B2*C2/DB2+B3*C3/DB3+B5*C5/DB5+B6*C6/DB6+
     &                     B8*C8/DB8+B9*C9/DB9
       YD1(JEX)=YD1(JEX)+B2*C2/DB2+B3*C3/DB3+B5*C5/DB5+B6*C6/DB6+
     &                     B8*C8/DB8+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B2*C2/DB21+B3*C3/DB31+B5*C5/DB51+B6*C6/DB61+
     &                     B8*C8/DB81+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B2*C2/DB21+B3*C3/DB31+B5*C5/DB51+B6*C6/DB61+
     &                     B8*C8/DB81+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B2*C2/DB22+B3*C3/DB32+B5*C5/DB52+B6*C6/DB62+
     &                     B8*C8/DB82+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B2*C2/DB22+B3*C3/DB32+B5*C5/DB52+B6*C6/DB62+
     &                     B8*C8/DB82+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B2*C2/DB23+B3*C3/DB33+B5*C5/DB53+B6*C6/DB63+
     &                     B8*C8/DB83+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B2*C2/DB23+B3*C3/DB33+B5*C5/DB53+B6*C6/DB63+
     &                     B8*C8/DB83+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+
C     &     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9)
       GO TO 149
       END IF
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B4*B4/DB4+B5*B5/DB5+B7*B7/DB7+B8*B8/DB8
       XNUM(JEXL)=XNUM(JEXL)+B1*BL1/DB1+B2*BL2/DB2+
     &     B4*BL4/DB4+B5*BL5/DB5+B7*BL7/DB7+B8*BL8/DB8
C       XNUM(4)=XNUM(4)+B1*CL1/DB1+B2*CL2/DB2+
C     &     B4*CL4/DB4+B5*CL5/DB5+B7*CL7/DB7+B8*CL8/DB8
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B2*B2/DB21+
     &     B4*B4/DB41+B5*B5/DB51+B7*B7/DB71+B8*B8/DB81
       XM1(JEXL)=XM1(JEXL)+B1*BL1/DB11+B2*BL2/DB21+
     &     B4*BL4/DB41+B5*BL5/DB51+B7*BL7/DB71+B8*BL8/DB81
C       XNUM(5)=XNUM(5)+B1*CL1/DB11+B2*CL2/DB21+
C     &     B4*CL4/DB41+B5*CL5/DB51+B7*CL7/DB71+B8*CL8/DB81
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B2*B2/DB22+
     &     B4*B4/DB42+B5*B5/DB52+B7*B7/DB72+B8*B8/DB82
       XM2(JEXL)=XM2(JEXL)+B1*BL1/DB12+B2*BL2/DB22+
     &     B4*BL4/DB42+B5*BL5/DB52+B7*BL7/DB72+B8*BL8/DB82
C       XNUM(6)=XNUM(6)+B1*CL1/DB12+B2*CL2/DB22+
C     &     B4*CL4/DB42+B5*CL5/DB52+B7*CL7/DB72+B8*CL8/DB82
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B2*B2/DB23+
     &     B4*B4/DB43+B5*B5/DB53+B7*B7/DB73+B8*B8/DB83
       XM3(JEXL)=XM3(JEXL)+B1*BL1/DB13+B2*BL2/DB23+
     &     B4*BL4/DB43+B5*BL5/DB53+B7*BL7/DB73+B8*BL8/DB83
C
C       XNUM(3)=XNUM(3)+B1*CL1/DB13+B2*CL2/DB23+
C     &     B4*CL4/DB43+B5*CL5/DB53+B7*CL7/DB73+B8*CL8/DB83
C
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B4*B4/DB4+B5*B5/DB5+B7*B7/DB7+B8*B8/DB8
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B4*C4/DB4+B5*C5/DB5+B7*C7/DB7+B8*C8/DB8
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B4*C4/DB4+B5*C5/DB5+B7*C7/DB7+B8*C8/DB8
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B4*C4/DB41+B5*C5/DB51+B7*C7/DB71+B8*C8/DB81
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B4*C4/DB41+B5*C5/DB51+B7*C7/DB71+B8*C8/DB81
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B4*C4/DB42+B5*C5/DB52+B7*C7/DB72+B8*C8/DB82
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B4*C4/DB42+B5*C5/DB52+B7*C7/DB72+B8*C8/DB82
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B4*C4/DB43+B5*C5/DB53+B7*C7/DB73+B8*C8/DB83
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B4*C4/DB43+B5*C5/DB53+B7*C7/DB73+B8*C8/DB83
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B7*B7/(DB7*DB7)+B8*B8/(DB8*DB8)
       GO TO 149
       END IF
C
 149     CONTINUE
         GO TO 100
        END IF
C
C *********************************************************
C
C
C *********************************************************
C I=J>K
C
        IF(I.EQ.J.AND.J.GT.K) THEN
         I1=K
         J1=J
         K1=I
         DO 150,A=1,NU
         DO 150,B=A,NU
         DO 150,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 150
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX1=-AX(C,A,K1,2)-AX(C,B,K1,2)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &-AX(A,C,J1,2)-AX(B,C,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX1=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)-BX(A,K1,J1,1)
     &-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB1=ENESD(JEX)+ZA1+ZA2-AX1-BX1
       DB11=ENESD(JEX)+HA1
       DB12=ENESD(JEX)+ZA1
       DB13=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX2=-AX(B,A,K1,2)-AX(B,C,K1,2)-AX(A,B,J1,2)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)
     &-AX(A,B,I1,2)+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)
     &+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX2=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB2=ENESD(JEX)+ZA1+ZA2-AX2-BX2
       DB21=ENESD(JEX)+HA1
       DB22=ENESD(JEX)+ZA1
       DB23=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)
          AX3=-AX(A,B,K1,2)-AX(A,C,K1,2)-AX(B,A,J1,2)-AX(C,A,J1,2)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX3=-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,K1,J1,1)
       DB3=ENESD(JEX)+ZA1+ZA2-AX3-BX3
       DB31=ENESD(JEX)+HA1
       DB32=ENESD(JEX)+ZA1
       DB33=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
C
C
C       REVERSE ORDER OF A,B,C!!!
       B1=V3(C,B,A)-V3(C,A,B)
       B2=V3(B,C,A)-V3(B,A,C)
       B3=V3(A,C,B)-V3(A,B,C)
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
C
       BL1=VL3(C,B,A)-VL3(C,A,B)
       BL2=VL3(B,C,A)-VL3(B,A,C)
       BL3=VL3(A,C,B)-VL3(A,B,C)
       BL4=VL3(B,C,A)-VL3(A,C,B)
       BL5=VL3(C,B,A)-VL3(A,B,C)
       BL6=VL3(C,A,B)-VL3(B,A,C)
C
       C1=U3(C,B,A)-U3(C,A,B)
       C2=U3(B,C,A)-U3(B,A,C)
       C3=U3(A,C,B)-U3(A,B,C)
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
C
C       CL1=UL3(C,B,A)-UL3(C,A,B)
C       CL2=UL3(B,C,A)-UL3(B,A,C)
C       CL3=UL3(A,C,B)-UL3(A,B,C)
C       CL4=UL3(B,C,A)-UL3(A,C,B)
C       CL5=UL3(C,B,A)-UL3(A,B,C)
C       CL6=UL3(C,A,B)-UL3(B,A,C)
C
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6
       XNUM(JEXL)=XNUM(JEXL)+B1*BL1/DB1+B2*BL2/DB2+
     &     B3*BL3/DB3+B4*BL4/DB4+B5*BL5/DB5+B6*BL6/DB6
C       XNUM(4)=XNUM(4)+B1*CL1/DB1+B2*CL2/DB2+
C     &     B3*CL3/DB3+B4*CL4/DB4+B5*CL5/DB5+B6*CL6/DB6
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B2*B2/DB21+
     &     B3*B3/DB31+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61
       XM1(JEXL)=XM1(JEXL)+B1*BL1/DB11+B2*BL2/DB21+
     &     B3*BL3/DB31+B4*BL4/DB41+B5*BL5/DB51+B6*BL6/DB61
C       XNUM(5)=XNUM(5)+B1*CL1/DB11+B2*CL2/DB21+
C     &     B3*CL3/DB31+B4*CL4/DB41+B5*CL5/DB51+B6*CL6/DB61
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B2*B2/DB22+
     &     B3*B3/DB32+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62
       XM2(JEXL)=XM2(JEXL)+B1*BL1/DB12+B2*BL2/DB22+
     &     B3*BL3/DB32+B4*BL4/DB42+B5*BL5/DB52+B6*BL6/DB62
C       XNUM(6)=XNUM(6)+B1*CL1/DB12+B2*CL2/DB22+
C     &     B3*CL3/DB32+B4*CL4/DB42+B5*CL5/DB52+B6*CL6/DB62
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B2*B2/DB23+
     &     B3*B3/DB33+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63
       XM3(JEXL)=XM3(JEXL)+B1*BL1/DB13+B2*BL2/DB23+
     &     B3*BL3/DB33+B4*BL4/DB43+B5*BL5/DB53+B6*BL6/DB63
C
C       XNUM(3)=XNUM(3)+B1*CL1/DB13+B2*CL2/DB23+
C     &     B3*CL3/DB33+B4*CL4/DB43+B5*CL5/DB53+B6*CL6/DB63
C
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)
       GO TO 150
       END IF
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B2*B2/DB2+B6*B6/DB6
       XNUM(JEXL)=XNUM(JEXL)+B2*BL2/DB2+B6*BL6/DB6
C       XNUM(4)=XNUM(4)+B2*CL2/DB2+B6*CL6/DB6
       XM1(JEX)=XM1(JEX)+B2*B2/DB21+B6*B6/DB61
       XM1(JEXL)=XM1(JEXL)+B2*BL2/DB21+B6*BL6/DB61
C       XNUM(5)=XNUM(5)+B2*CL2/DB21+B6*CL6/DB61
       XM2(JEX)=XM2(JEX)+B2*B2/DB22+B6*B6/DB62
       XM2(JEXL)=XM2(JEXL)+B2*BL2/DB22+B6*BL6/DB62
C       XNUM(6)=XNUM(6)+B2*CL2/DB22+B6*CL6/DB62
       XM3(JEX)=XM3(JEX)+B2*B2/DB23+B6*B6/DB63
       XM3(JEXL)=XM3(JEXL)+B2*BL2/DB23+B6*BL6/DB63
C
C       XNUM(3)=XNUM(3)+B2*CL2/DB23+B6*CL6/DB63
C
       DI6(JEX)=DI6(JEX)+B2*B2/DB2+B6*B6/DB6
       XDENOM(JEX)=XDENOM(JEX)+B2*C2/DB2+B6*C6/DB6
       YD1(JEX)=YD1(JEX)+B2*C2/DB2+B6*C6/DB6
       XD1(JEX)=XD1(JEX)+B2*C2/DB21+B6*C6/DB61
       YD3(JEX)=YD3(JEX)+B2*C2/DB21+B6*C6/DB61
       XD2(JEX)=XD2(JEX)+B2*C2/DB22+B6*C6/DB62
       YD4(JEX)=YD4(JEX)+B2*C2/DB22+B6*C6/DB62
       XD3(JEX)=XD3(JEX)+B2*C2/DB23+B6*C6/DB63
       YD2(JEX)=YD2(JEX)+B2*C2/DB23+B6*C6/DB63
C       XDENOM(JEX)=XDENOM(JEX)+B2*B2/(DB2*DB2)+B6*B6/(DB6*DB6)
       GO TO 150
       END IF
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B5*B5/DB5
       XNUM(JEXL)=XNUM(JEXL)+B1*BL1/DB1+B5*BL5/DB5
C       XNUM(4)=XNUM(4)+B1*CL1/DB1+B5*CL5/DB5
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B5*B5/DB51
       XM1(JEXL)=XM1(JEXL)+B1*BL1/DB11+B5*BL5/DB51
C       XNUM(5)=XNUM(5)+B1*CL1/DB11+B5*CL5/DB51
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B5*B5/DB52
       XM2(JEXL)=XM2(JEXL)+B1*BL1/DB12+B5*BL5/DB52
C       XNUM(6)=XNUM(6)+B1*CL1/DB12+B5*CL5/DB52
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B5*B5/DB53
       XM3(JEXL)=XM3(JEXL)+B1*BL1/DB13+B5*BL5/DB53
C
C       XNUM(3)=XNUM(3)+B1*CL1/DB13+B5*CL5/DB53
C
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B5*B5/DB5
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B5*C5/DB5
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B5*C5/DB5
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B5*C5/DB51
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B5*C5/DB51
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B5*C5/DB52
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B5*C5/DB52
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B5*C5/DB53
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B5*C5/DB53
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+B5*B5/(DB5*DB5)
       GO TO 150
       END IF
C
 150   CONTINUE
         GO TO 100
        END IF
C *****************************************************
C
C
C *****************************************************
C I>J=K
C
C
C
        IF(I.GT.J.AND.J.EQ.K) THEN
         I1=K
         J1=J
         K1=I
         DO 151,A=1,NU
         DO 151,B=A,NU
         DO 151,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 151
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX7=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)
     &+AX(B,A,J1,1)-AX(A,C,J1,2)-AX(B,C,J1,2)-AX(C,A,I1,2)-AX(C,B,I1,2)
        BX7=-BX(A,I1,J1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
       DB7=ENESD(JEX)+ZA1+ZA2-AX7-BX7
       DB71=ENESD(JEX)+HA1
       DB72=ENESD(JEX)+ZA1
       DB73=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX8=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(A,B,J1,2)+AX(A,C,J1,1)-AX(A,C,J1,2)
     &-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)-AX(B,A,I1,2)-AX(B,C,I1,2)
        BX8=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB8=ENESD(JEX)+ZA1+ZA2-AX8-BX8
       DB81=ENESD(JEX)+HA1
       DB82=ENESD(JEX)+ZA1
       DB83=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
          ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX9=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(B,A,J1,2)-AX(C,A,J1,2)+AX(B,C,J1,1)
     &-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)-AX(A,B,I1,2)-AX(A,C,I1,2)
        BX9=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,I1,J1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,I1,K1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB9=ENESD(JEX)+ZA1+ZA2-AX9-BX9
       DB91=ENESD(JEX)+HA1
       DB92=ENESD(JEX)+ZA1
       DB93=ENESD(JEX)+ZA1+ZA2
C
C
C
C
C       REVERSE ORDER OF A,B,C!!!
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
       B7=V3(B,A,C)-V3(A,B,C)
       B8=V3(C,A,B)-V3(A,C,B)
       B9=V3(C,B,A)-V3(B,C,A)
C
       BL4=VL3(B,C,A)-VL3(A,C,B)
       BL5=VL3(C,B,A)-VL3(A,B,C)
       BL6=VL3(C,A,B)-VL3(B,A,C)
       BL7=VL3(B,A,C)-VL3(A,B,C)
       BL8=VL3(C,A,B)-VL3(A,C,B)
       BL9=VL3(C,B,A)-VL3(B,C,A)
C
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
       C7=U3(B,A,C)-U3(A,B,C)
       C8=U3(C,A,B)-U3(A,C,B)
       C9=U3(C,B,A)-U3(B,C,A)
C
C       CL4=UL3(B,C,A)-UL3(A,C,B)
C       CL5=UL3(C,B,A)-UL3(A,B,C)
C       CL6=UL3(C,A,B)-UL3(B,A,C)
C       CL7=UL3(B,A,C)-UL3(A,B,C)
C       CL8=UL3(C,A,B)-UL3(A,C,B)
C       CL9=UL3(C,B,A)-UL3(B,C,A)
C
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEX)=XNUM(JEX)+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9
       XNUM(JEXL)=XNUM(JEXL)+B4*BL4/DB4+B5*BL5/DB5+B6*BL6/DB6+
     &                    B7*BL7/DB7+ B8*BL8/DB8+B9*BL9/DB9
C       XNUM(4)=XNUM(4)+B4*CL4/DB4+B5*CL5/DB5+B6*CL6/DB6+
C     &                    B7*CL7/DB7+ B8*CL8/DB8+B9*CL9/DB9
       XM1(JEX)=XM1(JEX)+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61+B7*B7/DB71+
     &                     B8*B8/DB81+B9*B9/DB91
       XM1(JEXL)=XM1(JEXL)+B4*BL4/DB41+B5*BL5/DB51+B6*BL6/DB61+
     &                    B7*BL7/DB71+ B8*BL8/DB81+B9*BL9/DB91
C       XNUM(5)=XNUM(5)+B4*CL4/DB41+B5*CL5/DB51+B6*CL6/DB61+
C     &                    B7*CL7/DB71+ B8*CL8/DB81+B9*CL9/DB91
       XM2(JEX)=XM2(JEX)+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62+B7*B7/DB72+
     &                     B8*B8/DB82+B9*B9/DB92
       XM2(JEXL)=XM2(JEXL)+B4*BL4/DB42+B5*BL5/DB52+B6*BL6/DB62+
     &                    B7*BL7/DB72+ B8*BL8/DB82+B9*BL9/DB92
C       XNUM(6)=XNUM(6)+B4*CL4/DB42+B5*CL5/DB52+B6*CL6/DB62+
C     &                    B7*CL7/DB72+ B8*CL8/DB82+B9*CL9/DB92
       XM3(JEX)=XM3(JEX)+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63+B7*B7/DB73+
     &                     B8*B8/DB83+B9*B9/DB93
       XM3(JEXL)=XM3(JEXL)+B4*BL4/DB43+B5*BL5/DB53+B6*BL6/DB63+
     &                    B7*BL7/DB73+ B8*BL8/DB83+B9*BL9/DB93
C
C       XNUM(3)=XNUM(3)+B4*CL4/DB43+B5*CL5/DB53+B6*CL6/DB63+
C     &                    B7*CL7/DB73+B8*CL8/DB83+B9*CL9/DB93
C
       DI6(JEX)=DI6(JEX)+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9
       YD1(JEX)=YD1(JEX)+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+B7*B7/(DB7*DB7)+
C     &                     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9)
       GO TO 151
       END IF
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B5*B5/DB5+B9*B9/DB9
       XNUM(JEXL)=XNUM(JEXL)+B5*BL5/DB5+B9*BL9/DB9
C       XNUM(4)=XNUM(4)+B5*CL5/DB5+B9*CL9/DB9
       XM1(JEX)=XM1(JEX)+B5*B5/DB51+B9*B9/DB91
       XM1(JEXL)=XM1(JEXL)+B5*BL5/DB51+B9*BL9/DB91
C       XNUM(5)=XNUM(5)+B5*CL5/DB51+B9*CL9/DB91
       XM2(JEX)=XM2(JEX)+B5*B5/DB52+B9*B9/DB92
       XM2(JEXL)=XM2(JEXL)+B5*BL5/DB52+B9*BL9/DB92
C       XNUM(6)=XNUM(6)+B5*CL5/DB52+B9*CL9/DB92
       XM3(JEX)=XM3(JEX)+B5*B5/DB53+B9*B9/DB93
       XM3(JEXL)=XM3(JEXL)+B5*BL5/DB53+B9*BL9/DB93
C
C       XNUM(3)=XNUM(3)+B5*CL5/DB53+B9*CL9/DB93
C
       DI6(JEX)=DI6(JEX)+B5*B5/DB5+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B5*C5/DB5+B9*C9/DB9
       YD1(JEX)=YD1(JEX)+B5*C5/DB5+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B5*C5/DB51+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B5*C5/DB51+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B5*C5/DB52+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B5*C5/DB52+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B5*C5/DB53+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B5*C5/DB53+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B5*B5/(DB5*DB5)+B9*B9/(DB9*DB9)
       GO TO 151
       END IF
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B4*B4/DB4+B8*B8/DB8
       XNUM(JEXL)=XNUM(JEXL)+B4*BL4/DB4+B8*BL8/DB8
C       XNUM(4)=XNUM(4)+B4*CL4/DB4+B8*CL8/DB8
       XM1(JEX)=XM1(JEX)+B4*B4/DB41+B8*B8/DB81
       XM1(JEXL)=XM1(JEXL)+B4*BL4/DB41+B8*BL8/DB81
C       XNUM(5)=XNUM(5)+B4*CL4/DB41+B8*CL8/DB81
       XM2(JEX)=XM2(JEX)+B4*B4/DB42+B8*B8/DB82
       XM2(JEXL)=XM2(JEXL)+B4*BL4/DB42+B8*BL8/DB82
C       XNUM(6)=XNUM(6)+B4*CL4/DB42+B8*CL8/DB82
       XM3(JEX)=XM3(JEX)+B4*B4/DB43+B8*B8/DB83
       XM3(JEXL)=XM3(JEXL)+B4*BL4/DB43+B8*BL8/DB83
C
C       XNUM(3)=XNUM(3)+B4*CL4/DB43+B8*CL8/DB83
C
       DI6(JEX)=DI6(JEX)+B4*B4/DB4+B8*B8/DB8
       XDENOM(JEX)=XDENOM(JEX)+B4*C4/DB4+B8*C8/DB8
       YD1(JEX)=YD1(JEX)+B4*C4/DB4+B8*C8/DB8
       XD1(JEX)=XD1(JEX)+B4*C4/DB41+B8*C8/DB81
       YD3(JEX)=YD3(JEX)+B4*C4/DB41+B8*C8/DB81
       XD2(JEX)=XD2(JEX)+B4*C4/DB42+B8*C8/DB82
       YD4(JEX)=YD4(JEX)+B4*C4/DB42+B8*C8/DB82
       XD3(JEX)=XD3(JEX)+B4*C4/DB43+B8*C8/DB83
       YD2(JEX)=YD2(JEX)+B4*C4/DB43+B8*C8/DB83
C       XDENOM(JEX)=XDENOM(JEX)+B4*B4/(DB4*DB4)+B8*B8/(DB8*DB8)
       GO TO 151
       END IF
C
 151     CONTINUE
         GO TO 100
        END IF
C ************************************
C
 100  CONTINUE
      RETURN
      END
      SUBROUTINE XT3SQ2CR(JEX,I,J,K,NO,NU,V3,U3,
     *                    AH,AP,APP,AHH,AHP,AX,BX,EH,EP)
C
C ### ORDERING I,J,K - REVERSED HERE
C JEX-NUMBER OF EXCITED STATE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER A,B,C
C
      DIMENSION U3(NU,NU,NU),V3(NU,NU,NU),EH(NO),EP(NU),
     *          AH(NO),AP(NU),
     *          AHH(NO,NO,2),AHP(NO,NU,2),APP(NU,NU,2),
     *          AX(NU,NU,NO,2),BX(NU,NO,NO,2)
C
      COMMON /EOMTRP/ DI1(10),DI2(10),DI3(10),DI4(10),DI5(10),DI6(10),
     *                ENESD(10),XNUM(10),XDENOM(10),R0(10),
     *                XM1(10),XM2(10),XM3(10),XD1(10),XD2(10),XD3(10),
     *                YD1(10),YD2(10),YD3(10),YD4(10),XNC3(10),DC3(10),
     *                XGRCORR,XGRCORR1,XGRCORR2,XGRCORR3,XGRCORR4,
     *                XGRCORR5,XGRCORR6,XGRCORR7,CI3GCORR
C
      DATA TWO/2.0D+00/
C
C
C
C *************************************************************
C
C I>J>K
C
        IF(I.GT.J.AND.J.GT.K) THEN
         I1=K
         J1=J
         K1=I
         DO 149,A=1,NU
         DO 149,B=A,NU
         DO 149,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 149
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX0=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)+AX(C,A,K1,1)
     &+AX(B,C,K1,1)-AX(B,C,K1,2)-AX(C,B,K1,2)+AX(C,B,K1,1)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)
     &+AX(B,C,I1,1)-AX(B,C,I1,2)-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX0=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB0=ENESD(JEX)+ZA1+ZA2-AX0-BX0
       DB01=ENESD(JEX)+HA1
       DB02=ENESD(JEX)+ZA1
       DB03=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX1=-AX(C,A,K1,2)-AX(C,B,K1,2)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &-AX(A,C,J1,2)-AX(B,C,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX1=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)-BX(A,K1,J1,1)
     &-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB1=ENESD(JEX)+ZA1+ZA2-AX1-BX1
       DB11=ENESD(JEX)+HA1
       DB12=ENESD(JEX)+ZA1
       DB13=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX2=-AX(B,A,K1,2)-AX(B,C,K1,2)-AX(A,B,J1,2)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)
     &-AX(A,B,I1,2)+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)
     &+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX2=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB2=ENESD(JEX)+ZA1+ZA2-AX2-BX2
       DB21=ENESD(JEX)+HA1
       DB22=ENESD(JEX)+ZA1
       DB23=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)
          AX3=-AX(A,B,K1,2)-AX(A,C,K1,2)-AX(B,A,J1,2)-AX(C,A,J1,2)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX3=-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,K1,J1,1)
       DB3=ENESD(JEX)+ZA1+ZA2-AX3-BX3
       DB31=ENESD(JEX)+HA1
       DB32=ENESD(JEX)+ZA1
       DB33=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX7=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)
     &+AX(B,A,J1,1)-AX(A,C,J1,2)-AX(B,C,J1,2)-AX(C,A,I1,2)-AX(C,B,I1,2)
        BX7=-BX(A,I1,J1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
       DB7=ENESD(JEX)+ZA1+ZA2-AX7-BX7
       DB71=ENESD(JEX)+HA1
       DB72=ENESD(JEX)+ZA1
       DB73=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX8=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(A,B,J1,2)+AX(A,C,J1,1)-AX(A,C,J1,2)
     &-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)-AX(B,A,I1,2)-AX(B,C,I1,2)
        BX8=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB8=ENESD(JEX)+ZA1+ZA2-AX8-BX8
       DB81=ENESD(JEX)+HA1
       DB82=ENESD(JEX)+ZA1
       DB83=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX9=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(B,A,J1,2)-AX(C,A,J1,2)+AX(B,C,J1,1)
     &-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)-AX(A,B,I1,2)-AX(A,C,I1,2)
        BX9=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,I1,J1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,I1,K1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB9=ENESD(JEX)+ZA1+ZA2-AX9-BX9
       DB91=ENESD(JEX)+HA1
       DB92=ENESD(JEX)+ZA1
       DB93=ENESD(JEX)+ZA1+ZA2
C
C
C       REVERSE ORDER OF A,B,C!!!
       B0=V3(C,B,A)-V3(B,C,A)-V3(C,A,B)+V3(A,C,B)+V3(B,A,C)-V3(A,B,C)
       B1=V3(C,B,A)-V3(C,A,B)
       B2=V3(B,C,A)-V3(B,A,C)
       B3=V3(A,C,B)-V3(A,B,C)
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
       B7=V3(B,A,C)-V3(A,B,C)
       B8=V3(C,A,B)-V3(A,C,B)
       B9=V3(C,B,A)-V3(B,C,A)
C
       C0=U3(C,B,A)-U3(B,C,A)-U3(C,A,B)+U3(A,C,B)+U3(B,A,C)-U3(A,B,C)
       C1=U3(C,B,A)-U3(C,A,B)
       C2=U3(B,C,A)-U3(B,A,C)
       C3=U3(A,C,B)-U3(A,B,C)
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
       C7=U3(B,A,C)-U3(A,B,C)
       C8=U3(C,A,B)-U3(A,C,B)
       C9=U3(C,B,A)-U3(B,C,A)
C
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEX)=XNUM(JEX)+TWO*(B0*B0/DB0+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9)
       DI6(JEX)=DI6(JEX)+TWO*(B0*B0/DB0+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9)
       XM1(JEX)=XM1(JEX)+TWO*(B0*B0/DB01+B1*B1/DB11+B2*B2/DB21+
     &     B3*B3/DB31+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61+B7*B7/DB71+
     &                     B8*B8/DB81+B9*B9/DB91)
       XM2(JEX)=XM2(JEX)+TWO*(B0*B0/DB02+B1*B1/DB12+B2*B2/DB22+
     &     B3*B3/DB32+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62+B7*B7/DB72+
     &                     B8*B8/DB82+B9*B9/DB92)
       XM3(JEX)=XM3(JEX)+TWO*(B0*B0/DB03+B1*B1/DB13+B2*B2/DB23+
     &     B3*B3/DB33+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63+B7*B7/DB73+
     &                     B8*B8/DB83+B9*B9/DB93)
       XDENOM(JEX)=XDENOM(JEX)+TWO*(B0*C0/DB0+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9)
       YD1(JEX)=YD1(JEX)+TWO*(B0*C0/DB0+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9)
       XD1(JEX)=XD1(JEX)+TWO*(B0*C0/DB01+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91)
       YD3(JEX)=YD3(JEX)+TWO*(B0*C0/DB01+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91)
       XD2(JEX)=XD2(JEX)+TWO*(B0*C0/DB02+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92)
       YD4(JEX)=YD4(JEX)+TWO*(B0*C0/DB02+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92)
       XD3(JEX)=XD3(JEX)+TWO*(B0*C0/DB03+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93)
       YD2(JEX)=YD2(JEX)+TWO*(B0*C0/DB03+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93)
C       XDENOM(JEX)=XDENOM(JEX)+TWO*(B0*B0/(DB0*DB0)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+B7*B7/(DB7*DB7)+
C     &                     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9))
       GO TO 149
       END IF
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B2*B2/DB2+B3*B3/DB3+B5*B5/DB5+B6*B6/DB6+
     &                     B8*B8/DB8+B9*B9/DB9
       XM1(JEX)=XM1(JEX)+B2*B2/DB21+B3*B3/DB31+B5*B5/DB51+B6*B6/DB61+
     &                     B8*B8/DB81+B9*B9/DB91
       XM2(JEX)=XM2(JEX)+B2*B2/DB22+B3*B3/DB32+B5*B5/DB52+B6*B6/DB62+
     &                     B8*B8/DB82+B9*B9/DB92
       XM3(JEX)=XM3(JEX)+B2*B2/DB23+B3*B3/DB33+B5*B5/DB53+B6*B6/DB63+
     &                     B8*B8/DB83+B9*B9/DB93
       DI6(JEX)=DI6(JEX)+B2*B2/DB2+B3*B3/DB3+B5*B5/DB5+B6*B6/DB6+
     &                     B8*B8/DB8+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B2*C2/DB2+B3*C3/DB3+B5*C5/DB5+B6*C6/DB6+
     &                     B8*C8/DB8+B9*C9/DB9
       YD1(JEX)=YD1(JEX)+B2*C2/DB2+B3*C3/DB3+B5*C5/DB5+B6*C6/DB6+
     &                     B8*C8/DB8+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B2*C2/DB21+B3*C3/DB31+B5*C5/DB51+B6*C6/DB61+
     &                     B8*C8/DB81+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B2*C2/DB21+B3*C3/DB31+B5*C5/DB51+B6*C6/DB61+
     &                     B8*C8/DB81+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B2*C2/DB22+B3*C3/DB32+B5*C5/DB52+B6*C6/DB62+
     &                     B8*C8/DB82+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B2*C2/DB22+B3*C3/DB32+B5*C5/DB52+B6*C6/DB62+
     &                     B8*C8/DB82+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B2*C2/DB23+B3*C3/DB33+B5*C5/DB53+B6*C6/DB63+
     &                     B8*C8/DB83+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B2*C2/DB23+B3*C3/DB33+B5*C5/DB53+B6*C6/DB63+
     &                     B8*C8/DB83+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+
C     &     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9)
       GO TO 149
       END IF
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B4*B4/DB4+B5*B5/DB5+B7*B7/DB7+B8*B8/DB8
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B2*B2/DB21+
     &     B4*B4/DB41+B5*B5/DB51+B7*B7/DB71+B8*B8/DB81
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B2*B2/DB22+
     &     B4*B4/DB42+B5*B5/DB52+B7*B7/DB72+B8*B8/DB82
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B2*B2/DB23+
     &     B4*B4/DB43+B5*B5/DB53+B7*B7/DB73+B8*B8/DB83
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B4*B4/DB4+B5*B5/DB5+B7*B7/DB7+B8*B8/DB8
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B4*C4/DB4+B5*C5/DB5+B7*C7/DB7+B8*C8/DB8
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B4*C4/DB4+B5*C5/DB5+B7*C7/DB7+B8*C8/DB8
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B4*C4/DB41+B5*C5/DB51+B7*C7/DB71+B8*C8/DB81
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B4*C4/DB41+B5*C5/DB51+B7*C7/DB71+B8*C8/DB81
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B4*C4/DB42+B5*C5/DB52+B7*C7/DB72+B8*C8/DB82
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B4*C4/DB42+B5*C5/DB52+B7*C7/DB72+B8*C8/DB82
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B4*C4/DB43+B5*C5/DB53+B7*C7/DB73+B8*C8/DB83
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B4*C4/DB43+B5*C5/DB53+B7*C7/DB73+B8*C8/DB83
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B7*B7/(DB7*DB7)+B8*B8/(DB8*DB8)
       GO TO 149
       END IF
C
 149     CONTINUE
         GO TO 100
        END IF
C
C *********************************************************
C
C
C *********************************************************
C I=J>K
C
        IF(I.EQ.J.AND.J.GT.K) THEN
         I1=K
         J1=J
         K1=I
         DO 150,A=1,NU
         DO 150,B=A,NU
         DO 150,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 150
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX1=-AX(C,A,K1,2)-AX(C,B,K1,2)
     &+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)+AX(B,A,J1,1)
     &-AX(A,C,J1,2)-AX(B,C,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX1=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)-BX(A,K1,J1,1)
     &-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB1=ENESD(JEX)+ZA1+ZA2-AX1-BX1
       DB11=ENESD(JEX)+HA1
       DB12=ENESD(JEX)+ZA1
       DB13=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX2=-AX(B,A,K1,2)-AX(B,C,K1,2)-AX(A,B,J1,2)
     &+AX(A,C,J1,1)-AX(A,C,J1,2)-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)
     &-AX(A,B,I1,2)+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)
     &+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX2=-BX(A,I1,J1,1)+BX(A,I1,J1,2)+BX(A,J1,I1,2)-BX(A,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB2=ENESD(JEX)+ZA1+ZA2-AX2-BX2
       DB21=ENESD(JEX)+HA1
       DB22=ENESD(JEX)+ZA1
       DB23=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)+AHH(I1,J1,2)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)
          AX3=-AX(A,B,K1,2)-AX(A,C,K1,2)-AX(B,A,J1,2)-AX(C,A,J1,2)
     &+AX(B,C,J1,1)-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX3=-BX(B,I1,J1,1)+BX(B,I1,J1,2)+BX(B,J1,I1,2)-BX(B,J1,I1,1)
     &-BX(C,I1,J1,1)+BX(C,I1,J1,2)+BX(C,J1,I1,2)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,K1,J1,1)
       DB3=ENESD(JEX)+ZA1+ZA2-AX3-BX3
       DB31=ENESD(JEX)+HA1
       DB32=ENESD(JEX)+ZA1
       DB33=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
C
C
C       REVERSE ORDER OF A,B,C!!!
       B1=V3(C,B,A)-V3(C,A,B)
       B2=V3(B,C,A)-V3(B,A,C)
       B3=V3(A,C,B)-V3(A,B,C)
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
C
       C1=U3(C,B,A)-U3(C,A,B)
       C2=U3(B,C,A)-U3(B,A,C)
       C3=U3(A,C,B)-U3(A,B,C)
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
C
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B2*B2/DB21+
     &     B3*B3/DB31+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B2*B2/DB22+
     &     B3*B3/DB32+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B2*B2/DB23+
     &     B3*B3/DB33+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B2*B2/DB2+
     &     B3*B3/DB3+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B2*C2/DB2+
     &     B3*C3/DB3+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B2*C2/DB21+
     &     B3*C3/DB31+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B2*C2/DB22+
     &     B3*C3/DB32+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B2*C2/DB23+
     &     B3*C3/DB33+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+
C     &     B2*B2/(DB2*DB2)+B3*B3/(DB3*DB3)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)
       GO TO 150
       END IF
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B2*B2/DB2+B6*B6/DB6
       XM1(JEX)=XM1(JEX)+B2*B2/DB21+B6*B6/DB61
       XM2(JEX)=XM2(JEX)+B2*B2/DB22+B6*B6/DB62
       XM3(JEX)=XM3(JEX)+B2*B2/DB23+B6*B6/DB63
       DI6(JEX)=DI6(JEX)+B2*B2/DB2+B6*B6/DB6
       XDENOM(JEX)=XDENOM(JEX)+B2*C2/DB2+B6*C6/DB6
       YD1(JEX)=YD1(JEX)+B2*C2/DB2+B6*C6/DB6
       XD1(JEX)=XD1(JEX)+B2*C2/DB21+B6*C6/DB61
       YD3(JEX)=YD3(JEX)+B2*C2/DB21+B6*C6/DB61
       XD2(JEX)=XD2(JEX)+B2*C2/DB22+B6*C6/DB62
       YD4(JEX)=YD4(JEX)+B2*C2/DB22+B6*C6/DB62
       XD3(JEX)=XD3(JEX)+B2*C2/DB23+B6*C6/DB63
       YD2(JEX)=YD2(JEX)+B2*C2/DB23+B6*C6/DB63
C       XDENOM(JEX)=XDENOM(JEX)+B2*B2/(DB2*DB2)+B6*B6/(DB6*DB6)
       GO TO 150
       END IF
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B1*B1/DB1+B5*B5/DB5
       XM1(JEX)=XM1(JEX)+B1*B1/DB11+B5*B5/DB51
       XM2(JEX)=XM2(JEX)+B1*B1/DB12+B5*B5/DB52
       XM3(JEX)=XM3(JEX)+B1*B1/DB13+B5*B5/DB53
       DI6(JEX)=DI6(JEX)+B1*B1/DB1+B5*B5/DB5
       XDENOM(JEX)=XDENOM(JEX)+B1*C1/DB1+B5*C5/DB5
       YD1(JEX)=YD1(JEX)+B1*C1/DB1+B5*C5/DB5
       XD1(JEX)=XD1(JEX)+B1*C1/DB11+B5*C5/DB51
       YD3(JEX)=YD3(JEX)+B1*C1/DB11+B5*C5/DB51
       XD2(JEX)=XD2(JEX)+B1*C1/DB12+B5*C5/DB52
       YD4(JEX)=YD4(JEX)+B1*C1/DB12+B5*C5/DB52
       XD3(JEX)=XD3(JEX)+B1*C1/DB13+B5*C5/DB53
       YD2(JEX)=YD2(JEX)+B1*C1/DB13+B5*C5/DB53
C       XDENOM(JEX)=XDENOM(JEX)+B1*B1/(DB1*DB1)+B5*B5/(DB5*DB5)
       GO TO 150
       END IF
C
 150   CONTINUE
         GO TO 100
        END IF
C *****************************************************
C
C
C *****************************************************
C I>J=K
C
C
C
        IF(I.GT.J.AND.J.EQ.K) THEN
         I1=K
         J1=J
         K1=I
         DO 151,A=1,NU
         DO 151,B=A,NU
         DO 151,C=B,NU
         IF(A.EQ.B.AND.B.EQ.C) GO TO 151
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)
     &+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX4=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)-AX(C,A,J1,2)-AX(C,B,J1,2)
     &+AX(A,B,I1,1)-AX(A,B,I1,2)-AX(B,A,I1,2)+AX(B,A,I1,1)
     &-AX(A,C,I1,2)-AX(B,C,I1,2)
        BX4=-BX(A,J1,I1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,J1,K1,1)-BX(C,K1,J1,1)
       DB4=ENESD(JEX)+ZA1+ZA2-AX4-BX4
       DB41=ENESD(JEX)+HA1
       DB42=ENESD(JEX)+ZA1
       DB43=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX5=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(B,A,J1,2)-AX(B,C,J1,2)-AX(A,B,I1,2)
     &+AX(A,C,I1,1)-AX(A,C,I1,2)-AX(C,A,I1,2)+AX(C,A,I1,1)-AX(C,B,I1,2)
        BX5=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)+BX(A,I1,K1,2)+BX(A,K1,I1,2)-BX(A,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)-BX(B,K1,J1,1)-BX(C,J1,K1,1)
       DB5=ENESD(JEX)+ZA1+ZA2-AX5-BX5
       DB51=ENESD(JEX)+HA1
       DB52=ENESD(JEX)+ZA1
       DB53=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)-AHH(I1,K1,1)+AHH(I1,K1,2)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX6=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(A,B,J1,2)-AX(A,C,J1,2)
     &-AX(B,A,I1,2)-AX(C,A,I1,2)+AX(B,C,I1,1)-AX(B,C,I1,2)
     &-AX(C,B,I1,2)+AX(C,B,I1,1)
        BX6=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,J1,I1,1)
     &-BX(B,I1,K1,1)+BX(B,I1,K1,2)+BX(B,K1,I1,2)-BX(B,K1,I1,1)
     &-BX(C,I1,K1,1)+BX(C,I1,K1,2)+BX(C,K1,I1,2)-BX(C,K1,I1,1)
     &-BX(A,K1,J1,1)-BX(B,J1,K1,1)-BX(C,J1,K1,1)
       DB6=ENESD(JEX)+ZA1+ZA2-AX6-BX6
       DB61=ENESD(JEX)+HA1
       DB62=ENESD(JEX)+ZA1
       DB63=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)+APP(A,B,2)-APP(C,B,1)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)+AHP(I1,C,1)
     &-AHP(I1,C,2)+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)
          AX7=AX(A,B,K1,1)-AX(A,B,K1,2)-AX(B,A,K1,2)+AX(B,A,K1,1)
     &-AX(A,C,K1,2)-AX(B,C,K1,2)+AX(A,B,J1,1)-AX(A,B,J1,2)-AX(B,A,J1,2)
     &+AX(B,A,J1,1)-AX(A,C,J1,2)-AX(B,C,J1,2)-AX(C,A,I1,2)-AX(C,B,I1,2)
        BX7=-BX(A,I1,J1,1)-BX(B,I1,J1,1)-BX(C,J1,I1,1)
     &-BX(A,I1,K1,1)-BX(B,I1,K1,1)-BX(C,K1,I1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
       DB7=ENESD(JEX)+ZA1+ZA2-AX7-BX7
       DB71=ENESD(JEX)+HA1
       DB72=ENESD(JEX)+ZA1
       DB73=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
           ZA2=
     &-APP(A,B,1)-APP(C,B,1)-APP(A,C,1)+APP(A,C,2)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)+AHP(I1,B,1)-AHP(I1,B,2)+AHP(I1,C,1)
     &+AHP(J1,A,1)-AHP(J1,A,2)+AHP(J1,B,1)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)-AHP(K1,A,2)+AHP(K1,B,1)
     &+AHP(K1,C,1)-AHP(K1,C,2)
          AX8=-AX(A,B,K1,2)+AX(A,C,K1,1)-AX(A,C,K1,2)-AX(C,A,K1,2)
     &+AX(C,A,K1,1)-AX(C,B,K1,2)-AX(A,B,J1,2)+AX(A,C,J1,1)-AX(A,C,J1,2)
     &-AX(C,A,J1,2)+AX(C,A,J1,1)-AX(C,B,J1,2)-AX(B,A,I1,2)-AX(B,C,I1,2)
        BX8=-BX(A,I1,J1,1)-BX(B,J1,I1,1)-BX(C,I1,J1,1)
     &-BX(A,I1,K1,1)-BX(B,K1,I1,1)-BX(C,I1,K1,1)
     &-BX(A,J1,K1,1)+BX(A,J1,K1,2)+BX(A,K1,J1,2)-BX(A,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB8=ENESD(JEX)+ZA1+ZA2-AX8-BX8
       DB81=ENESD(JEX)+HA1
       DB82=ENESD(JEX)+ZA1
       DB83=ENESD(JEX)+ZA1+ZA2
          HA1=EH(I1)+EH(J1)+EH(K1)-EP(A)-EP(B)-EP(C)
          ZA1=AH(I1)+AH(J1)+AH(K1)-AP(A)-AP(B)-AP(C)
          ZA2=
     &-APP(A,B,1)-APP(C,B,1)+APP(C,B,2)-APP(A,C,1)
     &-AHH(I1,J1,1)-AHH(K1,J1,1)+AHH(K1,J1,2)-AHH(I1,K1,1)
     &+AHP(I1,A,1)-AHP(I1,A,2)+AHP(I1,B,1)+AHP(I1,C,1)
     &+AHP(J1,A,1)+AHP(J1,B,1)-AHP(J1,B,2)
     &+AHP(J1,C,1)-AHP(J1,C,2)+AHP(K1,A,1)+AHP(K1,B,1)
     &-AHP(K1,B,2)+AHP(K1,C,1)-AHP(K1,C,2)
          AX9=-AX(B,A,K1,2)-AX(C,A,K1,2)+AX(B,C,K1,1)-AX(B,C,K1,2)
     &-AX(C,B,K1,2)+AX(C,B,K1,1)-AX(B,A,J1,2)-AX(C,A,J1,2)+AX(B,C,J1,1)
     &-AX(B,C,J1,2)-AX(C,B,J1,2)+AX(C,B,J1,1)-AX(A,B,I1,2)-AX(A,C,I1,2)
        BX9=-BX(A,J1,I1,1)-BX(B,I1,J1,1)-BX(C,I1,J1,1)
     &-BX(A,K1,I1,1)-BX(B,I1,K1,1)-BX(C,I1,K1,1)
     &-BX(B,J1,K1,1)+BX(B,J1,K1,2)+BX(B,K1,J1,2)-BX(B,K1,J1,1)
     &-BX(C,J1,K1,1)+BX(C,J1,K1,2)+BX(C,K1,J1,2)-BX(C,K1,J1,1)
       DB9=ENESD(JEX)+ZA1+ZA2-AX9-BX9
       DB91=ENESD(JEX)+HA1
       DB92=ENESD(JEX)+ZA1
       DB93=ENESD(JEX)+ZA1+ZA2
C
C
C
C
C       REVERSE ORDER OF A,B,C!!!
       B4=V3(B,C,A)-V3(A,C,B)
       B5=V3(C,B,A)-V3(A,B,C)
       B6=V3(C,A,B)-V3(B,A,C)
       B7=V3(B,A,C)-V3(A,B,C)
       B8=V3(C,A,B)-V3(A,C,B)
       B9=V3(C,B,A)-V3(B,C,A)
C
       C4=U3(B,C,A)-U3(A,C,B)
       C5=U3(C,B,A)-U3(A,B,C)
       C6=U3(C,A,B)-U3(B,A,C)
       C7=U3(B,A,C)-U3(A,B,C)
       C8=U3(C,A,B)-U3(A,C,B)
       C9=U3(C,B,A)-U3(B,C,A)
       IF(A.LT.B.AND.B.LT.C) THEN
       XNUM(JEX)=XNUM(JEX)+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9
       XM1(JEX)=XM1(JEX)+B4*B4/DB41+B5*B5/DB51+B6*B6/DB61+B7*B7/DB71+
     &                     B8*B8/DB81+B9*B9/DB91
       XM2(JEX)=XM2(JEX)+B4*B4/DB42+B5*B5/DB52+B6*B6/DB62+B7*B7/DB72+
     &                     B8*B8/DB82+B9*B9/DB92
       XM3(JEX)=XM3(JEX)+B4*B4/DB43+B5*B5/DB53+B6*B6/DB63+B7*B7/DB73+
     &                     B8*B8/DB83+B9*B9/DB93
       DI6(JEX)=DI6(JEX)+B4*B4/DB4+B5*B5/DB5+B6*B6/DB6+B7*B7/DB7+
     &                     B8*B8/DB8+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9
       YD1(JEX)=YD1(JEX)+B4*C4/DB4+B5*C5/DB5+B6*C6/DB6+B7*C7/DB7+
     &                     B8*C8/DB8+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B4*C4/DB41+B5*C5/DB51+B6*C6/DB61+B7*C7/DB71+
     &                     B8*C8/DB81+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B4*C4/DB42+B5*C5/DB52+B6*C6/DB62+B7*C7/DB72+
     &                     B8*C8/DB82+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B4*C4/DB43+B5*C5/DB53+B6*C6/DB63+B7*C7/DB73+
     &                     B8*C8/DB83+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B4*B4/(DB4*DB4)+
C     &     B5*B5/(DB5*DB5)+B6*B6/(DB6*DB6)+B7*B7/(DB7*DB7)+
C     &                     B8*B8/(DB8*DB8)+B9*B9/(DB9*DB9)
       GO TO 151
       END IF
       IF(A.EQ.B) THEN
       XNUM(JEX)=XNUM(JEX)+B5*B5/DB5+B9*B9/DB9
       XM1(JEX)=XM1(JEX)+B5*B5/DB51+B9*B9/DB91
       XM2(JEX)=XM2(JEX)+B5*B5/DB52+B9*B9/DB92
       XM3(JEX)=XM3(JEX)+B5*B5/DB53+B9*B9/DB93
       DI6(JEX)=DI6(JEX)+B5*B5/DB5+B9*B9/DB9
       XDENOM(JEX)=XDENOM(JEX)+B5*C5/DB5+B9*C9/DB9
       YD1(JEX)=YD1(JEX)+B5*C5/DB5+B9*C9/DB9
       XD1(JEX)=XD1(JEX)+B5*C5/DB51+B9*C9/DB91
       YD3(JEX)=YD3(JEX)+B5*C5/DB51+B9*C9/DB91
       XD2(JEX)=XD2(JEX)+B5*C5/DB52+B9*C9/DB92
       YD4(JEX)=YD4(JEX)+B5*C5/DB52+B9*C9/DB92
       XD3(JEX)=XD3(JEX)+B5*C5/DB53+B9*C9/DB93
       YD2(JEX)=YD2(JEX)+B5*C5/DB53+B9*C9/DB93
C       XDENOM(JEX)=XDENOM(JEX)+B5*B5/(DB5*DB5)+B9*B9/(DB9*DB9)
       GO TO 151
       END IF
       IF(B.EQ.C) THEN
       XNUM(JEX)=XNUM(JEX)+B4*B4/DB4+B8*B8/DB8
       XM1(JEX)=XM1(JEX)+B4*B4/DB41+B8*B8/DB81
       XM2(JEX)=XM2(JEX)+B4*B4/DB42+B8*B8/DB82
       XM3(JEX)=XM3(JEX)+B4*B4/DB43+B8*B8/DB83
       DI6(JEX)=DI6(JEX)+B4*B4/DB4+B8*B8/DB8
       XDENOM(JEX)=XDENOM(JEX)+B4*C4/DB4+B8*C8/DB8
       YD1(JEX)=YD1(JEX)+B4*C4/DB4+B8*C8/DB8
       XD1(JEX)=XD1(JEX)+B4*C4/DB41+B8*C8/DB81
       YD3(JEX)=YD3(JEX)+B4*C4/DB41+B8*C8/DB81
       XD2(JEX)=XD2(JEX)+B4*C4/DB42+B8*C8/DB82
       YD4(JEX)=YD4(JEX)+B4*C4/DB42+B8*C8/DB82
       XD3(JEX)=XD3(JEX)+B4*C4/DB43+B8*C8/DB83
       YD2(JEX)=YD2(JEX)+B4*C4/DB43+B8*C8/DB83
C       XDENOM(JEX)=XDENOM(JEX)+B4*B4/(DB4*DB4)+B8*B8/(DB8*DB8)
       GO TO 151
       END IF
C
 151     CONTINUE
         GO TO 100
        END IF
C ************************************
C
 100  CONTINUE
      RETURN
      END
C
C
C
C
C
C
