C 22 FEB 06 - MWS - FIX TWO LITTLE SNAGS
C  2 FEB 06 - MWS - CCSD DENSITY TO AO BASIS, SAVE SYM. FORM OF IT
C 17 JAN 06 - MW  - LAMBDIIS: FIX LEFT EIGENSOLVER BUG
C 17 JAN 06 - MWS - EOMINP,EOMDRV: ADD CR-CCSD(T)_L PATHWAY
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 27 JUN 05 - PP  - DAVIDSONRL: PRINT LEFT AMPLITUDES
C 30 APR 05 - MW,KK - LEFT EIGENVECS AND DENSITY FOR TRANSITION MOMENTS
C  9 JUN 04 - KK  - DAVIDSONMR: FIX BAD STATE SAVING
C 26 MAY 04 - MWS - EOMINP: CORRECT BUG IN ACTIVE ORBITAL SELECTION
C  7 APR 04 - KK,PP - NEW MODULE TO OBTAIN EOM-CCSD ENERGIES
C
C*MODULE EOMCC   *DECK EOMINP
      SUBROUTINE EOMINP(CCTYP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK,ABEL,ABELPT,CCPRP,CCPRPE
      DIMENSION GRPS(8)
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                MXCCIT,MXRLEIT,NWRDCC,ICCCNV,ICCRST,IDSKCC
      COMMON /EOMPAR/ CVGCI,CVGEOM,GRPEOM,NSTEOM(8),NOACT,NUACT,
     *                MOACTCC(MXAO),MTHTRIP,MTHCI,MTHEOM,MTHINIT,
     *                MAXCI,MAXEOM,MICCI,MICEOM,IROOTCC(2),
     *                IPROPCC,IPROPCCE
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMMOL/ GROUP,COMPLEX,IGROUP,NAXIS,ILABMO,ABEL
C
      PARAMETER (TEN=1.0D+01)
C
      PARAMETER (NNAM=17)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA GNAME/8HEOMINP  /
      DATA QNAM/8HMTRIP   ,8HMCI     ,8HMEOM    ,8HNOACT   ,8HNUACT   ,
     *          8HGROUP   ,8HNSTATE  ,8HMOACT   ,8HMINIT   ,8HMICCI   ,
     *          8HMICEOM  ,8HCVGCI   ,8HCVGEOM  ,8HMAXEOM  ,8HIROOT   ,
     *          8HMAXCI   ,8HCCPRPE  /
      DATA KQNAM/5*1,  5,81,-1,1,1,  1,3,3,1,21,  1,0/
C
      DATA GRPS/8HC1      ,8HCI      ,8HCS      ,8HC2      ,
     *          8HD2      ,8HC2V     ,8HC2H     ,8HD2H     /
C
      DATA CREOM,CRCCL/8HCR-EOM  ,8HCR-CCL   /
C
C        READ $EOMINP GROUP, FILL EOMPAR COMMON BLOCK
C
      NO    = NCCOCC - NCCFZC
      NU    = NCCTOT - NCCFZV - NCCOCC
      NCORR = NO + NU
C
      KQNAM(8) = 10*MXAO + 1
C
C        PREPARE DEFAULT PARAMETERS
C
      GRPEOM  = GRPS(1)
      IF(IGROUP.EQ.1)                GRPEOM = GRPS(1)
      IF(IGROUP.EQ.3)                GRPEOM = GRPS(2)
      IF(IGROUP.EQ.2)                GRPEOM = GRPS(3)
      IF(IGROUP.EQ.4.AND.NAXIS.EQ.2) GRPEOM = GRPS(4)
      IF(IGROUP.EQ.8.AND.NAXIS.EQ.2) GRPEOM = GRPS(5)
      IF(IGROUP.EQ.7.AND.NAXIS.EQ.2) GRPEOM = GRPS(6)
      IF(IGROUP.EQ.6.AND.NAXIS.EQ.2) GRPEOM = GRPS(7)
      IF(IGROUP.EQ.9.AND.NAXIS.EQ.2) GRPEOM = GRPS(8)
      DEFGRP = GRPEOM
      NSTEOM(1) = -100
      DO I=2,8
         NSTEOM(I) = 0
      ENDDO
C
C        DEFAULT STATE TO SAVE ENERGY AND SOMEDAY, DENSITY MATRIX, FOR
C        IS THE GROUND STATE (GIVEN AS IRREP NUMBER, STATE NUMBER)
C
      IROOTCC(1)=1
      IROOTCC(2)=0
C
C        INITIAL GUESS PROCEDURES, USED BY BOTH EOM-CCSD AND MMCC(2,3)
C
      MTHINIT = 2
      NOACT   = 0
      NUACT   = 0
      DO I=1,NCORR
         MOACTCC(I) = 0
         IA(I)=0
      ENDDO
C
      MTHEOM  = 0
      MICEOM  = 80
      MAXEOM  = 50
      CVGEOM  = 1.0D-04
      IF(CCTYP.EQ.CRCCL) CVGEOM=TEN**(-ICCCNV)
C
C        PARAMETERS USED BY THE MMCC(2,3) PROGRAM ARE
C
      MTHTRIP = 1
C
      MTHCI   = 1
      MICCI   = 80
      MAXCI   = 50
      CVGCI   = 1.0D-04
C
C         FLAG FOR EOM-CCSD PROPERTIES FOR THE GROUND STATE ONLY,
C         OR OPTIONALLY ALSO FOR THE EXCITED STATES (ALL OF THEM).
C
      CCPRP   = IPROPCC.NE.0
      CCPRPE  = .FALSE.
C
      CALL NAMEIO(IR,JRET,GNAME,NNAM,QNAM,KQNAM,
     *            MTHTRIP,MTHCI,MTHEOM,NOACT,NUACT,GRPEOM,NSTEOM,
     *            IA,MTHINIT,MICCI,MICEOM,CVGCI,CVGEOM,MAXEOM,
     *            IROOTCC,MAXCI,CCPRPE,
     *          0,0,  0,0,0,0,0,
     *    0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0,
     *    0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0)
C
      IF(JRET.EQ.2) THEN
         IF(MASWRK) WRITE(IW,9010)
         CALL ABRT
         STOP
      END IF
C
C        FORCE SOME OPTIONS
C
      IF(.NOT.ABELPT()) GRPEOM = GRPS(1)
      IPROPCCE=0
      IF(CCPRPE) CCPRP   =.TRUE.
      IF(CCPRPE) IPROPCC =1
      IF(CCPRPE) IPROPCCE=1
      IF(IPROPCC.EQ.1  .AND.  IPROPCCE.EQ.0) THEN
         IF(NSTEOM(1).EQ.-100) NSTEOM(1)=0
      ELSE
         IF(NSTEOM(1).EQ.-100) NSTEOM(1)=1
      END IF
C        CR-CCSD(T)_L IS ENTIRELY A GROUND STATE THING AT PRESENT
      IF(CCTYP.EQ.CRCCL) THEN
         DO I=1,8
            NSTEOM(I) = 0
         ENDDO
      END IF
C
      NERR = 0
C
      IF(GRPEOM.NE.GRPS(1)  .AND.  GRPEOM.NE.DEFGRP) THEN
         IF(MASWRK) WRITE(IW,9015) DEFGRP
         NERR=NERR+1
      END IF
C
C         MTHINIT=1 REQUIRES LITTLE-D ACTIVE SPACE DEFINITION
C
      IF(MTHINIT.EQ.1) THEN
         IF(NOACT.LE.0 .OR. NUACT.LE.0) THEN
            IF(MASWRK) WRITE(IW,9025)
            NERR=NERR+1
         END IF
         IF(NOACT.GT.NO) THEN
            IF(MASWRK) WRITE(IW,9020) 'NOACT',NOACT,' EXCEEDS NO',NO
            NERR=NERR+1
         END IF
         IF(NUACT.GT.NU) THEN
            IF(MASWRK) WRITE(IW,9020) 'NUACT',NUACT,' EXCEEDS NU',NU
            NERR=NERR+1
         END IF
C
C        FLAG ALL THE ACTIVE ORBITALS, EITHER EXPLICITLY INPUT MO'S...
C
         NACT = 0
  200    CONTINUE
            IF(IA(NACT+1).EQ.0) GO TO 210
            NACT = NACT+1
            MOACTCC(IA(NACT)-NCCFZC)=1
            IF(IA(NACT).NE.0  .AND.  NACT.LT.NCORR) GO TO 200
  210    CONTINUE
C
C        ... OR JUST AROUND THE HOMO/LUMO REGION
C
         IF(NACT.EQ.0) THEN
            DO I=NO-NOACT+1,NO
               MOACTCC(I) = 1
            ENDDO
            DO I=1,NUACT
               MOACTCC(NO+I) = 1
            ENDDO
         ELSE
            IF(NACT.NE.(NOACT+NUACT)) THEN
               IF(MASWRK) WRITE(IW,9030) NACT,NOACT,NUACT
               NERR=NERR+1
            END IF
         END IF
      ELSE
         NOACT=0
         NUACT=0
      END IF
C
      IF(NERR.GT.0) THEN
         IF(MASWRK) WRITE(IW,9290)
         CALL ABRT
         STOP
      END IF
C
C        PRINT INPUTS
C
      IF(MASWRK) THEN
         WRITE(IW,9100)
         WRITE(IW,9110) GRPEOM,NSTEOM,IROOTCC
         WRITE(IW,9120) MTHEOM,MAXEOM,MICEOM,CVGEOM
         IF(CCTYP.EQ.CREOM) THEN
           WRITE(IW,9130) MTHTRIP
           IF(MTHTRIP.GT.1) WRITE(IW,9140) MTHCI,MAXCI,MICCI,CVGCI
         END IF
         WRITE(IW,9145) CCPRP,CCPRPE
         WRITE(IW,9150) MTHINIT,NOACT,NUACT
         IF(MTHINIT.EQ.1) THEN
            IF(NACT.GT.0) THEN
               WRITE(IW,9160) (IA(III),III=1,NACT)
            ELSE
               WRITE(IW,9170)
            END IF
         ELSE
            WRITE(IW,9180)
         END IF
      END IF
C
C        REGENERATE INDEX ARRAY, USED AS SCRATCH VECTOR ABOVE
C
      DO I=1,NUM
         IA(I) = (I*I-I)/2
      ENDDO
      RETURN
C
 9010 FORMAT(1X,'ERROR IN $EOMINP GROUP, PLEASE FIX AND TRY AGAIN')
 9015 FORMAT(1X,'GROUP MUST BE THE CURRENT $DATA ABELIAN GROUP ',A4,
     *          ' OR ELSE C1')
 9020 FORMAT(1X,A5,'=',I5,' CANNOT EXCEED',A2,'=',I5,'.')
 9025 FORMAT(1X,'ERROR, FOR MINIT=1, NOACT AND NUACT MUST BE INPUT')
 9030 FORMAT(1X,'NUMBER OF ACTIVE MO-S DEFINED IN MOACT ARRAY=',I5/
     *       1X,'DOES NOT MATCH SUM OF NOACT=',I5,' PLUS NUACT=',I5)
 9100 FORMAT(/5X,43(1H-)/
     *       5X,'EQUATION OF MOTION INPUT FOR EXCITED STATES'/
     *       5X,43(1H-))
 9110 FORMAT(5X,'OPTIONS FOR STATE SELECTION:'/
     *       5X,'GROUP =',A8,2X,'NSTATE=',7(I2,','),I2,4X,
     *          'IROOT =',I2,',',I2)
 9120 FORMAT(5X,'OPTIONS FOR THE EOM-CCSD:'/
     *       5X,'MEOM  =',I8,2X,'MAXEOM=',I8,2X,'MICEOM=',I8,2X,
     *          'CVGEOM=',1P,E8.1)
 9130 FORMAT(5X,'OPTIONS FOR THE TRIPLES CORRECTION:'/
     *       5X,'MTRIP =',I8)
 9140 FORMAT(5X,'MCI   =',I8,2X,'MAXCI =',I8,2X,'MICCI =',I8,2X,
     *          'CVGCI =',1P,E8.1)
 9145 FORMAT(5X,'OPTIONS FOR PROPERTIES:'/
     *       5X,'CCPRP =',L8,2X,'CCPRPE =',L8)
 9150 FORMAT(5X,'OPTIONS FOR INITIAL GUESSES:'/
     *       5X,'MINIT =',I8,2X,'NOACT =',I8,2X,'NUACT =',I8)
 9160 FORMAT(5X,'MOACT =',10I5)
 9170 FORMAT(5X,'ACTIVE ORBITALS DEFAULTED TO HOMO/LUMO BOUNDARY')
 9180 FORMAT(5X,'NO DOUBLE EXCITATIONS WILL BE INCLUDED IN THE',
     *          ' INITIAL GUESS')
 9290 FORMAT(1X,'ERROR(S) WERE DETECTED IN $EOMINP.',
     *          '  PLEASE FIX AND RESUBMIT.')
      END
C
C*MODULE EOMCC   *DECK EOMDRV
      SUBROUTINE EOMDRV(CCTYP,ESCF,ECCSD,BESTEOM)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      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 /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C 27/05/2004 LEFT EOMSD ------------------
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C-----------------------------------------
C
      DATA CREOM,CRCCL/8HCR-EOM  ,8HCR-CCL   /
C
      IF (CCTYP.EQ.CRCCL) THEN
         WRITE(IW,9011) CCTYP
      ELSE
         WRITE(IW,9010) CCTYP
      END IF
C
C        OBTAIN INPUT VALUES
C
C---      READ(5,*) IOPTMM
C---      READ(5,*) NH,NP
C---      READ(5,*) NOA,NUA
C---      READ(5,*) MET,MEM
C---      IF(MEM.EQ.0) MEM=40000000
C---      READ(5,*) ICONV,MAXIT,IREST
C---      READ(5,*) INISTART
C---      READ(5,*) ICIMET
C---      READ(5,*) JCISPACE
C---      READ(5,*) IHSPACE,ICVCI
C---      READ(5,*) NROOT,ISPACE,ICNVEOM,MAXITEOM
C
      NO    = NCCOCC-NCCFZC
      NU    = NCCTOT-NCCFZV-NCCOCC
      NOA   = NOACT
      NUA   = NUACT
      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
      NU3   = NU*NU*NU
      NOU   = NO*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
      NO2U2 = NO*NO*NU*NU
C
C        OPEN DISK FILES FOR EOM CALCULATIONS
C        NOTE THAT FILE -NHH- WAS ALREADY CREATED DURING THE CCSD STEP
C
      NSTAR=80  ! 17 (FILE NUMBER IN ORIGINAL CODE)
      NC1=81    ! 18
      NC2=82    ! 19
      NHC1=83   ! 20
      NHC2=84   ! 31
      NHH=85    ! 27
      NPP=86    ! 28
      NAX=87    ! 29
      NAXX=88   ! 30
      NDIAG=89  ! 32
C
      LRLE  = NOU+NO2U2
      LNOU  = NOU
      LNO2U2= NO2U2
      LNU3  = NU3
C
      CALL CCOPEN(NSTAR,LRLE  ,'EOMSTAR')
      CALL CCOPEN(NC1  ,LNOU  ,'EOMVEC1')
      CALL CCOPEN(NC2  ,LNO2U2,'EOMVEC2')
      CALL CCOPEN(NHC1 ,LNOU  ,'EOMHC1')
      CALL CCOPEN(NHC2 ,LNO2U2,'EOMHC2')
      CALL CCOPEN(NPP  ,LNU3  ,'EOMPPPP')
      CALL CCOPEN(NAX  ,LRLE  ,'EOMRAMP')
      CALL CCOPEN(NAXX ,LRLE  ,'EOMRTMP')
      CALL CCOPEN(NDIAG,LRLE  ,'EOMDG12')
C
C        FILES FOR METHOD OF MOMENTS TRIPLES CORRECTIONS
C        ORIGINAL FILE NUMBERS SHOWN.
C
      IF(CCTYP.EQ.CREOM  .OR.  CCTYP.EQ.CRCCL) THEN
         ITAPP=90  ! 44
         IFAX =91  ! 49
         LAPP = MAX(2*NU*NU,2*NO*NO)
         LAX3 = MAX(2*NOU2,2*NO2U)
         CALL CCOPEN(ITAPP,LAPP  ,'MMPP')
         CALL CCOPEN(IFAX ,LAX3  ,'MMHPP')
      END IF
C 27/05/2004 LEFT EOMSD ------------------
      NL1=95
      NL2=96
      NNAXL=97
      NHL1=98
      NHL2=99
      CALL CCOPEN(NL1  ,LNOU  ,'EOMVL1')
      CALL CCOPEN(NL2  ,LNO2U2,'EOMVL2')
      CALL CCOPEN(NNAXL,LRLE  ,'EOMLVEC')
      CALL CCOPEN(NHL1 ,LNOU  ,'EOMHL1')
      CALL CCOPEN(NHL2 ,LNO2U2,'EOMHL2')
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(X(LEH),X(LEP),X(LAST),NUM,NO,NU,NCCFZC)
      CALL RETFM(NEED)
C
C        CARRY OUT THE EOM-CCSD CALCULATION
C
      CALL DREOMCC(NO,NU,X(LEH),X(LEP),INISTART,ECCSD,BESTEOM,CCTYP)
      CALL RETFM(NDEIG)
      WRITE(IW,*) '..... DONE WITH EOM-CCSD .....'
      CALL TIMIT(1)
C
C        CARRY OUT THE OPTIONAL TRIPLES CORRECTIONS
C
      IF(CCTYP.EQ.CREOM  .OR.  CCTYP.EQ.CRCCL) THEN
         WRITE(IW,9020)
         CALL MMDRV(ESCF,ECCSD,BESTEOM)
         WRITE(IW,9030)
         CALL TIMIT(1)
      END IF
      RETURN
C
 9010 FORMAT(/5X,26(1H-)/5X,'EQUATION-OF-MOTION PROGRAM'/5X,26(1H-)//
     *        5X,55(1H-)/5X,
     *    'K.KOWALSKI, P.PIECUCH, M.WLOCH, S.A.KUCHARSKI, M.MUSIAL'/
     *        5X,55(1H-)//
     *        1X,'CARRYING OUT ',A8,' CALCULATION.')
 9011 FORMAT(/5X,26(1H-)/5X,'EQUATION-OF-MOTION PROGRAM'/5X,26(1H-)//
     *        5X,55(1H-)/5X,
     *    'K.KOWALSKI, M.WLOCH, P.PIECUCH, S.A.KUCHARSKI, M.MUSIAL'/
     *        5X,55(1H-)//
     *        1X,'CARRYING OUT ',A8,' CALCULATION.')
 9020 FORMAT(/1X,'EOM-CCSD HAS FINISHED,',
     *          ' NOW ENTERING THE MMCC23 PROGRAM'/
     *       1X,'TO COMPUTE CR-EOMCCSD(T) AND/OR CR-CC(2,3)',
     *           ' TRIPLES CORRECTIONS')
 9030 FORMAT(/1X,'.... DONE WITH MMCC(2,3) TRIPLES CORRECTIONS ....')
      END
C*MODULE EOMCC   *DECK EOMEIG
      SUBROUTINE EOMEIG(EH,EP,EIG,NUM,NO,NU,NFZC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION EH(NO),EP(NU),EIG(NUM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
C        OBTAIN OCCUPIED AND VIRTUAL ORBITAL EIGENVALUES
C
      CALL DAREAD(IDAF,IODA,EIG,NUM,17,0)
      CALL DCOPY(NO,EIG(NFZC   +1),1,EH,1)
      CALL DCOPY(NU,EIG(NFZC+NO+1),1,EP,1)
      RETURN
      END
C*MODULE EOMCC   *DECK DREOMCC
      SUBROUTINE DREOMCC(NO,NU,EH,EP,INISTART,ECCSD,BESTEOM,CCTYP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DOUBLE PRECISION LITTLED,LITTLESD
C
      DIMENSION EH(NO),EP(NU)
C
      CHARACTER*1 JOBVL,JOBVR,SMALLS,SMALLD
      CHARACTER*3 VECREP,REP,GR
      CHARACTER*8 C8TMP
      CHARACTER*21 ZZKKCONV
C
      LOGICAL DBUG,SAVDEN,ABELPT
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                MXCCIT,MXRLEIT,NWRDCC,ICCCNV,ICCRST,IDSKCC
      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
      COMMON /EOMFIL/ NSTAR,NC1,NC2,NHC1,NHC2,NHH,NPP,NAX,NAXX,NDIAG,
     *                ITAPP,IFAX,NRR1,NRR2,NEXM,NEXE,NW2C,NW4C,
     *                NW4D,NW2BD,NW4B,NROO,NREXM,NREXE,
     *                JCISD,KCIF,JCISDNX
      COMMON /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         NOTE: MM23.SRC HAS AN EXPLANATION OF THE CONTENTS OF /EOMWFE/
      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 / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /XYZPRP/ XP,YP,ZP,
     *                DMX,DMY,DMZ,
     *                QXX,QYY,QZZ,QXY,QXZ,QYZ,
     *                QMXX,QMYY,QMZZ,QMXY,QMXZ,QMYZ,
     *                OXXX,OXXY,OXXZ,OXYY,OYYY,OYYZ,
     *                OXZZ,OYZZ,OZZZ,OXYZ,
     *                OMXXX,OMXXY,OMXXZ,OMXYY,OMYYY,
     *                OMYYZ,OMXZZ,OMYZZ,OMZZZ,OMXYZ
C
      DATA FEV/27.2113957D+00/,ELC/-1.0D+00/
      DATA CIBIGS/8HCIS     /
      DATA  CHECK/8HCHECK   /
      DATA CRCCL/8HCR-CCL   /
      DATA EOMCC/8HEOM-CCSD/
C
C        LOWER CASE D IS 100 IN ASCII COLLATING SEQUENCE
C        LOWER CASE S IS 115 IN ASCII COLLATING SEQUENCE
C
      SMALLD=CHAR(100)
      SMALLS=CHAR(115)
C
      C8TMP='EOMCCS'//SMALLD//' '
      READ(UNIT=C8TMP,FMT='(A8)') LITTLED
      C8TMP='EOMCC'//SMALLS//SMALLD//' '
      READ(UNIT=C8TMP,FMT='(A8)') LITTLESD
      C8TMP='CI'//SMALLS//'     '
      READ(UNIT=C8TMP,FMT='(A8)') CILITS
C
      NO2   = NO*NO
      NO3   = NO*NO*NO
      NO4   = NO*NO*NO*NO
      NU2   = NU*NU
      NU3   = NU*NU*NU
      NOU   = NO*NU
      NOU2  = NO*NU*NU
      NOU3  = NO*NU*NU*NU
      NO2U  = NO*NO*NU
      NO3U  = NO*NO*NO*NU
      NO2U2 = NO*NO*NU*NU
C
C         CARRY OUT ONE PART OF THE STANDARD TRIPLES CORRECTION
C         FOR THE GROUND STATE.
C
      CALL DRINTRI(NO,NU,1)
C
C         MEMORY ALLOCATION FOR ???STEPNAME???
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1   = LOADFM+1
      I2   = I1    + NOU                     ! O1
      I3   = I2    + MAX(NOU,NOU2,NO3,NU3)   ! TI
      I4   = I3    + NO2U2                   ! VOE
      LAST = I4    + MAX(NO3U,NOU3)          ! VE
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9090) '      WDEX',NEED,NGOTMX
      CALL FLSHBF(IW)
C
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK)
     *    CALL WDEX(NO,NU,X(I1),X(I2),X(I3),X(I4))
      CALL RETFM(NEED)
C
C         MEMORY ALLOCATION FOR ???STEPNAME???
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      I2   = I1     + NOU
      I3   = I2     + MAX(NU3,NO3,NOU2)
      I4   = I3     + NO2U2
      I5   = I4     + NO2U2
      I6   = I5     + MAX(NOU3,NO3U,NO2U2)
      LAST = I6     + MAX(NU3,NO2U2)
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9090) '  INTQUAT2',NEED,NGOTMX
      CALL FLSHBF(IW)
C
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK)
     *    CALL INTQUAT2(NO,NU,X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),NOU)
      CALL RETFM(NEED)
C
C          WRITE A NULL RECORD ON SOME DISK FILE
C
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1
      LAST = I1     + NO2U2
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK) THEN
         CALL ZEROMA(X(I1),1,NO2U2)
         CALL WCCFL(NC2,1,NO2U2,X(I1))
      END IF
      CALL RETFM(NEED)
C
C       ----- PREPARE AMPLITUDE GUESS -----
C       INISTART.EQ.1: MEMORY ALLOCATION FOR EOMCCSD
C       INISTART.EQ.2: MEMORY ALLOCATION FOR CIS
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
C
      IF(CCTYP.NE.CRCCL) THEN
      WRITE(IW,9010) NO,NU,NOA,NUA
      END IF
C
      GUESS = LITTLED
      IF(INISTART.EQ.2) GUESS=CIBIGS
C
      L1 = NUM
      NOPNU = NO + NU
C
C       THIS SET OF POINTERS IS FOR BIG-S,LITTLE-D (SEE IDIM)
C
      IDIX = NOA*NOA*NUA*NUA
      IDIM = NO*NU+NOA*NOA*NUA*NUA
      IDIM2= IDIM*IDIM
      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     + 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)-INTEGER MATRIX
      I17   = I16    + 4*IDIX     ! IPL2(I16)-INTEGER MATRIX
      I18   = I17    + NOU        ! INDEX1(I17)-INTEGER MATRIX
      LLAB  = I18    + NO2U2      ! INDEX2(I18)-INTEGER MATRIX
      LIACT = LLAB   + L1         ! LABMO
      LISORB= LIACT  + NOPNU      ! LIACTIVE
      LAST  = LISORB + NOPNU      ! LISORB
      NEED = LAST-LOADFM-1
C
      IF(NEED.LE.NGOTMX) THEN
         ISMALLSD = 0
         GO TO 200
      ELSE
         ISMALLSD = 1
         WRITE(IW,9020) GUESS,NEED,NGOTMX
      END IF
C
C       THIS SET OF POINTERS IS FOR LITTLE-S,LITTLE-D (SEE IDIM)
C
      GUESS = LITTLESD
      IF(INISTART.EQ.2) GUESS=CILITS
C
      NOA=1
      NUA=1
      IDIX=NOA*NOA*NUA*NUA
      IDIM=NOA*NUA+NOA*NOA*NUA*NUA
      IDIM2=IDIM*IDIM
      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     + 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/NWDVAR      ! IPL1(I15)-INTEGER MATRIX
      I17   = I16    + 4*IDIX/NWDVAR     ! IPL2(I16)-INTEGER MATRIX
      I18   = I17    + NOU/NWDVAR + 1    ! INDEX1(I17)-INTEGER MATRIX
      LLAB  = I18    + NO2U2/NWDVAR + 1  ! INDEX2(I18)-INTEGER MATRIX
      LIACT = LLAB   + L1         ! LABMO
      LAST  = LIACT  + NOPNU      ! LIACTIVE
      NEED = LAST - LOADFM - 1
C
  200 CONTINUE
      IF(CCTYP.NE.CRCCL) THEN
         WRITE(IW,9030) GUESS,NEED,2*IDIM2
         WRITE(IW,9090) '   EOMINIT',NEED,NGOTMX
         CALL FLSHBF(IW)
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *      CALL EOMINIT(NO,NU,NOA,NUA,
     *                   X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),X(I7),
     *                   X(I8),X(I9),X(I10),X(I11),X(I12),X(I13),
     *                   X(I14),X(I15),X(I16),X(I17),X(I18),
     *                   X(LLAB),X(LIACT),
     *                   EH,EP,INISTART,ISMALLSD,IDIM,L1,NOPNU)
         CALL RETFM(NEED)
C
      ELSE
C               AT LEAST, SET UP THE IRREP SYMMETRY INFORMATION
         WRITE(UNIT=GR,FMT='(A3)') GRPEOM
         IF(.NOT.ABELPT()) GR='C1 '
         CALL REPFIX(IW,GR,REP,IG)
      END IF
C
      IF(CCTYP.EQ.EOMCC) GO TO 300
C
C         MEMORY ALLOCATION FOR ???STEPNAME???
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1       ! T2 AMPLITUDES
      I2   = I1     + NO2U2   ! VHHPP MATRIX ELEMENTS
      I3   = I2     + NO2U2   ! AX HBAR-3BODY-PPH-TYPE
      I4   = I3     + 2*NOU2  ! BX HBAR-3BODY-PHH-TYPE
      I5   = I4     + 2*NO2U  ! AUX. MATRIX TI
      LAST = I5     + NOU2
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9090) '      BAR3',NEED,NGOTMX
      CALL FLSHBF(IW)
C
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK)
     *    CALL BAR3(NO,NU,X(I1),X(I2),X(I3),X(I4),X(I5))
      CALL RETFM(NEED)
C
C         MEMORY ALLOCATION FOR ???STEPNAME???
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1              !APP
      I2   = I1     + 2*NU2          !AHH
      I3   = I2     + 2*NO2          !AHP
      I4   = I3     + 2*NOU          !VPPP
      I5   = I4     + NU3            !VHHHH
      I6   = I5     + NO4            !VHPPH
      I7   = I6     + NO2U2          !FPP
      I8   = I7     + NU2            !FHH
      I9   = I8     + NO2            !AH
      I10  = I9     + NO             !AP
      LAST = I10    + NU
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9090) '     DENR3',NEED,NGOTMX
      CALL FLSHBF(IW)
C
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK)
     *    CALL DENR3(NO,NU,X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),
     *               X(I7),X(I8),X(I9),X(I10),EH,EP)
      CALL RETFM(NEED)
C
C         MEMORY ALLOCATION FOR ???STEPNAME???
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1   = LOADFM + 1        !APP
      I2   = I1     + 2*NU2    !AHH
      I3   = I2     + 2*NO2    !AHP
      I4   = I3     + 2*NOU    !VPPP
      I5   = I4     + NU3      !VHHHH
      I6   = I5     + NO4      !VHPPH
      LAST = I6     + NO2U2
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9090) '    DENCI3',NEED,NGOTMX
      CALL FLSHBF(IW)
C
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK) THEN
         CALL ZEROMA(X(I1),1,NEED)
         CALL DENCI3(NO,NU,X(I1),X(I2),X(I3),X(I4),X(I5),X(I6))
      END IF
      CALL RETFM(NEED)
C
C         MEMORY ALLOCATION FOR ???STEPNAME???
C
  300 CONTINUE
      LTI = MAX(NO2U2,NU3)
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      I1   = LOADFM  + 1
      I2   = I1      + NOU     ! O1
      I3   = I2      + NO2U2   ! T2
      I4   = I3      + NO2U2   ! VE
      LAST = I4      + LTI     ! TI
      NEED = LAST - LOADFM - 1
C
      WRITE(IW,9090) '     EXTIB',NEED,NGOTMX
      CALL FLSHBF(IW)
C
      CALL GETFM(NEED)
      IF(EXETYP.NE.CHECK)
     *    CALL EXTIB(NO,NU,X(I1),X(I2),X(I3),X(I4),EH,EP,LTI,NOU,NO2U2)
      CALL RETFM(NEED)
C
C
C ----------------------------------------
C
C
C
C
C
C
C 27/05/2004 LEFT EOMSD ------------------
C TO MAINTAIN CLEAR FORM OF THE PROGRAM WE RETAIN THE
C OLD EOMCCSD SOLVERS DAVIDSON AND DAVIDSONMR
C
C
C         DAVIDSON SOLVER...ONE ROOT AT A TIME
C
      IF(ISPACE.LT.2.AND.IPROPCC.EQ.0) THEN
         NOUP=NOU+NO2U2
         MEMS1 = NROOT*MAXITEOM
         MEMS2 = MEMS1*MEMS1
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
         CALL VALFM(LOADFM)
         LBAA  = LOADFM + 1
         LAS   = LBAA   + MEMS1
         LR    = LAS    + MEMS2
         LASTS = LR     + MEMS2
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
         I1    = LASTS + 1
         I2    = I1    + MAX(NOUP,MEMS2)     ! T2
         I3    = I2    +     NOUP            ! TI
         I4    = I3    + MAX(NOUP,MEMS2)     ! T1
         LASTI = I4    +     NOUP            ! EV
C
         J1    = LASTS + 1
         J2    = J1    + NO2U2   ! C
         J3    = J2    + NO2U2   ! HC
         J4    = J3    + NU3     ! TEMPI
         J5    = J4    + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
         J6    = J5    + NOU     ! C13BDY
         J7    = J6    + NU2     ! FP3BDY
         J8    = J7    + NO2U2   ! T23BDY
         LASTJ = J8    + NO2U2   ! VOE3BDY
C
         LAST = MAX(LASTI,LASTJ)
         NEED = LAST-LOADFM-1
C
         WRITE(IW,9090) '  DAVIDSON',NEED,NGOTMX
         CALL FLSHBF(IW)
C
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *      CALL DAVIDSON(IW,ECCSD,BESTEOM,NO,NU,
     *                    X(I1),X(I2),X(I3),X(I4),
     *                    X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
     *                    X(J7),X(J8),NOU,NU2,NU3,NO2U2,EH,EP,
     *                    X(LBAA),X(LAS),X(LR),MEMS1,MEMS2)
         CALL RETFM(NEED)
      END IF
C
C        NAKATSUJI SOLVER...SIMULTANEOUS ROOT SOLUTION
C
      IF(ISPACE.GT.2.AND.IPROPCC.EQ.0) THEN
         WRITE(6,*) ' '
         WRITE(6,*) 'MEOM CAN ONLY HAVE VALUES 0-4,',
     *   ' MEOM=3,4 REQUIRES CHOOSING CCPRPE=.TRUE.'
         WRITE(6,*) ' '
         CALL ABRT
      END IF
C
C         LEFT EOMCCSD
C
      IF(ISPACE.EQ.2.AND.IPROPCC.EQ.0) THEN
C
         NOUP=NOU+NO2U2
         MEMS0 = MAX(MAXITEOM,NROOT)
         MEMS1 = NROOT*MEMS0
         MEMS2 = MEMS1*MEMS1
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
         CALL VALFM(LOADFM)
         LBAA   = LOADFM + 1
         LAS    = LBAA   + MEMS1
         LR     = LAS    + MEMS2
         LAA    = LR     + MEMS2
         LEVAL  = LAA    + MEMS0
         LRES   = LEVAL  + MEMS0
         LEXCON = LRES   + MEMS0
         LR0CON = LEXCON + MEMS0
         LASTS  = LR0CON + MEMS0
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
         I1     = LASTS  + 1
         I2     = I1     + MAX(NOUP*NROOT,MEMS2)    ! T2
         I3     = I2     +     NOUP*NROOT           ! TI
         I4     = I3     + MAX(NOUP*NROOT,MEMS2)    ! T1
         I5     = I4     +     NOUP*NROOT           ! EV
         I6     = I5     +     NOUP                 ! TMP
         LASTI  = I6     +     NOUP                 ! T2AUX
C
         J1     = LASTS  + 1
         J2     = J1     + NO2U2   ! C
         J3     = J2     + NO2U2   ! HC
         J4     = J3     + NU3     ! TEMPI
         J5     = J4     + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
         J6     = J5     + NOU     ! C13BDY
         J7     = J6     + NU2     ! FP3BDY
         J8     = J7     + NO2U2   ! T23BDY
         LASTJ  = J8     + NO2U2   ! VOE3BDY
C
         LAST = MAX(LASTI,LASTJ)
         NEED = LAST-LOADFM-1
C
         WRITE(IW,9090) 'DAVIDSONMR',NEED,NGOTMX
         CALL FLSHBF(IW)
C
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *      CALL DAVIDSONMR(IW,ECCSD,BESTEOM,
     *                      NO,NU,NOUP,NOU,NU2,NU3,NO2U2,
     *                      X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),
     *                      X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
     *                      X(J7),X(J8),EH,EP,MEMS0,MEMS1,MEMS2,
     *                      X(LR),X(LAS),X(LBAA),X(LAA),X(LEVAL),
     *                      X(LRES),X(LEXCON),X(LR0CON))
         CALL RETFM(NEED)
      END IF
C
C
C
C ########### CCSD/EOMCCSD PROPERTIES #########
C 27/05/2004 LEFT EOMSD ------------------
C     IF PROPERTIES ARE NOT REQUIRED
C     EOMCCSD PART STOPS HERE
      IF(IPROPCC.EQ.0) RETURN
C
C
C
C
C
C
C ELECTRICAL DIPOLES AND LAMBDA VECTORS
C
C
C
C     MWS: THE AO DIPOLE INTEGRALS BELOW ARE EVALUATED AT THE
C          COORDINATE ORIGIN, AS OPPOSED TO THE CENTER OF MASS.
C     THIS IS WHAT OTHER TRANSITION DIPOLE CODES IN GAMESS DO,
C     BUT DOES MEAN THAT STATE SPECIFIC DIPOLES OF CHARGED
C     SPECIES WILL PRINT A DIFFERENT VECTOR THAN THE NORMAL
C     PROPERTY PACKAGE WHICH DOES THE DIPOLE TERM WITH RESPECT
C     TO THE CENTER OF MASS.
C
      ZERO=0.0D+00
      DBUG=.FALSE.
      CALL DIPINT(ZERO,ZERO,ZERO,DBUG)
C
C ### <PHI|(1+LAMBDA)H_{BAR} = 0
C DEC12/2003
C
C
CCCX      IF(IPROPCCG.EQ.777) THEN
CCCX         NOUP=NOU+NO2U2
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
CCCX         CALL VALFM(LOADFM)
CCCX         LASTS = LOADFM    !
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
CCCX
CCCX
CCCX         I1    = LASTS + 1
CCCX         I2    = I1    + NOUP            ! T2
CCCX         I3    = I2    + MAX(NOUP,NU3)   ! TI
CCCX         I4    = I3    + NOUP            ! T1
CCCX         LASTI = I4    + NOUP            ! EV
C
CCCX         J1    = LASTS + 1
CCCX         J2    = J1    + NO2U2   ! C
CCCX         J3    = J2    + NO2U2   ! HC
CCCC         J4    = J3    + NU3     ! TEMPI
CCCX         J4    = J3    + MAX(NU3,NOUP)     ! TEMPI
CCCX         J5    = J4    + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
CCCX         J6    = J5    + NOU     ! C13BDY
CCCX         J7    = J6    + NU2     ! FP3BDY
CCCX         J8    = J7    + NO2U2   ! T23BDY
CCCX         LASTJ = J8    + NO2U2   ! VOE3BDY
C
CCCX         LAST = MAX(LASTI,LASTJ)
CCCX         NEED = LAST-LOADFM-1
C
CCCX         WRITE(IW,9090) 'LAMBDA-VEC',NEED,NGOTMX
CCCX         CALL FLSHBF(IW)
C
CCCX         CALL GETFM(NEED)
CCCX         IF(EXETYP.NE.CHECK)
CCCX     *     CALL LAMBDAV(IW,NO,NU,X(I1),X(I2),
CCCX     *                 X(I3),X(I4),
CCCX     *                 X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
CCCX     *                 X(J7),X(J8),NOU,NU2,NU3,NO2U2,EH,EP)
CCCX         CALL RETFM(NEED)
CCCX      END IF
C
C ### <PHI|(1+LAMBDA)H_{BAR} = 0
C DEC12/2003
C
C       GET LAMBDA VECTOR (LEFT EIGENSTATE) FOR THE GROUND STATE CCSD
C
      IF(IPROPCC.EQ.1) THEN
         NOUP=NOU+NO2U2
         MEMS1=MXRLE     !ONE CAN CHANGE IT
         MEMS2=MEMS1*MEMS1
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
         CALL VALFM(LOADFM)
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
         LMA    = LOADFM + 1
         LMAUX  = LMA    + MEMS2   !MATRIX TO BE DIAGONALIZED
         LFV    = LMAUX  + MEMS2   !AUXILIARY MATRIX
         LFVAUX = LFV    + MEMS1   !FREE VEC.
         LVR    = LFVAUX + MEMS1   !
         LASTS  = LVR    + MEMS1   !INT. VEC.
C
         I1    = LASTS + 1
         I2    = I1    + NOUP            ! T2
         I3    = I2    + MAX(NOUP,NU3)   ! TI
         I4    = I3    + NOUP            ! T1
         LASTI = I4    + NOUP            ! EV
C
         J1    = LASTS + 1
         J1    = LASTI+1
         J2    = J1    + NO2U2   ! C
         J3    = J2    + NO2U2   ! HC
         J4    = J3    + NU3     ! TEMPI
         J5    = J4    + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
         J6    = J5    + NOU     ! C13BDY
         J7    = J6    + NU2     ! FP3BDY
         J8    = J7    + NO2U2   ! T23BDY
         LASTJ = J8    + NO2U2   ! VOE3BDY
C
         LAST = MAX(LASTI,LASTJ)
         NEED = LAST-LOADFM-1
C
         WRITE(IW,9090) '  LAMBDIIS',NEED,NGOTMX
         CALL FLSHBF(IW)
C
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *     CALL LAMBDIIS(IW,NO,NU,MEMS1,MEMS2,
     *                 X(LMA),X(LMAUX),X(LFV),X(LFVAUX),X(LVR),
     *                 X(I1),X(I2),X(I3),X(I4),
     *                 X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
     *                 X(J7),X(J8),NOU,NU2,NU3,NO2U2,EH,EP)
         CALL RETFM(NEED)
      END IF
C ________________________________________
C
C         DAVIDSON SOLVER...ONE ROOT AT A TIME
C
      IF(IPROPCC.EQ.1.AND.ISPACE.LT.2)
     *  THEN
         NOUP=NOU+NO2U2
         MEMS1 = NROOT*MAXITEOM
         MEMS2 = MEMS1*MEMS1
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
         CALL VALFM(LOADFM)
         LBAA  = LOADFM + 1
         LAS   = LBAA   + MEMS1
         LR    = LAS    + MEMS2
         LASTS = LR     + MEMS2
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
         I1    = LASTS + 1
         I2    = I1    + MAX(NOUP,MEMS2)     ! T2
         I3    = I2    +     NOUP            ! TI
         I4    = I3    + MAX(NOUP,MEMS2)     ! T1
         LASTI = I4    +     NOUP            ! EV
C
         J1    = LASTS + 1
         J2    = J1    + NO2U2   ! C
         J3    = J2    + NO2U2   ! HC
         J4    = J3    + NU3     ! TEMPI
         J5    = J4    + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
         J6    = J5    + NOU     ! C13BDY
         J7    = J6    + NU2     ! FP3BDY
         J8    = J7    + NO2U2   ! T23BDY
         LASTJ = J8    + NO2U2   ! VOE3BDY
C
         LAST = MAX(LASTI,LASTJ)
         NEED = LAST-LOADFM-1
C
         WRITE(IW,9090) '     DAVPR',NEED,NGOTMX
         CALL FLSHBF(IW)
C
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *      CALL DAVPR(IW,ECCSD,BESTEOM,NO,NU,
     *                    X(I1),X(I2),X(I3),X(I4),
     *                    X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
     *                    X(J7),X(J8),NOU,NU2,NU3,NO2U2,EH,EP,
     *                    X(LBAA),X(LAS),X(LR),MEMS1,MEMS2)
         CALL RETFM(NEED)
      END IF
C
C        NAKATSUJI SOLVER...SIMULTANEOUS ROOT SOLUTION
C
      IF(IPROPCC.EQ.1.AND.ISPACE.EQ.2) THEN
         NOUP=NOU+NO2U2
         MEMS0 = MAX(MAXITEOM,NROOT)
         MEMS1 = NROOT*MEMS0
         MEMS2 = MEMS1*MEMS1
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
         CALL VALFM(LOADFM)
         LBAA   = LOADFM + 1
         LAS    = LBAA   + MEMS1
         LR     = LAS    + MEMS2
         LAA    = LR     + MEMS2
         LEVAL  = LAA    + MEMS0
         LRES   = LEVAL  + MEMS0
         LEXCON = LRES   + MEMS0
         LR0CON = LEXCON + MEMS0
         LASTS  = LR0CON + MEMS0
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
         I1     = LASTS  + 1
         I2     = I1     + MAX(NOUP*NROOT,MEMS2)    ! T2
         I3     = I2     +     NOUP*NROOT           ! TI
         I4     = I3     + MAX(NOUP*NROOT,MEMS2)    ! T1
         I5     = I4     +     NOUP*NROOT           ! EV
         I6     = I5     +     NOUP                 ! TMP
         LASTI  = I6     +     NOUP                 ! T2AUX
C
         J1     = LASTS  + 1
         J2     = J1     + NO2U2   ! C
         J3     = J2     + NO2U2   ! HC
         J4     = J3     + NU3     ! TEMPI
         J5     = J4     + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
         J6     = J5     + NOU     ! C13BDY
         J7     = J6     + NU2     ! FP3BDY
         J8     = J7     + NO2U2   ! T23BDY
         LASTJ  = J8     + NO2U2   ! VOE3BDY
C
         LAST = MAX(LASTI,LASTJ)
         NEED = LAST-LOADFM-1
C
         WRITE(IW,9090) '   DAVPRMR',NEED,NGOTMX
         CALL FLSHBF(IW)
C
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *      CALL DAVMRPR(IW,ECCSD,BESTEOM,
     *                      NO,NU,NOUP,NOU,NU2,NU3,NO2U2,
     *                      X(I1),X(I2),X(I3),X(I4),X(I5),X(I6),
     *                      X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
     *                      X(J7),X(J8),EH,EP,MEMS0,MEMS1,MEMS2,
     *                      X(LR),X(LAS),X(LBAA),X(LAA),X(LEVAL),
     *                      X(LRES),X(LEXCON),X(LR0CON))
         CALL RETFM(NEED)
      END IF
C
C 27/05/2004 LEFT EOMSD ------------------
C ### NAKATSUJI SOLVER FOR LEFT AND RIGHT EIGENVECTOR
C DEC12/2003
C
      IF(IPROPCC.EQ.1.AND.ISPACE.GE.3.AND.IPROPCCE.EQ.0) THEN
         WRITE(6,*) ' '
         WRITE(6,*) 'MEOM CAN ONLY HAVE VALUES 0-4,',
     *   ' MEOM=3,4 REQUIRES CHOOSING CCPRPE=.TRUE.'
         WRITE(6,*) ' '
         CALL ABRT
      END IF
C
      IF(IPROPCC.EQ.1.AND.ISPACE.GE.5.AND.IPROPCCE.EQ.1) THEN
         WRITE(6,*) ' '
         WRITE(6,*) 'MEOM CAN ONLY HAVE VALUES 0-4,',
     *   ' MEOM=3,4 REQUIRES CHOOSING CCPRPE=.TRUE.'
         WRITE(6,*) ' '
         CALL ABRT
      END IF
C
      IF(IPROPCC.EQ.1.AND.ISPACE.EQ.3.AND.IPROPCCE.EQ.1) THEN
         NOUP=NOU+NO2U2
         MEMS1 = NROOT*MAXITEOM
         MEMS2 = MEMS1*MEMS1
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
         CALL VALFM(LOADFM)
         LWR   = LOADFM + 1
         LWI   = LWR   + MEMS1   !WR
         LWORK = LWI   + MEMS1   !WI
         LVR   = LWORK + 4*MEMS1 !LWORK
         LVL   = LVR   + MEMS2   !VR
         LMAT  = LVL   + MEMS2   !VL
         LRAUX = LMAT  + MEMS2   !MATRIX TO BE DIAGONALIZED
         LASTS = LRAUX + MEMS2   !AUXILIARY MATRIX R
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
         I1    = LASTS + 1
         I2    = I1    + MAX(NOUP,MEMS2)     ! T2
         I3    = I2    +     NOUP            ! TI
         I4    = I3    + MAX(NOUP,MEMS2)     ! T1
         I5    = I4    +     NOUP            ! EV
         LASTI = I5    +     NOUP            ! EVV
C
         J1    = LASTS + 1
         J2    = J1    + NO2U2   ! C
         J3    = J2    + NO2U2   ! HC
         J4    = J3    + NU3     ! TEMPI
         J5    = J4    + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
         J6    = J5    + NOU     ! C13BDY
         J7    = J6    + NU2     ! FP3BDY
         J8    = J7    + NO2U2   ! T23BDY
         LASTJ = J8    + NO2U2   ! VOE3BDY
C
         LAST = MAX(LASTI,LASTJ)
         NEED = LAST-LOADFM-1
C
         WRITE(IW,9090) 'DAVIDSONRL',NEED,NGOTMX
         CALL FLSHBF(IW)
C
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *     CALL DAVIDSONRL(IW,ECCSD,BESTEOM,NO,NU,
     *                 X(I1),X(I2),X(I3),X(I4),X(I5),
     *                 X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
     *                 X(J7),X(J8),NOU,NU2,NU3,NO2U2,EH,EP,
     *                 X(LWR),X(LWI),X(LWORK),X(LVR),X(LVL),
     *                 X(LMAT),X(LRAUX),MEMS1,MEMS2)
         CALL RETFM(NEED)
      END IF
C
C
C
C
C ### NAKATSUJI SOLVER FOR LEFT AND RIGHT EIGENVECTOR
C DEC12/2003
C
C
      IF(IPROPCC.EQ.1.AND.ISPACE.EQ.4.AND.IPROPCCE.EQ.1) THEN
         NOUP=NOU+NO2U2
         MEMS1 = NROOT*MAXITEOM
         MEMS2 = MEMS1*MEMS1
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
         CALL VALFM(LOADFM)
         LWR   = LOADFM + 1
         LWI   = LWR   + MEMS1   !WR
         LWORK = LWI   + MEMS1   !WI
         LVR   = LWORK + 4*MEMS1 !LWORK
         LVL   = LVR   + MEMS2   !VR
         LMAT  = LVL   + MEMS2   !VL
         LRAUX = LMAT  + MEMS2   !MATRIX TO BE DIAGONALIZED
         LASTS = LRAUX + MEMS2   !AUXILIARY MATRIX R
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
         I1    = LASTS + 1
         I2    = I1    + MAX(NOUP,MEMS2)     ! T2
         I3    = I2    +     NOUP            ! TI
         I4    = I3    + MAX(NOUP,MEMS2)     ! T1
         I5    = I4    +     NOUP            ! EV
         LASTI = I5    +     NOUP            ! EVV
C
         J1    = LASTS + 1
         J2    = J1    + NO2U2   ! C
         J3    = J2    + NO2U2   ! HC
         J4    = J3    + NU3     ! TEMPI
         J5    = J4    + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
         J6    = J5    + NOU     ! C13BDY
         J7    = J6    + NU2     ! FP3BDY
         J8    = J7    + NO2U2   ! T23BDY
         LASTJ = J8    + NO2U2   ! VOE3BDY
C
         LAST = MAX(LASTI,LASTJ)
         NEED = LAST-LOADFM-1
C
         WRITE(IW,9090) 'DAVIDSNRLN',NEED,NGOTMX
         CALL FLSHBF(IW)
C
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *     CALL DAVIDSNRLN(IW,ECCSD,BESTEOM,NO,NU,
     *                 X(I1),X(I2),X(I3),X(I4),X(I5),
     *                 X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
     *                 X(J7),X(J8),NOU,NU2,NU3,NO2U2,EH,EP,
     *                 X(LWR),X(LWI),X(LWORK),X(LVR),X(LVL),
     *                 X(LMAT),X(LRAUX),MEMS1,MEMS2)
         CALL RETFM(NEED)
      END IF
C
C DEC12/2003 LEFT-RIGHT EIGENVECTORS
C
      IF(IPROPCC.EQ.1.AND.ISPACE.LE.2.AND.IPROPCCE.EQ.1) THEN
         NOUP=NOU+NO2U2
!!!         MEMS1=MXRLE     !MOZNA TO ZMIENIC
         MEMS1 = MAXITEOM
         MEMS2=MEMS1*MEMS1
C
C                             SOLVER MEMORY.
C           SOME TEMPORARY SOLVER STORAGE OVERLAPS OTHER DATA BELOW
C
          CALL VALFM(LOADFM)
C
C           NOTE OVERLAPPING USE OF STORAGE HERE, -I- AND -J- POINTERS
C
         LMA    = LOADFM + 1
         LMAUX  = LMA    + MEMS2   !MATRIX TO BE DIAGONALIZED
         LFV    = LMAUX  + MEMS2   !AUXILIARY MATRIX
         LFVAUX = LFV    + MEMS1   !FREE VEC.
         IWR    = LFVAUX + MEMS1   !FREE AUX. VEC.
         IWI    = IWR    + MEMS1   !WR
         IWORK  = IWI    + MEMS1   !WL
         IVL    = IWORK  + 4*MEMS1 !WORK
         IVR    = IVL    + MEMS2   !VL MATRIX
         LASTS  = IVR    + MEMS2   !VR MATRIX
C
         I1    = LASTS + 1
         I2    = I1    + NOUP            ! T2
         I3    = I2    + MAX(NOUP,NU3)   ! TI
         I4    = I3    + NOUP            ! T1
         LASTI = I4    + NOUP            ! EV
C
         J1    = LASTS + 1
         J2    = J1    + NO2U2   ! C
         J3    = J2    + NO2U2   ! HC
         J4    = J3    + NU3     ! TEMPI
         J5    = J4    + MAX(NO4,NO3U,NO2U2,NOU3,NU3)  ! WORK ARRAYS
         J6    = J5    + NOU     ! C13BDY
         J7    = J6    + NU2     ! FP3BDY
         J8    = J7    + NO2U2   ! T23BDY
         LASTJ = J8    + NO2U2   ! VOE3BDY
C
         LAST = MAX(LASTI,LASTJ)
         NEED = LAST-LOADFM-1
C
         WRITE(IW,9090) ' LEFTDIISH',NEED,NGOTMX
         CALL FLSHBF(IW)
C
         CALL GETFM(NEED)
         IF(EXETYP.NE.CHECK)
     *     CALL LEFTDIISH(IW,NO,NU,MEMS1,MEMS2,
     *                 X(LMA),X(LMAUX),X(LFV),X(LFVAUX),
     *                 X(IWR),X(IWI),X(IWORK),X(IVL),X(IVR),
     *                 X(I1),X(I2),X(I3),X(I4),
     *                 X(J1),X(J2),X(J3),X(J4),X(J5),X(J6),
     *                 X(J7),X(J8),NOU,NU2,NU3,NO2U2,EH,EP)
         CALL RETFM(NEED)
      END IF
C
C        ---- DIPOLE/TRANSITION DIPOLE EVALUATION -----
C         (THIS BLOCK TERMINATES NEAR END OF ROUTINE)
C
      IF(IPROPCC.EQ.1) THEN
C
      NOUP=NOU+NO2U2
      TWO3=(2.0D+00)/(3.0D+00)
C
C ALL NUCLEAR CONTRIBUTIONS TO DIPOLE MOMENT
C
      DMXNU=0.0D+00
      DMYNU=0.0D+00
      DMZNU=0.0D+00
      CHARGE=0.0D+00
      DO 280  I=1,NAT
         ZNUC = ZAN(I)
         CHARGE = CHARGE + ZNUC
         XN = C(1,I) - XP
         YN = C(2,I) - YP
         ZN = C(3,I) - ZP
         DMXNU = DMXNU + ZNUC*XN
         DMYNU = DMYNU + ZNUC*YN
         DMZNU = DMZNU + ZNUC*ZN
 280  CONTINUE
C
      L1 = NUM
      M1 = NQMT
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
      M2 = (M1*M1+M1)/2
      NCCACT = NO+NU
      NCCMO  = NCCFZC + NCCACT
C
      CALL VALFM(LOADFM)
      LGOO    = LOADFM  + 1
      LGUU    = LGOO    + NO2
      LGOU    = LGUU    + NU2
      LGALL   = LGOU    + NOU
      LLA     = LGALL   + NCCACT*NCCACT
      LRA     = LLA     + NOUP
      LTA     = LRA     + NOUP
      LAU     = LTA     + NOUP
      LTI     = LAU     + NOUP
      ILDIPM1 = LTI     + NU3
      ILDIPM2 = ILDIPM1 + M2
      ILDIPM3 = ILDIPM2 + M2
      ILWRK   = ILDIPM3 + M2
      ILAO    = ILWRK   + L1
      ILVEC   = ILAO    + L2
      IWRD    = ILVEC   + L3
      IWID    = IWRD    + NCCACT
      IVRD    = IWID    + NCCACT
      IWORKD  = IVRD    + NCCACT*NCCACT
      LTOTD   = IWORKD  + 4*NCCACT
      LAODEN  = LTOTD   + NCCACT*NCCACT
      LAOSYM  = LAODEN  + L3
      LVEC    = LAOSYM  + L2
      LWORK   = LVEC    + L3
      ILASTDI = LWORK   + L1*NCCACT
      NEED = ILASTDI-LOADFM-1
      WRITE(IW,9090) 'D.M. CALC.',NEED,NGOTMX
      CALL FLSHBF(IW)
      CALL GETFM(NEED)
C
      IREADM=0
      ISY=0
      WRITE(IP,9065)
C
C LOOP OVER PAIRS OF STATES, GENERATING ONE-BODY DENSITY MATRIX .
C
      DO 500 ISTATE1=0,NROOT
         IF(NROOT.EQ.0) IMAX2L=0
         IF(NROOT.GT.0) IMAX2L=ISTATE1
         IF(ISTATE1.EQ.0) THEN
            IVAR  = 0
            ILE   = 0
            IRE   = 0
            IMAXM = 1
         ELSE
            JGO=IUST(ISTATE1)
            IF(KKTRIM(JGO).EQ.1.AND.KKTRIML(JGO).EQ.1) THEN
               ZZKKCONV='EOMCCSD     CONVERGED'
            ELSE
               GO TO 500
            END IF
            IVAR  = 0
            IMAXM = 2
         END IF
C
         IF(ISTATE1.EQ.0) THEN
            WRITE(IW,9046)
            WRITE(IW,9047)
         ELSE
            WRITE(IW,9048)
            WRITE(IW,9049) XKKEOM(JGO)*FEV,ZZKKCONV
            WRITE(IW,9069) VECREP(JGO)
            WRITE(IW,9047)
         END IF
C
         DO 501 ISTATE2=0,IMAX2L
            IF(ISTATE2.GT.0) THEN
               JGO2=IUST(ISTATE2)
               IF(KKTRIM(JGO2).NE.1.OR.KKTRIML(JGO2).NE.1) GO TO 501
            ELSE
               IF(LAMCON.NE.1) GO TO 501
               JGO2=0
            END IF
            DO 502 IIMOM=1,IMAXM
               IF(ISTATE1.EQ.ISTATE2.AND.IIMOM.EQ.2) GO TO 502
               IF(IIMOM.EQ.1.AND.ISTATE1.NE.0) THEN
                  ILE=JGO2
                  IRE=JGO
               END IF
               IF(IIMOM.EQ.2.AND.ISTATE1.NE.0) THEN
                  ILE=JGO
                  IRE=JGO2
               END IF
C
C   GENERATE THE DENSITY MATRIX IN MO BASIS FOR THIS PAIR OF STATES.
C   THE DENSITY IS EXPECTATION VALUE TYPE FOR THE SAME STATES, AND
C   A TRANSITION DENSITY MATRIX IF THE STATES ARE DIFFERENT.
C
               CALL CCDENS1(IVAR,ILE,IRE,NO,NU,
     *                      X(LGOO),X(LGUU),X(LGOU),X(LGALL),
     *                      X(LLA),X(LRA),X(LTA),X(LAU),X(LTI))
C
C   OUTPUT THE DENSITY MATRIX IN THE MO BASIS TO PUNCH FILE
C
               CALL DENS1STO(NO,NU,IRE,ILE,X(LGALL))
C
C   THIS CODE LETS YOU KNOW IF THE DENSITY BEING COMPUTED IS BETWEEN
C   THE SAME LEFT AND RIGHT STATES LABELED ISTATE1 AND ISTATE2, AND
C   IF ITS ENERGY IS TO BE SAVED AS -BESTEOM- ENERGY.  IF SO, SAVE
C   A SYMMETRIZED FORM OF THE DENSITY IN THE AO BASIS FOR PROPERTIES.
C
               SAVDEN=.FALSE.
               IF(ISTATE1.EQ.ISTATE2) THEN
                  IF(ISTATE1.EQ.0) THEN
                     IF(IROOTCC(2).EQ.0) SAVDEN=.TRUE.
                  ELSE
                     IF(VECREP(IUST(ISTATE1)).EQ.REP(IROOTCC(1))) THEN
                        ISY=ISY+1
                        IF(IROOTCC(2).EQ.ISY) SAVDEN = .TRUE.
                     END IF
                  END IF
               END IF
C
               IF(SAVDEN) THEN
                  CALL CCBTDENS(NCCFZC,NCCACT,NCCMO,L1,L2,IROOTCC,
     *                          X(LGALL),X(LTOTD),X(LAODEN),
     *                          X(LAOSYM),X(LVEC),X(LWORK))
               END IF
C
C            TRANSFORM DIPOLE INTEGRALS FROM AO TO MO BASIS
C
               IF(IREADM.EQ.0) THEN
                  CALL MODIPS(L1,L2,M1,M2,X(ILDIPM1),X(ILDIPM2),
     *                        X(ILDIPM3),X(ILWRK),X(ILAO),X(ILVEC))
                  IREADM=1
               END IF
C
C             GENERATE STATE-SPECIFIC OR TRANSITION DIPOLE MOMENTS,
C             STATE-SPECIFIC MUST ADD NUCLEAR TERM AS WELL.
C
         CALL CCMOMDP(IRE,ILE,NO,NU,L2,X(LGALL),X(ILDIPM1),CCMOMX)
         CALL CCMOMDP(IRE,ILE,NO,NU,L2,X(LGALL),X(ILDIPM2),CCMOMY)
         CALL CCMOMDP(IRE,ILE,NO,NU,L2,X(LGALL),X(ILDIPM3),CCMOMZ)
C
               CCMOMX=CCMOMX*ELC
               CCMOMY=CCMOMY*ELC
               CCMOMZ=CCMOMZ*ELC
               IF(ISTATE1.EQ.ISTATE2) THEN
                  CCMOMX=CCMOMX+DMXNU
                  CCMOMY=CCMOMY+DMYNU
                  CCMOMZ=CCMOMZ+DMZNU
               END IF
C
C        OUTPUT OF THE RESULTS
C
               IF(ISTATE1.EQ.ISTATE2.AND.ISTATE1.NE.0) THEN
                   WRITE(IW,9061)
                   WRITE(IW,9050) CCMOMX,CCMOMY,CCMOMZ
                   WRITE(IW,9061)
               END IF
               IF(IIMOM.EQ.1.AND.
     *            ISTATE1.NE.0.AND.ISTATE1.NE.ISTATE2) THEN
                  IF(ISTATE2.EQ.0) THEN
                     WRITE(IW,9060) 0.0D+00*FEV,XKKEOM(JGO)*FEV
                  ELSE
                     WRITE(IW,9060) XKKEOM(JGO2)*FEV,XKKEOM(JGO)*FEV
                  END IF
                  WRITE(IW,9051) CCMOMX,CCMOMY,CCMOMZ
                  RTMOMX=CCMOMX
                  RTMOMY=CCMOMY
                  RTMOMZ=CCMOMZ
               END IF
               IF(IIMOM.EQ.2.AND.
     *            ISTATE1.NE.0.AND.ISTATE1.NE.ISTATE2) THEN
                  WRITE(IW,9052) CCMOMX,CCMOMY,CCMOMZ
                  DIPSTX=CCMOMX*RTMOMX
                  DIPSTY=CCMOMY*RTMOMY
                  DIPSTZ=CCMOMZ*RTMOMZ
                  WRITE(IW,9053) DIPSTX,DIPSTY,DIPSTZ
                  IF(ISTATE2.EQ.0) THEN
                     XDIFFE=XKKEOM(JGO)
                  ELSE
                     XDIFFE=XKKEOM(JGO)-XKKEOM(JGO2)
                  END IF
                  XOSSTX=CCMOMX*RTMOMX*XDIFFE*TWO3
                  XOSSTY=CCMOMY*RTMOMY*XDIFFE*TWO3
                  XOSSTZ=CCMOMZ*RTMOMZ*XDIFFE*TWO3
                  WRITE(IW,9054) XOSSTX,XOSSTY,XOSSTZ
               END IF
C
               IF(ISTATE1.EQ.0) THEN
                  WRITE(IW,9061)
                  WRITE(IW,9055) CCMOMX,CCMOMY,CCMOMZ
                  WRITE(IW,9061)
               END IF
C
C       GENERATE LEFT/RIGHT NATURAL ORBITALS AND THEIR OCCUPATION ARRAY
C
               IF(ILE.EQ.IRE) THEN
                  JOBVL='N'
                  JOBVR='V'
                  LLWORK=4*(NO+NU)
                  CALL DGEEV(JOBVL,JOBVR,NO+NU,X(LGALL),NO+NU,
     *                       X(IWRD),X(IWID),VVVL,NO+NU,X(IVRD),NO+NU,
     *                       X(IWORKD),LLWORK,INFO)
                  IF(INFO.NE.0) WRITE(IW,*) 'DREOMCC: DGEEV DIED',INFO
                  CALL ENAOPRNT(NO,NU,NCCFZC,X(IWRD),X(IWID),X(IVRD),
     *                          X(IWORKD),X(IWORKD+NCCACT))
               END IF
  502       CONTINUE
  501    CONTINUE
  500 CONTINUE
C
      CALL RETFM(NEED)
      CALL FLSHBF(IW)
      CALL FLSHBF(IP)
C
      END IF  ! CLOSES -IPRPCC- BLOCK
C
C BACK TO THE NORMALIZATION ||R1+R2||=1
C
      WRITE(IP,9066)
      CALL BACKNDR(NO,NU)
C ----------------------------------------
C
      RETURN
C
 9010 FORMAT(/1X,'THE ORBITAL RANGES USED BY THE INITIAL AMPLITUDE',
     *          ' GUESS ARE'/
     *       1X,'THE NUMBER OF CORRELATED OCCUPIED ORBITALS=',I6/
     *       1X,'THE NUMBER OF CORRELATED  VIRTUAL ORBITALS=',I6/
     *       1X,'THE NUMBER OF ACTIVE     OCCUPIED ORBITALS=',I6/
     *       1X,'THE NUMBER OF ACTIVE      VIRTUAL ORBITALS=',I6)
 9020 FORMAT(1X,A8,' GUESS WOULD REQUIRE',I10,
     *       ' WORDS, AVAILABLE=',I10)
 9030 FORMAT(/1X,'USING ',A8,' AMPLITUDE INITIAL GUESS, REQUIRING',
     *          I10,' WORDS.'/
     *       1X,'OF THIS,',I10,' WORDS ARE FOR MATRICES HM AND VR.')
 9046 FORMAT(//,20X,'GROUND STATE CCSD PROPERTIES'/
     *          20X,'----------------------------'/)
 9047 FORMAT(26X,' X-COMPONENT',4X,' Y-COMPONENT',4X,' Z-COMPONENT'/
     *       26X,' -----------',4X,' -----------',4X,' -----------')
 9048 FORMAT(//,20X,'EXCITED STATE EOMCCSD PROPERTIES'/
     *       20X,'--------------------------------')
 9049 FORMAT(2X,'EXCIT. ENERGY.= ',F8.3,1X,'EV',3X,A21)
 9069 FORMAT(2X,'SYMMETRY OF THE STATE ',1X,A3/)
 9055 FORMAT(1X,'CCSD     DIPOLE  MOM.  ',F14.9,2X,F14.9,2X,F14.9)
 9050 FORMAT(1X,'EOMCCSD  DIPOLE  MOM.  ',F14.9,2X,F14.9,2X,F14.9)
 9051 FORMAT(/1X,'RIGHT  TRANSITION MOM. ',F13.8,2X,F13.8,2X,F13.8)
 9052 FORMAT(1X,'LEFT   TRANSITION MOM. ',F13.8,2X,F13.8,2X,F13.8)
 9053 FORMAT(1X,'DIPOLE       STRENGTH  ',F13.8,2X,F13.8,2X,F13.8)
 9054 FORMAT(1X,'OSCILLATOR   STRENGTH  ',F13.8,2X,F13.8,2X,F13.8/)
 9060 FORMAT(1X,'TRANSITION: ',F8.3,' EV  ==> ',F8.3,' EV')
 9061 FORMAT(1X,69(1H-))
 9065 FORMAT(//1X,'ONE-BODY CCSD/EOMCCSD DENSITY MATRICES')
 9066 FORMAT(1X,'DONE WITH ONE-BODY CCSD/EOMCCSD DENSITY MATRICES')
 9090 FORMAT(1X,'MEMORY USAGE BY ',A10,':',I10,' NEEDED,',I10,
     *          ' AVAILABLE')
      END
C*MODULE EOMCC   *DECK WDEX
      SUBROUTINE WDEX(NO,NU,O1,TI,VOE,VE)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION O1(*),TI(*),VOE(*),VE(*)
C
C        -O1- IS USED AS NOU
C        -TI- IS USED AS NOU AND NOU2 IN TRT1 AND RO2HPP, AND AS
C             NU3 OR NO3 IN THE TOP OR BOTTOM HALF OF THIS ROUTINE
C        -VE- IS USED AS NOU3 IN TOP HALF AND NO3U IN BOTTOM HALF
C        -VOE- IS USED AS NO2U2 IN BOTH HALVES
C
C        PREPARE I^{AI}_{BC} AND I^{IJ}_{KA} INTERMEDIATES
C
      NOU  = NO*NU
      NOU2 = NO*NU*NU
      NO2U = NO*NO*NU
      CALL RO1(1,NO,NU,O1)
      CALL RO2HPP(1,NO,NU,TI,VOE)
      CALL RDVEM4(0,NO,NU,TI,VE)
      CALL TRT1(NO,NU,TI,O1)
      CALL CCMATMUL(O1,VOE,VE,NU,NOU2,NO,0,1)
      CALL WRVE(1,NO,NU,VE)
C      NOU3=NO*NU*NU*NU
C      CALL CHKSUM('VE     ',VE,NOU3)
C
      CALL TRT1(NU,NO,TI,O1)
      CALL RO2HPP(1,NO,NU,TI,VOE)
      CALL RDVEM4(1,NU,NO,TI,VE)
      CALL TRANSQ(VOE,NOU)
      CALL CCMATMUL(O1,VOE,VE,NO,NO2U,NU,0,0)
      CALL WRVM(1,NO,NU,VE)
C      NO3U=NO*NO*NO*NU
C      CALL CHKSUM('VE     ',VE,NO3U)
      RETURN
      END
C*MODULE EOMCC   *DECK INTQUAT2
      SUBROUTINE INTQUAT2(NO,NU,O1,TI,O2,T2,VE,V,NOU)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION O1(NOU),TI(*),O2(NO,NO,NU,NU),T2(*),
     *          VE(NU,NU,NO,NU),V(NU,NU,NU)
C
      DATA HALF/0.5D+00/
C
C        PREPARE I^{AB}_{CD}, I^{IA}_{JB}, AND I^{IA}_{BJ} INTERMEDIATES
C
      NO2   = NO*NO
      NU2   = NU*NU
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
      NOU3  = NO*NU*NU*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL RO1(1,NO,NU,O1)
      CALL RDVEM3(0,NO,NU,TI,VE)
      CALL RDVE3(1,NO,NU,TI,VE)
      CALL VECMUL(VE,NOU3,HALF)
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13)
      CALL TRANMD(T2,NU,NU,NO,NO,12)
      CALL RO2HPP(1,NO,NU,TI,O2)
      CALL TRANSQ(O2,NOU)!PHHP
      CALL INSITU(NU,NO,NO,NU,TI,O2,13)
      CALL TRANMD(O2,NO,NO,NU,NU,12)
C
      DO I=1,NU
         CALL RDVPP(I,NO,NU,V)
         CALL CCMATMUL(T2,O2(1,1,1,I),V,NU2,NU,NO2,0,0)
         CALL TRANT3(V,NU,1)
         CALL CCMATMUL(VE(1,1,1,I),O1,V,NU2,NU,NO,0,1)
         CALL TRT1(NO,NU,TI,O1)
         CALL INSITU(NU,NU,NO,NU,TI,VE,13)
         CALL TRANMD(VE,NO,NU,NU,NU,24)
         CALL CCMATMUL(O1,VE(1,1,1,I),V,NU,NU2,NO,0,1)
         CALL TRT1(NU,NO,TI,O1)
         CALL TRANMD(VE,NO,NU,NU,NU,24)
         CALL INSITU(NO,NU,NU,NU,TI,VE,13)
         CALL TRANT3(V,NU,1)
         CALL WRVPP(I,NU,V)
      ENDDO
C
      CALL RO2HPP(1,NO,NU,TI,T2)
      CALL RDVE(1,NO,NU,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,12)
      CALL CCMATMUL(O1,VE,T2,NO,NOU2,NU,0,0)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL TRANSQ(T2,NOU)
      CALL RDVEM4(1,NU,NO,TI,VE)
      CALL TRT1(NO,NU,TI,O1)
      CALL CCMATMUL(O1,VE,T2,NU,NO2U,NO,0,1)
      CALL TRANSQ(T2,NOU)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL VECCOP(NO2U2,V,T2)
      CALL RO2(1,NO,NU,O2)
      CALL TRANSQ(O2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,O2,12)
      CALL RO2HPP(1,NO,NU,TI,VE)
      CALL VECMUL(O2,NO2U2,HALF)
      CALL SYMT21(O2,NO,NU,NO,NU,13)
      CALL CCMATMUL(O2,VE,T2,NOU,NOU,NOU,0,0)
      CALL DESM21(O2,NO,NU,NO,NU,13)
      CALL TRANMD(VE,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,VE,T2,NOU,NOU,NOU,0,1)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL VECCOP(NO2U2,VE,V)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL VECSUB(T2,VE,NO2U2)
      CALL VECADD(VE,T2,NO2U2)
      CALL VECADD(VE,T2,NO2U2)
      CALL WO2(6,NO,NU,VE)
      CALL RO2HPP(2,NO,NU,TI,T2)
      CALL TRANSQ(T2,NOU)
      CALL RDVEM4(1,NU,NO,TI,VE)
      CALL TRANMD(VE,NO,NO,NO,NU,13)
      CALL RO1(1,NO,NU,O1)
      CALL CCTMATMUL(O1,VE,T2,NU,NO2U,NO,0,1)
      CALL TRANSQ(T2,NOU)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL TRANMD(O2,NO,NU,NO,NU,13)
      CALL RO2HPP(1,NO,NU,TI,VE)
      CALL TRANMD(VE,NO,NU,NU,NO,23)
      CALL CCMATMUL(O2,VE,V,NOU,NOU,NOU,1,1)
      CALL VECADD(T2,V,NO2U2)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      CALL RDVE(1,NO,NU,VE)
      CALL TRANMD(VE,NU,NU,NU,NO,13)
      CALL RO1(1,NO,NU,O1)
      CALL CCMATMUL(O1,VE,T2,NO,NOU2,NU,0,0)
      CALL TRANMD(T2,NO,NU,NU,NO,14)
      CALL TRANMD(T2,NO,NU,NU,NO,1234)
      CALL VECADD(T2,V,NO2U2)
      CALL WO2(7,NO,NU,T2)
      CALL RDVM(3,NO,NU,VE)
      CALL RO1(3,NO,NU,O1)
      CALL RO2(1,NO,NU,O2)
      CALL TRANSQ(O2,NOU)
      CALL CCMATMUL(O1,O2,VE,NO,NO2U,NU,0,0)
      CALL WRVM(3,NO,NU,VE)
      RETURN
      END
C*MODULE EOMCC   *DECK EXTIB
      SUBROUTINE EXTIB(NO,NU,O1,T2,VE,TI,OEH,OEP,LTI,NOU,NO2U2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION O1(NOU),T2(NO2U2),TI(LTI),VE(NO2U2),OEH(NO),OEP(NU)
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
      NOUP  = NO2U2 + NOU
      CALL DIAGT1(NO,NU,O1,T2,VE,OEH,OEP,NOU,NO2U2)
      CALL DIAGT2(NO,NU,T2,TI,VE,OEH,OEP,NO2U2,LTI)
      CALL WCCFL(NDIAG,1,NOUP,O1)
      RETURN
      END
C*MODULE EOMCC   *DECK ADDGT1
      SUBROUTINE ADDGT1(NO,NU,TI,VOE,OEH,OEP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER A
C
      DIMENSION VOE(NO,NU,NO,NU),OEH(NO),OEP(NU),TI(*)
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
      NO2 = NO*NO
      NU2 = NU*NU
      CALL RCCFL(NHH,1,NO2,TI)
      CALL RCCFL(NHH,2,NU2,TI(NO2+1))
C
      DO I=1,NO
         DO A=1,NU
            II=I+(I-1)*NO
            IA=A+(A-1)*NU
            VOE(I,A,I,A)=VOE(I,A,I,A)+OEP(A)-OEH(I)+TI(NO2+IA)-TI(II)
         ENDDO
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK ADDGT2
      SUBROUTINE ADDGT2(NO,NU,TI,VOE,OEH,OEP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER A,B
C
      DIMENSION VOE(NU,NU,NO,NO),OEH(NO),OEP(NU),TI(*)
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
      NO2 = NO*NO
      NU2 = NU*NU
      CALL RCCFL(NHH,1,NO2,TI)
      CALL RCCFL(NHH,2,NU2,TI(NO2+1))
C
      DO I=1,NO
         DO J=1,NO
            DO A=1,NU
               DO B=1,NU
                  II=I+(I-1)*NO
                  JJ=J+(J-1)*NO
                  IA=A+(A-1)*NU
                  IB=B+(B-1)*NU
                  VOE(A,B,I,J)=OEH(I)+OEH(J)-OEP(A)-OEP(B)
     *                        +TI(II)+TI(JJ)-TI(NO2+IA)-TI(NO2+IB)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK DIAGT2
      SUBROUTINE DIAGT2(NO,NU,T2,TI,V,OEH,OEP,NO2U2,LTI)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T2(NO2U2),TI(LTI),V(NO2U2),OEH(NO),OEP(NU)
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
      DATA ONEM/-1.0D+00/
C
      NO2U2 = NO*NO*NU*NU
      NO4   = NO*NO*NO*NO
C
      CALL ADDGT2(NO,NU,TI,T2,OEH,OEP)
      CALL RCCFL(NHH,3,NO4,TI)
      CALL ADIAG1(NO,NU,T2,TI)
      CALL ADIAG2(NO,NU,T2,TI)
      CALL RO2(7,NO,NU,TI)
      CALL TRANMD(T2,NU,NU,NO,NO,12)
      CALL ADIAG3(NO,NU,T2,TI)
      CALL TRANMD(T2,NU,NU,NO,NO,12)
      CALL RO2(6,NO,NU,V)
      CALL VECSUB(TI,V,NO2U2)
      CALL ADIAG3(NO,NU,T2,TI)
      CALL VECMUL(T2,NO2U2,ONEM)
      CALL INSITU(NU,NU,NO,NO,TI,T2,13)
      CALL TRANMD(T2,NO,NU,NU,NO,23)
      RETURN
      END
C*MODULE EOMCC   *DECK ADIAG1
      SUBROUTINE ADIAG1(NO,NU,T2,V)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER A,B
C
      DIMENSION T2(NU,NU,NO,NO),V(NO,NO,NO,NO)
C
      DO I=1,NO
         DO J=1,NO
            X=V(I,J,I,J)
            DO A=1,NU
               DO B=1,NU
                  T2(A,B,I,J) = T2(A,B,I,J) - X
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK ADIAG2
      SUBROUTINE ADIAG2(NO,NU,T2,V)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER A,B
C
      DIMENSION T2(NU,NU,NO,NO),V(NU,NU,NU)
C
      DO B=1,NU
         CALL RDVPP(B,NO,NU,V)
         CALL TRANT3(V,NU,1)
         DO A=1,NU
            X=V(A,A,B)
            DO I=1,NO
               DO J=1,NO
                  T2(A,B,I,J) = T2(A,B,I,J) - X
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK ADIAG3
      SUBROUTINE ADIAG3(NO,NU,T2,V)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER A,B
C
      DIMENSION T2(NU,NU,NO,NO),V(NO,NU,NU,NO)
C
      DO I=1,NO
         DO J=1,NO
            DO A=1,NU
               DO B=1,NU
                  T2(A,B,I,J) = T2(A,B,I,J) + V(I,A,A,I) + V(J,B,B,J)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK DAVIDSON
      SUBROUTINE DAVIDSON(IW,ECCSD,BESTEOM,NO,NU,
     *                    T2,TI,T1,EV,C,HC,TEMPI,
     *                    VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
     *                    NOU,NU2,NU3,NO2U2,OEH,OEP,
     *                    BAA,AS,R,MEMS1,MEMS2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL MCIT
      CHARACTER*3 XSYM,VECREP,REP
      CHARACTER*14 YYKKCONV
      DIMENSION ISTACK(100)
C
      DIMENSION T2(*),TI(*),T1(*),EV(*),
     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
     *          OEH(NO),OEP(NU),BAA(MEMS1),AS(MEMS2),R(MEMS2)
C
      PARAMETER (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)
      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
      EQUIVALENCE (IHSPACE,LMICRO)
C
      DATA TWO/2.0D+00/,FEV/27.2113957D+00/
C
      DO I=1,100
         IUST(I)=0
         ISTACK(I)=0
         KVGEOM(I)=0
         EOMSDE(I)=0.0D+00
      ENDDO
C
      IF(NROOT.GT.0) WRITE(IW,9000)
C
      TOL  = CVGEOM
      TOLPR= 0.05D+00
      IF(ISPACE.EQ.0) LMICRO=NROOT*MAXITEOM
      NOUP=NOU+NO2U2
      NTOTITER=0
      IROOT=0
      NDIMR=1
      NBAD =0
C
      ICROOT=0
      IMICRO=1
      IDIM  =0
C
C        LOOP OVER FINDING EACH EXCITED STATE
C
      DO 100 NRT=1,NROOT
      WRITE(IW,9010) IROOT+1
      IF(ISPACE.EQ.0.AND.NRT.NE.1.AND.IMICRO.NE.IDIM) THEN
         IMIC1=IMICRO-1
         CALL RADCOPY(IMIC1,IDIM-1,R,AS)
         CALL DCOPY(IMIC1*IMIC1,AS,1,R,1)
         IDIM=IMICRO
         END IF
      IF(ISPACE.EQ.1) THEN
         NDIMR=1
         IMICRO=1
         IDIM=1
      END IF
C
      NSP=1
      IRST=IROOT+1
C
C      IF(IRST.EQ.1)IRST=IFIRSTR
C
      CALL RSTAR(IRST,NOUP,TI)
      CALL NORMT2(NO,NU,TI,T1)
C
C      ISTR=0
C      CALL ZEROMA(TI,NOU+1,NOUP)
C      IF(IROOT.EQ.0)CALL DSCAL(NOU,ONE/SQRT(TWO),TI,1)
C      IF(ISTR.EQ.1) THEN
C         CALL ZEROMA(TI,1,NOUP)
C         CALL STARTNEW(IROOT,NO,NU,TI(NOU+1))
C      END IF
C
      IF(IROOT.EQ.0) THEN
         CALL WCCFL(NC1,NDIMR,NOU,TI)
         CALL WCCFL(NC2,NDIMR,NO2U2,TI(NOU+1))
      END IF
C
      CALL WCCFL(NAX,2,NOUP,TI)
C
      IF(IROOT.GT.0) THEN
         CALL ORT3( NO,NU,NOUP,IDIM-1,TI,T2,T1,RES)
         CALL WCCFL(NC1,IDIM,NOU,TI)
         CALL WCCFL(NC2,IDIM,NO2U2,TI(NOU+1))
      END IF
C
C        AT THIS SPOT WE ARE USING THE STORAGE ALLOCATED
C        BY THE -J- POINTERS, RATHER THAN THE -I- POINTERS
C
 777  CONTINUE
      NTOTITER=NTOTITER+1
      IDIM=IMICRO
      CALL CHC1(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
      CALL CHC2(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
C
C        AND NOW WE ARE BACK TO THE -I- POINTERS
C
      CALL SMALMA(NO,NU,IDIM,T2,TI,AS,R,MEMS2)
      CALL ZEROMA(T2,1,IDIM*IDIM)
      CALL DIAGO(IDIM,AS,T2)
      CALL SELVEC(NO,NU,IDIM,TI,T2,T1,AS,EV,EVAL,IMAX)
C
      CALL COMB(NHC1,IDIM,NO,NU,T2(1+(IMAX-1)*IDIM),T1,TI)
      CALL DAXPY(NOUP,-EVAL,EV,1,TI,1)
      CALL DCOPY(NOUP,TI,1,T1,1)
      CALL RCCFL(NDIAG,1,NOUP,T2)
      DO 12 I=1,NOUP
         X=EVAL-T2(I)
         T1(I)=T1(I)/X
 12   CONTINUE
      CALL ORTX(NO,NU,NOUP,IDIM,T1,T2,TI,RES,BAA,MEMS1)
C
      WRITE(IW,9020) NSP,IDIM,EVAL,(EVAL*FEV),RES
      CALL FLSHBF(IW)
C
      NDIMR=NDIMR+1
      IMICRO=IMICRO+1
      IDIM=IMICRO
      MCIT=IMICRO.GT.LMICRO
      IF (MCIT) THEN
         IDIM=1
         IMICRO=1
         CALL WCCFL(NC1,IDIM,NOU,EV)
         CALL WCCFL(NC2,IDIM,NO2U2,EV(1+NOU))
      END IF
C
C         HAVE WE RUN OUT OF ITERATIONS WITHOUT CONVERGING?
C
      IF(RES.GT.TOL .AND. NSP.GE.MAXITEOM) THEN
         WRITE(IW,9025)
         NBAD = NBAD+1
         IROOT=IROOT+1
         CALL WCCFL(NAX,(IROOT+2),NOUP,EV)
C
         CALL FIXSYM(NO,NU,EV(1),EV(1+NOU),XSYM)
         WRITE(IW,9330) XSYM
C
         EOMSDE(NRT)= EVAL
         KVGEOM(NRT)= 0
         VECREP(NRT)= XSYM
         GO TO 822
      END IF
C
C         IF WE HAVEN'T CONVERGED, GO BACK
C
      IF(RES.GT.TOL) THEN
         NSP=NSP+1
         IF(.NOT.MCIT) THEN
            CALL WCCFL(NC1,IDIM,NOU,T1)
            CALL WCCFL(NC2,IDIM,NO2U2,T1(1+NOU))
         END IF
         CALL WCCFL(NAX,2,NOUP,EV)
         GO TO 777
      END IF
C
C         THIS STATE IS CONVERGED, SO SAVE AND PRINT RESULTS
C
      IF(ISPACE.EQ.0.AND.RES.GT.TOL) IMICRO=IMICRO-NSP
      IROOT=IROOT+1
      NDIMR=1
      CALL WCCFL(NAX,(IROOT+2),NOUP,EV)
C
      CALL FIXSYM(NO,NU,EV(1),EV(1+NOU),XSYM)
      WRITE(IW,9330) XSYM
      EOMSDE(NRT) = EVAL
      KVGEOM(NRT) = 1
      VECREP(NRT) = XSYM
C
C         AMPLITUDE PRINTING...
C
 822  CONTINUE
      WRITE(IW,9030)
C
      IPOS=1
      DO 560 IIIA=1,NU
       DO 561 IIII=1,NO
        XXX=ABS(EV(IPOS))
        IF(XXX.GT.TOLPR) THEN
         WRITE(IW,9040) EV(IPOS),IIII+NCCFZC,IIIA+NO+NCCFZC
        END IF
        IPOS=IPOS+1
  561  CONTINUE
  560 CONTINUE
C
      IPOS=1
      DO 570,JJJ=1,NO
       DO 571,JJB=1,NU
        DO 572,IIA=1,NU
         DO 573,III=1,NO
          XXX=ABS(EV(IPOS+NOU))
          IF(XXX.GT.TOLPR) THEN
            WRITE(IW,9050) EV(IPOS+NOU),III+NCCFZC,JJJ+NCCFZC,
     &                     IIA+NO+NCCFZC,JJB+NO+NCCFZC
          END IF
          IPOS=IPOS+1
  573    CONTINUE
  572   CONTINUE
  571  CONTINUE
  570 CONTINUE
C
      CALL RO1(3,NO,NU,T1)
      R0A=TWO*DDOT(NOU,T1,1,EV,1)
      CALL RO2HPP(1,NO,NU,TI,T1)
      CALL SYMT21(T1,NO,NU,NU,NO,23)
      R0B=DDOT(NO2U2,T1,1,EV(NOU+1),1)
      R00=(R0A+R0B)/EVAL
      ICROOT=ICROOT+1
C
      WRITE(IW,9060) R00
      EOMR0(NRT) = R00
C
      XAEL=0.0D+00
      CALL AELKK(NO,NU,EV(1),EV(NOU+1),XAEL)
      WRITE(IW,9070) XAEL
C
      ESTATE = ECCSD + EVAL
      WRITE(IW,9080) IROOT,ESTATE
C
C     --- THIS ENDS LOOP OVER ALL STATES ---
C
 100  CONTINUE
C
C          --- PRINT A SORTED LIST OF ENERGIES AS SUMMARY ---
C        NOTE, INDEXX JUST FINDS A SORTING PERMUTATION IN -IUST-,
C        THE ORDER OF EOMSDE, ETC. IS NOT ACTUALLY ALTERED.
C
      CALL INDEXX(NROOT,EOMSDE,IUST,80,ISTACK,100)
      IF(NROOT.GT.0) THEN
         WRITE(IW,9300)
         WRITE(IW,9310)
      END IF
      ISY=0
      DO I=1,NROOT
         JGO=IUST(I)
         IF(VECREP(JGO).EQ.REP(IROOTCC(1))) THEN
            ISY=ISY+1
            IF(IROOTCC(2).EQ.ISY) BESTEOM=ECCSD+EOMSDE(JGO)
         END IF
         IF(KVGEOM(JGO).EQ.1) THEN
            YYKKCONV='     CONVERGED'
         ELSE
            YYKKCONV=' NOT CONVERGED'
         END IF
         WRITE(IW,9320) VECREP(JGO),EOMSDE(JGO),EOMSDE(JGO)*FEV,
     *                  EOMSDE(JGO)+ECCSD,YYKKCONV
      ENDDO
      IF(IROOTCC(2).EQ.0) BESTEOM = ECCSD
      WRITE(IW,*) ' '
C
      NTOTEOM = ICROOT
      NBADEOM = NBAD
C
      IF(NBAD.GT.0) WRITE(IW,9090) NBAD,NROOT
      RETURN
C
 9000 FORMAT(/7X,'RESULTS  OF  THE  EOM-CCSD   ITERATIONS')
 9010 FORMAT(/1X,'SOLVING FOR ROOT NUMBER',I5,' ...'/
     *       1X,'        TOT        EXCITATION ENERGY',10X,
     *          'AMPLITUDE'/
     *       1X,'   ITR  ITR      HARTREE         EV          ',
     *          'CONVERGENCE')
 9020 FORMAT(1X,2I5,3F15.9)
 9025 FORMAT(/1X,'* * * UWAGA! * * * THIS STATE DID NOT CONVERGE.'/)
 9030 FORMAT(1X,'THE LARGEST R1 AND R2 AMPLITUDES FOR THIS ROOT ARE')
 9040 FORMAT(1X,'R1=',F15.10,' FOR   I -> A   =',2I5)
 9050 FORMAT(1X,'R2=',F15.10,' FOR I,J -> A,B =',4I5)
 9060 FORMAT(1X,'GROUND STATE''S WEIGHT R0 = ',F15.10)
 9070 FORMAT(1X,'REL DIAGNOSTIC (R1*R1 + 2*R2*R2): ',F8.3)
 9080 FORMAT(1X,'THE TOTAL ENERGY OF ROOT',I4,
     *          ' IS E(EOM-CCSD) =',F20.10)
 9090 FORMAT(/1X,'EOM-CCSD HALTED WITHOUT FINDING ALL DESIRED STATES'/
     *        1X,I4,' UNCONVERGED OUT OF',I4,' REQUESTED')
 9300 FORMAT(//15X,'---- SUMMARY OF EOM-CCSD CALCULATIONS ----'/)
 9310 FORMAT(17X,'EXCITATION',6X,'EXCITATION',6X,'TOTAL'/
     *       4X,'SYMMETRY',5X,'ENERGY (H)',6X,'ENERGY (EV)',5X,
     *       'ENERGY (H)',10X,'ITERATIONS')
 9320 FORMAT(7X,A3,2X,F15.8,6X,F8.3,4X,F15.8,5X,A14)
 9330 FORMAT(1X,'SYMMETRY OF THE STATE: ',A3)
      END
C*MODULE EOMCC   *DECK DAVIDSONMR
      SUBROUTINE DAVIDSONMR(IW,ECCSD,BESTEOM,
     *                      NO,NU,NOUP,NOU,NU2,NU3,NO2U2,
     *                      T2,TI,T1,EV,TMP,T2AUX,C,HC,TEMPI,
     *                      VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
     *                      OEH,OEP,MEMS0,MEMS1,MEMS2,
     *                      R,AS,BAA,AA,EVAL,RES,EXCON,R0CON)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 XSYM,VECREP,REP
      CHARACTER*14 YYKKCONV
      DIMENSION ISTACK(100)
C
      DIMENSION T2(*),TI(*),T1(NOUP,*),EV(NOUP,*),TMP(*),T2AUX(*),
     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
     *          OEH(NO),OEP(NU),R(MEMS2),AS(MEMS2),BAA(MEMS1),
     *          AA(MEMS0),EVAL(MEMS0),RES(MEMS0),EXCON(MEMS0),
     *          R0CON(MEMS0)
C
      PARAMETER (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)
      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
      EQUIVALENCE (IHSPACE,LMICRO)
      DATA TWO/2.0D+00/,FEV/27.2113957D+00/
C
      TOL= CVGEOM
      TOLPR=0.05D+00
      NBAD=0
C
      DO I=1,100
       IUST(I)=0
       ISTACK(I)=0
       KVGEOM(I)=0
       EOMSDE(I)=0.0D+00
      ENDDO
C
      ICONT=0
      IZAPIS=0
      CALL RO1(3,NO,NU,T2AUX)
      CALL RO2HPP(1,NO,NU,TI,T2AUX(1+NOU))
      CALL SYMT21(T2AUX(1+NOU),NO,NU,NU,NO,23)
C
      IROOT=0
      IF(NROOT.GT.0) WRITE(IW,9000) NROOT
C
      ICROOT=0
      IDIM=1
      NSP=1
C
      DO 100 NRT=1,NROOT
         CALL RSTAR(NRT,NOUP,TI)
         CALL NORMT2(NO,NU,TI,T1)
         IF(NRT.EQ.1) THEN
            CALL WCCFL(NC1,NRT,NOU,TI)
            CALL WCCFL(NC2,NRT,NO2U2,TI(NOU+1))
         END IF
         CALL WCCFL(NAX,NRT,NOUP,TI)
         IF(NRT.GT.1) THEN
            CALL ORT3(NO,NU,NOUP,NRT-1,TI,T2,T1,RSS)
            CALL WCCFL(NC1,NRT,NOU,TI)
            CALL WCCFL(NC2,NRT,NO2U2,TI(NOU+1))
         END IF
 100  CONTINUE
C
C        LOOP OVER EOM MACRO-ITERATIONS STARTS HERE
C
  777 CONTINUE
C
C        AT THIS SPOT WE ARE USING THE STORAGE ALLOCATED
C        BY THE -J- POINTERS, RATHER THAN THE -I- POINTERS
C
      DO NRT=1,NROOT
         INRT=NROOT*(IDIM-1)+NRT
         CALL CHC1(INRT,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
         CALL CHC2(INRT,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *             C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
      ENDDO
C
C        AND NOW WE ARE BACK TO USING THE -I- POINTERS
C
      CALL TESTORT(NROOT,NOUP,NO,NU,TI,T1)
      IDRT=IDIM*NROOT
      CALL SMALMAMR(NO,NU,IDRT,T2,T2(1+NOUP),R,AS,MEMS2)
      CALL ZEROMA(T2,1,IDRT*IDRT)
      CALL DIAGO(IDRT,AS,T2)
C
      DO 102 IROOT=1,NROOT
         IRTTMP = IROOT
         CALL SELVECMR(NO,NU,NOUP,IRTTMP,IDRT,TI,T1(1,IRTTMP),
     *                 T2,AS,EV,IMX,EVAL,MEMS0)
         CALL COMB(NHC1,IDRT,NO,NU,T2(1+(IMX-1)*IDRT),T1(1,IRTTMP),TI)
         CALL DAXPY(NOUP,-EVAL(IRTTMP),EV(1,IRTTMP),1,TI,1)
         CALL DCOPY(NOUP,TI,1,T1(1,IRTTMP),1)
         CALL DAVCOR(NOUP,EVAL(IRTTMP),T1(1,IRTTMP),TMP)
 102  CONTINUE
C
      CALL ORTXMR(NROOT,NO,NU,NOUP,IDIM,T1,T2,TI,BAA,AA,RES,MEMS0,MEMS1)
      RESMAX=RES(IDAMAX(NROOT,RES,1))
C
      WRITE(IW,9010) NSP,IDIM,RESMAX,(EVAL(I),I=1,NROOT)
      CALL FLSHBF(IW)
C
C ** ADDED BY KK --- SPUST UZBIEZNIONYCH
C
      DO 650,IKK=1,NROOT
        ISREP=0
        XXX=ABS(RES(IKK))
        IF(XXX.LT.TOL) THEN
           XENE=EVAL(IKK)
           R0A=TWO*DDOT(NOU,T2AUX,1,EV(1,IKK),1)
           R0B=DDOT(NO2U2,T2AUX(1+NOU),1,EV(NOU+1,IKK),1)
           R00=(R0A+R0B)/EVAL(IKK)
           XR0=ABS(R00)
           IF(ICONT.EQ.0) THEN
            ICONT=1
            EXCON(ICONT)=XENE
            R0CON(ICONT)=R00
            CALL WCCFL(NAXX,ICONT,NOUP,EV(1,IKK))
            IZAPIS=IZAPIS+1
           ELSE
            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
            IF(ISREP.EQ.0) THEN
             ICONT=ICONT+1
             EXCON(ICONT)=XENE
             R0CON(ICONT)=R00
             CALL WCCFL(NAXX,ICONT,NOUP,EV(1,IKK))
             IZAPIS=IZAPIS+1
            END IF
           END IF
        END IF
C
CDBG    WRITE(6,*) '   '
CDBG    WRITE(6,*) 'IKK=',IKK
CDBG    WRITE(6,*) 'TOL:',TOL
CDBG    WRITE(6,*) 'RES(IKK)',RES(IKK)
CDBG    WRITE(6,*) 'EVAL(IKK)',EVAL(IKK)
CDBG    WRITE(6,*) 'EXCON',(EXCON(III),III=1,5)
CDBG    WRITE(6,*) 'XEDIFF XRDIFF',XEDIFF,XRDIFF
CDBG    WRITE(6,*) 'ISREP',ISREP
CDBG    WRITE(6,*) 'ICONT',ICONT
CDBG    WRITE(6,*) 'IZAPIS',IZAPIS
CDBG    CALL FLSHBF(6)
C
 650  CONTINUE
C
      IDIM=IDIM+1
      IF(IDIM.GT.LMICRO) THEN
         IDIM=1
         DO IROOT=1,NROOT
            CALL WCCFL(NAX,IROOT,NOUP,EV(1,IROOT))
         ENDDO
C
         CALL ORTXEV(NROOT,NO,NU,NOUP,EV,TMP)
C
         DO IROOT=1,NROOT
            CALL WCCFL(NC1,IROOT,NOU,EV(1,IROOT))
            CALL WCCFL(NC2,IROOT,NO2U2,EV(1+NOU,IROOT))
         ENDDO
      END IF
C
C         NEXT TEST IS TRUE IF WE HAVE NOT YET CONVERGED ALL STATES
C
      IF(RESMAX.GT.TOL) THEN
C
C         CHECK TO SEE IF WE HAVE DONE TOO MANY ITERATIONS,
C         OR IF WE ARE RIDICULOUSLY FAR FROM BEING CONVERGED.
C         IN THESE CASES WE SAVE CONVERGED AND UNCONVERGED ROOTS.
C
         NSP=NSP+1
         IF (NSP.GT.MAXITEOM)   WRITE(IW,9200)
         IF (RESMAX.GT.5.0D+03) WRITE(IW,9210)
C
         IF (RESMAX.GT.5.0D+03  .OR.  NSP.GT.MAXITEOM) THEN
            WRITE(IW,9220) ICONT
            DO III=1,ICONT
               CALL RCCFL(NAXX,III,NOUP,EV(1,1))
               CALL FIXSYM(NO,NU,EV(1,1),EV(1+NOU,1),XSYM)
               EOMSDE(III) = EXCON(III)
               EOMR0(III)  = R0CON(III)
               VECREP(III) = XSYM
               KVGEOM(III) = 1
               WRITE(IW,9230)XSYM,EOMSDE(III),EOMSDE(III)*FEV,
     *                       EOMSDE(III)+ECCSD
               CALL WCCFL(NAX,III,NOUP,EV(1,1))
            ENDDO
C              FRANKLY, I DON'T SEE HOW THE NEXT COULD EVER BE TRUE
            IF(ICONT.GT.NROOT.AND.MTHTRIP.NE.0) THEN
              ICONT=NROOT
              WRITE(IW,9340) NROOT
            END IF
            NTOTEOM = ICONT
            NBAD = 0
            NBADEOM =NBAD
            RETURN
         END IF
C
C          PREPARE FOR CARRYING ON WITH THE NEXT ITERATION
C
         IF(IDIM.GT.1) THEN
            DO IROOT=1,NROOT
               CALL WCCFL(NC1,IDRT+IROOT,NOU,T1(1,IROOT))
               CALL WCCFL(NC2,IDRT+IROOT,NO2U2,T1(1+NOU,IROOT))
               CALL WCCFL(NAX,IROOT,NOUP,EV(1,IROOT))
            ENDDO
         END IF
         GO TO 777
      END IF
C
C     ---- IF WE GET HERE ALL ROOTS OF THE EOM HAVE CONVERGED ----
C
      DO IROOT=1,NROOT
         CALL WCCFL(NAX,IROOT,NOUP,EV(1,IROOT))
      ENDDO
C
C         PREPARATION WORK FOR COMPUTING R00'S
C
      CALL RO1(3,NO,NU,T2)
      CALL RO2HPP(1,NO,NU,TI,T2(1+NOU))
      CALL SYMT21(T2(1+NOU),NO,NU,NU,NO,23)
C
C         PRINT ENERGIES, AMPLITUDES, DIAGNOSTICS
C
      DO 500 IROOT=1,NROOT
         WRITE(IW,9020) IROOT,EVAL(IROOT),EVAL(IROOT)*FEV,
     *                  ECCSD+EVAL(IROOT)
         WRITE(IW,9030)
         IPOS=1
         DO IIIA=1,NU
            DO IIII=1,NO
               XXX=ABS(EV(IPOS,IROOT))
               IF(XXX.GT.TOLPR)
     *   WRITE(IW,9040) EV(IPOS,IROOT),IIII+NCCFZC,IIIA+NO+NCCFZC
               IPOS=IPOS+1
            ENDDO
         ENDDO
C
         IPOS=1
         DO JJJ=1,NO
            DO JJB=1,NU
               DO IIA=1,NU
                  DO III=1,NO
                     XXX=ABS(EV(IPOS+NOU,IROOT))
                     IF(XXX.GT.TOLPR) WRITE(IW,9050)
     *   EV(IPOS+NOU,IROOT),III+NCCFZC,JJJ+NCCFZC,
     *   IIA+NO+NCCFZC,JJB+NO+NCCFZC
                     IPOS=IPOS+1
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
C
         R0A=TWO*DDOT(NOU,T2,1,EV(1,IROOT),1)
         R0B=DDOT(NO2U2,T2(1+NOU),1,EV(NOU+1,IROOT),1)
         R00=(R0A+R0B)/EVAL(IROOT)
         ICROOT=ICROOT+1
         WRITE(IW,9060) R00
C
         CALL FIXSYM(NO,NU,EV(1,IROOT),EV(1+NOU,IROOT),XSYM)
         EOMSDE(IROOT) = EVAL(IROOT)
         EOMR0(IROOT)  = R00
         VECREP(IROOT) = XSYM
         KVGEOM(IROOT) = 1
C
         XAEL=0.0D+00
         CALL AELKK(NO,NU,EV(1,IROOT),EV(NOU+1,IROOT),XAEL)
         WRITE(IW,9070) XAEL
  500 CONTINUE
      NTOTEOM = NROOT
      NBADEOM = 0
C
C          --- PRINT A SORTED LIST OF ENERGIES AS SUMMARY ---
C
CCCX  822 CONTINUE
      CALL INDEXX(NROOT,EOMSDE,IUST,80,ISTACK,100)
      IF(NROOT.GT.0) THEN
         WRITE(IW,9300)
         WRITE(IW,9310)
      END IF
      ISY=0
      DO I=1,NROOT
         JGO=IUST(I)
         IF(VECREP(JGO).EQ.REP(IROOTCC(1))) THEN
            ISY=ISY+1
            IF(IROOTCC(2).EQ.ISY) BESTEOM=ECCSD+EOMSDE(JGO)
         END IF
         IF(KVGEOM(JGO).EQ.1) THEN
            YYKKCONV='     CONVERGED'
         ELSE
            YYKKCONV=' NOT CONVERGED'
         END IF
         WRITE(IW,9320) VECREP(JGO),EOMSDE(JGO),EOMSDE(JGO)*FEV,
     *                  EOMSDE(JGO)+ECCSD,YYKKCONV
      ENDDO
      IF(IROOTCC(2).EQ.0) BESTEOM = ECCSD
      WRITE(IW,*) ' '
      RETURN
C
 9000 FORMAT(/7X,'RESULTS  OF  THE  EOM-CCSD   ITERATIONS'//
     *       1X,'           AMPLITUDE     EXCITATION ENERGIES',
     *          ' (HARTREE)'/
     *       1X,'NSP IDIM    CONVERG.     TO ROOTS 1,  ...,',I4)
 9010 FORMAT(1X,2I3,F15.9,4F14.9/(22X,4F14.9))
 9020 FORMAT(/5X,'----- RESULTS FOR ROOT NUMBER',I4,' -----'/
     *       1X,'EXCITATION ENERGY=',F10.5,' HARTREE, OR',F10.5,' EV'/
     *       1X,'THE TOTAL ENERGY IS E(EOM-CCSD) =',F20.10)
 9030 FORMAT(1X,'THE LARGEST R1 AND R2 AMPLITUDES FOR THIS ROOT ARE')
 9040 FORMAT(1X,'R1=',F15.10,' FOR   I -> A   =',2I5)
 9050 FORMAT(1X,'R2=',F15.10,' FOR I,J -> A,B =',4I5)
 9060 FORMAT(1X,'GROUND STATE''S WEIGHT R0 = ',F15.10)
 9070 FORMAT(1X,'REL DIAGNOSTIC (R1*R1 + 2*R2*R2): ',F8.3)
C
 9200 FORMAT(1X,'DAVIDSONMR: TOO MANY ITERATIONS')
 9210 FORMAT(1X,'DAVIDSONMR: NORM OF RESIDUAL VECTOR TOO LARGE')
 9220 FORMAT(1X,I3,' CONVERGED VECTORS ARE STORED IN FILE -EOMRTMP-,'/
     *       5X,'AND CAN FURTHER BE USED BY THE MMEOM(2,3) PROGRAM.')
C 27/05/2004 LEFT EOMSD ------------------
 9230 FORMAT(4X,A3,4X,F15.8,6X,F8.3,4X,F15.8)
C ----------------------------------------
 9300 FORMAT(//15X,'---- SUMMARY OF EOM-CCSD CALCULATIONS ----'/)
 9310 FORMAT(17X,'EXCITATION',6X,'EXCITATION',6X,'TOTAL'/
     *       4X,'SYMMETRY',5X,'ENERGY (H)',6X,'ENERGY (EV)',5X,
     *       'ENERGY (H)',10X,'ITERATIONS')
 9320 FORMAT(7X,A3,2X,F15.8,6X,F8.3,4X,F15.8,5X,A14)
 9340 FORMAT(1X,'THE FIRST',I4,' ROOTS WILL BE PASSED TO MMCC(2,3)')
      END
C 27/05/2004 LEFT EOMSD ------------------ MODULE DAVPR
C*MODULE EOMCC   *DECK DAVPR
      SUBROUTINE DAVPR(IW,ECCSD,BESTEOM,NO,NU,
     *                    T2,TI,T1,EV,C,HC,TEMPI,
     *                    VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
     *                    NOU,NU2,NU3,NO2U2,OEH,OEP,
     *                    BAA,AS,R,MEMS1,MEMS2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL MCIT
      CHARACTER*3 XSYM,VECREP,REP
      CHARACTER*14 YYKKCONV
      DIMENSION ISTACK(100)
C
      DIMENSION T2(*),TI(*),T1(*),EV(*),
     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
     *          OEH(NO),OEP(NU),BAA(MEMS1),AS(MEMS2),R(MEMS2)
C
      PARAMETER (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)
      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
      EQUIVALENCE (IHSPACE,LMICRO)
C
      DATA FEV/27.2113957D+00/
C
      DO I=1,100
         IUST(I)  =0
         ISTACK(I)=0
         KVGEOM(I)=0
         EOMSDE(I)=0.0D+00
         XKKEOM(I)=0.0D+00
         KKTRIM(I)=0
         EOMR0L(I)=0.0D+00
      ENDDO
C
      IF(NROOT.GT.0) WRITE(IW,9000)
C
      TOL  = CVGEOM
      TOLPR= 0.05D+00
      IF(ISPACE.EQ.0) LMICRO=NROOT*MAXITEOM
      NOUP=NOU+NO2U2
      NTOTITER=0
      IROOT=0
      NDIMR=1
      NBAD =0
C
      ICROOT=0
      IMICRO=1
      IDIM  =0
C
C        LOOP OVER FINDING EACH EXCITED STATE
C
      DO 100 NRT=1,NROOT
      WRITE(IW,9010) IROOT+1
      IF(ISPACE.EQ.0.AND.NRT.NE.1.AND.IMICRO.NE.IDIM) THEN
         IMIC1=IMICRO-1
         CALL RADCOPY(IMIC1,IDIM-1,R,AS)
         CALL DCOPY(IMIC1*IMIC1,AS,1,R,1)
         IDIM=IMICRO
         END IF
      IF(ISPACE.EQ.1) THEN
         NDIMR=1
         IMICRO=1
         IDIM=1
      END IF
C
      NSP=1
      IRST=IROOT+1
C
C      IF(IRST.EQ.1)IRST=IFIRSTR
C
      CALL RSTAR(IRST,NOUP,TI)
      CALL NORMT2(NO,NU,TI,T1)
C
C      ISTR=0
C      CALL ZEROMA(TI,NOU+1,NOUP)
C      IF(IROOT.EQ.0)CALL DSCAL(NOU,ONE/SQRT(TWO),TI,1)
C      IF(ISTR.EQ.1) THEN
C         CALL ZEROMA(TI,1,NOUP)
C         CALL STARTNEW(IROOT,NO,NU,TI(NOU+1))
C      END IF
C
      IF(IROOT.EQ.0) THEN
         CALL WCCFL(NC1,NDIMR,NOU,TI)
         CALL WCCFL(NC2,NDIMR,NO2U2,TI(NOU+1))
      END IF
C
      CALL WCCFL(NAX,2,NOUP,TI)
C
      IF(IROOT.GT.0) THEN
         CALL ORT3( NO,NU,NOUP,IDIM-1,TI,T2,T1,RES)
         CALL WCCFL(NC1,IDIM,NOU,TI)
         CALL WCCFL(NC2,IDIM,NO2U2,TI(NOU+1))
      END IF
C
C        AT THIS SPOT WE ARE USING THE STORAGE ALLOCATED
C        BY THE -J- POINTERS, RATHER THAN THE -I- POINTERS
C
 777  CONTINUE
      NTOTITER=NTOTITER+1
      IDIM=IMICRO
      CALL CHC1(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
      CALL CHC2(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
C
C        AND NOW WE ARE BACK TO THE -I- POINTERS
C
      CALL SMALMA(NO,NU,IDIM,T2,TI,AS,R,MEMS2)
      CALL ZEROMA(T2,1,IDIM*IDIM)
      CALL DIAGO(IDIM,AS,T2)
      CALL SELVEC(NO,NU,IDIM,TI,T2,T1,AS,EV,EVAL,IMAX)
C
      CALL COMB(NHC1,IDIM,NO,NU,T2(1+(IMAX-1)*IDIM),T1,TI)
      CALL DAXPY(NOUP,-EVAL,EV,1,TI,1)
      CALL DCOPY(NOUP,TI,1,T1,1)
      CALL RCCFL(NDIAG,1,NOUP,T2)
      DO 12 I=1,NOUP
         X=EVAL-T2(I)
         T1(I)=T1(I)/X
 12   CONTINUE
      CALL ORTX(NO,NU,NOUP,IDIM,T1,T2,TI,RES,BAA,MEMS1)
C
      WRITE(IW,9020) NSP,IDIM,EVAL,(EVAL*FEV),RES
      CALL FLSHBF(IW)
C
      NDIMR=NDIMR+1
      IMICRO=IMICRO+1
      IDIM=IMICRO
      MCIT=IMICRO.GT.LMICRO
      IF (MCIT) THEN
         IDIM=1
         IMICRO=1
         CALL WCCFL(NC1,IDIM,NOU,EV)
         CALL WCCFL(NC2,IDIM,NO2U2,EV(1+NOU))
      END IF
C
C         HAVE WE RUN OUT OF ITERATIONS WITHOUT CONVERGING?
C
      IF(RES.GT.TOL .AND. NSP.GE.MAXITEOM) THEN
         WRITE(IW,9025)
         NBAD = NBAD+1
         IROOT=IROOT+1
CCCX         CALL WCCFL(NAX,(IROOT+2),NOUP,EV) !27/05/2004
C
         CALL FIXSYM(NO,NU,EV(1),EV(1+NOU),XSYM)
         WRITE(IW,9330) XSYM
C
         EOMSDE(NRT)= EVAL
         KVGEOM(NRT)= 0
         VECREP(NRT)= XSYM
         XKKEOM(NRT)= EVAL
         KKTRIM(NRT)= 0
C
         CALL BIORTF1(NO,NU,NOUP,EV,T1,TI,EVAL,R00)
         CALL WCCFL(NAX,(IROOT+2),NOUP,EV)
         GO TO 822
      END IF
C
C         IF WE HAVEN'T CONVERGED, GO BACK
C
      IF(RES.GT.TOL) THEN
         NSP=NSP+1
         IF(.NOT.MCIT) THEN
            CALL WCCFL(NC1,IDIM,NOU,T1)
            CALL WCCFL(NC2,IDIM,NO2U2,T1(1+NOU))
         END IF
         CALL WCCFL(NAX,2,NOUP,EV)
         GO TO 777
      END IF
C
C         THIS STATE IS CONVERGED, SO SAVE AND PRINT RESULTS
C
      IF(ISPACE.EQ.0.AND.RES.GT.TOL) IMICRO=IMICRO-NSP
      IROOT=IROOT+1
      NDIMR=1
C 27/05/2004 LEFT EOMSD ------------------
      CALL BIORTF1(NO,NU,NOUP,EV,T1,TI,EVAL,R00)
C ----------------------------------------
      CALL WCCFL(NAX,(IROOT+2),NOUP,EV)
C
      CALL FIXSYM(NO,NU,EV(1),EV(1+NOU),XSYM)
      WRITE(IW,9330) XSYM
      EOMSDE(NRT) = EVAL
      KVGEOM(NRT) = 1
      VECREP(NRT) = XSYM
      KKTRIM(NRT) = 1
      XKKEOM(NRT) = EVAL
C
C         AMPLITUDE PRINTING...
C
 822  CONTINUE
      WRITE(IW,9030)
C
      IPOS=1
      DO 560 IIIA=1,NU
       DO 561 IIII=1,NO
        XXX=ABS(EV(IPOS))
        IF(XXX.GT.TOLPR) THEN
           WRITE(IW,9040) EV(IPOS),IIII+NCCFZC,IIIA+NO+NCCFZC
        END IF
        IPOS=IPOS+1
  561  CONTINUE
  560 CONTINUE
C
      IPOS=1
      DO 570,JJJ=1,NO
       DO 571,JJB=1,NU
        DO 572,IIA=1,NU
         DO 573,III=1,NO
          XXX=ABS(EV(IPOS+NOU))
          IF(XXX.GT.TOLPR) THEN
            WRITE(IW,9050) EV(IPOS+NOU),III+NCCFZC,JJJ+NCCFZC,
     &                     IIA+NO+NCCFZC,JJB+NO+NCCFZC
          END IF
          IPOS=IPOS+1
  573    CONTINUE
  572   CONTINUE
  571  CONTINUE
  570 CONTINUE
C
CCCX      CALL RO1(3,NO,NU,T1)
CCCX      R0A=TWO*DDOT(NOU,T1,1,EV,1)
CCCX      CALL RO2HPP(1,NO,NU,TI,T1)
CCCX      CALL SYMT21(T1,NO,NU,NU,NO,23)
CCCX      R0B=DDOT(NO2U2,T1,1,EV(NOU+1),1)
CCCX      R00=(R0A+R0B)/EVAL
C 27/05/2004 LEFT EOMSD ----------
      EOMR0L(NRT)=R00
C --------------------------------
      ICROOT=ICROOT+1
C
      WRITE(IW,9060) R00
      EOMR0(NRT) = R00
C
      XAEL=0.0D+00
      CALL AELKK(NO,NU,EV(1),EV(NOU+1),XAEL)
      WRITE(IW,9070) XAEL
C
      ESTATE = ECCSD + EVAL
      WRITE(IW,9080) IROOT,ESTATE
C
C     --- THIS ENDS LOOP OVER ALL STATES ---
C
 100  CONTINUE
C
C          --- PRINT A SORTED LIST OF ENERGIES AS SUMMARY ---
C        NOTE, INDEXX JUST FINDS A SORTING PERMUTATION IN -IUST-,
C        THE ORDER OF EOMSDE, ETC. IS NOT ACTUALLY ALTERED.
C
      CALL INDEXX(NROOT,EOMSDE,IUST,80,ISTACK,100)
      IF(NROOT.GT.0) THEN
         WRITE(IW,9300)
         WRITE(IW,9310)
      END IF
      ISY=0
      DO I=1,NROOT
         JGO=IUST(I)
         IF(VECREP(JGO).EQ.REP(IROOTCC(1))) THEN
            ISY=ISY+1
            IF(IROOTCC(2).EQ.ISY) BESTEOM=ECCSD+EOMSDE(JGO)
         END IF
         IF(KVGEOM(JGO).EQ.1) THEN
            YYKKCONV='     CONVERGED'
         ELSE
            YYKKCONV=' NOT CONVERGED'
         END IF
         WRITE(IW,9320) VECREP(JGO),EOMSDE(JGO),EOMSDE(JGO)*FEV,
     *                  EOMSDE(JGO)+ECCSD,YYKKCONV
      ENDDO
      IF(IROOTCC(2).EQ.0) BESTEOM = ECCSD
      IF(NROOT.GT.0) WRITE(IW,*) ' '
C
      NTOTEOM = ICROOT
      NBADEOM = NBAD
C
      IF(NBAD.GT.0) WRITE(IW,9090) NBAD,NROOT
      RETURN
C
 9000 FORMAT(/7X,'RESULTS  OF  THE  EOM-CCSD   ITERATIONS')
 9010 FORMAT(/1X,'SOLVING FOR ROOT NUMBER',I5,' ...'/
     *       1X,'        TOT        EXCITATION ENERGY',10X,
     *          'AMPLITUDE'/
     *       1X,'   ITR  ITR      HARTREE         EV          ',
     *          'CONVERGENCE')
 9020 FORMAT(1X,2I5,3F15.9)
 9025 FORMAT(/1X,'* * * UWAGA! * * * THIS STATE DID NOT CONVERGE.'/)
 9030 FORMAT(1X,'THE LARGEST R1 AND R2 AMPLITUDES FOR THIS ROOT ARE')
 9040 FORMAT(1X,'R1=',F15.10,' FOR   I -> A   =',2I5)
 9050 FORMAT(1X,'R2=',F15.10,' FOR I,J -> A,B =',4I5)
 9060 FORMAT(1X,'GROUND STATE''S WEIGHT R0 = ',F15.10)
 9070 FORMAT(1X,'REL DIAGNOSTIC (R1*R1 + 2*R2*R2): ',F8.3)
 9080 FORMAT(1X,'THE TOTAL ENERGY OF ROOT',I4,
     *          ' IS E(EOM-CCSD) =',F20.10)
 9090 FORMAT(/1X,'EOM-CCSD HALTED WITHOUT FINDING ALL DESIRED STATES'/
     *        1X,I4,' UNCONVERGED OUT OF',I4,' REQUESTED')
 9300 FORMAT(//15X,'---- SUMMARY OF EOM-CCSD CALCULATIONS ----'/)
 9310 FORMAT(17X,'EXCITATION',6X,'EXCITATION',6X,'TOTAL'/
     *       4X,'SYMMETRY',5X,'ENERGY (H)',6X,'ENERGY (EV)',5X,
     *       'ENERGY (H)',10X,'ITERATIONS')
 9320 FORMAT(7X,A3,2X,F15.8,6X,F8.3,4X,F15.8,5X,A14)
 9330 FORMAT(1X,'SYMMETRY OF THE STATE: ',A3)
      END
C 27/05/2004 LEFT EOMSD ------------------ MODULE DAVMRPR
C*MODULE EOMCC   *DECK DAVMRPR
      SUBROUTINE DAVMRPR(IW,ECCSD,BESTEOM,
     *                      NO,NU,NOUP,NOU,NU2,NU3,NO2U2,
     *                      T2,TI,T1,EV,TMP,T2AUX,C,HC,TEMPI,
     *                      VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
     *                      OEH,OEP,MEMS0,MEMS1,MEMS2,
     *                      R,AS,BAA,AA,EVAL,RES,EXCON,R0CON)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*3 XSYM,VECREP,REP
      CHARACTER*14 YYKKCONV
      DIMENSION ISTACK(100)
C
      DIMENSION T2(*),TI(*),T1(NOUP,*),EV(NOUP,*),TMP(*),T2AUX(*),
     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
     *          OEH(NO),OEP(NU),R(MEMS2),AS(MEMS2),BAA(MEMS1),
     *          AA(MEMS0),EVAL(MEMS0),RES(MEMS0),EXCON(MEMS0),
     *          R0CON(MEMS0)
C
      PARAMETER (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)
      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 /IBADMR/ IBAD
C
      EQUIVALENCE (IHSPACE,LMICRO)
      DATA TWO/2.0D+00/,FEV/27.2113957D+00/,ONE/1.0D+00/
C
      TOL= CVGEOM
      TOLPR=0.05D+00
      NBAD=0
C 27/05/2004 LEFT EOMSD ------------
      IBAD=0
C ----------------------------------
C
      DO I=1,100
       IUST(I)  =0
       ISTACK(I)=0
       KVGEOM(I)=0
       EOMSDE(I)=0.0D+00
       KKTRIM(I)=0
       XKKEOM(I)=0.0D+00
       EOMR0L(I)=0.0D+00
      ENDDO
C
      ICONT=0
      IZAPIS=0
      CALL RO1(3,NO,NU,T2AUX)
      CALL RO2HPP(1,NO,NU,TI,T2AUX(1+NOU))
      CALL SYMT21(T2AUX(1+NOU),NO,NU,NU,NO,23)
C
      IROOT=0
      IF(NROOT.GT.0) WRITE(IW,9000) NROOT
C
      ICROOT=0
      IDIM=1
      NSP=1
C
      DO 100 NRT=1,NROOT
         CALL RSTAR(NRT,NOUP,TI)
         CALL NORMT2(NO,NU,TI,T1)
         IF(NRT.EQ.1) THEN
            CALL WCCFL(NC1,NRT,NOU,TI)
            CALL WCCFL(NC2,NRT,NO2U2,TI(NOU+1))
         END IF
         CALL WCCFL(NAX,NRT,NOUP,TI)
         IF(NRT.GT.1) THEN
            CALL ORT3(NO,NU,NOUP,NRT-1,TI,T2,T1,RSS)
            CALL WCCFL(NC1,NRT,NOU,TI)
            CALL WCCFL(NC2,NRT,NO2U2,TI(NOU+1))
         END IF
 100  CONTINUE
C
C        LOOP OVER EOM MACRO-ITERATIONS STARTS HERE
C
  777 CONTINUE
C
C        AT THIS SPOT WE ARE USING THE STORAGE ALLOCATED
C        BY THE -J- POINTERS, RATHER THAN THE -I- POINTERS
C
      DO NRT=1,NROOT
         INRT=NROOT*(IDIM-1)+NRT
         CALL CHC1(INRT,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
         CALL CHC2(INRT,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *             C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
      ENDDO
C
C        AND NOW WE ARE BACK TO USING THE -I- POINTERS
C
      CALL TESTORT(NROOT,NOUP,NO,NU,TI,T1)
      IDRT=IDIM*NROOT
      CALL SMALMAMR(NO,NU,IDRT,T2,T2(1+NOUP),R,AS,MEMS2)
      CALL ZEROMA(T2,1,IDRT*IDRT)
      CALL DIAGO(IDRT,AS,T2)
C
      DO 102 IROOT=1,NROOT
         IRTTMP = IROOT
         CALL SELVECMR(NO,NU,NOUP,IRTTMP,IDRT,TI,T1(1,IRTTMP),
     *                 T2,AS,EV,IMX,EVAL,MEMS0)
         CALL COMB(NHC1,IDRT,NO,NU,T2(1+(IMX-1)*IDRT),T1(1,IRTTMP),TI)
         CALL DAXPY(NOUP,-EVAL(IRTTMP),EV(1,IRTTMP),1,TI,1)
         CALL DCOPY(NOUP,TI,1,T1(1,IRTTMP),1)
         CALL DAVCOR(NOUP,EVAL(IRTTMP),T1(1,IRTTMP),TMP)
 102  CONTINUE
C
      CALL ORTXMR(NROOT,NO,NU,NOUP,IDIM,T1,T2,TI,BAA,AA,RES,MEMS0,MEMS1)
      RESMAX=RES(IDAMAX(NROOT,RES,1))
C
      WRITE(IW,9010) NSP,IDIM,RESMAX,(EVAL(I),I=1,NROOT)
      CALL FLSHBF(IW)
C
C ** ADDED BY KK --- SPUST UZBIEZNIONYCH
C
      DO 650,IKK=1,NROOT
        ISREP=0
        XXX=ABS(RES(IKK))
        IF(XXX.LT.TOL) THEN
           XENE=EVAL(IKK)
C 27/05/2004 LEFT EOMSD ------------
           CALL RO1(3,NO,NU,T2AUX)
           CALL RO2HPP(1,NO,NU,TI,T2AUX(1+NOU))
           CALL SYMT21(T2AUX(1+NOU),NO,NU,NU,NO,23)
           R0A=TWO*DDOT(NOU,T2AUX,1,EV(1,IKK),1)
           R0B=DDOT(NO2U2,T2AUX(1+NOU),1,EV(NOU+1,IKK),1)
           R00=(R0A+R0B)/EVAL(IKK)
           CALL DCOPY(NOUP,EV(1,IKK),1,T2AUX,1)
           CALL SPINKA(NO,NU,T2AUX)
           Z=DDOT(NOUP,EV(1,IKK),1,T2AUX,1)
           Z=Z+R00*R00
           Z=ABS(Z)
           CALL DSCAL(NOUP,ONE/SQRT(Z),EV(1,IKK),1)
           R00=R00/SQRT(Z)
CCCX           R0A=TWO*DDOT(NOU,T2AUX,1,EV(1,IKK),1)
CCCX           R0B=DDOT(NO2U2,T2AUX(1+NOU),1,EV(NOU+1,IKK),1)
CCCX           R00=(R0A+R0B)/EVAL(IKK)
C ----------------------------------
           XR0=ABS(R00)
           IF(ICONT.EQ.0) THEN
            ICONT=1
            EXCON(ICONT)=XENE
            R0CON(ICONT)=R00
            CALL WCCFL(NAXX,ICONT,NOUP,EV(1,IKK))
C 27/05/2004 LEFT EOMSD ------------
              CALL DSCAL(NOUP,SQRT(Z),EV(1,IKK),1) !!LEFT-RIGHT
C ----------------------------------
            IZAPIS=IZAPIS+1
           ELSE
            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
            IF(ISREP.EQ.0) THEN
             ICONT=ICONT+1
             EXCON(ICONT)=XENE
             R0CON(ICONT)=R00
             CALL WCCFL(NAXX,ICONT,NOUP,EV(1,IKK))
C 27/05/2004 LEFT EOMSD ------------
              CALL DSCAL(NOUP,SQRT(Z),EV(1,IKK),1)  !!LEFT-RIGHT
C ----------------------------------
             IZAPIS=IZAPIS+1
            END IF
           END IF
        END IF
C
CDBG    WRITE(6,*) '   '
CDBG    WRITE(6,*) 'IKK=',IKK
CDBG    WRITE(6,*) 'TOL:',TOL
CDBG    WRITE(6,*) 'RES(IKK)',RES(IKK)
CDBG    WRITE(6,*) 'EVAL(IKK)',EVAL(IKK)
CDBG    WRITE(6,*) 'EXCON',(EXCON(III),III=1,5)
CDBG    WRITE(6,*) 'XEDIFF XRDIFF',XEDIFF,XRDIFF
CDBG    WRITE(6,*) 'ISREP',ISREP
CDBG    WRITE(6,*) 'ICONT',ICONT
CDBG    WRITE(6,*) 'IZAPIS',IZAPIS
CDBG    CALL FLSHBF(6)
C
 650  CONTINUE
C
      IDIM=IDIM+1
      IF(IDIM.GT.LMICRO) THEN
         IDIM=1
         DO IROOT=1,NROOT
            CALL WCCFL(NAX,IROOT,NOUP,EV(1,IROOT))
         ENDDO
C
         CALL ORTXEV(NROOT,NO,NU,NOUP,EV,TMP)
C
         DO IROOT=1,NROOT
            CALL WCCFL(NC1,IROOT,NOU,EV(1,IROOT))
            CALL WCCFL(NC2,IROOT,NO2U2,EV(1+NOU,IROOT))
         ENDDO
      END IF
C
C         NEXT TEST IS TRUE IF WE HAVE NOT YET CONVERGED ALL STATES
C
      IF(RESMAX.GT.TOL) THEN
C
C         CHECK TO SEE IF WE HAVE DONE TOO MANY ITERATIONS,
C         OR IF WE ARE RIDICULOUSLY FAR FROM BEING CONVERGED.
C         IN THESE CASES WE SAVE CONVERGED AND UNCONVERGED ROOTS.
C
         NSP=NSP+1
         IF (NSP.GT.MAXITEOM)   WRITE(IW,9200)
         IF (RESMAX.GT.5.0D+03) WRITE(IW,9210)
C
         IF (RESMAX.GT.5.0D+03  .OR.  NSP.GT.MAXITEOM) THEN
            WRITE(IW,9220) ICONT
            DO III=1,ICONT
               CALL RCCFL(NAXX,III,NOUP,EV(1,1))
C 27/05/2004 LEFT EOMSD ------------------
CCCX ERROR      CALL FIXSYM(NO,NU,EV(1,III),EV(1+NOU,III),XSYM)
           CALL FIXSYM(NO,NU,EV(1,1),EV(1+NOU,1),XSYM)
C ----------------------------------------
               EOMSDE(III) = EXCON(III)
               EOMR0(III)  = R0CON(III)
               VECREP(III) = XSYM
C 27/05/2004 LEFT EOMSD ------------------
CCCX               IF(ABS(RES(III)).GT.TOL) THEN
CCCX                  KVGEOM(III) = 0
CCCX                  NBAD = NBAD+1
CCCX               ELSE
CCCX                  KVGEOM(III) = 1
CCCX               END IF
             KVGEOM(III) = 1
             XKKEOM(III) = EXCON(III)
             KKTRIM(III) = 1
             EOMR0L(III) = R0CON(III)
             WRITE(IW,9230) XSYM,EOMSDE(III),EOMSDE(III)*FEV,
     *                      EOMSDE(III)+ECCSD
             CALL WCCFL(NAX,III,NOUP,EV(1,1))
            ENDDO
C              FRANKLY, I DON'T SEE HOW THE NEXT COULD EVER BE TRUE
            IF(ICONT.GT.NROOT.AND.MTHTRIP.NE.0) THEN
              ICONT=NROOT
              WRITE(IW,9340) NROOT
            END IF
            NTOTEOM = ICONT
            CALL INDEXX(ICONT,EOMSDE,IUST,80,ISTACK,100)
C 27/05/2004 LEFT EOMSD ------------------
CCCX            NBADEOM = NBAD
            NBAD = 0
            NBADEOM =NBAD
            IBAD = 1
            RETURN
CCCX            GO TO 822
C ----------------------------------------
         END IF
C
C          PREPARE FOR CARRYING ON WITH THE NEXT ITERATION
C
         IF(IDIM.GT.1) THEN
            DO IROOT=1,NROOT
               CALL WCCFL(NC1,IDRT+IROOT,NOU,T1(1,IROOT))
               CALL WCCFL(NC2,IDRT+IROOT,NO2U2,T1(1+NOU,IROOT))
               CALL WCCFL(NAX,IROOT,NOUP,EV(1,IROOT))
            ENDDO
         END IF
         GO TO 777
      END IF
C
C     ---- IF WE GET HERE ALL ROOTS OF THE EOM HAVE CONVERGED ----
C
      DO IROOT=1,NROOT
C 27/05/2004 LEFT EOMSD ------------------
           CALL RO1(3,NO,NU,T2AUX)
           CALL RO2HPP(1,NO,NU,TI,T2AUX(1+NOU))
           CALL SYMT21(T2AUX(1+NOU),NO,NU,NU,NO,23)
           R0A=TWO*DDOT(NOU,T2AUX,1,EV(1,IROOT),1)
           R0B=DDOT(NO2U2,T2AUX(1+NOU),1,EV(NOU+1,IROOT),1)
           R00=(R0A+R0B)/EVAL(IROOT)
           CALL DCOPY(NOUP,EV(1,IROOT),1,T2AUX,1)
           CALL SPINKA(NO,NU,T2AUX)
           Z=DDOT(NOUP,EV(1,IROOT),1,T2AUX,1)
           Z=Z+R00*R00
           Z=ABS(Z)
           CALL DSCAL(NOUP,ONE/SQRT(Z),EV(1,IROOT),1)
           R00=R00/SQRT(Z)
C ----------------------------------------
         CALL WCCFL(NAX,IROOT,NOUP,EV(1,IROOT))
      ENDDO
C
C         PREPARATION WORK FOR COMPUTING R00'S
C
      CALL RO1(3,NO,NU,T2)
      CALL RO2HPP(1,NO,NU,TI,T2(1+NOU))
      CALL SYMT21(T2(1+NOU),NO,NU,NU,NO,23)
C
C         PRINT ENERGIES, AMPLITUDES, DIAGNOSTICS
C
      DO 500 IROOT=1,NROOT
         WRITE(IW,9020) IROOT,EVAL(IROOT),EVAL(IROOT)*FEV,
     *                  ECCSD+EVAL(IROOT)
         WRITE(IW,9030)
         IPOS=1
         DO IIIA=1,NU
            DO IIII=1,NO
               XXX=ABS(EV(IPOS,IROOT))
               IF(XXX.GT.TOLPR)
     *   WRITE(IW,9040) EV(IPOS,IROOT),IIII+NCCFZC,IIIA+NO+NCCFZC
               IPOS=IPOS+1
            ENDDO
         ENDDO
C
         IPOS=1
         DO JJJ=1,NO
            DO JJB=1,NU
               DO IIA=1,NU
                  DO III=1,NO
                     XXX=ABS(EV(IPOS+NOU,IROOT))
                     IF(XXX.GT.TOLPR) WRITE(IW,9050)
     *   EV(IPOS+NOU,IROOT),III+NCCFZC,JJJ+NCCFZC,
     *   IIA+NO+NCCFZC,JJB+NO+NCCFZC
                     IPOS=IPOS+1
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
C
         R0A=TWO*DDOT(NOU,T2,1,EV(1,IROOT),1)
         R0B=DDOT(NO2U2,T2(1+NOU),1,EV(NOU+1,IROOT),1)
         R00=(R0A+R0B)/EVAL(IROOT)
         ICROOT=ICROOT+1
         WRITE(IW,9060) R00
C
         CALL FIXSYM(NO,NU,EV(1,IROOT),EV(1+NOU,IROOT),XSYM)
         EOMSDE(IROOT) = EVAL(IROOT)
         EOMR0(IROOT)  = R00
         VECREP(IROOT) = XSYM
         KVGEOM(IROOT) = 1
         XKKEOM(IROOT) = EVAL(IROOT)
         KKTRIM(IROOT) = 1
         EOMR0L(IROOT) = R00
C
         XAEL=0.0D+00
         CALL AELKK(NO,NU,EV(1,IROOT),EV(NOU+1,IROOT),XAEL)
         WRITE(IW,9070) XAEL
  500 CONTINUE
      NTOTEOM = NROOT
      NBADEOM = 0
C 27/05/2004 LEFT EOMSD ------------------
      IBAD=0
C ----------------------------------------
C
C          --- PRINT A SORTED LIST OF ENERGIES AS SUMMARY ---
C
CCCX  822 CONTINUE
      CALL INDEXX(NROOT,EOMSDE,IUST,80,ISTACK,100)
      IF(NROOT.GT.0) THEN
         WRITE(IW,9300)
         WRITE(IW,9310)
      END IF
      ISY=0
      DO I=1,NROOT
         JGO=IUST(I)
         IF(VECREP(JGO).EQ.REP(IROOTCC(1))) THEN
            ISY=ISY+1
            IF(IROOTCC(2).EQ.ISY) BESTEOM=ECCSD+EOMSDE(JGO)
         END IF
         IF(KVGEOM(JGO).EQ.1) THEN
            YYKKCONV='     CONVERGED'
         ELSE
            YYKKCONV=' NOT CONVERGED'
         END IF
         WRITE(IW,9320) VECREP(JGO),EOMSDE(JGO),EOMSDE(JGO)*FEV,
     *                  EOMSDE(JGO)+ECCSD,YYKKCONV
      ENDDO
      IF(IROOTCC(2).EQ.0) BESTEOM = ECCSD
      WRITE(IW,*) ' '
      RETURN
C
 9000 FORMAT(/7X,'RESULTS  OF  THE  EOM-CCSD   ITERATIONS'//
     *       1X,'           AMPLITUDE     EXCITATION ENERGIES',
     *          ' (HARTREE)'/
     *       1X,'NSP IDIM    CONVERG.     TO ROOTS 1,  ...,',I4)
 9010 FORMAT(1X,2I3,F15.9,4F14.9/(22X,4F14.9))
 9020 FORMAT(/5X,'----- RESULTS FOR ROOT NUMBER',I4,' -----'/
     *       1X,'EXCITATION ENERGY=',F10.5,' HARTREE, OR',F10.5,' EV'/
     *       1X,'THE TOTAL ENERGY IS E(EOM-CCSD) =',F20.10)
 9030 FORMAT(1X,'THE LARGEST R1 AND R2 AMPLITUDES FOR THIS ROOT ARE')
 9040 FORMAT(1X,'R1=',F15.10,' FOR   I -> A   =',2I5)
 9050 FORMAT(1X,'R2=',F15.10,' FOR I,J -> A,B =',4I5)
 9060 FORMAT(1X,'GROUND STATE''S WEIGHT R0 = ',F15.10)
 9070 FORMAT(1X,'REL DIAGNOSTIC (R1*R1 + 2*R2*R2): ',F8.3)
C
 9200 FORMAT(1X,'DAVIDSONMR: TOO MANY ITERATIONS')
 9210 FORMAT(1X,'DAVIDSONMR: NORM OF RESIDUAL VECTOR TOO LARGE')
 9220 FORMAT(1X,I3,' CONVERGED VECTORS ARE STORED IN FILE -EOMRTMP-,'/
     *       5X,'AND CAN FURTHER BE USED BY THE MMEOM(2,3) PROGRAM.')
C 27/05/2004 LEFT EOMSD ------------------
 9230 FORMAT(4X,A3,4X,F15.8,6X,F8.3,4X,F15.8)
C ----------------------------------------
 9300 FORMAT(//15X,'---- SUMMARY OF EOM-CCSD CALCULATIONS ----'/)
 9310 FORMAT(17X,'EXCITATION',6X,'EXCITATION',6X,'TOTAL'/
     *       4X,'SYMMETRY',5X,'ENERGY (H)',6X,'ENERGY (EV)',5X,
     *       'ENERGY (H)',10X,'ITERATIONS')
 9320 FORMAT(7X,A3,2X,F15.8,6X,F8.3,4X,F15.8,5X,A14)
 9340 FORMAT(1X,'THE FIRST',I4,' ROOTS WILL BE PASSED TO MMCC(2,3)')
      END
C*MODULE EOMCC   *DECK DIAGT1
      SUBROUTINE DIAGT1(NO,NU,O1,T2,VE,OEH,OEP,NOU,NO2U2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION O1(NOU),T2(NO2U2),VE(NO2U2),OEH(NO),OEP(NU)
C
      CALL RO2(6,NO,NU,VE)
      CALL RO2(7,NO,NU,T2)
      CALL VECSUB(VE,T2,NO2U2)
      CALL TRANSQ(VE,NOU)
      CALL INSITU(NU,NO,NO,NU,T2,VE,12)
      CALL ADDGT1(NO,NU,T2,VE,OEH,OEP)
      CALL DCOPY(NOU,VE,NOU+1,O1,1)
      RETURN
      END
C*MODULE EOMCC   *DECK ADDF
      SUBROUTINE ADDF(N,F,OE)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION F(N,N),OE(N)
C
      DO I=1,N
      F(I,I)=F(I,I)+OE(I)
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK SMALMA
      SUBROUTINE SMALMA(NO,NU,NSP,T1,T2,AS,R,MEMS2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(*),T2(*),AS(MEMS2),R(MEMS2)
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
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
C
      IF (NSP.GT.1) THEN
         CALL RADCOPY(NSP,NSP-1,R,AS)
      END IF
C
      CALL RCCFL(NC1,NSP,NOU,T2)
      CALL RCCFL(NC2,NSP,NO2U2,T2(1+NOU))
      CALL SPINKA(NO,NU,T2)
      DO 15 I=NSP,1,-1
         CALL RCCFL(NHC1,I,NOU,T1)                           !NEW
         CALL RCCFL(NHC2,I,NO2U2,T1(1+NOU))                  !NEW
         JI=NSP+(I-1)*NSP
         AS(JI)=DDOT(NOUP,T2,1,T1,1)
 15   CONTINUE
C
      CALL RCCFL(NHC1,NSP,NOU,T1)                           !NEW
      CALL RCCFL(NHC2,NSP,NO2U2,T1(1+NOU))                  !NEW
      CALL SPINKA(NO,NU,T1)
      DO 16 I=NSP,1,-1
         CALL RCCFL(NC1,I,NOU,T2)
         CALL RCCFL(NC2,I,NO2U2,T2(1+NOU))
         JI=I+(NSP-1)*NSP
         AS(JI)=DDOT(NOUP,T1,1,T2,1)
 16   CONTINUE
      CALL DCOPY(NSP*NSP,AS,1,R,1)
      RETURN
      END
C*MODULE EOMCC   *DECK SMALMAMR
      SUBROUTINE SMALMAMR(NO,NU,NSP,T1,T2,R,AS,MEMS2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(*),T2(*),R(MEMS2),AS(MEMS2)
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
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
C
      DO 15 I=1,NSP
         CALL RCCFL(NC1,I,NOU,T2)
         CALL RCCFL(NC2,I,NO2U2,T2(1+NOU))
         CALL SPINKA(NO,NU,T2)
         DO 16 J=1,NSP
            CALL RCCFL(NHC1,J,NOU,T1)
            CALL RCCFL(NHC2,J,NO2U2,T1(1+NOU))
            IJ=(J-1)*NSP+I
            AS(IJ)=DDOT(NOUP,T2,1,T1,1)
   16    CONTINUE
   15 CONTINUE
C
      CALL DCOPY(NSP*NSP,AS,1,R,1)
C
      RETURN
      END
C*MODULE EOMCC   *DECK SELVEC
      SUBROUTINE SELVEC(NO,NU,NSP,TI,T1,T2,AS,EV,EVAL,IMAX)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(*),T1(*),T2(*),AS(*),EV(*)
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
      DATA ZERO/0.0D+00/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP=NOU+NO2U2
      CALL RCCFL(NAX,2,NOUP,EV)
      DO 1 I=1,NSP
      CALL RCCFL(NC1,I,NOU,T2)
      CALL RCCFL(NC2,I,NO2U2,T2(1+NOU))
      TI(I)=DDOT(NOUP,T2,1,EV,1)
 1    CONTINUE
      XMAX=ZERO
      IMAX=1
      DO 10 I=1,NSP
      X=ABS(DDOT(NSP,TI,1,T1(1+(I-1)*NSP),1))
      IF (X.GT.XMAX) THEN
      XMAX=X
      IMAX=I
      END IF
 10   CONTINUE
      EVAL=AS(NSP*NSP+IMAX)
      CALL COMB(NC1,NSP,NO,NU,T1(1+(IMAX-1)*NSP),T2,TI)
      CALL DCOPY(NOUP,TI,1,EV,1)
      RETURN
      END
C*MODULE EOMCC   *DECK SELVECMR
      SUBROUTINE SELVECMR(NO,NU,NOUP,IROOT,IDRT,TI,T1,T2,AS,EV,IMAX,
     *                    EVAL,MEMS0)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(*),T1(*),T2(*),AS(*),EV(NOUP,*),EVAL(MEMS0)
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
      DATA ZERO/0.0D+00/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      CALL RCCFL(NAX,IROOT,NOUP,EV(1,IROOT))
      DO I=1,IDRT
         CALL RCCFL(NC1,I,NOU,T1)
         CALL RCCFL(NC2,I,NO2U2,T1(1+NOU))
         TI(I)=DDOT(NOUP,T1,1,EV(1,IROOT),1)
      ENDDO
      XMAX=ZERO
      IMAX=1
      DO I=1,IDRT
         X=ABS(DDOT(IDRT,TI,1,T2(1+(I-1)*IDRT),1))
         IF (X.GT.XMAX) THEN
            XMAX=X
            IMAX=I
         END IF
      ENDDO
      EVAL(IROOT)=AS(IDRT*IDRT+IMAX)
      CALL COMB(NC1,IDRT,NO,NU,T2(1+(IMAX-1)*IDRT),T1,TI)
      CALL DCOPY(NOUP,TI,1,EV(1,IROOT),1)
      RETURN
      END
C*MODULE EOMCC   *DECK COMB
      SUBROUTINE COMB(NF,NSP,NO,NU,T2,T1,TI)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(*),T2(*),TI(*)
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
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
      CALL ZEROMA(TI,1,NOUP)
      DO I=1,NSP
         CALL RCCFL(NF,I,NOU,T1)
         IF(NF.EQ.NHC1) NF1=NHC2
         IF(NF.EQ.NC1)  NF1=NC2
         CALL RCCFL(NF1,I,NO2U2,T1(1+NOU))
         X=T2(I)
         CALL DAXPY(NOUP,X,T1,1,TI,1)
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK CHC1
      SUBROUTINE CHC1(NSP,NO,NU,C,HC,TI,VOE,OEH,OEP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(*),VOE(*),C(*),HC(*),OEH(NO),OEP(NU)
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
      DATA TWO/2.0D+00/,HALF/0.5D+00/
C
C        WORKING STORAGE -VOE- IS USED AS NO3U IN -RDVM-,
C             NOU3 IN -RDVE-, AND NO2U2 IN -RO2- AND -RO2HPP-
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 RCCFL(NC1,NSP,NOU,C)
      CALL ZEROMA(HC,1,NOU)
      CALL RCCFL(NHH,2,NU2,TI)
      CALL ADDF(NU,TI,OEP)
      CALL CCMATMUL(C,TI,HC,NO,NU,NU,1,0)
      CALL TRT1(NO,NU,TI,C)
      CALL TRT1(NO,NU,TI,HC)
      CALL RCCFL(NHH,1,NO2,TI)
      CALL ADDF(NO,TI,OEH)
      CALL CCMATMUL(C,TI,HC,NU,NO,NO,0,1)
      CALL TRT1(NU,NO,TI,HC)
      CALL RO2(6,NO,NU,VOE)
      CALL VECMUL(C,NOU,TWO)
      CALL CCMATMUL(VOE,C,HC,NOU,1,NOU,0,0)
      CALL VECMUL(C,NOU,HALF)
      CALL RO2(7,NO,NU,VOE)
      CALL CCMATMUL(VOE,C,HC,NOU,1,NOU,0,1)
      CALL TRT1(NU,NO,TI,C)
      CALL RCCFL(NC2,NSP,NO2U2,C)
      CALL RO2HPP(1,NO,NU,TI,VOE)
      CALL SYMT21(VOE,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,C,13)
      CALL RDVE(1,NO,NU,VOE)
      CALL SYMT21(VOE,NU,NU,NU,NO,23)
      CALL TRT1(NO,NU,TI,HC)
      CALL CCMATMUL(VOE,C,HC,NU,NO,NOU2,0,0)
      CALL TRT1(NU,NO,TI,HC)
      CALL RDVM(1,NO,NU,VOE)
      CALL SYMT21(VOE,NO,NO,NO,NU,23)
      CALL INSITU(NU,NU,NO,NO,TI,C,13)
      CALL TRANSQ(C,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,C,13)
      CALL CCMATMUL(VOE,C,HC,NO,NU,NO2U,0,1)
      CALL INSITU(NO,NO,NU,NU,TI,C,23)
      CALL TRANMD(C,NO,NU,NO,NU,13)
      CALL RO1(3,NO,NU,TI)
      CALL SYMT21(C,NO,NU,NO,NU,13)
      CALL CCMATMULT(C,TI,HC,NOU,1,NOU,0,0)
      CALL WCCFL(NHC1,NSP,NOU,HC)
      RETURN
      END
C*MODULE EOMCC   *DECK CHC2
      SUBROUTINE CHC2(NSP,NO,NU,C,HC,TI,VE,OEH,OEP,C13BDY,FP3BDY,
     *           T23BDY,VOE3BDY,NOU,NU2,NO2U2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(*),VE(*),C(NU,NO,NO,NU),HC(*),OEH(NO),OEP(NU),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2)
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
      DATA TWO/2.0D+00/,HALF/0.5D+00/
C
C       WORKING STORAGE -VE- IS USED AS
C          NO4 IN -RFL-, NU3 IN -RDVPPI-,
C          NO2U2 IN -RO2- AND -INSITU-,
C          NO3U IN -RDVM-, NOU3 IN -THREEB-
C       WHICH IS PERHAPS NOT A COMPLETE LIST!
C
      NO2   = NO*NO
      NO4   = NO*NO*NO*NO
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
C
      CALL ZEROMA(HC,1,NO2U2)
      CALL RCCFL(NC1,NSP,NOU,C)
      CALL RDVE(3,NO,NU,VE)
      CALL CCMATMUL(C,VE,HC,NO,NOU2,NU,0,0)
      CALL RDVM(3,NO,NU,VE)
      CALL TRANSQ(HC,NOU)
      CALL CCTMATMUL(C,VE,HC,NU,NO2U,NO,0,1)
      CALL TRANSQ(HC,NOU)
      CALL RCCFL(NC2,NSP,NO2U2,C)
      CALL RCCFL(NHH,2,NU2,TI)
      CALL ADDF(NU,TI,OEP)
      CALL TRANSQ(C,NOU)
      CALL TRANSQ(HC,NOU)
      CALL CCMATMUL(C,TI,HC,NO2U,NU,NU,0,0)
      CALL TRANSQ(HC,NOU)
      CALL TRANMD(C,NU,NO,NO,NU,23)
      CALL INSITU(NO,NU,NU,NO,TI,HC,13)
      CALL VECMUL(C,NO2U2,HALF)
C
      DO I=1,NU
         CALL RDVPPI(I,NU,VE)
         CALL CCMATMUL(VE,C(1,1,1,I),HC,NU2,NO2,NU,0,0)
      ENDDO
C
      CALL TRANMD(C,NU,NO,NO,NU,23)
      CALL TRANSQ(C,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,C,13)
      CALL RCCFL(NHH,3,NO4,VE)
      CALL MTRANS(VE,NO,11)
      CALL MTRANS(VE,NO,12)
      CALL CCMATMUL(C,VE,HC,NU2,NO2,NO2,0,0)
      CALL VECMUL(C,NO2U2,TWO)
      CALL INSITU(NU,NU,NO,NO,TI,C,13)
      CALL INSITU(NU,NU,NO,NO,TI,HC,13)
      CALL TRANMD(HC,NO,NU,NU,NO,14)
      CALL TRANMD(HC,NO,NU,NU,NO,23)
      CALL RCCFL(NHH,1,NO2,TI)
      CALL ADDF(NO,TI,OEH)
      CALL CCMATMUL(C,TI,HC,NOU2,NO,NO,0,1)
      CALL TRANMD(HC,NO,NU,NU,NO,14)
      CALL TRANMD(HC,NO,NU,NU,NO,23)
      CALL RO2(6,NO,NU,VE)
      CALL INSITU(NO,NU,NU,NO,TI,VE,12)
      CALL TRANSQ(VE,NOU)
      CALL SYMT21(C,NO,NU,NU,NO,23)
      CALL CCMATMUL(C,VE,HC,NOU,NOU,NOU,0,0)
      CALL DESM21(C,NO,NU,NU,NO,23)
      CALL RO2(7,NO,NU,VE)
      CALL INSITU(NO,NU,NU,NO,TI,VE,12)
      CALL TRANSQ(VE,NOU)
      CALL CCMATMUL(C,VE,HC,NOU,NOU,NOU,0,1)
      CALL TRANMD(C,NO,NU,NU,NO,23)
      CALL TRANMD(HC,NO,NU,NU,NO,23)
      CALL CCMATMUL(C,VE,HC,NOU,NOU,NOU,0,1)
      CALL TRANMD(HC,NO,NU,NU,NO,14)
      CALL THREEB(NSP,NO,NU,NOU,NU2,NO2U2,TI,C,HC,VE,
     *            C13BDY,FP3BDY,T23BDY,VOE3BDY)
      CALL SYMETR(HC,NO,NU)
      CALL WCCFL(NHC2,NSP,NO2U2,HC)
      RETURN
      END
C*MODULE EOMCC   *DECK THREEB
      SUBROUTINE THREEB(NSP,NO,NU,NOU,NU2,NO2U2,TI,C2,HC,VE,C1,FP,
     *                  T2,VOE)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(*),C2(*),HC(*),VE(*),C1(NOU),FP(NU2),
     *          T2(NO2U2),VOE(NO2U2)
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
      NO2=NO*NO
      NO2U=NO*NO*NU
      NOU2=NO*NU*NU
C
      CALL RCCFL(NC1,NSP,NOU,C1)
      CALL RCCFL(NC2,NSP,NO2U2,C2)
      CALL RDVM(1,NO,NU,VE)
      CALL SYMT21(VE,NO,NO,NO,NU,23)
      CALL CCMATMUL(VE,C1,FP,NO2,1,NOU,1,0)
      CALL TRT1(NO,NU,TI,C1)
      CALL TRANSQ(FP,NO)
      CALL INSITU(NO,NU,NU,NO,TI,C2,12)
      CALL TRANMD(C2,NU,NO,NU,NO,13)
      CALL RO2HPP(1,NO,NU,TI,VOE)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,12)
      CALL SYMT21(VOE,NO,NU,NO,NU,13)
      CALL CCMATMUL(VOE,C2,FP,NO,NO,NOU2,0,0)
      CALL RO2(1,NO,NU,T2)
      CALL CCMATMUL(T2,FP,HC,NOU2,NO,NO,0,1)
      CALL CCMATMUL(C2,VOE,FP,NU,NU,NO2U,1,1)
      CALL RDVE(1,NO,NU,VE)
      CALL SYMT21(VE,NU,NU,NU,NO,23)
      CALL CCMATMUL(VE,C1,FP,NU2,1, NOU,0,0)
      CALL TRANSQ(FP,NU)
      CALL RO2(1,NO,NU,T2)
      CALL TRANSQ(T2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,T2,13)
      CALL TRANMD(T2,NO,NO,NU,NU,12)
      CALL TRANSQ(HC,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,HC,13)
      CALL TRANMD(HC,NO,NO,NU,NU,12)
      CALL CCMATMUL(T2,FP,HC,NO2U,NU,NU,0,0)
      CALL TRANMD(HC,NO,NO,NU,NU,12)
      CALL INSITU(NO,NO,NU,NU,TI,HC,13)
      CALL TRANSQ(HC,NOU)
      RETURN
      END
C*MODULE EOMCC   *DECK SPINKA
      SUBROUTINE SPINKA(NO,NU,C)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION C(*)
C
      DATA TWO/2.0D+00/
C
      NOU = NO*NU
      CALL DSCAL(NOU,TWO,C,1)
      CALL SYMT21(C(NOU+1),NO,NU,NU,NO,23)
      RETURN
      END
C*MODULE EOMCC   *DECK RADCOPY
      SUBROUTINE RADCOPY(N,N1,R,AS)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION R(N1,N1),AS(N,N)
C
      CALL ZEROMA(AS,1,N*N)
      DO I=1,N1
         DO J=1,N1
            AS(I,J)=R(I,J)
         ENDDO
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK NORMT2
      SUBROUTINE NORMT2(NO,NU,A,B)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(*),B(*)
C
      DATA ONE/1.0D+00/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
      CALL DCOPY(NOUP,A,1,B,1)
      CALL SPINKA(NO,NU,B)
      Z=DDOT(NOUP,A,1,B,1)
      CALL DSCAL(NOUP,ONE/SQRT(Z),A,1)
      RETURN
      END
C*MODULE EOMCC   *DECK AELKK
       SUBROUTINE AELKK(NO,NU,R1,R2,XAEL)
       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
       DIMENSION R1(NO,NU),R2(NO,NU,NU,NO)
C
       DATA TWO/2.0D+00/,FOUR/4.0D+00/
C
       XAEL=0.0D+00
       DO 1,I=1,NO
       DO 2,IA=1,NU
        XAEL=XAEL+TWO*R1(I,IA)*R1(I,IA)
        XAEL=XAEL+TWO*R2(I,IA,IA,I)*R2(I,IA,IA,I)
 2     CONTINUE
 1     CONTINUE
       DO 3,I=1,NO
       DO 4,J=I+1,NO
       DO 5,IA=1,NU
       DO 6,IB=IA,NU
        IF(IA.EQ.IB) THEN
         XAEL=XAEL+FOUR*R2(I,IA,IA,J)*R2(I,IA,IA,J)
         GO TO 6
        ELSE
         XXX=(R2(I,IA,IB,J)-R2(I,IB,IA,J))*(R2(I,IA,IB,J)
     &       -R2(I,IB,IA,J))+R2(I,IA,IB,J)*R2(I,IA,IB,J)
     &       +R2(I,IB,IA,J)*R2(I,IB,IA,J)
         XAEL=XAEL+FOUR*XXX
        END IF
 6     CONTINUE
 5     CONTINUE
 4     CONTINUE
 3     CONTINUE
       DO 7,I=1,NO
       DO 8,IA=1,NU
       DO 9,IB=IA+1,NU
        XAEL=XAEL+FOUR*R2(I,IA,IB,I)*R2(I,IA,IB,I)
 9     CONTINUE
 8     CONTINUE
 7     CONTINUE
       RETURN
       END
C*MODULE EOMCC   *DECK TESTORT
      SUBROUTINE TESTORT(NROOT,NOUP,NO,NU,TI,T1)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(NOUP),T1(NOUP)
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
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
C
C        NEXT LINE IS JUST TO TURN OFF A FTNCHEK MESSAGE,
C        IN CASE ANYONE WANTS TO USE THE ORTHOGONALITY CHECK
C        BELOW, WE NEED TO BE PASSING IN THE -T1- ARRAY.
C
      T1(1) = 0.0D+00
C
      DO 10 I=1,NROOT
         CALL RCCFL(NC1,I,NOU,TI)
         CALL RCCFL(NC2,I,NO2U2,TI(NOU+1))
         CALL SPINKA(NO,NU,TI)
C
C               ORTHOGONALITY CHECK COMMENTED OUT
CDBG     DO J=I,NROOT
CDBG        CALL RCCFL(NC1,J,NOU,T1)
CDBG        CALL RCCFL(NC2,J,NO2U2,T1(NOU+1))
CDBG        X=DDOT(NOUP,T1,1,TI,1)
CDBG        WRITE(6,7) I,J,X
CDBG     ENDDO
CDBG7    FORMAT(2I3,F15.10)
C
 10   CONTINUE
      RETURN
      END
C*MODULE EOMCC   *DECK DAVCOR
      SUBROUTINE DAVCOR(NOUP,EVAL,T1,T2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(NOUP),T2(NOUP)
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
      CALL RCCFL(NDIAG,1,NOUP,T2)
C
      DO I=1,NOUP
         X=EVAL-T2(I)
         T1(I)=T1(I)/X
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK DIAGO
      SUBROUTINE DIAGO(N,A,C)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(*),C(*)
C
      I1=1              !MATRIX TO BE DIAGONALIZED
      I2=I1+N*N         !REAL PART OF EIGENVALUES
      I3=I2+N           !IMAGINARY PART OF EIGENVALUES
      I3A=I2+N*N
      CALL RG(N,N,A(I1),A(I2),A(I3),1,C(I1),C(I2),C(I3),IERR)
      CALL AFTERRG(N,A(I2),A(I3),C(I1),C(I2),C(I3A),0)
      RETURN
      END
C
C*MODULE EOMCC   *DECK AFTERRG
      SUBROUTINE AFTERRG(NORDER,EVALR,EVALI,EVEC,SCR,ISCR,IPRINT)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION EVALR(NORDER),EVEC(NORDER,NORDER),SCR(NORDER,NORDER),
     *          ISCR(NORDER),EVALI(NORDER)
C
      DATA ONE/1.0D+00/
C
      DO 10 I=1,NORDER
       ISCR(I)=I
10    CONTINUE
      CALL PIKSR2(NORDER,EVALR,ISCR)
C
      DO 11 I=1,NORDER
       J=ISCR(I)
       X=ONE/DNRM2(NORDER,EVEC(1,J),1)
       CALL DSCAL(NORDER,X,EVEC(1,J),1)
       CALL DCOPY(NORDER,EVEC(1,J),1,SCR(1,I),1)
11    CONTINUE
      CALL DCOPY(NORDER*NORDER,SCR,1,EVEC,1)
C
      DO 13 I=1,NORDER
       J=ISCR(I)
       CALL DCOPY(1,EVALI(J),1,SCR(I,1),1)
13    CONTINUE
      CALL DCOPY(NORDER,SCR,1,EVALI,1)
C
      IF(IPRINT.NE.0) THEN
       WRITE(6,999)
999    FORMAT(T4,'EIGENVALUE',T22,'REAL PART',T43,'IMAGINARY',
     &        ' PART')
       DO 14 I=1,NORDER
        WRITE(6,1000)I,EVALR(I),EVALI(I)
1000    FORMAT(T6,I6,T21,F12.6,T44,F12.6)
14     CONTINUE
      END IF
      IF(IPRINT.GT.10) THEN
       DO 12 I=1,NORDER
        WRITE(6,1001)I
        WRITE(6,'((8F10.7))')(EVEC(K,I),K=1,NORDER)
1001   FORMAT(T3,'EIGENVECTOR #',I3,':')
12     CONTINUE
      END IF
      RETURN
      END
C
C*MODULE EOMCC   *DECK EOMINIT
      SUBROUTINE EOMINIT(NO,NU,NOA,NUA,
     &           FHH,FPP,FHP,HHHH,HHHP,HPPH,PPPH,VPPP,TRANS,
     &           HM,WR,WI,VR,WORK,IPL1,IPL2,INDEX1,INDEX2,
     *           LABMO,IACTIVE,EH,EP,
     &           INISTART,ISMALLSD,IDIM,L1,NOPNU)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C NO - NUMBER OF CORRELATED OCCUPIED ORBITALS
C NU - NUMBER OF CORRELATED UNOCCUPIED ORBITALS
C GR - SYMMETRY GROUP (CHARACTER*3)
C IVECSYM - SYMMETRY SPECIFICATION (INTEGER VECTOR)
C ISORB - INTEGER VECTOR WITH ORBITAL SYMMETRIES
C NOA - NUMBER OF ACTIVE OCCUPIED CORRELATED ORBITALS
C NUA - NUMBER OF ACTIVE UNOCCUPIED CORRELATED ORBITALS
C IACTIVE - SPECIFICATION OF ACTIVENESS (INTEGER VECTOR)
C
C        THIS GROUP IS ORBITAL SYMMETRY ASSIGNMENT
C
      CHARACTER*3 VECREP
      LOGICAL ABELPT
      DIMENSION LABMO(L1),IACTIVE(NOPNU)
      CHARACTER*3 GR,REP
      CHARACTER*4 LBTEMP
      DIMENSION NREX(4),MCX(8,8,4)
      DIMENSION IVECSYM(8),LABREP(8)
C
      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
      CHARACTER*1 JOBVL,JOBVR
      DIMENSION HM(IDIM,IDIM),WR(IDIM),WI(IDIM),VR(IDIM,IDIM),
     *          WORK(4*IDIM)
C
C  TRANS - USED TO STORE A SINGLE INITIAL VECTOR IN THE FORM
C          CONSISTENT WITH S.A.K. CONVENTION
      DIMENSION TRANS(NO*NU+NO*NO*NU*NU)
C
      PARAMETER (MXAO=8192)
C
      COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                MXCCIT,MXRLEIT,NWRDCC,ICCCNV,ICCRST,IDSKCC
      COMMON /EOMINF/ ISPACE,IHSPACE,JCISPACE,ICIMET,IOPTMM,
     *                NROOT,NOAX,NUAX,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)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
C DATA BLOCK FOR MATRICES NRE AND MC
C
      DATA NREX/1,2,4,8/
      DATA MCX/
     &1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     &
     & 1,1,0,0,0,0,0,0, 1,-1,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,
     & 0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,
     & 0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,
     &
     & 1,1,1,1,0,0,0,0,      1,1,-1,-1,0,0,0,0, 1,-1,1,-1,0,0,0,0,
     & 1,-1,-1,1,0,0,0,0, 0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,
     & 0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,
     &
     & 1,1,1,1,1,1,1,1,      1,1,1,1,-1,-1,-1,-1,  1,1,-1,-1,1,1,-1,-1,
     & 1,1,-1,-1,-1,-1,1,1,  1,-1,1,-1,1,-1,1,-1,  1,-1,1,-1,-1,1,-1,1,
     & 1,-1,-1,1,1,-1,-1,1,  1,-1,-1,1,-1,1,1,-1/
C
      DO K=1,4
         DO J=1,8
            DO I=1,8
               MC(I,J,K) = MCX(I,J,K)
            ENDDO
         ENDDO
         NRE(K) = NREX(K)
      ENDDO
C
C         SET UP THE ORBITAL SYMMETRY INFORMATION
C         ROUTINE FIXSYM USES THESE DATA TO SET STATE SYMMETRY VALUES.
C
      WRITE(UNIT=GR,FMT='(A3)') GRPEOM
      IF(.NOT.ABELPT()) GR='C1 '
C
      WRITE(IW,9010) GR
      CALL REPFIX(IW,GR,REP,IG)
C
      NIRREP = NRE(IG)
      DO I=1,NIRREP
         LBTEMP(1:3) = REP(I)
         LBTEMP(4:4) = ' '
         READ(UNIT=LBTEMP,FMT='(A4)') LABREP(I)
      ENDDO
C
C        4 BYTE MO SYMMETRY LABELS ARE AVAILABLE ON DISK FROM THE SCF
C        USE THESE TO FILL -ISORB- WITH CORRECT INTEGER VALUES
C
      IF(GR.EQ.'C1 ') THEN
         DO I=1,NO+NU
            ISORB(I) = 1
         ENDDO
      ELSE
         CALL DAREAD(IDAF,IODA,LABMO,L1,255,1)
         NERR=0
         DO I=1,NO+NU
            LTEMP = LABMO(I+NCCFZC)
            MATCH=0
            DO J=1,NIRREP
               IF(LTEMP.EQ.LABREP(J)) MATCH=J
            ENDDO
            ISORB(I) = MATCH
            IF(MATCH.EQ.0) THEN
               WRITE(IW,9020) I+NCCFZC,LTEMP
               NERR=NERR+1
            END IF
         ENDDO
         IF(NERR.GT.0) THEN
            WRITE(IW,9030) NERR
            CALL ABRT
            STOP
         END IF
      END IF
C
C        COPY USER CHOICES FOR STATES/IRREP AND ACTIVE ORBITALS
C
      DO I=1,8
         IVECSYM(I) = NSTEOM(I)
      ENDDO
      DO I=1,NO+NU
         IACTIVE(I) = MOACTCC(I)
      ENDDO
C
C       THE SYMMETRY OF STATES IS BASED ON INPUT, INITIALLY,
C       AND GETS RECOMPUTED LATER AFTER EOM CONVERGES EACH ROOT.
C
      IGO=1
      DO I=1,NRE(IG)
         DO J=1,IVECSYM(I)
            VECREP(IGO)=REP(I)
            IGO=IGO+1
         ENDDO
      ENDDO
C
      JOBVL='N'
      JOBVR='V'
      LWORK=4*IDIM
C
      NROOT=0
      DO I=1,NRE(IG)
         NROOT=NROOT+IVECSYM(I)
      ENDDO
C
C MAIN LOOP FOR THE CI-LIST
C
C MAIN LOOP FOR EOMSD START
C
      IPREV=0
      DO 100 I=1,NRE(IG)
         IF(IVECSYM(I).EQ.0) GO TO 100
         IROOT=IVECSYM(I)
         DO 550,IJK1=1,IDIM
            WR(IJK1)=0.0D+00
            WI(IJK1)=0.0D+00
         DO 551,IJK2=1,IDIM
            VR(IJK1,IJK2)=0.0D+00
 551     CONTINUE
 550     CONTINUE
         CALL LIST12(NO,NU,NOA,NUA,MC,NRE,I,IG,ISORB,IACTIVE,
     *               IPL1,IPL2,ILC1,ILC2,INISTART,ISMALLSD)
         CALL FINDEX12(NO,NU,NOA,NUA,ILC1,ILC2,IPL1,IPL2,INDEX1,INDEX2,
     *                 INISTART)
         IF(INISTART.EQ.1) THEN
            CALL HFILL(NO,NU,NOA,NUA,ILC1,ILC2,IPL1,IPL2,INDEX1,INDEX2,
     *                 HM,FHH,FPP,FHP,HHHH,HHHP,HPPH,PPPH,VPPP,IDIM,
     *                 EH,EP)
         ELSE
            CALL CISFILL(NO,NU,ILC1,IPL1,INDEX1,HM,
     *                   FHH,FPP,FHP,HPPH,VPPP,IDIM,EH,EP)
         END IF
C
         NORDER=ILC1+ILC2
C
CDBG     WRITE(6,*) 'MATRIX -HM- IN -EOMINIT-'
CDBG     DO IPP=1,NORDER
CDBG        DO IQQ=1,NORDER
CDBG           WRITE(6,8) HM(IPP,IQQ),IPP,IQQ
CDBG        ENDDO
CDBG     ENDDO
CDBG     CALL FLSHBF(6)
CDBG8    FORMAT(F18.11,2I5)
C
         WRITE(IW,9050) ILC1+ILC2
         CALL DGEEV(JOBVL,JOBVR,NORDER,HM,IDIM,WR,WI,VL,IDIM,VR,IDIM,
     *               WORK,LWORK,INFO)
C
         IF(INFO.EQ.0) THEN
            WRITE(IW,9060) IROOT,REP(I)
         ELSE
            WRITE(IW,*) 'INITIAL DIAGONALIZATION ERROR INFO:',INFO
            CALL ABRT
            STOP
         END IF
C
         CALL EORDER(NO,NU,NOA,NUA,NORDER,IROOT,WR,WI,INDEXX,INFO1)
C
         IF(INFO1.EQ.0) THEN
            WRITE(IW,9070)
            WRITE(IW,9080) REP(I)
            DO IJK=1,IROOT
               WRITE(IW,9090) WR(INDEXX(IJK))
            ENDDO
         ELSE
            WRITE(IW,*) 'EOMINIT: PROBLEM IN INITIAL EIGENVAL. ORDERING'
            CALL ABRT
            STOP
         END IF
C
         CALL STOREINI(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,'ORBITAL',I5,' HAS UNKNOWN SYMMETRY LABEL ',A4)
 9030 FORMAT(1X,'UNABLE TO ASSIGN SYMMETRY TO',I5,' ORBITAL(S).'/
     *       1X,'PLEASE PROVIDE CRISPLY CONVERGED SCF ORBITALS!')
 9050 FORMAT(1X,'DIMENSION OF THE INITIAL GUESS MATRIX=',I6)
 9060 FORMAT(1X,I4,' INITIAL VECTORS OF ',A3,
     *       ' SYMMETRY HAVE BEEN FOUND.')
 9070 FORMAT(4X,'ORDERING OF THE INITIAL EIGENVALUES WAS SUCCESSFUL')
 9080 FORMAT(4X,'INITIAL EIGENVALUES OF ',A3,' SYMMETRY:')
 9090 FORMAT(5X,F20.10)
      END
C
C*MODULE EOMCC   *DECK HFILL
      SUBROUTINE HFILL(NO,NU,NOA,NUA,ILC1,ILC2,IPL1,IPL2,
     *                 INDEX1,INDEX2,HM,FHH,FPP,FHP,
     *                 HHHH,HHHP,HPPH,PPPH,VPPP,IDIM,EH,EP)
      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 IPL1(NO*NU,2),IPL2(NOA*NOA*NUA*NUA,4)
      DIMENSION INDEX1(NO,NU),INDEX2(NO,NU,NU,NO)
      DIMENSION HM(IDIM,IDIM)
      DIMENSION EH(NO),EP(NU)
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
      NO2=NO*NO
      NO3=NO*NO2
      NO4=NO*NO3
      NU2=NU*NU
C
      DO 1,I=1,IDIM
      DO 2,J=1,IDIM
        HM(I,J)=0.0D+00
 2    CONTINUE
 1    CONTINUE
      CALL RCCFL(NHH,2,NU2,FPP)
      CALL RCCFL(NHH,1,NO2,FHH)
      CALL RO1(3,NO,NU,FHP)
      CALL RCCFL(NHH,3,NO4,HHHH)
      CALL RDVM(1,NO,NU,HHHP)
      CALL RDVE(1,NO,NU,PPPH)
      CALL RO2(6,NO,NU,HPPH)
C SINGLES
      DO 3,IR=1,ILC1
       I=IPL1(IR,1)
       IA=IPL1(IR,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 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 RO2(7,NO,NU,HPPH)  !HPPH
      DO 19,IR=1,ILC1
       I=IPL1(IR,1)
       IA=IPL1(IR,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 RDVM(3,NO,NU,HHHP)
      CALL RDVE(3,NO,NU,PPPH)
      DO 22,IPP=1,ILC2
       IR=IPP+ILC1
       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 RO2(6,NO,NU,HPPH)
      DO 39,IPP=1,ILC2
       IR=IPP+ILC1
       I=IPL2(IPP,1)
       J=IPL2(IPP,2)
       IA=IPL2(IPP,3)
       IB=IPL2(IPP,4)
       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 RDVPPI(IFF,NU,VPPP)
       DO 46,IPP=1,ILC2
        IR=IPP+ILC1
        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
C
CDBG  WRITE(6,*) 'DIAGONAL OF MATRIX -HM- IN -HFILL-'
CDBG  DO I=1,ILC1+ILC2
CDBG     WRITE(6,8) HM(I,I),I
CDBG  ENDDO
CDBG  CALL FLSHBF(6)
CDBG8 FORMAT(F18.11,2I5)
C
      RETURN
      END
C
C*MODULE EOMCC   *DECK CISFILL
      SUBROUTINE CISFILL(NO,NU,ILC1,IPL1,INDEX1,HM,
     *                   FHH,FPP,FHP,HPPH,VPPP,IDIM,EH,EP)
      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(IDIM,IDIM)
C
      DO 1,I=1,IDIM
      DO 2,J=1,IDIM
        HM(I,J)=0.0D+00
 2    CONTINUE
 1    CONTINUE
C
C      CALL RCCFL(NHH,2,NU2,FPP)
C      CALL RCCFL(NHH,1,NO2,FHH)
C      CALL RO1(3,NO,NU,FHP)
C      CALL RO2(6,NO,NU,HPPH)
C
       CALL RF(NO,NU,FHH,FPP,FHP)
       CALL RO2HPP(1,NO,NU,VPPP,HPPH)
C
C SINGLES
C
      DO 3,IR=1,ILC1
       I=IPL1(IR,1)
       IA=IPL1(IR,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
C
        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
C      CALL RO2(7,NO,NU,HPPH)  !HPPH
      CALL RO2HPP(2,NO,NU,VPPP,HPPH)
      DO 19,IR=1,ILC1
       I=IPL1(IR,1)
       IA=IPL1(IR,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
CDBG  WRITE(6,*) 'DIAGONAL OF MATRIX -HM- IN -CISFILL-'
CDBG  DO I=1,IDIM
CDBG     DO J=1,IDIM
CDBG        WRITE(6,8) HM(I,I),I,I
CDBG     ENDDO
CDBG  ENDDO
CDBG  CALL FLSHBF(6)
CDBG8 FORMAT(F18.11,2I5)
C
      RETURN
      END
C
C*MODULE EOMCC   *DECK LIST12
      SUBROUTINE LIST12(NO,NU,NOA,NUA,MC,NRE,ISKK,IG,ISORB,IACTIVE,
     *                  IPL1,IPL2,ILC1,ILC2,INISTART,ISMALLSD)
      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 INISTART
      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
C SINGLES
C
      DO 6 I=1,NO
        DO 5 IA=1,NU
          IF(ISMALLSD.EQ.1) THEN
            IACTSD=IACTIVE(I)+IACTIVE(IA)
            IF(IACTSD.NE.2) GO TO 5
          END IF
          IDIFF=0
          DO 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
          ENDDO
          ILC1=ILC1+1
          IPL1(ILC1,1)=I
          IPL1(ILC1,2)=IA
    5   CONTINUE
    6 CONTINUE
C
C INISTART
C
      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
C
      RETURN
      END
C
C*MODULE EOMCC   *DECK FINDEX12
      SUBROUTINE FINDEX12(NO,NU,NOA,NUA,ILC1,ILC2,IPL1,IPL2,
     &                    INDEX1,INDEX2,INISTART)
      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 INISTART
C
      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    CONTINUE
C
C INISTART
C
      IF(INISTART.EQ.1) THEN
         DO 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
            INDEX2(I2,IA2,IA1,I1)=I+ILC1
         ENDDO
      END IF
C
      RETURN
      END
C
C*MODULE EOMCC   *DECK STOREINI
      SUBROUTINE STOREINI(NO,NU,NOA,NUA,INDEX1,INDEX2,VR,TRANS,
     *                    IROOT,IPREV,INDEXX,INISTART)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION INDEX1(NO,NU),INDEX2(NO,NU,NU,NO),
     *          VR(NO*NU+NOA*NOA*NUA*NUA,NO*NU+NOA*NOA*NUA*NUA),
     *          TRANS(NO*NU+NO*NO*NU*NU)
C
      DIMENSION INDEXX(*)
C
      DO 1,IR=1,IROOT
        ICOL=INDEXX(IR)
        CALL ZEROMA(TRANS,1,NO*NU+NO*NO*NU*NU)
C SINGLES
        INE=0
        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
C
        CALL WSTAR(IR+IPREV,NO*NU+NO*NO*NU*NU,TRANS)
 1    CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK REPFIX
      SUBROUTINE REPFIX(IW,GR,REP,IG)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      CHARACTER*3 GR,REP(8)
C
      IF (GR.EQ.'C1 ') THEN
         IG=1
         REP(1)='A  '
         RETURN
      END IF
C
      IF (GR.EQ.'C2 ' .OR. GR.EQ.'CS ' .OR. GR.EQ.'CI ') IG=2
      IF (GR.EQ.'C2 ') THEN
         REP(1)='A  '
         REP(2)='B  '
         RETURN
      END IF
      IF (GR.EQ.'CS ') THEN
         REP(1)="A' "
         REP(2)="A''"
         RETURN
      END IF
      IF (GR.EQ.'CI ') THEN
         REP(1)='AG '
         REP(2)='AU '
         RETURN
      END IF
C
      IF (GR.EQ.'C2V' .OR. GR.EQ.'C2H' .OR. GR.EQ.'D2 ') IG=3
      IF (GR.EQ.'C2V') THEN
         REP(1)='A1 '
         REP(2)='A2 '
         REP(3)='B1 '
         REP(4)='B2 '
         RETURN
      END IF
      IF (GR.EQ.'C2H') THEN
         REP(1)='AG '
         REP(2)='AU '
         REP(3)='BG '
         REP(4)='BU '
         RETURN
      END IF
      IF (GR.EQ.' D2') THEN
         REP(1)='A  '
         REP(2)='B1 '
         REP(3)='B2 '
         REP(4)='B3 '
         RETURN
      END IF
      IF (GR.EQ.'D2H') THEN
         IG=4
         REP(1)='AG '
         REP(2)='AU '
         REP(3)='B1G'
         REP(4)='B1U'
         REP(5)='B2G'
         REP(6)='B2U'
         REP(7)='B3G'
         REP(8)='B3U'
         RETURN
      END IF
C
      WRITE(IW,*) 'ERROR IN THE EOM-CCSD SYMMETRY ASSIGNMENT.'
      WRITE(IW,*) 'CHOOSE POINT GROUPS ONLY FROM THE ABELIAN GROUPS:'
      WRITE(IW,*) 'C1,  C2,CS,CI,   C2V,C2H,D2,  D2H'
      CALL ABRT
      STOP
      END
C
C*MODULE EOMCC   *DECK EORDER
      SUBROUTINE EORDER(NO,NU,NOA,NUA,NORDER,IROOT,WR,WI,INDEXX,INFO1)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION WR(NO*NU+NOA*NOA*NUA*NUA),WI(NO*NU+NOA*NOA*NUA*NUA),
     *          INDEXX(100)
C
      INFO1=0
      TOL=1.0D-10
      DO I=1,100
         INDEXX(I)=0
      ENDDO
      IMAG=0
      IF(IROOT.GT.NORDER) THEN
       WRITE(6,*) 'TOO MANY INITIAL VECTORS REQUESTED'
       INFO1=1
       RETURN
      END IF
      DO 2,I=1,NORDER
       XXX=ABS(WI(I))
       IF(XXX.GT.TOL) THEN
        WR(I)=0.0D+00
        IMAG=IMAG+1
       END IF
 2    CONTINUE
C  WR->WI
      DO 10,I=1,NORDER
       WI(I)=WR(I)
 10   CONTINUE
      IREAL=NORDER-IMAG
      IF(IROOT.GT.IREAL) THEN
       WRITE(6,*) 'TOO MANY INITIAL VECTORS REQUESTED'
       INFO1=1
       RETURN
      END IF
      DO 3,I=1,IROOT
       XMIN=1.0D+10
       IMIN=0
       DO 4,J=1,NORDER
        IF(WI(J).EQ.0.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)=0.0D+00
 3    CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK DENR3
      SUBROUTINE DENR3(NO,NU,APP,AHH,AHP,VPPP,VHHHH,VHPPH,FPP,FHH,
     &                 AH,AP,EH,EP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION APP(NU,NU,2),AHH(NO,NO,2),AHP(NO,NU,2),
     *          VPPP(NU,NU,NU),VHHHH(NO,NO,NO,NO),VHPPH(NO,NU,NU,NO),
     *          FPP(NU,NU),FHH(NO,NO),AH(NO),AP(NU),
     *          EH(NO),EP(NU)
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
      NO2 = NO*NO
      NU2 = NU*NU
      NOU = NO*NU
      NO4 = NO*NO*NO*NO
C
      CALL RCCFL(NHH,2,NU2,FPP)
      DO 1,IA=1,NU
       AP(IA)=FPP(IA,IA)+EP(IA)
 1    CONTINUE
      CALL RCCFL(NHH,1,NO2,FHH)
      DO 2,I=1,NO
       AH(I)=FHH(I,I)+EH(I)
 2    CONTINUE
      CALL RCCFL(NHH,3,NO4,VHHHH)
      DO 3,I=1,NO
      DO 4,J=1,NO
       AHH(I,J,1)=VHHHH(I,J,I,J)
 4    CONTINUE
 3    CONTINUE
      DO 5,I=1,NO
      DO 6,J=1,NO
       AHH(I,J,2)=VHHHH(I,J,J,I)
 6    CONTINUE
 5    CONTINUE
      CALL RO2(7,NO,NU,VHPPH)
      DO 7,I=1,NO
      DO 8,IA=1,NU
       AHP(I,IA,1)=VHPPH(I,IA,IA,I)
 8    CONTINUE
 7    CONTINUE
      CALL RO2(6,NO,NU,VHPPH)
      DO 9,I=1,NO
      DO 10,IA=1,NU
       AHP(I,IA,2)=VHPPH(I,IA,IA,I)
 10   CONTINUE
 9    CONTINUE
      DO 11,IA=1,NU
       CALL RDVPPI(IA,NU,VPPP)
       DO 12,IB=1,NU
        APP(IB,IA,1)=VPPP(IB,IA,IB)
        APP(IB,IA,2)=VPPP(IA,IB,IB)
 12    CONTINUE
 11   CONTINUE
C
      CALL WCCFL(ITAPP,1,   NO,AH )
      CALL WCCFL(ITAPP,2,   NU,AP )
      CALL WCCFL(ITAPP,3,2*NU2,APP)
      CALL WCCFL(ITAPP,4,2*NO2,AHH)
      CALL WCCFL(ITAPP,5,2*NOU,AHP)
      RETURN
      END
C
C*MODULE EOMCC   *DECK DENCI3
      SUBROUTINE DENCI3(NO,NU,APP,AHH,AHP,VPPP,VHHHH,VHPPH)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION APP(NU,NU,2),AHH(NO,NO,2),AHP(NO,NU,2),
     *          VPPP(NU,NU,NU),VHHHH(NO,NO,NO,NO),VHPPH(NO,NU,NU,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
C
      NOU = NO*NU
      NO2 = NO*NO
      NU2 = NU*NU
C
      CALL RDOV4(1,NU,NO,VPPP,VHHHH)
      DO 3,I=1,NO
      DO 4,J=1,NO
       AHH(I,J,1)=VHHHH(I,J,I,J)
 4    CONTINUE
 3    CONTINUE
      DO 5,I=1,NO
      DO 6,J=1,NO
       AHH(I,J,2)=VHHHH(I,J,J,I)
 6    CONTINUE
 5    CONTINUE
C
      CALL RO2HPP(2,NO,NU,VPPP,VHPPH)
      DO 7,I=1,NO
      DO 8,IA=1,NU
       AHP(I,IA,1)=VHPPH(I,IA,IA,I)
 8    CONTINUE
 7    CONTINUE
C
      CALL RO2HPP(1,NO,NU,VPPP,VHPPH)
      DO 9,I=1,NO
      DO 10,IA=1,NU
       AHP(I,IA,2)=VHPPH(I,IA,IA,I)
 10   CONTINUE
 9    CONTINUE
C
      DO 11,IA=1,NU
       CALL RDVPP(IA,NO,NU,VPPP)
       DO 12,IB=1,NU
        APP(IB,IA,1)=VPPP(IB,IA,IB)
        APP(IB,IA,2)=VPPP(IA,IB,IB)
 12    CONTINUE
 11   CONTINUE
C
      CALL WCCFL(ITAPP,6,2*NU2,APP)
      CALL WCCFL(ITAPP,7,2*NO2,AHH)
      CALL WCCFL(ITAPP,8,2*NOU,AHP)
      RETURN
      END
C
C*MODULE EOMCC   *DECK BAR3
      SUBROUTINE BAR3(NO,NU,T2,VR,AX,BX,TI)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T2(NO,NU,NU,NO),VR(NO,NU,NU,NO),
     *          AX(NU,NU,NO,2),BX(NU,NO,NO,2),TI(NU,NU,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
C
      NOU2 = NO*NU*NU
      NO2U = NO*NO*NU
C
      CALL RO2(1,NO,NU,T2)
      CALL RO2HPP(1,NO,NU,TI,VR)
C
C ZEROING OF THE MATICES
C
      DO 1,K=1,2
       DO 2,IA=1,NU
       DO 3,IB=1,NU
       DO 4,I=1,NO
        AX(IA,IB,I,K)=0.0D+00
 4     CONTINUE
 3     CONTINUE
 2     CONTINUE
       DO 5,IA=1,NU
       DO 6,I=1,NO
       DO 7,J=1,NO
        BX(IA,I,J,K)=0.0D+00
 7     CONTINUE
 6     CONTINUE
 5     CONTINUE
 1    CONTINUE
C AX(*,*,*,1-2)
      DO 8,IA=1,NU
      DO 9,IB=1,NU
      DO 10,K=1,NO
      DO 11,N=1,NO
       AX(IA,IB,K,1)=AX(IA,IB,K,1)+VR(N,IB,IA,K)*T2(N,IA,IB,K)
       AX(IA,IB,K,2)=AX(IA,IB,K,2)+VR(N,IB,IA,K)*T2(N,IB,IA,K)
 11   CONTINUE
 10   CONTINUE
 9    CONTINUE
 8    CONTINUE
C
C BX(*,*,*,1-2)
C
      DO 12,IA=1,NU
      DO 13,I=1,NO
      DO 14,J=1,NO
      DO 15,IE=1,NU
       BX(IA,I,J,1)=BX(IA,I,J,1)+VR(J,IA,IE,I)*T2(I,IE,IA,J)
       BX(IA,I,J,2)=BX(IA,I,J,2)+VR(J,IA,IE,I)*T2(I,IA,IE,J)
 15   CONTINUE
 14   CONTINUE
 13   CONTINUE
 12   CONTINUE
C
      CALL WCCFL(IFAX,1,2*NOU2,AX)
      CALL WCCFL(IFAX,2,2*NO2U,BX)
C
      RETURN
      END
C
C*MODULE EOMCC   *DECK ORT3
      SUBROUTINE ORT3(NO,NU,N,ND,VA,VX,TMP,R)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION VA(N),VX(N),TMP(N)
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
      DATA ONE /1.0D+00/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      XT12=DDOT(N,VA,1,TMP,1)
      R=SQRT(XT12)
      X = ONE / R
      CALL DSCAL(N,X,VA,1)
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      DO 10 I=ND ,1 ,-1
      CALL RCCFL(NC1,I,NOU,VX)
      CALL RCCFL(NC2,I,NO2U2,VX(NOU+1))
      RX=DDOT(N,VX,1,TMP,1)
      CALL DAXPY(N,-RX,VX,1,VA,1)
10    CONTINUE
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      XT12=DDOT(N,VA,1,TMP,1)
      R2=SQRT(XT12)
      X=ONE/R2
      CALL DSCAL(N,X,VA,1)
      RETURN
      END
C
C*MODULE EOMCC   *DECK ORTX
      SUBROUTINE ORTX(NO,NU,N,ND,VA,VX,TMP,R,BAA,MEMS1)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION VA(N),VX(N),TMP(N),BAA(MEMS1)
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
      DATA ONE /1.0D+00/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
C
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      XT12=DDOT(N,VA,1,TMP,1)
      R=SQRT(XT12)
      X = ONE/R
      CALL DSCAL(N,X,VA,1)
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      DO 10 I=1,ND
      CALL RCCFL(NC1,I,NOU,VX)
      CALL RCCFL(NC2,I,NO2U2,VX(NOU+1))
      X12=DDOT(N,VX,1,TMP,1)
      RX=X12
      BAA(I)=RX
 10   CONTINUE
      DO 101 I=1,ND
      RX=BAA(I)
      CALL RCCFL(NC1,I,NOU,VX)
      CALL RCCFL(NC2,I,NO2U2,VX(NOU+1))
      CALL DAXPY(N,-RX,VX,1,VA,1)
 101  CONTINUE
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      X12=DDOT(N,VA,1,TMP,1)
      R2=SQRT(X12)
      X=ONE/R2
      CALL DSCAL(N,X,VA,1)
      RETURN
      END
C*MODULE EOMCC   *DECK ORTXEV
      SUBROUTINE ORTXEV(NROOT,NO,NU,N,VA,VX)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION VA(N,NROOT),VX(N)
C
      DATA ONE/1.0D+00/
C
      DO 110 IROOT=1,NROOT
      CALL DCOPY(N,VA(1,IROOT),1,VX,1)
      CALL SPINKA(NO,NU,VX)
      XT12=DDOT(N,VA(1,IROOT),1,VX,1)
      RR=SQRT(XT12)
      X = ONE/RR
      CALL DSCAL(N,X,VA(1,IROOT),1)
 110  CONTINUE
      DO 111 IROOT=2,NROOT
      CALL DCOPY(N,VA(1,IROOT),1,VX,1)
      CALL SPINKA(NO,NU,VX)
      DO 5 I=1,IROOT-1
      X=DDOT(N,VA(1,I),1,VX,1)
      CALL DAXPY(N,-X,VA(1,I),1,VA(1,IROOT),1)
 5    CONTINUE
      CALL DCOPY(N,VA(1,IROOT),1,VX,1)
      CALL SPINKA(NO,NU,VX)
      X12=DDOT(N,VA(1,IROOT),1,VX,1)
      R2=SQRT(X12)
      X=ONE/R2
      CALL DSCAL(N,X,VA(1,IROOT),1)
 111  CONTINUE
      RETURN
      END
C*MODULE EOMCC   *DECK ORTXMR
      SUBROUTINE ORTXMR(NROOT,NO,NU,N,ND,VA,VX,TMP,
     *                  BAA,AA,RES,MEMS0,MEMS1)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION VA(N,NROOT),VX(N),TMP(N),BAA(MEMS1),AA(MEMS0),RES(MEMS0)
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
      DATA ONE /1.0D+00/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
C
      DO 110 IROOT=1,NROOT
      CALL DCOPY(N,VA(1,IROOT),1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      XT12=DDOT(N,VA(1,IROOT),1,TMP,1)
      RES(IROOT)=SQRT(XT12)
      X = ONE/RES(IROOT)
      CALL DSCAL(N,X,VA(1,IROOT),1)
      CALL DCOPY(N,VA(1,IROOT),1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
C
      DO 5 I=1,IROOT-1
      AA(I)=DDOT(N,VA(1,I),1,TMP,1)
 5    CONTINUE
      DO 6 I=1,IROOT-1
      CALL DAXPY(N,-AA(I),VA(1,I),1,VA(1,IROOT),1)
 6    CONTINUE
C      CALL DCOPY(N,VA(1,IROOT),1,TMP,1)
      NDMR=ND*NROOT
      DO 10 I=1,NDMR
      CALL RCCFL(NC1,I,NOU,VX)
      CALL RCCFL(NC2,I,NO2U2,VX(NOU+1))
      X12=DDOT(N,VX,1,TMP,1)
      RX=X12
      BAA(I)=RX
 10   CONTINUE
      DO 101 I=1,NDMR
      RX=BAA(I)
      CALL RCCFL(NC1,I,NOU,VX)
      CALL RCCFL(NC2,I,NO2U2,VX(NOU+1))
      CALL DAXPY(N,-RX,VX,1,VA(1,IROOT),1)
 101  CONTINUE
      CALL DCOPY(N,VA(1,IROOT),1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      X12=DDOT(N,VA(1,IROOT),1,TMP,1)
      R2=SQRT(X12)
      X=ONE/R2
      CALL DSCAL(N,X,VA(1,IROOT),1)
 110  CONTINUE
      RETURN
      END
C*MODULE EOMCC   *DECK PIKSR2
      SUBROUTINE PIKSR2(N,ARR,NLIST)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION ARR(N),NLIST(N)
C
C SIMPLE SORTER FROM NUMERICAL RECIPES.
C
      DO 12 J=2,N
        A=ARR(J)
        NLST=NLIST(J)
        DO 11 I=J-1,1,-1
         IF(ARR(I).LE.A) GO TO 10
         ARR(I+1)=ARR(I)
         NLIST(I+1)=NLIST(I)
   11 CONTINUE
      I=0
   10 ARR(I+1)=A
      NLIST(I+1)=NLST
   12 CONTINUE
      RETURN
      END
C
C
C
C
C
C
C
C
C  (1+LAMBDA) VECTOR
C  LEFT EOMCCSD EIGENVECTORS
C  ONE-BODY CCSD/EOMCCSD DENSITY MATRIX
C  27/05/2004
C
C
C
C
C
C LEFT-RIGHT EIGENVECTORS 12/09/2003
C MARTA WLOCH ADDED LHL1 LHL2 THREEBL
C*MODULE EOMCC   *DECK LHL1
      SUBROUTINE LHL1(NSP,NO,NU,C,HC,TI,VOE,OEH,OEP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(*),VOE(*),C(*),HC(*),OEH(NO),OEP(NU)
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 /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C
      DATA TWO/2.0D+00/,HALF/0.5D+00/
C
C        WORKING STORAGE -VOE- IS USED AS NO3U IN -RDVM-,
C             NOU3 IN -RDVE-, AND NO2U2 IN -RO2- AND -RO2HPP-
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
      CALL RCCFL(NL1,NSP,NOU,C) ! IE /\ L1 ?
      CALL ZEROMA(HC,1,NOU)     ! HC->LH
      CALL RCCFL(NHH,2,NU2,TI) !AE
      CALL ADDF(NU,TI,OEP)
C C(IE)TI(EA)->(IA)
      CALL CCMATMULT(C,TI,HC,NO,NU,NU,0,0)
      CALL TRT1(NO,NU,TI,C) !AM
      CALL TRT1(NO,NU,TI,HC) !AI
      CALL RCCFL(NHH,1,NO2,TI) !IM
      CALL ADDF(NO,TI,OEH)
C C(AM)TI(MI)->(AI)
      CALL CCMATMULT(C,TI,HC,NU,NO,NO,0,1)
      CALL TRT1(NU,NO,TI,C)
      CALL RO2(6,NO,NU,VOE) !MEAI
      CALL VECMUL(C,NOU,TWO)
C 2(AIME)(ME)->(AI)
      CALL CCTMATMUL(VOE,C,HC,NOU,1,NOU,0,0)
      CALL VECMUL(C,NOU,HALF)
      CALL RO2(7,NO,NU,VOE) !MEAI
C (AIME)(ME)->(AI)
      CALL CCTMATMUL(VOE,C,HC,NOU,1,NOU,0,1)
      CALL TRT1(NU,NO,TI,HC) !IA
CCCCCCCC
      CALL RCCFL(NL2,NSP,NO2U2,C) ! MEFI /\ /\ L2
C
C ZAMIANA DASZKOW /\ NA \/
C RDVE(1,NO,NU,VOE)->RDVE(3,NO,NU,VOE)
C RDVM(1,NO,NU,VOE)->RDVM(3,NO,NU,VOE)
C RO1(3,NO,NU,TI)  _>RO1(1,NO,NU,T1)
C
      CALL INSITU(NO,NU,NU,NO,TI,C,13) !FEMI
CCC      CALL RDVE(1,NO,NU,VOE)
      CALL RDVE(3,NO,NU,VOE) !AFEM
      CALL SYMT21(VOE,NU,NU,NU,NO,23)
      CALL TRT1(NO,NU,TI,HC) !AI
C [2VOE(AFEM)-(AEFM)]C(FEMI)->AI
      CALL CCMATMUL(VOE,C,HC,NU,NO,NOU2,0,0)
      CALL TRT1(NU,NO,TI,HC) !IA
CCC      CALL RDVM(1,NO,NU,VOE)
      CALL RDVM(3,NO,NU,VOE) !INME
      CALL SYMT21(VOE,NO,NO,NO,NU,23)
      CALL INSITU(NU,NU,NO,NO,TI,C,13) !NAEM
      CALL TRANSQ(C,NOU) !EMNA
      CALL INSITU(NU,NO,NO,NU,TI,C,13) !NMEA
C [2VE(INME)-(IMNE)]C(NMEA)->IA
      CALL CCMATMUL(VOE,C,HC,NO,NU,NO2U,0,1)
CCCCCCCCCCCC
C      CALL ZEROMA(HC,1,NOU)     ! DEBUG
      CALL WCCFL(NHL1,NSP,NOU,HC)
      RETURN
      END
C*MODULE EOMCC   *DECK LHL2
      SUBROUTINE LHL2(NSP,NO,NU,C,HC,TI,VE,OEH,OEP,C13BDY,FP3BDY,
     *           T23BDY,VOE3BDY,NOU,NU2,NO2U2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(*),VE(*),C(*),HC(NO,NO,NU,NU),OEH(NO),OEP(NU),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2)
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 /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C
      DATA TWO/2.0D+00/,HALF/0.5D+00/
C
C       WORKING STORAGE -VE- IS USED AS
C          NO4 IN -RFL-, NU3 IN -RDVPPI-,
C          NO2U2 IN -RO2- AND -INSITU-,
C          NO3U IN -RDVM-, NOU3 IN -THREEB-
C       WHICH IS PERHAPS NOT A COMPLETE LIST!
C
      NO2   = NO*NO
      NO4   = NO*NO*NO*NO
      NO2U  = NO*NO*NU
      NOU2  = NO*NU*NU
C
      CALL ZEROMA(HC,1,NO2U2)
      CALL RCCFL(NL1,NSP,NOU,C) !IE
CCC      CALL RDVE(3,NO,NU,VE)
      CALL RDVE(1,NO,NU,VE) !EABJ DASZEK W DOL /\
C C(IE)VE(EABJ)-> (IABJ)
      CALL CCMATMUL(C,VE,HC,NO,NOU2,NU,0,0)
CCC      CALL RDVM(3,NO,NU,VE)
      CALL RDVM(1,NO,NU,VE) !MJIA
      CALL TRANSQ(HC,NOU) !BJIA
C C(BM)VE(MJIA)-> (BJIA)
      CALL CCTMATMUL(C,VE,HC,NU,NO2U,NO,0,1)
      CALL TRANSQ(HC,NOU)
CCCCCCCCCCC NOWY DIAGRAM NIE ZWIAZANY
      CALL RO1(3,NO,NU,VE) !IA
      CALL TRT1(NO,NU,TI,VE)
C (IA)(BJ)->IABJ
      CALL CCMATMUL(C,VE,HC,NOU,NOU,1,0,0)
CCCCCCCC NIE ZWIAZANY
      CALL RCCFL(NL2,NSP,NO2U2,C)
      CALL RCCFL(NHH,2,NU2,TI)
      CALL TRANSQ(TI,NU)
      CALL ADDF(NU,TI,OEP)
      CALL TRANSQ(C,NOU)
      CALL TRANSQ(HC,NOU)
      CALL CCMATMUL(C,TI,HC,NO2U,NU,NU,0,0)
      CALL TRANSQ(C,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,C,13)
      CALL INSITU(NU,NO,NO,NU,TI,HC,13)
      CALL VECMUL(C,NO2U2,HALF)
C
      DO I=1,NU
         CALL RDVPPI(I,NU,VE) !FEBA
C (BAFE)(FIJE)->(BAIJ)
         CALL CCTMATMUL(C,VE,HC(1,1,1,I),NO2,NU,NU2,0,0)
      ENDDO
      CALL INSITU(NO,NO,NU,NU,TI,HC,13)
      CALL TRANSQ(HC,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,HC,13)
      CALL RCCFL(NHH,3,NO4,VE)
CCC      CALL MTRANS(VE,NO,11)
CCC      CALL MTRANS(VE,NO,12)
      CALL CCMATMUL(C,VE,HC,NU2,NO2,NO2,0,0)
      CALL VECMUL(C,NO2U2,TWO)
      CALL INSITU(NU,NU,NO,NO,TI,C,13)
      CALL INSITU(NU,NU,NO,NO,TI,HC,13)
      CALL TRANMD(HC,NO,NU,NU,NO,14)
      CALL TRANMD(HC,NO,NU,NU,NO,23)
      CALL RCCFL(NHH,1,NO2,TI)
      CALL TRANSQ(TI,NO)
      CALL ADDF(NO,TI,OEH)
      CALL CCMATMUL(C,TI,HC,NOU2,NO,NO,0,1)
      CALL TRANMD(HC,NO,NU,NU,NO,14)
      CALL TRANMD(HC,NO,NU,NU,NO,23)
      CALL RO2(6,NO,NU,VE)
      CALL INSITU(NO,NU,NU,NO,TI,VE,12)
CCC      CALL TRANSQ(VE,NOU)
      CALL SYMT21(C,NO,NU,NU,NO,23)
      CALL CCMATMUL(C,VE,HC,NOU,NOU,NOU,0,0)
      CALL DESM21(C,NO,NU,NU,NO,23)
      CALL RO2(7,NO,NU,VE)
      CALL INSITU(NO,NU,NU,NO,TI,VE,12)
CCC      CALL TRANSQ(VE,NOU)
      CALL CCMATMUL(C,VE,HC,NOU,NOU,NOU,0,1)
      CALL TRANMD(C,NO,NU,NU,NO,23)
      CALL TRANMD(HC,NO,NU,NU,NO,23)
      CALL CCMATMUL(C,VE,HC,NOU,NOU,NOU,0,1)
      CALL TRANMD(HC,NO,NU,NU,NO,14)
      CALL THREEBL(NSP,NO,NU,NOU,NU2,NO2U2,TI,C,HC,VE,
     *            C13BDY,FP3BDY,T23BDY,VOE3BDY)
      CALL SYMETR(HC,NO,NU)
C      CALL ZEROMA(HC,1,NO2U2)
      CALL WCCFL(NHL2,NSP,NO2U2,HC)
      RETURN
      END
C*MODULE EOMCC   *DECK THREEBL
      SUBROUTINE THREEBL(NSP,NO,NU,NOU,NU2,NO2U2,TI,C2,HC,VE,HC1,FP,
     *                  T2,VOE)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TI(*),C2(*),HC(*),VE(*),HC1(NOU),FP(NU2),
     *          T2(NO2U2),VOE(NO2U2)
C
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C
      NO2=NO*NO
      NO2U=NO*NO*NU
      NOU2=NO*NU*NU
C
      CALL RCCFL(NHL1,NSP,NOU,HC1)    !HC1
C
      CALL RCCFL(NL2,NSP,NO2U2,C2) !MFEJ
      CALL RO2(1,NO,NU,T2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL TRANMD(T2,NU,NO,NU,NO,13)
      CALL RDVM(1,NO,NU,VE)            !HC1
      CALL SYMT21(VE,NO,NO,NO,NU,23)   !HC1
      CALL TRANSQ(C2,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,C2,12)
      CALL SYMT21(C2,NO,NU,NO,NU,13)
C
      CALL CCMATMUL(C2,T2,FP,NO,NO,NOU2,1,0)
      CALL RO2HPP(1,NO,NU,TI,VOE)
      CALL TRANSQ(FP,NO)                    !HC1
      CALL CCMATMUL(VOE,FP,HC,NOU2,NO,NO,0,1)
      CALL TRANSQ(FP,NO)                    !HC1
C
      CALL CCMATMUL(FP,VE,HC1,1,NOU,NO2,0,1) !HC1
      CALL CCMATMUL(T2,C2,FP,NU,NU,NO2U,1,1)
      CALL RDVE(1,NO,NU,VE)                  !HC1
      CALL SYMT21(VE,NU,NU,NU,NO,23)         !HC1
      CALL TRT1(NO,NU,TI,HC1)                !HC1
C
      CALL TRANSQ(FP,NU)
      CALL CCMATMUL(FP,VE,HC1,1,NOU,NU2,0,1) !HC1
C      CALL TRANSQ(FP,NU)
      CALL TRT1(NU,NO,TI,HC1)
      CALL TRANSQ(VOE,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VOE,13)
      CALL TRANMD(VOE,NO,NO,NU,NU,12)
      CALL TRANSQ(HC,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,HC,13)
      CALL TRANMD(HC,NO,NO,NU,NU,12)
      CALL TRANSQ(FP,NU)
      CALL CCMATMUL(VOE,FP,HC,NO2U,NU,NU,0,0)
      CALL TRANMD(HC,NO,NO,NU,NU,12)
      CALL INSITU(NO,NO,NU,NU,TI,HC,13)
      CALL TRANSQ(HC,NOU)
      CALL WCCFL(NHL1,NSP,NOU,HC1)           !HC1
      RETURN
      END
C
C*MODULE EOMCC   *DECK DAVIDSONRL
      SUBROUTINE DAVIDSONRL(IW,ECCSD,BESTEOM,NO,NU,
     *                    T2,TI,T1,EV,EVV,C,HC,TEMPI,
     *                    VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
     *                    NOU,NU2,NU3,NO2U2,OEH,OEP,
     *                    WR,WI,WORK,VR,VL,XMAT,R,MEMS1,MEMS2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T2(*),TI(*),T1(*),EV(*),EVV(*),
     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
     *          OEH(NO),OEP(NU),WR(MEMS1),WI(MEMS1),WORK(4*MEMS1),
     *          VL(MEMS2),VR(MEMS2),XMAT(MEMS1,MEMS1),
     *          R(MEMS1,MEMS1)
C
      PARAMETER (MXAO=8192)
C
      DIMENSION ISTACK(100)
      CHARACTER*3 VECREP,XSYM,REP
      CHARACTER*14 YYKKCONV
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
C MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C
C      EQUIVALENCE (IHSPACE,LMICRO)
C
      DATA ONE/1.0D+00/,FEV/27.2113957D+00/
C
      DO I=1,100
       KKTRIM(I)  = 0
       KKTRIML(I) = 0
       XKKEOM(I)  = 0.0D+00
       ISTACK(I)  = 0
       KVGEOM(I)  = 0
       IUST(I)    = 0
       EOMSDE(I)  = 0.0D+00
       EOMR0(I)   = 0.0D+00
       EOMR0L(I)  = 0.0D+00
      ENDDO
C
C     --- END TEMPORARY INTERFACE TO MMCC(2,3) PROGRAM ---
C
      IF(NROOT.GT.0) WRITE(IW,9000)
C
CCC      CALL ZEROMA(XMAT,1,MEMS2)
CCC      CALL ZEROMA(R,1,MEMS2)
      DO 1,I=1,MEMS1
      DO 1,J=1,MEMS1
       R(I,J)=0.0D+00
       XMAT(I,J)=0.0D+00
 1    CONTINUE
      TOL  = CVGEOM
      TOLPR= 0.05D+00
      NOUP=NOU+NO2U2
CCCX      NTOTITER=0
      IROOT=0
      NBAD =0
C
C ADDED BY KK (+1 THE FIRST R1,R2=0 - THE GROUND STATE)
C      CALL DRWZERO(EV)
C ADDED BY  KK (COUNTER OF CONVERGED EOMCCSD ROOTS)
C
      ICROOT=0
      IMICRO=0
      IDIM  =0
C
C        LOOP OVER FINDING EACH EXCITED STATE
C
      DO 100 NRT=1,NROOT
C
      WRITE(IW,9010) IROOT+1
C READING INITIAL NRT-TH RIGHT AND LEFT EIGENVEC.
      IDIM=IDIM+1
      CALL RSTAR(NRT,NOUP,T1)
      CALL RSTAR(NRT,NOUP,T2)
CCC INITIAL LEFT=INITIAL RIGHT
CCC   CALL RSTAR(NRT+NROOT,NOUP,T2)
      CALL DCOPY(NOUP,T1,1,TI,1)
      CALL SPINKA(NO,NU,TI)
      Z=DDOT(NOUP,TI,1,T2,1)
      IF(Z.LT.0.0D+00) THEN
      Z=ABS(Z)
      CALL DSCAL(NOUP,-ONE/SQRT(Z),T1,1)
      CALL DSCAL(NOUP,ONE/SQRT(Z),T2,1)
      ELSE
      Z=ABS(Z)
      CALL DSCAL(NOUP,ONE/SQRT(Z),T1,1)
      CALL DSCAL(NOUP,ONE/SQRT(Z),T2,1)
      END IF
      IF(IDIM.EQ.1) THEN
         CALL WCCFL(NC1,IDIM,NOU,T1)
         CALL WCCFL(NC2,IDIM,NO2U2,T1(NOU+1))
         CALL WCCFL(NL1,IDIM,NOU,T2)
         CALL WCCFL(NL2,IDIM,NO2U2,T2(NOU+1))
      END IF
      CALL WCCFL(NAX,2,NOUP,T1)
      CALL WCCFL(NNAXL,2,NOUP,T2)
      IF(IDIM.GT.1) THEN
C BIORTHONORMALIZATION OF THE INITIAL VECTORS
         CALL ORT3RL(NO,NU,NOUP,IDIM-1,T1,TI,EV,RES1,1)
         CALL ORT3RL(NO,NU,NOUP,IDIM-1,T2,TI,EV,RES2,2)
         CALL DCOPY(NOUP,T1,1,TI,1)
         CALL SPINKA(NO,NU,TI)
         Z=DDOT(NOUP,TI,1,T2,1)
         Z=ABS(Z)
         CALL DSCAL(NOUP,ONE/SQRT(Z),T1,1)
         CALL DSCAL(NOUP,ONE/SQRT(Z),T2,1)
         CALL WCCFL(NC1,IDIM,NOU,T1)
         CALL WCCFL(NC2,IDIM,NO2U2,T1(NOU+1))
         CALL WCCFL(NL1,IDIM,NOU,T2)
         CALL WCCFL(NL2,IDIM,NO2U2,T2(NOU+1))
      END IF
C
C        AT THIS SPOT WE ARE USING THE STORAGE ALLOCATED
C        BY THE -J- POINTERS, RATHER THAN THE -I- POINTERS
C
      IMICRO=1
 777  CONTINUE
      CALL CHC1(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
      CALL CHC2(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
      CALL LHL1(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
      CALL LHL2(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
C
C        AND NOW WE ARE BACK TO THE -I- POINTERS
C
      CALL SMALMARL(NO,NU,IDIM,T2,TI,XMAT,R,MEMS1)
      CALL ZEROMA(VL,1,MEMS2)
      CALL ZEROMA(VR,1,MEMS2)
      CALL ZEROMA(WORK,1,4*MEMS1)
      CALL ZEROMA(WR,1,MEMS1)
      CALL ZEROMA(WI,1,MEMS1)
      CALL DIAGORL(IW,XMAT,WR,WI,WORK,VR,VL,IDIM,MEMS1)
      CALL SELVECRL(NO,NU,IDIM,MEMS1,WR,WI,VR,VL,EV,EVV,
     *              T2,TI,EVAL,IMAX)
C EV  - RIGHT VECTOR EPSI(IDIM)
C EVV - LEFT VECTOR  EPSI-BAR(IDIM)
      CALL WCCFL(NAX,2,NOUP,EV)
      CALL WCCFL(NNAXL,2,NOUP,EVV)
C AND NOW: Q-RIGHT(IDIM+1) CORRECTION VECTOR
      CALL COMBRL(NHC1,IDIM,NO,NU,MEMS1,VR,IMAX,T1,TI)
      CALL DAXPY(NOUP,-EVAL,EV,1,TI,1)
      CALL DCOPY(NOUP,TI,1,EV,1)
C NOW: EV = (H(BAR)-EVAL)EPSI(IDIM)
C AND NOW: Q-LEFT(IDIM+1) CORRECTION VECTOR
      CALL COMBRL(NHL1,IDIM,NO,NU,MEMS1,VL,IMAX,T1,TI)
      CALL DAXPY(NOUP,-EVAL,EVV,1,TI,1)
      CALL DCOPY(NOUP,TI,1,EVV,1)
C NOW: EVV = EPSI-BAR(IDIM)(H(BAR)-EVAL)
      CALL RCCFL(NDIAG,1,NOUP,T2)
      DO 12 I=1,NOUP
         X=EVAL-T2(I)
         EV(I)=EV(I)/X
         EVV(I)=EVV(I)/X
 12   CONTINUE
C
C BIORTHONORMALIZATION OF THE CORRECTIONS
         CALL ORT3RL(NO,NU,NOUP,IDIM,EV,TI,T1,RES1,1)
         CALL ORT3RL(NO,NU,NOUP,IDIM,EVV,TI,T2,RES2,2)
         RES=MAX(RES1,RES2)
         CALL DCOPY(NOUP,EV,1,T1,1)
         CALL DCOPY(NOUP,EVV,1,T2,1)
         CALL SPINKA(NO,NU,T1)
         Z=DDOT(NOUP,T1,1,T2,1)
      IF(Z.LT.0.0D+00) THEN
        Z=ABS(Z)
        CALL DSCAL(NOUP,ONE/SQRT(Z),EV,1)
        CALL DSCAL(NOUP,-ONE/SQRT(Z),EVV,1)
      ELSE
        CALL DSCAL(NOUP,ONE/SQRT(Z),EV,1)
        CALL DSCAL(NOUP,ONE/SQRT(Z),EVV,1)
      END IF
C
      WRITE(IW,9020) IMICRO,IDIM,EVAL,(EVAL*FEV),RES
      CALL FLSHBF(IW)
C
C
      IF(RES.GT.TOL.AND.IMICRO.GE.MAXITEOM) THEN
         IF(IMICRO.GE.MAXITEOM) THEN
            WRITE(IW,9025)
            NBAD = NBAD+1
         END IF
         IDIM=IDIM-IMICRO
         CALL DEACTSM(IDIM,MEMS1,R,XMAT)
C
         CALL FIXSYM(NO,NU,EV(1),EV(1+NOU),XSYM)
         WRITE(IW,9330) XSYM
         VECREP(NRT)=XSYM
         KKTRIM(NRT)=0
         KVGEOM(NRT)=0
         KKTRIML(NRT)=0
         XKKEOM(NRT)=EVAL
         EOMSDE(NRT)=EVAL
         IROOT=IROOT+1
         CALL RCCFL(NAX,2,NOUP,EV)
         CALL RCCFL(NNAXL,2,NOUP,EVV)
         CALL BIORTF2(NO,NU,NOUP,EV,EVV,T1,T2,EVAL,R00)
         CALL WCCFL(NAX,(IROOT+2),NOUP,EV)
         CALL WCCFL(NNAXL,(IROOT+2),NOUP,EVV)
         EOMR0L(NRT)=R00
         EOMR0(NRT)=R00
         GO TO 822
      END IF
C
      IF(RES.GT.TOL.AND.IMICRO.LT.MAXITEOM) THEN
         CALL WCCFL(NC1,IDIM+1,NOU,EV)
         CALL WCCFL(NC2,IDIM+1,NO2U2,EV(NOU+1))
         CALL WCCFL(NL1,IDIM+1,NOU,EVV)
         CALL WCCFL(NL2,IDIM+1,NO2U2,EVV(NOU+1))
         IDIM=IDIM+1
         IMICRO=IMICRO+1
         GO TO 777
      END IF
C
C         THIS STATE IS CONVERGED OR ELSE MAYBE OUT OF ITERATIONS,
C         SO SAVE AND PRINT RESULTS
C
      IROOT=IROOT+1
      CALL RCCFL(NAX,2,NOUP,EV)
      CALL RCCFL(NNAXL,2,NOUP,EVV)
      CALL BIORTF2(NO,NU,NOUP,EV,EVV,T1,T2,EVAL,R00)
      CALL WCCFL(NAX,(IROOT+2),NOUP,EV)
      CALL WCCFL(NNAXL,(IROOT+2),NOUP,EVV)
C
C ADDED BY KK
C
      CALL FIXSYM(NO,NU,EV(1),EV(1+NOU),XSYM)
      VECREP(NRT)=XSYM
      WRITE(IW,9330) XSYM
      KKTRIM(NRT)=1
      KVGEOM(NRT)=1
      KKTRIML(NRT)=1
      XKKEOM(NRT)=EVAL
      EOMSDE(NRT)=EVAL
      EOMR0L(NRT)=R00
      EOMR0(NRT)=R00
C
C        RIGHT AND LEFT AMPLITUDE PRINTING
C
 822  CONTINUE
      WRITE(IW,9030)
C
      IPOS=1
      DO 560 IIIA=1,NU
       DO 561 IIII=1,NO
        XXX=ABS(EV(IPOS))
        IF(XXX.GT.TOLPR) THEN
         WRITE(IW,9040) EV(IPOS),IIII,IIIA+NO
        END IF
        IPOS=IPOS+1
  561  CONTINUE
  560 CONTINUE
C
      IPOS=1
      DO 570,JJJ=1,NO
       DO 571,JJB=1,NU
        DO 572,IIA=1,NU
         DO 573,III=1,NO
          XXX=ABS(EV(IPOS+NOU))
          IF(XXX.GT.TOLPR) THEN
            WRITE(IW,9050) EV(IPOS+NOU),III,JJJ,IIA+NO,JJB+NO
          END IF
          IPOS=IPOS+1
  573    CONTINUE
  572   CONTINUE
  571  CONTINUE
  570 CONTINUE
C
      WRITE(IW,*) '   '
      IPOS=1
      DO 1560 IIIA=1,NU
       DO 1561 IIII=1,NO
        XXX=ABS(EV(IPOS))
        IF(XXX.GT.TOLPR) THEN
         WRITE(IW,9041) EVV(IPOS),IIII,IIIA+NO
        END IF
        IPOS=IPOS+1
 1561  CONTINUE
 1560 CONTINUE
C
      IPOS=1
      DO 1570,JJJ=1,NO
       DO 1571,JJB=1,NU
        DO 1572,IIA=1,NU
         DO 1573,III=1,NO
          XXX=ABS(EV(IPOS+NOU))
          IF(XXX.GT.TOLPR) THEN
           WRITE(IW,9051) EVV(IPOS+NOU),III,JJJ,IIA+NO,JJB+NO
          END IF
          IPOS=IPOS+1
 1573    CONTINUE
 1572   CONTINUE
 1571  CONTINUE
 1570 CONTINUE
C
CCCX      CALL RO1(3,NO,NU,T1)
CCCX      R0A=TWO*DDOT(NOU,T1,1,EV,1)
CCCX      CALL RO2HPP(1,NO,NU,TI,T1)
CCCX      CALL SYMT21(T1,NO,NU,NU,NO,23)
CCCX      R0B=DDOT(NO2U2,T1,1,EV(NOU+1),1)
CCCX      R00=(R0A+R0B)/EVAL
      ICROOT=ICROOT+1
C
C
      WRITE(IW,9060) R00
C
      XAEL=0.0D+00
      CALL AELKK(NO,NU,EV(1),EV(NOU+1),XAEL)
      WRITE(IW,9070) XAEL
C
      ESTATE = ECCSD + EVAL
      WRITE(IW,9080) IROOT,ESTATE
 100  CONTINUE
C
      NBADEOM=NBAD
      NTOTEOM=ICROOT
C
      CALL INDEXX(NROOT,XKKEOM,IUST,80,ISTACK,100)
      IF(NROOT.GT.0) THEN
         WRITE(IW,9300)
         WRITE(IW,9310)
      END IF
      ISY=0
      DO I=1,NROOT
         JGO=IUST(I)
         IF(VECREP(JGO).EQ.REP(IROOTCC(1))) THEN
            ISY=ISY+1
            IF(IROOTCC(2).EQ.ISY) BESTEOM=ECCSD+EOMSDE(JGO)
         END IF
         IF(KKTRIM(JGO).EQ.1) THEN
            YYKKCONV='     CONVERGED'
         ELSE
            YYKKCONV=' NOT CONVERGED'
         END IF
         WRITE(IW,9320) VECREP(JGO),XKKEOM(JGO),XKKEOM(JGO)*FEV,
     &                 XKKEOM(JGO)+ECCSD,YYKKCONV
      ENDDO
      IF(IROOTCC(2).EQ.0) BESTEOM = ECCSD
      WRITE(IW,*) ' '
C
      IF(NBAD.GT.0) WRITE(IW,9090) NBAD,NROOT
      RETURN
C
 9000 FORMAT(/7X,'RESULTS  OF  THE  EOM-CCSD   ITERATIONS')
 9010 FORMAT(/1X,'SOLVING FOR ROOT NUMBER',I5,' ...'/
     *       1X,'        TOT        EXCITATION ENERGY',10X,
     *          'AMPLITUDE'/
     *       1X,'   ITR  ITR      HARTREE         EV           ',
     *          'CONVERG.')
 9020 FORMAT(1X,2I5,3F15.9)
 9025 FORMAT(/1X,'* * * UWAGA! * * * THIS STATE DID NOT CONVERGE.'/)
 9030 FORMAT(1X,'THE LARGEST RIGHT AND LEFT S AND D AMPLITUDES',
     *          ' FOR THIS ROOT ARE')
 9040 FORMAT(1X,'R1=',F15.10,' FOR   I -> A   =',2I5)
 9041 FORMAT(1X,'L1=',F15.10,' FOR   I -> A   =',2I5)
 9050 FORMAT(1X,'R2=',F15.10,' FOR I,J -> A,B =',4I5)
 9051 FORMAT(1X,'L2=',F15.10,' FOR I,J -> A,B =',4I5)
 9060 FORMAT(1X,'GROUND STATE''S WEIGHT R0 = ',F15.10)
 9070 FORMAT(1X,'REL DIAGNOSTIC (R1*R1 + 2*R2*R2): ',F8.3)
 9080 FORMAT(1X,'THE TOTAL ENERGY OF ROOT',I4,
     *          ' IS E(EOM-CCSD) =',F20.10)
 9090 FORMAT(/1X,'EOM-CCSD HALTED WITHOUT FINDING ALL DESIRED STATES'/
     *        1X,I4,' UNCONVERGED OUT OF',I4,' REQUESTED')
 9300 FORMAT(//15X,'---- SUMMARY OF EOM-CCSD CALCULATIONS ----'/)
 9310 FORMAT(17X,'EXCITATION',6X,'EXCITATION',6X,'TOTAL'/
     *       4X,'SYMMETRY',5X,'ENERGY (H)',6X,'ENERGY (EV)',5X,
     *       'ENERGY (H)',10X,'ITERATIONS')
 9320 FORMAT(7X,A3,2X,F15.8,6X,F8.3,4X,F15.8,5X,A14)
 9330 FORMAT(1X,'SYMMETRY OF THE STATE: ',A3)
      END
C
C*MODULE EOMCC   *DECK DAVIDSNRLN
      SUBROUTINE DAVIDSNRLN(IW,ECCSD,BESTEOM,NO,NU,
     *                    T2,TI,T1,EV,EVV,C,HC,TEMPI,
     *                    VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
     *                    NOU,NU2,NU3,NO2U2,OEH,OEP,
     *                    WR,WI,WORK,VR,VL,XMAT,R,MEMS1,MEMS2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
CCCX      LOGICAL MCIT
C
      DIMENSION T2(*),TI(*),T1(*),EV(*),EVV(*),
     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
     *          OEH(NO),OEP(NU),WR(MEMS1),WI(MEMS1),WORK(4*MEMS1),
     *          VL(MEMS2),VR(MEMS2),XMAT(MEMS1,MEMS1),
     *          R(MEMS1,MEMS1)
C
      PARAMETER (MXAO=8192)
C
      DIMENSION ISTACK(100)
      CHARACTER*3 VECREP,XSYM,REP
      CHARACTER*14 YYKKCONV
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 /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
      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
C      EQUIVALENCE (IHSPACE,LMICRO)
C
      DATA ONE/1.0D+00/,FEV/27.2113957D+00/
C
      DO I=1,100
       KKTRIM(I) = 0
       KKTRIML(I)= 0
       XKKEOM(I) = 0.0D+00
       ISTACK(I) = 0
       KVGEOM(I) = 0
       IUST(I)   = 0
       EOMSDE(I) = 0.0D+00
       EOMR0(I)  = 0.0D+00
       EOMR0L(I) = 0.0D+00
      ENDDO
C
C
      IF(NROOT.GT.0) WRITE(IW,9000)
C
      DO 1,I=1,MEMS1
      DO 1,J=1,MEMS1
       R(I,J)=0.0D+00
       XMAT(I,J)=0.0D+00
 1    CONTINUE
      TOL  = CVGEOM
      TOLPR= 0.05D+00
      NOUP=NOU+NO2U2
CCCX      NTOTITER=0
      IROOT=0
      NBAD =0
C
C ADDED BY KK (+1 THE FIRST R1,R2=0 - THE GROUND STATE)
C      CALL DRWZERO(EV)
C ADDED BY  KK (COUNTER OF CONVERGED EOMCCSD ROOTS)
C
      ICROOT=0
      IMICRO=0
      IDIM  =0
C
C        LOOP OVER FINDING EACH EXCITED STATE
C
      DO 100 NRT=1,NROOT
C
      WRITE(IW,9010) IROOT+1
C READING INITIAL NRT-TH RIGHT AND LEFT EIGENVEC.
      IDIM=1
      CALL ZEROMA(XMAT,1,MEMS2)
      CALL ZEROMA(R,1,MEMS2)
C INITAIL LEFT = INITIAL RIGHT
      CALL RSTAR(NRT,NOUP,T1)
      CALL RSTAR(NRT,NOUP,T2)
CCCX          INITIAL LEFT - ACTIVATE EOMINILEFT
CCCX      CALL RSTAR(NRT+NROOT,NOUP,T2)
      CALL DCOPY(NOUP,T1,1,TI,1)
      CALL SPINKA(NO,NU,TI)
      Z=DDOT(NOUP,TI,1,T2,1)
      Z=ABS(Z)
      CALL DSCAL(NOUP,ONE/SQRT(Z),T1,1)
      CALL DSCAL(NOUP,ONE/SQRT(Z),T2,1)
      IF(IDIM.EQ.1) THEN
         CALL WCCFL(NC1,IDIM,NOU,T1)
         CALL WCCFL(NC2,IDIM,NO2U2,T1(NOU+1))
         CALL WCCFL(NL1,IDIM,NOU,T2)
         CALL WCCFL(NL2,IDIM,NO2U2,T2(NOU+1))
      END IF
      CALL WCCFL(NAX,2,NOUP,T1)
      CALL WCCFL(NNAXL,2,NOUP,T2)
C
C        AT THIS SPOT WE ARE USING THE STORAGE ALLOCATED
C        BY THE -J- POINTERS, RATHER THAN THE -I- POINTERS
C
      IMICRO=1
 777  CONTINUE
      CALL CHC1(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
      CALL CHC2(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
      CALL LHL1(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
      CALL LHL2(IDIM,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
C
C        AND NOW WE ARE BACK TO THE -I- POINTERS
C
      CALL SMALMARL(NO,NU,IDIM,T2,TI,XMAT,R,MEMS1)
      CALL ZEROMA(VL,1,MEMS2)
      CALL ZEROMA(VR,1,MEMS2)
      CALL ZEROMA(WORK,1,4*MEMS1)
      CALL ZEROMA(WR,1,MEMS1)
      CALL ZEROMA(WI,1,MEMS1)
      CALL DIAGORL(IW,XMAT,WR,WI,WORK,VR,VL,IDIM,MEMS1)
      CALL SELVECRL(NO,NU,IDIM,MEMS1,WR,WI,VR,VL,EV,EVV,
     *              T2,TI,EVAL,IMAX)
C EV  - RIGHT VECTOR EPSI(IDIM)
C EVV - LEFT VECTOR  EPSI-BAR(IDIM)
      CALL WCCFL(NAX,2,NOUP,EV)
      CALL WCCFL(NNAXL,2,NOUP,EVV)
C AND NOW: Q-RIGHT(IDIM+1) CORRECTION VECTOR
      CALL COMBRL(NHC1,IDIM,NO,NU,MEMS1,VR,IMAX,T1,TI)
      CALL DAXPY(NOUP,-EVAL,EV,1,TI,1)
      CALL DCOPY(NOUP,TI,1,EV,1)
C NOW: EV = (H(BAR)-EVAL)EPSI(IDIM)
C AND NOW: Q-LEFT(IDIM+1) CORRECTION VECTOR
      CALL COMBRL(NHL1,IDIM,NO,NU,MEMS1,VL,IMAX,T1,TI)
      CALL DAXPY(NOUP,-EVAL,EVV,1,TI,1)
      CALL DCOPY(NOUP,TI,1,EVV,1)
C NOW: EVV = EPSI-BAR(IDIM)(H(BAR)-EVAL)
      CALL RCCFL(NDIAG,1,NOUP,T2)
      DO 12 I=1,NOUP
         X=EVAL-T2(I)
         EV(I)=EV(I)/X
         EVV(I)=EVV(I)/X
 12   CONTINUE
C
C
C
C BIORTHONORMALIZATION OF THE CORRECTIONS
C
         CALL ORT3RL(NO,NU,NOUP,IDIM,EV,TI,T1,RES1,1)
         CALL ORT3RL(NO,NU,NOUP,IDIM,EVV,TI,T2,RES2,2)
         RES=MAX(RES1,RES2)
         CALL DCOPY(NOUP,EV,1,T1,1)
         CALL DCOPY(NOUP,EVV,1,T2,1)
         CALL SPINKA(NO,NU,T1)
         Z=DDOT(NOUP,T1,1,T2,1)
      IF(Z.LT.0.0D+00) THEN
        Z=ABS(Z)
        CALL DSCAL(NOUP,ONE/SQRT(Z),EV,1)
        CALL DSCAL(NOUP,-ONE/SQRT(Z),EVV,1)
      ELSE
        CALL DSCAL(NOUP,ONE/SQRT(Z),EV,1)
        CALL DSCAL(NOUP,ONE/SQRT(Z),EVV,1)
      END IF
C
      WRITE(IW,9020) IMICRO,IDIM,EVAL,(EVAL*FEV),RES
      CALL FLSHBF(IW)
C
C
      IF(RES.GT.TOL.AND.IMICRO.GE.MAXITEOM) THEN
         IF(IMICRO.GE.MAXITEOM) THEN
            WRITE(IW,9025)
            NBAD = NBAD+1
         END IF
C
         CALL FIXSYM(NO,NU,EV(1),EV(1+NOU),XSYM)
         VECREP(NRT)=XSYM
         WRITE(IW,9330) XSYM
         KKTRIM(NRT)=0
         KKTRIML(NRT)=0
         KVGEOM(NRT)=0
         XKKEOM(NRT)=EVAL
         EOMSDE(NRT)=EVAL
         IROOT=IROOT+1
         CALL RCCFL(NAX,2,NOUP,EV)
         CALL RCCFL(NNAXL,2,NOUP,EVV)
         CALL BIORTF2(NO,NU,NOUP,EV,EVV,T1,T2,EVAL,R00)
         CALL WCCFL(NAX,(IROOT+2),NOUP,EV)
         CALL WCCFL(NNAXL,(IROOT+2),NOUP,EVV)
         EOMR0L(NRT)=R00
         EOMR0(NRT)=R00
         GO TO 822
      END IF
C
      IF(RES.GT.TOL.AND.IMICRO.LT.MAXITEOM) THEN
         CALL WCCFL(NC1,IDIM+1,NOU,EV)
         CALL WCCFL(NC2,IDIM+1,NO2U2,EV(NOU+1))
         CALL WCCFL(NL1,IDIM+1,NOU,EVV)
         CALL WCCFL(NL2,IDIM+1,NO2U2,EVV(NOU+1))
         IDIM=IDIM+1
         IMICRO=IMICRO+1
         GO TO 777
      END IF
C
C         THIS STATE IS CONVERGED OR ELSE MAYBE OUT OF ITERATIONS,
C         SO SAVE AND PRINT RESULTS
C
      IROOT=IROOT+1
      CALL RCCFL(NAX,2,NOUP,EV)
      CALL RCCFL(NNAXL,2,NOUP,EVV)
      CALL BIORTF2(NO,NU,NOUP,EV,EVV,T1,T2,EVAL,R00)
      CALL WCCFL(NAX,(IROOT+2),NOUP,EV)
      CALL WCCFL(NNAXL,(IROOT+2),NOUP,EVV)
C
C ADDED BY KK
C
      CALL FIXSYM(NO,NU,EV(1),EV(1+NOU),XSYM)
      VECREP(NRT)=XSYM
      WRITE(IW,9330) XSYM
      KKTRIM(NRT)=1
      KKTRIML(NRT)=1
      KVGEOM(NRT)=1
      XKKEOM(NRT)=EVAL
      EOMSDE(NRT)=EVAL
      EOMR0L(NRT)=R00
      EOMR0(NRT)=R00
C
C        RIGHT AND LEFT AMPLITUDE PRINTING
C
 822  CONTINUE
      WRITE(IW,9030)
C
      IPOS=1
      DO 560 IIIA=1,NU
       DO 561 IIII=1,NO
        XXX=ABS(EV(IPOS))
        IF(XXX.GT.TOLPR) THEN
         WRITE(IW,9040) EV(IPOS),IIII,IIIA+NO
        END IF
        IPOS=IPOS+1
  561  CONTINUE
  560 CONTINUE
C
      IPOS=1
      DO 570,JJJ=1,NO
       DO 571,JJB=1,NU
        DO 572,IIA=1,NU
         DO 573,III=1,NO
          XXX=ABS(EV(IPOS+NOU))
          IF(XXX.GT.TOLPR) THEN
            WRITE(IW,9050) EV(IPOS+NOU),III,JJJ,IIA+NO,JJB+NO
          END IF
          IPOS=IPOS+1
  573    CONTINUE
  572   CONTINUE
  571  CONTINUE
  570 CONTINUE
C
      WRITE(IW,*) '   '
      IPOS=1
      DO 1560 IIIA=1,NU
       DO 1561 IIII=1,NO
        XXX=ABS(EV(IPOS))
        IF(XXX.GT.TOLPR) THEN
         WRITE(IW,9041) EVV(IPOS),IIII,IIIA+NO
        END IF
        IPOS=IPOS+1
 1561  CONTINUE
 1560 CONTINUE
C
      IPOS=1
      DO 1570,JJJ=1,NO
       DO 1571,JJB=1,NU
        DO 1572,IIA=1,NU
         DO 1573,III=1,NO
          XXX=ABS(EV(IPOS+NOU))
          IF(XXX.GT.TOLPR) THEN
           WRITE(IW,9051) EVV(IPOS+NOU),III,JJJ,IIA+NO,JJB+NO
          END IF
          IPOS=IPOS+1
 1573    CONTINUE
 1572   CONTINUE
 1571  CONTINUE
 1570 CONTINUE
C
CCCX      CALL RO1(3,NO,NU,T1)
CCCX      R0A=TWO*DDOT(NOU,T1,1,EV,1)
CCCX      CALL RO2HPP(1,NO,NU,TI,T1)
CCCX      CALL SYMT21(T1,NO,NU,NU,NO,23)
CCCX      R0B=DDOT(NO2U2,T1,1,EV(NOU+1),1)
CCCX      R00=(R0A+R0B)/EVAL
      ICROOT=ICROOT+1
C
CCCX  88  FORMAT(2D22.14,2X,A3,I4)
C
C
      WRITE(IW,9060) R00
C
      XAEL=0.0D+00
      CALL AELKK(NO,NU,EV(1),EV(NOU+1),XAEL)
      WRITE(IW,9070) XAEL
C
      ESTATE = ECCSD + EVAL
      WRITE(IW,9080) IROOT,ESTATE
 100  CONTINUE
C
      NBADEOM=NBAD
      NTOTEOM=ICROOT
C
      CALL INDEXX(NROOT,XKKEOM,IUST,80,ISTACK,100)
      IF(NROOT.GT.0) THEN
         WRITE(IW,9300)
         WRITE(IW,9310)
      END IF
      ISY=0
      DO I=1,NROOT
         JGO=IUST(I)
         IF(VECREP(JGO).EQ.REP(IROOTCC(1))) THEN
            ISY=ISY+1
            IF(IROOTCC(2).EQ.ISY) BESTEOM=ECCSD+EOMSDE(JGO)
         END IF
         IF(KKTRIM(JGO).EQ.1) THEN
            YYKKCONV='     CONVERGED'
         ELSE
            YYKKCONV=' NOT CONVERGED'
         END IF
         WRITE(IW,9320) VECREP(JGO),XKKEOM(JGO),XKKEOM(JGO)*FEV,
     &                 XKKEOM(JGO)+ECCSD,YYKKCONV
      ENDDO
      IF(IROOTCC(2).EQ.0) BESTEOM = ECCSD
      WRITE(IW,*) ' '
C
      IF(NBAD.GT.0) WRITE(IW,9090) NBAD,NROOT
      RETURN
C
 9000 FORMAT(/7X,'RESULTS  OF  THE  EOM-CCSD   ITERATIONS')
 9010 FORMAT(/1X,'SOLVING FOR ROOT NUMBER',I5,' ...'/
     *       1X,'        TOT        EXCITATION ENERGY',10X,
     *          'AMPLITUDE'/
     *       1X,'   ITR  ITR      HARTREE         EV           ',
     *          'CONVERG.')
 9020 FORMAT(1X,2I5,3F15.9)
 9025 FORMAT(/1X,'* * * UWAGA! * * * THIS STATE DID NOT CONVERGE.'/)
 9030 FORMAT(1X,'THE LARGEST RIGHT AND LEFT S AND D AMPLITUDES',
     *          ' FOR THIS ROOT ARE')
 9040 FORMAT(1X,'R1=',F15.10,' FOR   I -> A   =',2I5)
 9041 FORMAT(1X,'L1=',F15.10,' FOR   I -> A   =',2I5)
 9050 FORMAT(1X,'R2=',F15.10,' FOR I,J -> A,B =',4I5)
 9051 FORMAT(1X,'L2=',F15.10,' FOR I,J -> A,B =',4I5)
 9060 FORMAT(1X,'GROUND STATE''S WEIGHT R0 = ',F15.10)
 9070 FORMAT(1X,'REL DIAGNOSTIC (R1*R1 + 2*R2*R2): ',F8.3)
 9080 FORMAT(1X,'THE TOTAL ENERGY OF ROOT',I4,
     *          ' IS E(EOM-CCSD) =',F20.10)
 9090 FORMAT(/1X,'EOM-CCSD HALTED WITHOUT FINDING ALL DESIRED STATES'/
     *        1X,I4,' UNCONVERGED OUT OF',I4,' REQUESTED')
 9300 FORMAT(//15X,'---- SUMMARY OF EOM-CCSD CALCULATIONS ----'/)
 9310 FORMAT(17X,'EXCITATION',6X,'EXCITATION',6X,'TOTAL'/
     *       4X,'SYMMETRY',5X,'ENERGY (H)',6X,'ENERGY (EV)',5X,
     *       'ENERGY (H)',10X,'ITERATIONS')
 9320 FORMAT(7X,A3,2X,F15.8,6X,F8.3,4X,F15.8,5X,A14)
 9330 FORMAT(1X,'SYMMETRY OF THE STATE: ',A3)
      END
C
C*MODULE EOMCC   *DECK LAMBDAV
C      SUBROUTINE LAMBDAV(IW,NO,NU,T2,TI,T1,EV,
C     *                    C,HC,TEMPI,
C     *                    VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
C     *                    NOU,NU2,NU3,NO2U2,OEH,OEP)
C      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C      LOGICAL MCIT
CC
C      DIMENSION T2(*),TI(*),T1(*),EV(*),
C     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
C     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
C     *          OEH(NO),OEP(NU)
CC
C      CHARACTER*3 XSYM
CC
C      PARAMETER (MXAO=8192)
CC
CC     --- END TEMPORARY INTERFACE TO MMCC(2,3) PROGRAM ---
CC
CC
C      COMMON /EOMFIL/ NSTAR,NC1,NC2,NHC1,NHC2,NHH,NPP,NAX,NAXX,NDIAG,
C     *                ITAPP,IFAX,NRR1,NRR2,NEXM,NEXE,NW2C,NW4C,
C     *                NW4D,NW2BD,NW4B,NROO,NREXM,NREXE,
C     *                JCISD,KCIF,JCISDNX
C      COMMON /EOMINF/ ISPACE,IHSPACE,JCISPACE,ICIMET,IOPTMM,
C     *                NROOT,NOA,NUA,MAXITEOM
CC      COMMON /EOMPAR/ CVGCI,CVGEOM,GRPEOM,NSTEOM(8),NOACT,NUACT,
C     *                MOACTCC(MXAO),MTHTRIP,MTHCI,MTHEOM,MTHINIT,
C     *                MAXCI,MAXEOM,MICCI,MICEOM,IROOTCC(2),
C     *                IPROPCC,IPROPCCE
CC MARTA'S FILES
C      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
CC
CC
C      DATA ONE/1.0D+00/,TWO/2.0D+00/,FEV/27.2113957D+00/,ZERO/0.0D+00/,
C     *     ONEM/-1.0D+00/
CC
CC
C      WRITE(IW,9000)
C      WRITE(IW,9010)
CC
C      TOL  = CVGEOM
C      TOLPR= 0.05D+00
C      NOUP=NOU+NO2U2
CC
CC
C      IMICRO=0
C      IDIM  =0
CC
CC READING INITIAL LAMBDA-VEC (T1 AND T2 AMPLITUDES).
CC
C      IDIM=IDIM+1
C      CALL RO1(1,NO,NU,T1)
C      CALL RO2(1,NO,NU,T1(NOU+1))
CCCCC      CALL ZEROMA(T1,1,NOUP)
CC
CC
C      IMICRO=1
CC
CC
C 777  CONTINUE
C      CALL WCCFL(NNAXL,1,NOUP,T1)
C      CALL WCCFL(NL1,1,NOU,T1)
C      CALL WCCFL(NL2,1,NO2U2,T1(NOU+1))
CC
CC        AT THIS SPOT WE ARE USING THE STORAGE ALLOCATED
CC        BY THE -J- POINTERS, RATHER THAN THE -I- POINTERS
CC
C      CALL LHL1(1,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
C      CALL LHL2(1,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
C     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
CC
CC        AND NOW WE ARE BACK TO THE -I- POINTERS
CC  VECTOR OF COEFFICIENTS
C      CALL RO1(3,NO,NU,T1)
C      CALL RO2HPP(1,NO,NU,TI,T1(NOU+1))
C      CALL DSCAL(NOUP,ONEM,T1,1)
CC X^T H(BAR)
C      CALL RCCFL(NHL1,1,NOU,T2)
C      CALL RCCFL(NHL2,1,NO2U2,T2(NOU+1))
C      CALL DAXPY(NOUP,ONEM,T2,1,T1,1)
C      CALL ZEROMA(T2,1,NOUP)
C      CALL RCCFL(NDIAG,1,NOUP,T2)
CC
C      DO 12 I=1,NOUP
C         X=T2(I)
C         EV(I)=T1(I)/X
C 12   CONTINUE
CC
C      CALL ZEROMA(T2,1,NOUP)
C      CALL DCOPY(NOUP,EV,1,T2,1)
C      CALL SPINKA(NO,NU,T2)
C      Z=DDOT(NOUP,T2,1,EV,1)
C      RES=ABS(Z)
C      RES=SQRT(RES)
CC T1 -> -(<PHI|H_BAR(Q1+Q2)+<PHI|(L1+L2)H_BAR(Q1+Q2))
CC T2 -> DIAG.(Q1+Q2)(H_BAR)(Q1+Q2)
CC EV -> D^{-1} * T1 (CORRECTION)
C      CALL ZEROMA(T1,1,NOUP)
C      CALL RCCFL(NNAXL,1,NOUP,T1)
C      CALL DAXPY(NOUP,ONE,EV,1,T1,1)
CC T1 -> (L1+L2)^{OLD}+CORRECTION(EV)
C      WRITE(IW,9020) IDIM,RES
C      CALL FLSHBF(IW)
CC
CC
C      IF(RES.GT.TOL.AND.IMICRO.GE.MAXITEOM) THEN
C         IF(IMICRO.GE.MAXITEOM) THEN
C            WRITE(IW,9025)
C         END IF
CC
C         CALL FIXSYM(NO,NU,T1(1),T1(1+NOU),XSYM)
C         WRITE(IW,9330) XSYM
C         CALL WCCFL(NNAXL,1,NOUP,T1)
C         GO TO 822
C      END IF
CC
C      IF(RES.GT.TOL.AND.IMICRO.LT.MAXITEOM) THEN
C         IDIM=IDIM+1
C         IMICRO=IMICRO+1
C         GO TO 777
C      END IF
CC
CC         THIS STATE IS CONVERGED OR ELSE MAYBE OUT OF ITERATIONS,
CC         SO SAVE AND PRINT RESULTS
CC
CCCCC      CALL WCCFL(NNAXL,1,NOUP,T1)
CC ACHTUNG
C          CALL WO1(5,NO,NU,T1)
C          CALL WO2(8,NO,NU,T1(1+NOU))
CC
CC ADDED BY KK
CC
C      CALL FIXSYM(NO,NU,T1(1),T1(1+NOU),XSYM)
C      WRITE(IW,9330) XSYM
CC
CC         AMPLITUDE PRINTING...
CC
C 822  CONTINUE
C      WRITE(IW,9030)
CC
C      IPOS=1
C      DO 560 IIIA=1,NU
C       DO 561 IIII=1,NO
C        XXX=ABS(T1(IPOS))
C        IF(XXX.GT.TOLPR) THEN
C         WRITE(IW,9040) T1(IPOS),IIII,IIIA+NO
C        END IF
C        IPOS=IPOS+1
C  561  CONTINUE
C  560 CONTINUE
CC
C      IPOS=1
C      DO 570,JJJ=1,NO
C       DO 571,JJB=1,NU
C        DO 572,IIA=1,NU
C         DO 573,III=1,NO
C          XXX=ABS(T1(IPOS+NOU))
C          IF(XXX.GT.TOLPR) THEN
C            WRITE(IW,9050) T1(IPOS+NOU),III,JJJ,IIA+NO,JJB+NO
C          END IF
C          IPOS=IPOS+1
C  573    CONTINUE
C  572   CONTINUE
C  571  CONTINUE
C  570 CONTINUE
CC
CC
CC
C      RETURN
CC
C 9000 FORMAT(/7X,'RESULTS  OF  THE  LAMBDA VECTOR   ITERATIONS')
C 9010 FORMAT(/1X,'SOLVING LAMBDA VECTOR',I5/
C     *       1X,' ITR      CONVERG.')
C 9020 FORMAT(1X,I5,F15.9)
C 9025 FORMAT(/1X,'* * * UWAGA! * * * LAMBDA-VEC DID NOT CONVERGE.'/)
C 9030 FORMAT(1X,'THE LARGEST LA1 AND LA2 AMPLITUDES FOR THIS ROOT ARE')
C 9040 FORMAT(1X,'LA1=',F15.10,' FOR   I -> A   =',2I5)
C 9050 FORMAT(1X,'LA2=',F15.10,' FOR I,J -> A,B =',4I5)
C 9330 FORMAT(1X,'SYMMETRY OF THE STATE: ',A3) !!!
C      END
C
C
C
C
C
C
C*MODULE EOMCC   *DECK LAMBDIIS
      SUBROUTINE LAMBDIIS(IW,NO,NU,MEMS1,MEMS2,
     *                    AM,AMAUX,FBV,FBVAUX,IPVT,
     *                    T2,TI,T1,EV,
     *                    C,HC,TEMPI,
     *                    VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
     *                    NOU,NU2,NU3,NO2U2,OEH,OEP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
CCCX      LOGICAL MCIT
C
      DIMENSION T2(*),TI(*),T1(*),EV(*),
     *          AM(MEMS1,MEMS1),AMAUX(MEMS1,MEMS1),
     *          FBV(MEMS1),FBVAUX(MEMS1),IPVT(MEMS1),
     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
     *          OEH(NO),OEP(NU)
C
      PARAMETER (MXAO=8192)
C
      CHARACTER*3 REP,VECREP,XSYM
C
      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 /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
      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
      DATA ONE/1.0D+00/
C
C
      WRITE(IW,9000)
      WRITE(IW,9015)
C
      TOL  = CVGEOM
      TOLPR= 0.05D+00
      NOUP=NOU+NO2U2
C
      LAMCON=0
C
      ITERTOT  = 1
C
C
C READING INITIAL LAMBDA-VEC (T1 AND T2 AMPLITUDES).
C
      CALL RO1(1,NO,NU,T1)
      CALL RO2(1,NO,NU,T1(NOU+1))
      CALL WCCFL(NNAXL,1,NOUP,T1)
      CALL WCCFL(NL1,1,NOU,T1)
      CALL WCCFL(NL2,1,NO2U2,T1(NOU+1))
      CALL LHL1(1,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
      CALL LHL2(1,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
      CALL RCCFL(NHL1,1,NOU,T1)
      CALL RCCFL(NHL2,1,NO2U2,T1(NOU+1))
      CALL WCCFL(NNAXL,2,NOUP,T1)
 888  CONTINUE
C NNAXL RECORDE STRUCTURE:
C #1 => L(N) (N-MICROITERATION'S NUMBER)
C #2 => U(1), #3 => U(2) ETC.
      CALL ZEROMA(AM,1,MEMS2)
      CALL ZEROMA(AMAUX,1,MEMS2)
      CALL ZEROMA(FBV,1,MEMS1)
      CALL ZEROMA(FBVAUX,1,MEMS1)
      CALL RCCFL(NNAXL,1,NOUP,T1)
      CALL WCCFL(NL1,1,NOU,T1)
      CALL WCCFL(NL2,1,NO2U2,T1(NOU+1))
      CALL RCCFL(NNAXL,2,NOUP,T1)
      CALL WCCFL(NHL1,1,NOU,T1)
      CALL WCCFL(NHL2,1,NO2U2,T1(NOU+1))
C INITIAL ELEMENTS OF AM AND
      CALL DCOPY(NOUP,T1,1,T2,1)
      CALL SPINKA(NO,NU,T2)
      AM(1,1)=DDOT(NOUP,T2,1,T1,1)
      AMAUX(1,1)=AM(1,1)
      CALL RO1(3,NO,NU,T2)
      CALL RO2HPP(1,NO,NU,TI,T2(NOU+1))
      CALL SPINKA(NO,NU,T2)
      FBV(1)=-DDOT(NOUP,T2,1,T1,1)
      FBVAUX(1)=FBV(1)
C INITIAL SHIFTS COMPLETED
      DO 777,I=2,MEMS1
       CALL RO1(3,NO,NU,T2)
       CALL RO2HPP(1,NO,NU,TI,T2(NOU+1))
C           NOTE, THE NOW USED ONEM WAS -1
C       CALL DSCAL(NOUP,ONEM,T2,1)
       CALL RCCFL(NNAXL,2,NOUP,T1)
       CALL DAXPY(NOUP,ONE,T1,1,T2,1)
C NOW ON T2 WE STORE (B-L(I)*H(BAR))
C       CALL RCCFL(NDIAG,1,NOUP,T1)
        CALL ADDDEN1(NO,NU,T2,OEH,OEP)
        CALL ADDDEN(NO,NU,T2(NOU+1),OEH,OEP)
       DO 12 J=1,NOUP
C          X=T1(J)
C          EV(J)=T2(J)/X
          EV(J)=T2(J)
 12    CONTINUE
C NOW: EV=D^{-1}(B-L(I)*H(BAR))
       CALL ORTDIIS(NO,NU,NOUP,I-1,EV,T1,T2,RES)
        WRITE(IW,9020) ITERTOT,RES
        CALL FLSHBF(IW)
       IF(ABS(RES).LT.TOL) THEN
         CALL RCCFL(NNAXL,1,NOUP,T1)
         LAMCON=1
         GO TO 999
       END IF
       CALL WCCFL(NL1,I,NOU,EV)
       CALL WCCFL(NL2,I,NO2U2,EV(NOU+1))
C AFTER ORTHOGONALIZATION
       IXC=I
       CALL LHL1(IXC,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
       CALL LHL2(IXC,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *           C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
C U(I)*H(BAR) CALCULATED
        IXC=I
        CALL SMMADIIS(NO,NU,IXC,T1,T2,AM,AMAUX,MEMS1)
CCCX       CALL SMMADIIS(NO,NU,I,T1,T2,AM,AMAUX,MEMS1)
       CALL RCCFL(NHL1,I,NOU,T1)
       CALL RCCFL(NHL2,I,NO2U2,T1(NOU+1))
       CALL RO1(3,NO,NU,T2)
       CALL RO2HPP(1,NO,NU,TI,T2(NOU+1))
       CALL SPINKA(NO,NU,T2)
       FBVAUX(I)=-DDOT(NOUP,T2,1,T1,1)
       DO 13,J=1,MEMS1
        FBV(J)=FBVAUX(J)
 13    CONTINUE
C NOW: SOLVING DIIS EQUATIONS: DGEFA AND DGESL
       JOBX=0
       IF(I.LT.MEMS1) THEN
         DO 14,J=I+1,MEMS1
          AM(J,J)=1.0D+00
 14      CONTINUE
       END IF
       CALL DGEFA(AM,MEMS1,MEMS1,IPVT,INFO)
        IF(INFO.NE.0) THEN
         WRITE(IW,*) 'PROBLEMS WITH SOLVING LAMBDA-DIIS EQ.'
         CALL FLSHBF(IW)
         CALL ABRT
        END IF
       CALL DGESL(AM,MEMS1,MEMS1,IPVT,FBV,JOBX)
       CALL COMBDIIS(NL1,I,NO,NU,MEMS1,FBV,T1,T2)
       CALL WCCFL(NNAXL,1,NOUP,T2)
       CALL COMBDIIS(NHL1,I,NO,NU,MEMS1,FBV,T1,T2)
       CALL WCCFL(NNAXL,2,NOUP,T2)
       ITERTOT=ITERTOT+1
       IF(ITERTOT.GT.MAXITEOM) THEN
        LAMCON=0
        GO TO 1000
       END IF
C TEST FOR MAXIT
 777  CONTINUE
C
      GO TO 888  !MAIN LOOP
C
 1000 CONTINUE  ! NOT CONVERGED
        WRITE(IW,9025)
 999  CONTINUE  ! CONVERGED
C
C ACHTUNG NA NADPISYWANIE NA NNAXL(1) W LEFTDIIS
CCCC      CALL WCCFL(NNAXL,1,NOUP,T1)
          CALL WO1(5,NO,NU,T1)
          CALL WO2(8,NO,NU,T1(1+NOU))
C
C     THIS IS A GROUND STATE ROUTINE, SO WE DON'T STORE INTO -VECREP-.
C     HOWEVER, WE KNOW THE CLOSED SHELL GROUND STATE REFERENCE MUST
C     BE A TOTALLY SYMMETRIC STATE.
C
CCCC      CALL FIXSYM(NO,NU,T1(1),T1(1+NOU),XSYM)
C
          XSYM = REP(1)
          WRITE(IW,9330) XSYM
C
C         AMPLITUDE PRINTING...
C
      WRITE(IW,9030)
C
      IPOS=1
      DO 560 IIIA=1,NU
       DO 561 IIII=1,NO
        XXX=ABS(T1(IPOS))
        IF(XXX.GT.TOLPR) THEN
         WRITE(IW,9040) T1(IPOS),IIII,IIIA+NO
        END IF
        IPOS=IPOS+1
  561  CONTINUE
  560 CONTINUE
C
      IPOS=1
      DO 570,JJJ=1,NO
       DO 571,JJB=1,NU
        DO 572,IIA=1,NU
         DO 573,III=1,NO
          XXX=ABS(T1(IPOS+NOU))
          IF(XXX.GT.TOLPR) THEN
            WRITE(IW,9050) T1(IPOS+NOU),III,JJJ,IIA+NO,JJB+NO
          END IF
          IPOS=IPOS+1
  573    CONTINUE
  572   CONTINUE
  571  CONTINUE
  570 CONTINUE
C
C
C
      RETURN
C
 9000 FORMAT(/1X,'SOLVING FOR THE GROUND STATE''S LAMBDA VECTOR',
     *           ' (LEFT EIGENSTATE) USING DIIS')
 9015 FORMAT(/3X,'ITR       CONVERG.')
 9020 FORMAT(1X,I5,F15.9)  !!!
 9025 FORMAT(/1X,'* * * UWAGA! * * * LAMBDA-VEC DID NOT CONVERGE.'/)
 9030 FORMAT(1X,'THE LARGEST LA1 AND LA2 AMPLITUDES FOR THIS ROOT ARE')
 9040 FORMAT(1X,'LA1=',F15.10,' FOR   I -> A   =',2I5)
 9050 FORMAT(1X,'LA2=',F15.10,' FOR I,J -> A,B =',4I5)
 9330 FORMAT(1X,'SYMMETRY OF THE GROUND STATE LEFT EIGENSTATE: ',A3)
      END
C
C
C
C*MODULE EOMCC   *DECK LEFTDIIS
C      SUBROUTINE LEFTDIIS(IW,NO,NU,MEMS1,MEMS2,
C     *                    AM,AMAUX,FBV,FBVAUX,
C     *                    WR,WI,WORK,VL,VR,
C     *                    T2,TI,T1,EV,
C     *                    C,HC,TEMPI,
C     *                    VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
C     *                    NOU,NU2,NU3,NO2U2,OEH,OEP)
C      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
CCCX      LOGICAL MCIT
CC
C      DIMENSION T2(*),TI(*),T1(*),EV(*),
C     *          AM(MEMS1,MEMS1),AMAUX(MEMS1,MEMS1),
C     *          FBV(MEMS1),FBVAUX(MEMS1),
C     *          WR(MEMS1),WI(MEMS1),WORK(4*MEMS1),
C     *          VL(MEMS1,MEMS1),VR(MEMS1,MEMS1),
C     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
C     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
C     *          OEH(NO),OEP(NU)
CC
C      CHARACTER*3 XSYM
C      CHARACTER*1 JOBVL,JOBVR
C      CHARACTER*3 VECREP
CC
C      PARAMETER (MXAO=8192)
CC
CC     --- END TEMPORARY INTERFACE TO MMCC(2,3) PROGRAM ---
CC
C      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
CC
C      COMMON /EOMFIL/ NSTAR,NC1,NC2,NHC1,NHC2,NHH,NPP,NAX,NAXX,NDIAG,
C     *                ITAPP,IFAX,NRR1,NRR2,NEXM,NEXE,NW2C,NW4C,
C     *                NW4D,NW2BD,NW4B,NROO,NREXM,NREXE,
C     *                JCISD,KCIF,JCISDNX
C      COMMON /EOMINF/ ISPACE,IHSPACE,JCISPACE,ICIMET,IOPTMM,
C     *                NROOT,NOA,NUA,MAXITEOM
C      COMMON /EOMPAR/ CVGCI,CVGEOM,GRPEOM,NSTEOM(8),NOACT,NUACT,
C     *                MOACTCC(MXAO),MTHTRIP,MTHCI,MTHEOM,MTHINIT,
C     *                MAXCI,MAXEOM,MICCI,MICEOM,IROOTCC(2),
C     *                IPROPCC,IPROPCCE
CC MARTA'S FILES
C      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
CC
C      COMMON /EOMWFE/ EOMSDE(100),EOMR0(100),EOMR0L(100),
C     *                CR1D1A(100),CR2D1A(100),CR1D1B(100),CR2D1B(100),
C     *                CRCI3(100),XDELWB(100),XKKEOM(100),
C     *              CR1A(100),CR1B(100),CR1C(100),CR1D(100),CR2A(100),
C     *                CR2B(100),CR2C(100),CR2D(100),CREX3(100),
C     *                KVGEOM(100),IUST(100),IREL(100),
C     *                KKTRIM(100),KKTRIML(100),
C     *                INUMEOM,NTOTEOM,NBADEOM,NTOTCISD,NCVGCISD,LAMCON,
C     *                IVSYMAD(8),VECREP(100)
CC
C      COMMON /IBADMR/ IBAD
CC
CC
C      DATA  ONEM/-1.0D+00/,BIGNUM/10000.0D+00/,TOLIMAG/1.0D-07/
CCC
C
C      DO I=1,100
C       KKTRIML(I)=0
C      ENDDO
C      JOBVR='V'
C      JOBVL='N'
C      LWORK = 4*MEMS1
CC
C      WRITE(IW,8999)
C      WRITE(IW,9000)
C      WRITE(IW,9010)
CC
C      TOL  = CVGEOM
C      TOLPR= 0.05D+00
C      NOUP=NOU+NO2U2
CC
C      CALL ZEROMA(FBVAUX,1,MEMS1)
CC
C      DO 100,NRT=1,NROOT
C      ITERTOT  = 1
C      IF(KKTRIM(NRT).NE.1) GO TO 100
C      WRITE(IW,9014) XKKEOM(NRT),VECREP(NRT)
C      WRITE(IW,9015)
C      EVAL=XKKEOM(NRT)
CCCC        WRITE(IW,*) 'EVAL FROM LEFTDIIS',EVAL
CCCC        CALL FLSHBF(IW)
CC
CC
CC READING INITIAL LAMBDA-VEC (T1 AND T2 VECTORS).
CC
CCCCX      CALL RCCFL(NAX,NRT+2,NOUP,T1)
C       IF(ISPACE.NE.2) THEN
C        CALL RCCFL(NAX,NRT+2,NOUP,T1)
C       ELSE
C        CALL RCCFL(NAX,NRT,NOUP,T1)
C       END IF
CC
C      CALL WCCFL(NNAXL,1,NOUP,T1)
CCCC         WRITE(IW,*) 'AMP L PO INICJALIZACJI'
CCCC         CALL MAXT1T2(NO,NU,T1(1),T1(1+NOU))
C      CALL WCCFL(NL1,1,NOU,T1)
C      CALL WCCFL(NL2,1,NO2U2,T1(NOU+1))
C      CALL LHL1(1,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
C      CALL LHL2(1,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
C     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
C      CALL RCCFL(NL1,1,NOU,EV)
C      CALL RCCFL(NL2,1,NO2U2,EV(NOU+1))
C      CALL RCCFL(NHL1,1,NOU,T1)
C      CALL RCCFL(NHL2,1,NO2U2,T1(NOU+1))
C      CALL DAXPY(NOUP,-EVAL,EV,1,T1,1)
C      CALL WCCFL(NHL1,1,NOU,T1)
C      CALL WCCFL(NHL2,1,NO2U2,T1(1+NOU))
C      CALL RCCFL(NHL1,1,NOU,T1)
C      CALL RCCFL(NHL2,1,NO2U2,T1(NOU+1))
C      CALL WCCFL(NNAXL,2,NOUP,T1)
C 888  CONTINUE
CC NNAXL RECORDE STRUCTURE:
CC #1 => L(N) (N-MICROITERATION'S NUMBER)
CC #2 => U(1), #3 => U(2) ETC.
C      CALL ZEROMA(AM,1,MEMS2)
C      CALL ZEROMA(AMAUX,1,MEMS2)
C      CALL RCCFL(NNAXL,1,NOUP,T1)
C      CALL WCCFL(NL1,1,NOU,T1)
C      CALL WCCFL(NL2,1,NO2U2,T1(NOU+1))
C      CALL RCCFL(NNAXL,2,NOUP,T1)
C      CALL WCCFL(NHL1,1,NOU,T1)
C      CALL WCCFL(NHL2,1,NO2U2,T1(NOU+1))
CC INITIAL ELEMENTS OF AM AND
C      CALL DCOPY(NOUP,T1,1,T2,1)
C      CALL SPINKA(NO,NU,T2)
C      AM(1,1)=DDOT(NOUP,T2,1,T1,1)
C      AMAUX(1,1)=AM(1,1)
CC INITIAL SHIFTS COMPLETED
C      DO 777,I=2,MEMS1
C       CALL ZEROMA(T2,1,NOUP)
C       CALL RCCFL(NNAXL,2,NOUP,T1)
C       CALL DAXPY(NOUP,ONEM,T1,1,T2,1)
CC NOW ON T2 WE STORE (B-L(I)*H(BAR))
C       CALL RCCFL(NDIAG,1,NOUP,T1)
C       DO 12 J=1,NOUP
C          X=EVAL-T1(J)
C          EV(J)=T2(J)/X
C 12    CONTINUE
C NOW: EV=D^{-1}(B-L(I)*H(BAR))
CCCCX       CALL ORTDIIS(NO,NU,NOUP,I-1,EV,T1,T2,RES)
C       CALL ORTDIISLL(NO,NU,NOUP,I-1,EV,T1,T2,RES)
C        WRITE(IW,9020) ITERTOT,RES
C        CALL FLSHBF(IW)
C       IF(ABS(RES).LT.TOL) THEN
C        KKTRIML(NRT)=1
C        GO TO 999
C       END IF
C       CALL WCCFL(NL1,I,NOU,EV)
C       CALL WCCFL(NL2,I,NO2U2,EV(NOU+1))
CC AFTER ORTHOGONALIZATION
C       IXC=I
C       CALL LHL1(IXC,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
C       CALL LHL2(IXC,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
C     *           C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
C       CALL RCCFL(NL1,I,NOU,EV)
C       CALL RCCFL(NL2,I,NO2U2,EV(NOU+1))
C       CALL RCCFL(NHL1,I,NOU,T1)
C       CALL RCCFL(NHL2,I,NO2U2,T1(NOU+1))
C       CALL DAXPY(NOUP,-EVAL,EV,1,T1,1)
C       CALL WCCFL(NHL1,I,NOU,T1)
C       CALL WCCFL(NHL2,I,NO2U2,T1(1+NOU))
CC U(I)*H(BAR) CALCULATED
C       IXC=I
C       CALL SMMADIIS(NO,NU,IXC,T1,T2,AM,AMAUX,MEMS1)
CC NOW: SOLVING DIIS EQUATIONS: DGEFA AND DGESL
C       IF(I.LT.MEMS1) THEN
C         DO 14,J=I+1,MEMS1
C          AM(J,J)=BIGNUM
C 14      CONTINUE
C       END IF
C       CALL ZEROMA(VR,1,MEMS2)
C       CALL ZEROMA(VL,1,MEMS2)
C       CALL ZEROMA(WR,1,MEMS1)
C       CALL ZEROMA(WI,1,MEMS1)
CCC        WRITE(IW,*) 'MACIERZ AM'
CCC        DO 7113,IIIX=1,MEMS1
CCC        WRITE(IW,7150)(AM(IIIX,IIIY),IIIY=1,MEMS1)
CCC 7113   CONTINUE
C       CALL DGEEV(JOBVL,JOBVR,MEMS1,AM,MEMS1,WR,WI,
C     *           VL,MEMS1,VR,MEMS1,WORK,LWORK,INFO)
C       IF(INFO.NE.0) THEN
C            WRITE(IW,*) 'EOMCCSD SOLVER ERROR INFO:',INFO
C            CALL ABRT
C            STOP
C       END IF
CCC        WRITE(IW,*) 'MACIERZ VR'
CCC        DO 7112,IIIX=1,MEMS1
CCC        WRITE(IW,7150)(VR(IIIX,IIIY),IIIY=1,MEMS1)
CCC 7112   CONTINUE
CCC 7150   FORMAT(5F15.7)
CCCX       IMAX=0
CCCX       XMAX=0.0D+00
CCCX       DO 320,J=1,MEMS1
CCCX        XXX=ABS(VR(1,J))
CCCX        IF(XXX.GT.XMAX) THEN
CCCX         IMAX=J
CCCX         XMAX=XXX
CCCX        END IF
CCCX 320   CONTINUE
CCCX          WRITE(IW,*) 'LEFTDIIS IMAX=',IMAX
CCCX          CALL FLSHBF(IW)
CCCX       IF(IMAX.EQ.0) THEN
CCCX         WRITE(IW,*) 'PROBLEM WITH SORTING IN LEFTDIIS'
CCCX         CALL ABRT
CCCX       END IF
CCCX       DO 321,J=1,MEMS1
CCCX        FBV(J)=VR(J,IMAX)
CCCX 321   CONTINUE
C       IMIN=0
C       EMIN=(2.0D+00)*BIGNUM
C       DO 320,J=1,MEMS1
C        ZIMAG=ABS(WI(J))
C        IF(ZIMAG.GT.TOLIMAG) GO TO 320
C        ZREAL=ABS(WR(J))
C        IF(ZREAL.LT.EMIN) THEN
C          EMIN=WR(J)
C          IMIN=J
C        END IF
C 320   CONTINUE
CCC         WRITE(IW,*) 'FROM LEFTDIIS IMIN=',IMIN
CCC         WRITE(IW,*) 'FROM LEFTDIIS EMIN=',EMIN
C       IF(IMIN.EQ.0) THEN
C         WRITE(IW,*) 'PROBLEM WITH SORTING IN LEFTDIIS'
C         CALL ABRT
C       END IF
C       DO 321,J=1,MEMS1
C        FBV(J)=VR(J,IMIN)
C 321   CONTINUE
CC NOW: FORMING OPTIMAL LINEAR COMBINATION
C       CALL COMBDIIS(NL1,I,NO,NU,MEMS1,FBV,T1,T2)
C       CALL WCCFL(NNAXL,1,NOUP,T2)
CCC         WRITE(IW,*) 'AMP L PO COMBDIIS'
CCC         CALL MAXT1T2(NO,NU,T2(1),T2(1+NOU))
C       CALL COMBDIIS(NHL1,I,NO,NU,MEMS1,FBV,T1,T2)
C       CALL WCCFL(NNAXL,2,NOUP,T2)
C       ITERTOT=ITERTOT+1
C       IF(ITERTOT.GT.MAXITEOM) GO TO 1000
CC TEST FOR MAXIT
C 777  CONTINUE
CC
C      GO TO 888  !MAIN LOOP
CC
C 1000 CONTINUE  ! NOT CONVERGED
C        WRITE(IW,9025)
C 999  CONTINUE  ! CONVERGED
CC
CC
C       IF(ISPACE.NE.2) THEN        !READING RIGHT EIGVE.
C        CALL RCCFL(NAX,NRT+2,NOUP,EV)
C       ELSE
C        CALL RCCFL(NAXX,NRT,NOUP,EV)
C       END IF
C      CALL RCCFL(NNAXL,1,NOUP,T1)  !READING LEFT EIGVE.
CC
C      CALL BIORTF2(NO,NU,NOUP,EV,T1,T2,TI,EVAL,R00X)
CC
C      CALL WCCFL(NNAXL,2+NRT,NOUP,T1)
C         CALL FIXSYM(NO,NU,T1(1),T1(1+NOU),XSYM)
C         WRITE(IW,9330) XSYM
CC
CC         AMPLITUDE PRINTING...
CC
C      WRITE(IW,9030)
CC
C      IPOS=1
C      DO 560 IIIA=1,NU
C       DO 561 IIII=1,NO
C        XXX=ABS(T1(IPOS))
C        IF(XXX.GT.TOLPR) THEN
C         WRITE(IW,9040) T1(IPOS),IIII,IIIA+NO
C        END IF
C        IPOS=IPOS+1
C  561  CONTINUE
C  560 CONTINUE
CC
C      IPOS=1
C      DO 570,JJJ=1,NO
C       DO 571,JJB=1,NU
C        DO 572,IIA=1,NU
C         DO 573,III=1,NO
C          XXX=ABS(T1(IPOS+NOU))
C          IF(XXX.GT.TOLPR) THEN
C            WRITE(IW,9050) T1(IPOS+NOU),III,JJJ,IIA+NO,JJB+NO
C          END IF
C          IPOS=IPOS+1
C  573    CONTINUE
C  572   CONTINUE
C  571  CONTINUE
C  570 CONTINUE
CC
C 100  CONTINUE
CC
CC
C      RETURN
CC
C 8999 FORMAT(////,7X,'DIIS PROCEDURE FOR LEFT EOMCCSD PROBLEM',//)
C 9000 FORMAT(/7X,'RESULTS  OF  THE  LEFT EOMCCSD VECTOR ITERATIONS')
C 9010 FORMAT(/1X,'SOLVING LEFT VECTOR')
C 9014 FORMAT(//2X,'EXCIT. ENERGY',F15.9,1X,'SYMMETRY:',1X,A3)
C 9015 FORMAT(1X,' ITR      CONVERG.')
C 9020 FORMAT(1X,I5,F15.9)
C 9025 FORMAT(/1X,'* * * UWAGA! * * * LAMBDA-VEC DID NOT CONVERGE.'/)
C 9030 FORMAT(1X,'THE LARGEST LA1 AND LA2 AMPLITUDES FOR THIS ROOT ARE')
C 9040 FORMAT(1X,'LA1=',F15.10,' FOR   I -> A   =',2I5)
C 9050 FORMAT(1X,'LA2=',F15.10,' FOR I,J -> A,B =',4I5)
C 9330 FORMAT(1X,'SYMMETRY OF THE STATE: ',A3)
C      END
C
C
C*MODULE EOMCC   *DECK LEFTDIISH
      SUBROUTINE LEFTDIISH(IW,NO,NU,MEMS1,MEMS2,
     *                    AM,AMAUX,FBV,FBVAUX,
     *                    WR,WI,WORK,VL,VR,
     *                    T2,TI,T1,EV,
     *                    C,HC,TEMPI,
     *                    VEWORK,C13BDY,FP3BDY,T23BDY,VOE3BDY,
     *                    NOU,NU2,NU3,NO2U2,OEH,OEP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
CCCX      LOGICAL MCIT
C
      DIMENSION T2(*),TI(*),T1(*),EV(*),
     *          AM(MEMS1,MEMS1),AMAUX(MEMS1,MEMS1),
     *          FBV(MEMS1),FBVAUX(MEMS1),
     *          WR(MEMS1),WI(MEMS1),WORK(4*MEMS1),
     *          VL(MEMS1,MEMS1),VR(MEMS1,MEMS1),
     *          C(NO2U2),HC(NO2U2),TEMPI(NU3),VEWORK(*),
     *          C13BDY(NOU),FP3BDY(NU2),T23BDY(NO2U2),VOE3BDY(NO2U2),
     *          OEH(NO),OEP(NU)
C
      CHARACTER*3 XSYM
      CHARACTER*1 JOBVL,JOBVR
      CHARACTER*3 VECREP
C
      PARAMETER (MXAO=8192)
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 /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
      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
C
      DATA ONEM/-1.0D+00/,BIGNUM/10000.0D+00/
C
C
      DO I=1,100
       KKTRIML(I)=0
      ENDDO
      JOBVR='N'
      JOBVL='V'
      LWORK = 4*MEMS1
C
      WRITE(IW,8999)
      WRITE(IW,9000)
      WRITE(IW,9010)
C
      TOL  = CVGEOM
      TOLPR= 0.05D+00
      NOUP=NOU+NO2U2
C
      CALL ZEROMA(FBVAUX,1,MEMS1)
C
      DO 100,NRT=1,NROOT
      ITERTOT  = 1
      ELOCAL=0.0D+00
      IF(KKTRIM(NRT).NE.1) GO TO 100
      WRITE(IW,9014) XKKEOM(NRT),VECREP(NRT)
      WRITE(IW,9015)
      EVAL=XKKEOM(NRT)
CCC        WRITE(IW,*) 'EVAL FROM LEFTDIIS',EVAL
CCC        CALL FLSHBF(IW)
C
C
C READING INITIAL LAMBDA-VEC (T1 AND T2 VECTORS).
C
       IF(ISPACE.NE.2) THEN
         CALL RCCFL(NAX,NRT+2,NOUP,T1)
       ELSE
         CALL RCCFL(NAX,NRT,NOUP,T1)
       END IF
C
      CALL WCCFL(NNAXL,1,NOUP,T1)
CCC         WRITE(IW,*) 'AMP L PO INICJALIZACJI'
CCC         CALL MAXT1T2(NO,NU,T1(1),T1(1+NOU))
      CALL WCCFL(NL1,1,NOU,T1)
      CALL WCCFL(NL2,1,NO2U2,T1(NOU+1))
      CALL LHL1(1,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
      CALL LHL2(1,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *          C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
      CALL RCCFL(NL1,1,NOU,EV)
      CALL RCCFL(NL2,1,NO2U2,EV(NOU+1))
      CALL RCCFL(NHL1,1,NOU,T1)
      CALL RCCFL(NHL2,1,NO2U2,T1(NOU+1))
      CALL DAXPY(NOUP,-EVAL,EV,1,T1,1)
      CALL WCCFL(NHL1,1,NOU,T1)
      CALL WCCFL(NHL2,1,NO2U2,T1(1+NOU))
      CALL RCCFL(NHL1,1,NOU,T1)
      CALL RCCFL(NHL2,1,NO2U2,T1(NOU+1))
      CALL WCCFL(NNAXL,2,NOUP,T1)
 888  CONTINUE
C NNAXL RECORDE STRUCTURE:
C #1 => L(N) (N-MICROITERATION'S NUMBER)
C #2 => U(1), #3 => U(2) ETC.
      CALL ZEROMA(AM,1,MEMS2)
      CALL ZEROMA(AMAUX,1,MEMS2)
      CALL RCCFL(NNAXL,1,NOUP,T1)
      CALL WCCFL(NL1,1,NOU,T1)
      CALL WCCFL(NL2,1,NO2U2,T1(NOU+1))
      CALL RCCFL(NNAXL,2,NOUP,T1)
      CALL WCCFL(NHL1,1,NOU,T1)
      CALL WCCFL(NHL2,1,NO2U2,T1(NOU+1))
C INITIAL ELEMENTS OF AM AND
CCCX      CALL DCOPY(NOUP,T1,1,T2,1)
      CALL RCCFL(NNAXL,1,NOUP,T2)
      CALL SPINKA(NO,NU,T2)
      AM(1,1)=DDOT(NOUP,T2,1,T1,1)
      AMAUX(1,1)=AM(1,1)
C INITIAL SHIFTS COMPLETED
      DO 777,I=2,MEMS1
       CALL ZEROMA(T2,1,NOUP)
       CALL RCCFL(NNAXL,2,NOUP,T1)
       CALL DAXPY(NOUP,ONEM,T1,1,T2,1)
C NOW ON T2 WE STORE (B-L(I)*H(BAR))
       CALL RCCFL(NDIAG,1,NOUP,T1)
       DO 12 J=1,NOUP
          X=ELOCAL-(EVAL-T1(J))
          EV(J)=T2(J)/X
 12    CONTINUE
C NOW: EV=D^{-1}(B-L(I)*H(BAR))
CCCX       CALL ORTDIIS(NO,NU,NOUP,I-1,EV,T1,T2,RES)
       CALL ORTDIISLL(NO,NU,NOUP,I-1,EV,T1,T2,RES)
        WRITE(IW,9020) ITERTOT,RES
        CALL FLSHBF(IW)
       IF(ABS(RES).LT.TOL) THEN
        KKTRIML(NRT)=1
        GO TO 999
       END IF
       CALL WCCFL(NL1,I,NOU,EV)
       CALL WCCFL(NL2,I,NO2U2,EV(NOU+1))
C AFTER ORTHOGONALIZATION
       IXC=I
       CALL LHL1(IXC,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP)
       CALL LHL2(IXC,NO,NU,C,HC,TEMPI,VEWORK,OEH,OEP,
     *           C13BDY,FP3BDY,T23BDY,VOE3BDY,NOU,NU2,NO2U2)
       CALL RCCFL(NL1,I,NOU,EV)
       CALL RCCFL(NL2,I,NO2U2,EV(NOU+1))
       CALL RCCFL(NHL1,I,NOU,T1)
       CALL RCCFL(NHL2,I,NO2U2,T1(NOU+1))
       CALL DAXPY(NOUP,-EVAL,EV,1,T1,1)
       CALL WCCFL(NHL1,I,NOU,T1)
       CALL WCCFL(NHL2,I,NO2U2,T1(1+NOU))
C U(I)*H(BAR) CALCULATED
       IXC=I
       CALL SMMADIISH(NO,NU,IXC,T1,T2,AM,AMAUX,MEMS1)
C NOW: SOLVING DIIS EQUATIONS: DGEFA AND DGESL
       IF(I.LT.MEMS1) THEN
         DO 14,J=I+1,MEMS1
          AM(J,J)=BIGNUM
 14      CONTINUE
       END IF
       CALL ZEROMA(VR,1,MEMS2)
       CALL ZEROMA(VL,1,MEMS2)
       CALL ZEROMA(WR,1,MEMS1)
       CALL ZEROMA(WI,1,MEMS1)
CCC        WRITE(IW,*) 'MACIERZ AM'
CCC        DO 7113,IIIX=1,MEMS1
CCC        WRITE(IW,7150)(AM(IIIX,IIIY),IIIY=1,MEMS1)
CCC 7113   CONTINUE
       CALL DGEEV(JOBVL,JOBVR,MEMS1,AM,MEMS1,WR,WI,
     *           VL,MEMS1,VR,MEMS1,WORK,LWORK,INFO)
       IF(INFO.NE.0) THEN
            WRITE(IW,*) 'EOMCCSD SOLVER ERROR INFO:',INFO
            CALL ABRT
            STOP
       END IF
CCC        WRITE(IW,*) 'MACIERZ VR'
CCC        DO 7112,IIIX=1,MEMS1
CCC        WRITE(IW,7150)(VL(IIIX,IIIY),IIIY=1,MEMS1)
CCC 7112   CONTINUE
CCC 7150   FORMAT(5F15.7)
       IMAX=0
       XMAX=0.0D+00
       DO 320,J=1,MEMS1
        XXX=ABS(VL(1,J))
        IF(XXX.GT.XMAX) THEN
         IMAX=J
         XMAX=XXX
        END IF
 320   CONTINUE
CCCX          WRITE(IW,*) 'LEFTDIIS IMAX=',IMAX
CCCX          CALL FLSHBF(IW)
       IF(IMAX.EQ.0) THEN
         WRITE(IW,*) 'PROBLEM WITH SORTING IN LEFTDIIS'
         CALL ABRT
       END IF
       DO 321,J=1,MEMS1
        FBV(J)=VL(J,IMAX)
 321   CONTINUE
       ELOCAL=WR(IMAX)
C
CCCX       IMIN=0
CCCX       EMIN=(2.0D+00)*BIGNUM
CCCX       DO 320,J=1,MEMS1
CCCX        ZIMAG=ABS(WI(J))
CCCX        IF(ZIMAG.GT.TOLIMAG) GO TO 320
CCCX        ZREAL=ABS(WR(J))
CCCX        IF(ZREAL.LT.EMIN) THEN
CCCX          EMIN=WR(J)
CCCX          IMIN=J
CCCX        END IF
CCCX 320   CONTINUE
CCC         WRITE(IW,*) 'FROM LEFTDIIS IMIN=',IMIN
CCC         WRITE(IW,*) 'FROM LEFTDIIS EMIN=',EMIN
CCCX       IF(IMIN.EQ.0) THEN
CCCX         WRITE(IW,*) 'PROBLEM WITH SORTING IN LEFTDIIS'
CCCX         CALL ABRT
CCCX       END IF
CCCX       DO 321,J=1,MEMS1
CCCX        FBV(J)=VL(J,IMIN)
CCCX 321   CONTINUE
C NOW: FORMING OPTIMAL LINEAR COMBINATION
       CALL COMBDIIS(NL1,I,NO,NU,MEMS1,FBV,T1,T2)
       CALL WCCFL(NNAXL,1,NOUP,T2)
CCC         WRITE(IW,*) 'AMP L PO COMBDIIS'
CCC         CALL MAXT1T2(NO,NU,T2(1),T2(1+NOU))
       CALL COMBDIIS(NHL1,I,NO,NU,MEMS1,FBV,T1,T2)
       CALL WCCFL(NNAXL,2,NOUP,T2)
       ITERTOT=ITERTOT+1
       IF(ITERTOT.GT.MAXITEOM) THEN
         KKTRIML(NRT)=0
         GO TO 1000
       END IF
C TEST FOR MAXIT
 777  CONTINUE
C
      GO TO 888  !MAIN LOOP
C
 1000 CONTINUE  ! NOT CONVERGED
        WRITE(IW,9025)
 999  CONTINUE  ! CONVERGED
C
C
C
C
       IF(ISPACE.NE.2) THEN        !READING RIGHT EIGVE.
        CALL RCCFL(NAX,NRT+2,NOUP,EV)
       ELSE
        CALL RCCFL(NAX,NRT,NOUP,EV)
       END IF
      CALL RCCFL(NNAXL,1,NOUP,T1)  !READING LEFT EIGVE.
C
      CALL BIORTF2(NO,NU,NOUP,EV,T1,T2,TI,EVAL,R00X)
C
      CALL WCCFL(NNAXL,2+NRT,NOUP,T1)
         CALL FIXSYM(NO,NU,T1(1),T1(1+NOU),XSYM)
         WRITE(IW,9330) XSYM
C
C         AMPLITUDE PRINTING...
C
      WRITE(IW,9030)
C
      IPOS=1
      DO 560 IIIA=1,NU
       DO 561 IIII=1,NO
        XXX=ABS(T1(IPOS))
        IF(XXX.GT.TOLPR) THEN
         WRITE(IW,9040) T1(IPOS),IIII,IIIA+NO
        END IF
        IPOS=IPOS+1
  561  CONTINUE
  560 CONTINUE
C
      IPOS=1
      DO 570,JJJ=1,NO
       DO 571,JJB=1,NU
        DO 572,IIA=1,NU
         DO 573,III=1,NO
          XXX=ABS(T1(IPOS+NOU))
          IF(XXX.GT.TOLPR) THEN
            WRITE(IW,9050) T1(IPOS+NOU),III,JJJ,IIA+NO,JJB+NO
          END IF
          IPOS=IPOS+1
  573    CONTINUE
  572   CONTINUE
  571  CONTINUE
  570 CONTINUE
C
 100  CONTINUE
C
C
      RETURN
C
 8999 FORMAT(////,7X,'DIIS PROCEDURE FOR LEFT EOMCCSD PROBLEM',//)
 9000 FORMAT(/7X,'RESULTS  OF  THE  LEFT EOMCCSD VECTOR ITERATIONS')
 9010 FORMAT(/1X,'SOLVING LEFT VECTOR')
 9014 FORMAT(//2X,'EXCIT. ENERGY',F15.9,1X,'SYMMETRY:',1X,A3)
 9015 FORMAT(1X,' ITR      CONVERG.')!!!
 9020 FORMAT(1X,I5,F15.9)  !!!
 9025 FORMAT(/1X,'* * * UWAGA! * * * LAMBDA-VEC DID NOT CONVERGE.'/)
 9030 FORMAT(1X,'THE LARGEST LA1 AND LA2 AMPLITUDES FOR THIS ROOT ARE')
 9040 FORMAT(1X,'LA1=',F15.10,' FOR   I -> A   =',2I5)
 9050 FORMAT(1X,'LA2=',F15.10,' FOR I,J -> A,B =',4I5)
 9330 FORMAT(1X,'SYMMETRY OF THE STATE: ',A3) !!!
      END
C
C
C
C
C
      SUBROUTINE BIORTF1(NO,NU,NOUP,EV,T1,TI,EVAL,R00)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION EV(*),T1(*),TI(*)
      DATA ONE/1.0D+00/,TWO/2.0D+00/
      NOU=NO*NU
      NO2U2=NOU*NOU
C NORMALIZATION OF R-VECTOR TO 1
      CALL DCOPY(NOUP,EV,1,T1,1)
      CALL SPINKA(NO,NU,T1)
      Z=DDOT(NOUP,EV,1,T1,1)
      CALL RO1(3,NO,NU,T1)
      R0A=TWO*DDOT(NOU,T1,1,EV,1)
      CALL RO2HPP(1,NO,NU,TI,T1)
      CALL SYMT21(T1,NO,NU,NU,NO,23)
      R0B=DDOT(NO2U2,T1,1,EV(NOU+1),1)
      R00=(R0A+R0B)/EVAL
      Z=Z+R00*R00
      Z=ABS(Z)
      CALL DSCAL(NOUP,ONE/SQRT(Z),EV,1)
      R00=R00/SQRT(Z)
         CALL DCOPY(NOUP,EV,1,T1,1)
         CALL SPINKA(NO,NU,T1)
         Z=DDOT(NOUP,EV,1,T1,1)
         Z=Z+R00*R00
      RETURN
      END
C
      SUBROUTINE BIORTF2(NO,NU,NOUP,EV,EVV,T1,TI,EVAL,R00)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION EV(*),EVV(*),T1(*),TI(*)
      DATA ONE/1.0D+00/,TWO/2.0D+00/
      NOU=NO*NU
      NO2U2=NOU*NOU
C NORMALIZATION OF R-VECTOR TO 1
      CALL DCOPY(NOUP,EV,1,T1,1)
      CALL SPINKA(NO,NU,T1)
      Z=DDOT(NOUP,EV,1,T1,1)
      CALL RO1(3,NO,NU,T1)
      R0A=TWO*DDOT(NOU,T1,1,EV,1)
      CALL RO2HPP(1,NO,NU,TI,T1)
      CALL SYMT21(T1,NO,NU,NU,NO,23)
      R0B=DDOT(NO2U2,T1,1,EV(NOU+1),1)
      R00=(R0A+R0B)/EVAL
      Z=Z+R00*R00
      Z=ABS(Z)
      CALL DSCAL(NOUP,ONE/SQRT(Z),EV,1)
      R00=R00/SQRT(Z)
C BIORTHONORMALIZATION <L|R>
      CALL DCOPY(NOUP,EVV,1,T1,1)
      CALL SPINKA(NO,NU,T1)
      Z=DDOT(NOUP,EV,1,T1,1)
      IF(Z.LT.0.0D+00) THEN
      Z=ABS(Z)
      CALL DSCAL(NOUP,-ONE/Z,EVV,1)
      ELSE
      Z=ABS(Z)
      CALL DSCAL(NOUP,ONE/Z,EVV,1)
      END IF
      RETURN
      END
C
C
C
C*MODULE EOMCC   *DECK ORT3RL
      SUBROUTINE ORT3RL(NO,NU,N,ND,VA,VX,TMP,RES,ICS)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION VA(N),VX(N),TMP(N)
      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 MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
      DATA ONE /1.0D+00/
C ICS=1(VA-RIGHT EIGENVECTOR)
C ISC=2(VA-LEFT  EIGENVECTOR)
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
      IF(ICS.EQ.1) THEN
       IFILE1=NC1
       IFILE2=NC2
       JFILE1=NL1
       JFILE2=NL2
      ELSE
       IFILE1=NL1
       IFILE2=NL2
       JFILE1=NC1
       JFILE2=NC2
      END IF
C
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)   !VA IS READY FOR DDOT-ING
      RES=DDOT(NOUP,TMP,1,VA,1)
      RES=SQRT(RES)
      DO 10,I=1,ND
       CALL RCCFL(JFILE1,I,NOU,VX)
       CALL RCCFL(JFILE2,I,NO2U2,VX(NOU+1))
       XOV1=DDOT(N,TMP,1,VX,1)
       CALL RCCFL(IFILE1,I,NOU,VX)
       CALL RCCFL(IFILE2,I,NO2U2,VX(NOU+1))
       CALL DSCAL(N,-XOV1,VX,1)
       CALL DAXPY(N,ONE,VX,1,VA,1)
       CALL DCOPY(N,VA,1,TMP,1) ! ADDED
       CALL SPINKA(NO,NU,TMP)   ! VA IS READY FOR DDOT-ING
 10   CONTINUE
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)
      XOV2=DDOT(N,TMP,1,VA,1)
      XOV2=ABS(XOV2)
      RXX=ONE/SQRT(XOV2)
      CALL DSCAL(N,RXX,VA,1)
      RETURN
      END
C
C*MODULE EOMCC   *DECK SMALMARL
      SUBROUTINE SMALMARL(NO,NU,NSP,T1,T2,AS,R,MEMS1)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(*),T2(*),AS(MEMS1,MEMS1),R(MEMS1,MEMS1)
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 MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
C
CCC      IF (NSP.GT.1) THEN
CCC         CALL RADCOPY(NSP,NSP-1,R,AS)
CCC      END IF
         DO 1,I=1,MEMS1
         DO 2,J=1,MEMS1
          AS(I,J)=R(I,J)
 2       CONTINUE
 1       CONTINUE
C
      CALL RCCFL(NL1,NSP,NOU,T2)
      CALL RCCFL(NL2,NSP,NO2U2,T2(1+NOU))
      CALL SPINKA(NO,NU,T2)
      DO 15 I=1,NSP
         CALL RCCFL(NHC1,I,NOU,T1)                           !NEW
         CALL RCCFL(NHC2,I,NO2U2,T1(1+NOU))                  !NEW
         AS(NSP,I)=DDOT(NOUP,T2,1,T1,1)
 15   CONTINUE
C
      CALL RCCFL(NHC1,NSP,NOU,T1)                           !NEW
      CALL RCCFL(NHC2,NSP,NO2U2,T1(1+NOU))                  !NEW
      CALL SPINKA(NO,NU,T1)
      DO 16 I=1,NSP
         CALL RCCFL(NL1,I,NOU,T2)
         CALL RCCFL(NL2,I,NO2U2,T2(1+NOU))
         AS(I,NSP)=DDOT(NOUP,T1,1,T2,1)
 16   CONTINUE
CCC      CALL DCOPY(NSP*NSP,AS,1,R,1)
CCC      CALL RADCOPY(NSP,NSP,AS,R)
         DO 3,I=1,MEMS1
         DO 4,J=1,MEMS1
          R(I,J)=AS(I,J)
 4       CONTINUE
 3       CONTINUE
      RETURN
      END
C
C
C*MODULE EOMCC   *DECK DIAGORL
      SUBROUTINE DIAGORL(IW,XMAT,WR,WI,WORK,VR,VL,IDIM,MEMS1)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION XMAT(MEMS1,MEMS1),WR(MEMS1),WI(MEMS1),
     *          WORK(4*MEMS1),VR(MEMS1,MEMS1),VL(MEMS1,MEMS1)
      CHARACTER*1 JOBVL,JOBVR
      JOBVL = 'V'
      JOBVR = 'V'
      LWORK = 4*MEMS1
      CALL DGEEV(JOBVL,JOBVR,IDIM,XMAT,MEMS1,WR,WI,
     *           VL,MEMS1,VR,MEMS1,WORK,LWORK,INFO)
      IF(INFO.NE.0) THEN
            WRITE(IW,*) 'EOMCCSD SOLVER ERROR INFO:',INFO
            CALL ABRT
            STOP
      END IF
      RETURN
      END
C*MODULE EOMCC   *DECK SELVECRL
      SUBROUTINE SELVECRL(NO,NU,NSP,MEMS1,WR,WI,VR,VL,EV,EVV,
     *              T2,TI,EVAL,IMAX)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION WR(MEMS1),WI(MEMS1),VR(MEMS1,MEMS1),
     *          VL(MEMS1,MEMS1),EV(*),EVV(*),T2(*),TI(*)
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 MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
      DATA ZERO/0.0D+00/TOLIMAG/1.0D-07/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP=NOU+NO2U2
      CALL RCCFL(NAX,2,NOUP,EV)
      CALL RCCFL(NNAXL,2,NOUP,EVV)
      DO 1 I=1,NSP
      CALL RCCFL(NC1,I,NOU,T2)
      CALL RCCFL(NC2,I,NO2U2,T2(1+NOU))
      TI(I)=DDOT(NOUP,T2,1,EV,1)
 1    CONTINUE
      XMAX=ZERO
      IMAX=1
      DO 10 I=1,NSP
      X=ABS(DDOT(NSP,TI,1,VR(1,I),1))
      EIMAG=ABS(WI(I))
      IF (X.GT.XMAX.AND.EIMAG.LE.TOLIMAG) THEN
      XMAX=X
      IMAX=I
      END IF
 10   CONTINUE
      EVAL=WR(IMAX)
      CALL COMBRL(NC1,NSP,NO,NU,MEMS1,VR,IMAX,T2,TI)
      CALL DCOPY(NOUP,TI,1,EV,1)
      CALL COMBRL(NL1,NSP,NO,NU,MEMS1,VL,IMAX,T2,TI)
      CALL DCOPY(NOUP,TI,1,EVV,1)
      RETURN
      END
C*MODULE EOMCC   *DECK COMBRL
      SUBROUTINE COMBRL(NF,NSP,NO,NU,MEMS1,VR,IMAX,T1,TI)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(*),TI(*),VR(MEMS1,MEMS1)
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 MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C LINEAR COMBINATION OF VECTORS STORED ON TI
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
      CALL ZEROMA(TI,1,NOUP)
      DO I=1,NSP
         CALL RCCFL(NF,I,NOU,T1)
         IF(NF.EQ.NHC1) NF1=NHC2
         IF(NF.EQ.NC1)  NF1=NC2
         IF(NF.EQ.NL1)  NF1=NL2
         IF(NF.EQ.NHL1) NF1=NHL2
         CALL RCCFL(NF1,I,NO2U2,T1(1+NOU))
         X=VR(I,IMAX)
         CALL DAXPY(NOUP,X,T1,1,TI,1)
      ENDDO
      RETURN
      END
C*MODULE EOMCC   *DECK DEACTSM
      SUBROUTINE DEACTSM(IDIM,MEMS1,R,XMAT)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION R(MEMS1,MEMS1),XMAT(MEMS1,MEMS1)
      DATA ZERO /0.0D+00/
      DO 1,I=IDIM+1,MEMS1
      DO 2,J=1,MEMS1
         R(I,J)=ZERO
         R(J,I)=ZERO
         XMAT(I,J)=ZERO
         XMAT(J,I)=ZERO
 2    CONTINUE
 1    CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK ORTDIIS
      SUBROUTINE ORTDIIS(NO,NU,N,ND,VA,VX,TMP,RES)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION VA(N),VX(N),TMP(N)
C MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
CCCX      DATA ONE /1.0D+00/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
C
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)   !VA IS READY FOR DDOT-ING
      RES=DDOT(NOUP,TMP,1,VA,1)
      RES=ABS(RES)
      RES=SQRT(RES)
      DO 10,I=1,ND
       CALL RCCFL(NL1,I,NOU,VX)
       CALL RCCFL(NL2,I,NO2U2,VX(NOU+1))
       XOV1=DDOT(N,TMP,1,VX,1)
       CALL DAXPY(N,-XOV1,VX,1,VA,1)
       CALL DCOPY(N,VA,1,TMP,1)
       CALL SPINKA(NO,NU,TMP)   ! VA IS READY FOR DDOT-ING
 10   CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK ORTDIISLL
      SUBROUTINE ORTDIISLL(NO,NU,N,ND,VA,VX,TMP,RES)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION VA(N),VX(N),TMP(N)
C MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
CCCX      DATA ONE /1.0D+00/
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
C
      CALL DCOPY(N,VA,1,TMP,1)
      CALL SPINKA(NO,NU,TMP)   !VA IS READY FOR DDOT-ING
      RES=DDOT(NOUP,TMP,1,VA,1)
      RES=ABS(RES)
      RES=SQRT(RES)
      DO 10,I=1,ND
       CALL RCCFL(NL1,I,NOU,VX)
       CALL RCCFL(NL2,I,NO2U2,VX(NOU+1))
       XOV1=DDOT(N,TMP,1,VX,1)
       CALL DAXPY(N,-XOV1,VX,1,VA,1)
       CALL DCOPY(N,VA,1,TMP,1)
       CALL SPINKA(NO,NU,TMP)   ! VA IS READY FOR DDOT-ING
 10   CONTINUE
      CALL DCOPY(N,VA,1,TMP,1) !NORMAL.OF THE CORR.
      CALL SPINKA(NO,NU,TMP)
      XNO=DDOT(NOUP,TMP,1,VA,1)
      IF(XNO.LT.0.0D+00) THEN
       XNO1=-1.0D+00/SQRT(-XNO)
       CALL DSCAL(NOUP,XNO1,VA,1)
      ELSE
       XNO1=1.0D+00/SQRT(XNO)
       CALL DSCAL(NOUP,XNO1,VA,1)
      END IF
      RETURN
      END
C
C*MODULE EOMCC   *DECK SMMADIIS
      SUBROUTINE SMMADIIS(NO,NU,NSP,T1,T2,AS,R,MEMS1)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(*),T2(*),AS(MEMS1,MEMS1),R(MEMS1,MEMS1)
C
C MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
C
         DO 1,I=1,MEMS1
         DO 2,J=1,MEMS1
          AS(I,J)=R(I,J)
 2       CONTINUE
 1       CONTINUE
C
      CALL RCCFL(NHL1,NSP,NOU,T2)
      CALL RCCFL(NHL2,NSP,NO2U2,T2(1+NOU))
      CALL SPINKA(NO,NU,T2)
      DO 15 I=1,NSP
         CALL RCCFL(NHL1,I,NOU,T1)                           !NEW
         CALL RCCFL(NHL2,I,NO2U2,T1(1+NOU))                  !NEW
         AS(NSP,I)=DDOT(NOUP,T2,1,T1,1)
 15   CONTINUE
C
      CALL RCCFL(NHL1,NSP,NOU,T1)                           !NEW
      CALL RCCFL(NHL2,NSP,NO2U2,T1(1+NOU))                  !NEW
      CALL SPINKA(NO,NU,T1)
      DO 16 I=1,NSP
         CALL RCCFL(NHL1,I,NOU,T2)
         CALL RCCFL(NHL2,I,NO2U2,T2(1+NOU))
         AS(I,NSP)=DDOT(NOUP,T1,1,T2,1)
 16   CONTINUE
         DO 3,I=1,MEMS1
         DO 4,J=1,MEMS1
          R(I,J)=AS(I,J)
 4       CONTINUE
 3       CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK SMMADIISH
      SUBROUTINE SMMADIISH(NO,NU,NSP,T1,T2,AS,R,MEMS1)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(*),T2(*),AS(MEMS1,MEMS1),R(MEMS1,MEMS1)
C
C MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
C
         DO 1,I=1,MEMS1
         DO 2,J=1,MEMS1
          AS(I,J)=R(I,J)
 2       CONTINUE
 1       CONTINUE
C
      CALL RCCFL(NHL1,NSP,NOU,T2)
      CALL RCCFL(NHL2,NSP,NO2U2,T2(1+NOU))
      CALL SPINKA(NO,NU,T2)
      DO 15 I=1,NSP
         CALL RCCFL(NL1,I,NOU,T1)                           !NEW
         CALL RCCFL(NL2,I,NO2U2,T1(1+NOU))                  !NEW
         AS(NSP,I)=DDOT(NOUP,T2,1,T1,1)
 15   CONTINUE
C
      CALL RCCFL(NL1,NSP,NOU,T1)                           !NEW
      CALL RCCFL(NL2,NSP,NO2U2,T1(1+NOU))                  !NEW
      CALL SPINKA(NO,NU,T1)
      DO 16 I=1,NSP
         CALL RCCFL(NHL1,I,NOU,T2)
         CALL RCCFL(NHL2,I,NO2U2,T2(1+NOU))
         AS(I,NSP)=DDOT(NOUP,T1,1,T2,1)
 16   CONTINUE
         DO 3,I=1,MEMS1
         DO 4,J=1,MEMS1
          R(I,J)=AS(I,J)
 4       CONTINUE
 3       CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK COMBDIIS
      SUBROUTINE COMBDIIS(NF,NSP,NO,NU,MEMS1,VR,T1,TI)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION T1(*),TI(*),VR(MEMS1)
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 MARTA'S FILES
      COMMON /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
C LINEAR COMBINATION OF VECTORS STORED ON TI
      NOU   = NO*NU
      NO2U2 = NO*NO*NU*NU
      NOUP  = NOU + NO2U2
      CALL ZEROMA(TI,1,NOUP)
      DO I=1,NSP
         CALL RCCFL(NF,I,NOU,T1)
         IF(NF.EQ.NHC1) NF1=NHC2
         IF(NF.EQ.NC1)  NF1=NC2
         IF(NF.EQ.NL1)  NF1=NL2
         IF(NF.EQ.NHL1) NF1=NHL2
         CALL RCCFL(NF1,I,NO2U2,T1(1+NOU))
         X=VR(I)
         CALL DAXPY(NOUP,X,T1,1,TI,1)
      ENDDO
      RETURN
      END
C
C
C
C*MODULE EOMCC   *DECK CCDENS1
      SUBROUTINE CCDENS1(IVAR,ILE,IRE,NO,NU,GOO,GUU,GOU,GALL,
     *                   XL,XR,XT,XAUX,TI)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION GOO(*),GUU(*),GOU(*),
     *          GALL(NO+NU,NO+NU),
     *          XL(*),XR(*),XT(*),XAUX(*),TI(*)
C
      CHARACTER*3 VECREP
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 /EOMMAR/ NL1,NL2,NHL1,NHL2,NNAXL
      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 /IBADMR/ IBAD
C
C IVAR = 0 <L(ILE)|...|R(IRE)>
C IVAR = 1 <R(ILE)|...|L(IRE)>
C
      NO2=NO*NO
      NU2=NU*NU
      NOU=NO*NU
      NO2U2=NOU*NOU
      NOUP=NOU+NO2U2
C
      CALL ZEROMA(GOO,1,NO2)
      CALL ZEROMA(GUU,1,NU2)
      CALL ZEROMA(GOU,1,NOU)
      CALL ZEROMA(GALL,1,(NO+NU)*(NO+NU))
C
C
C
      IF(IVAR.EQ.0) THEN
C READING LEFT EIGENVECTOR
      IF(ILE.EQ.0) THEN
       XL0=1.0D+00
       CALL RO1(5,NO,NU,XL)
       CALL RO2(8,NO,NU,XL(1+NOU))
      ELSE
       XL0=0.0D+00
       CALL RCCFL(NNAXL,ILE+2,NOUP,XL)
      END IF
C READING RIGHT EIGENVECTOR
      IF(IRE.EQ.0) THEN
       XR0=1.0D+00
       CALL ZEROMA(XR,1,NOUP)
      ELSE
       XR0=EOMR0L(IRE)
       IF(ISPACE.NE.2) THEN
        CALL RCCFL(NAX,IRE+2,NOUP,XR)
       ELSE
        CALL RCCFL(NAX,IRE,NOUP,XR)
       END IF
      END IF
C
      END IF !(IVAR=0)
C
C
C
      IF(IVAR.EQ.1) THEN
C READING RIGHT EIGENVECTOR
      IF(IRE.EQ.0) THEN
       XR0=1.0D+00
       CALL RO1(5,NO,NU,XR)
       CALL RO2(8,NO,NU,XR(1+NOU))
      ELSE
       XR0=0.0D+00
       CALL RCCFL(NNAXL,IRE+2,NOUP,XR)
      END IF
C READING LEFT EIGENVECTOR
      IF(ILE.EQ.0) THEN
       XL0=1.0D+00
       CALL ZEROMA(XL,1,NOUP)
      ELSE
       XL0=EOMR0L(ILE)
       IF(ISPACE.NE.2) THEN
        CALL RCCFL(NAX,ILE+2,NOUP,XL)
       ELSE
          IF(IBAD.EQ.0) THEN
           CALL RCCFL(NAX,ILE,NOUP,XL)
          ELSE
           CALL RCCFL(NAXX,ILE,NOUP,XL)
          END IF
       END IF
      END IF
C
      END IF !(IVAR=1)
C
C
C
C READING CLUSTER AMPLITUDES T1 AND T2
       CALL RO1(1,NO,NU,XT)
       CALL RO2(1,NO,NU,XT(1+NOU))
C
       CALL XGOO(NO,NU,XR0,XL(1),XL(1+NOU),
     *           XR(1),XR(1+NOU),XT(1),XT(1+NOU),
     *           XAUX(1),XAUX(1+NOU),TI,GOO,GALL)
C
       CALL RO1(1,NO,NU,XT)
       CALL RO2(1,NO,NU,XT(1+NOU))
C
       CALL XGUU(NO,NU,XR0,XL(1),XL(1+NOU),
     *           XR(1),XR(1+NOU),XT(1),XT(1+NOU),
     *           XAUX(1),XAUX(1+NOU),TI,GUU,GALL)
C
       CALL RO1(1,NO,NU,XT)
       CALL RO2(1,NO,NU,XT(1+NOU))
C
       CALL XGUO(NO,NU,XR0,XL(1),XL(1+NOU),
     *           XR(1),
     *           XAUX(1),XAUX(1+NOU),TI,GOU,GALL)
C
       CALL XGOU(NO,NU,XL0,XR0,XL(1),XL(1+NOU),
     *           XR(1),XR(1+NOU),XT(1),XT(1+NOU),
     *           XAUX(1),XAUX(1+NOU),TI,GOO,GUU,GOU,GALL,IRE,ILE)
C
       IF(IRE.EQ.ILE) THEN
       DO 11,I=1,NO
         GALL(I,I)=GALL(I,I)+2.0D+00
 11    CONTINUE
       END IF
C UNIFIED NOTATION
C D^{A}_{B} * F^{B}_{A}
       DO 20,I=1,NO+NU
       DO 21,J=I+1,NO+NU
         XDO=GALL(J,I)
         XUP=GALL(I,J)
         GALL(I,J)=XDO
         GALL(J,I)=XUP
 21    CONTINUE
 20    CONTINUE
C
CCCX *** DEBUG ***
CCCX          WRITE(IW,*) 'TRACE OF DENSITY MATRIX'
CCCX          XDIAGDD=0.0D+00
CCCX            DO 12,I=1,NO+NU
CCCX            XDIAGDD=XDIAGDD+GALL(I,I)
CCCX            DO 13,J=1,NO+NU
CCCX             WRITE(IW,1122) GALL(I,J),I,J
CCCX 13         CONTINUE
CCCX 12         CONTINUE
CCCX 1122     FORMAT(F18.8,3X,2I5)
CCCX          WRITE(IW,*) 'TR(D1)= ',XDIAGDD
CCCX          CALL FLSHBF(IW)
C
       RETURN
       END
C
C*MODULE EOMCC   *DECK XGOO
      SUBROUTINE XGOO(NO,NU,XR0,XL1,XL2,R1,R2,
     *                T1,T2,AUX1,AUX2,TI,GOO,GALL)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION XL1(*),XL2(*),R1(*),R2(*),T1(*),T2(*),
     *          AUX1(*),AUX2(*),TI(*),GOO(NO,NO),
     *          GALL(NO+NU,NO+NU)
      DATA XMTWO/-2.0D+00/,ONE/1.0D+00/,ZERO/0.0D+00/
CCCX      NO2=NO*NO
      NU2=NU*NU
      NOU=NO*NU
      NO2U2=NOU*NOU
      NOU2=NO*NU2
CCCX      NU3=NU*NU2
      CALL ZEROMA(AUX2,1,NO2U2)
      CALL DCOPY(NO2U2,R2,1,AUX2,1)
      CALL DAXPY(NO2U2,XR0,T2,1,AUX2,1)
      CALL PT1R1(NO,NU,T1,R1,AUX2)
      CALL DCOPY(NO2U2,XL2,1,T2,1)
      CALL SYMT21(T2,NO,NU,NU,NO,23)
      CALL DGEMM('N','T',NO,NO,NOU2,XMTWO,AUX2,NO,T2,NO,
     *           ZERO,GOO,NO)
      CALL ZEROMA(AUX1,1,NOU)
      CALL DCOPY(NOU,R1,1,AUX1,1)
      CALL DAXPY(NOU,XR0,T1,1,AUX1,1)
      CALL DCOPY(NOU,XL1,1,T1,1)
      CALL TRT1(NO,NU,TI,T1)
      CALL DGEMM('N','N',NO,NO,NU,XMTWO,AUX1,NO,T1,NU,
     *           ONE,GOO,NO)
      DO 1,I=1,NO
      DO 1,J=1,NO
       GALL(I,J)=GOO(I,J)
 1    CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK XGUU
      SUBROUTINE XGUU(NO,NU,XR0,XL1,XL2,R1,R2,
     *                T1,T2,AUX1,AUX2,TI,GUU,GALL)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION XL1(*),XL2(*),R1(*),R2(*),T1(*),T2(*),
     *          AUX1(*),AUX2(*),TI(*),GUU(NU,NU),
     *          GALL(NO+NU,NO+NU)
      DATA TWO/2.0D+00/,ONE/1.0D+00/,ZERO/0.0D+00/
      NO2=NO*NO
CCCX      NU2=NU*NU
      NOU=NO*NU
      NO2U2=NOU*NOU
CCCX      NOU2=NO*NU2
      NO2U=NO2*NU
CCCX      NU3=NU*NU2
      CALL ZEROMA(AUX2,1,NO2U2)
      CALL DCOPY(NO2U2,R2,1,AUX2,1)
      CALL DAXPY(NO2U2,XR0,T2,1,AUX2,1)
      CALL PT1R1(NO,NU,T1,R1,AUX2)
      CALL INSITU(NO,NU,NU,NO,TI,AUX2,12)
      CALL DCOPY(NO2U2,XL2,1,T2,1)
      CALL SYMT21(T2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,T2,12)
      CALL DGEMM('N','T',NU,NU,NO2U,TWO,T2,NU,AUX2,NU,
     *           ZERO,GUU,NU)
      CALL ZEROMA(AUX1,1,NOU)
      CALL DCOPY(NOU,R1,1,AUX1,1)
      CALL DAXPY(NOU,XR0,T1,1,AUX1,1)
      CALL DCOPY(NOU,XL1,1,T1,1)
      CALL TRT1(NO,NU,TI,T1)
      CALL DGEMM('N','N',NU,NU,NO,TWO,T1,NU,AUX1,NO,
     *           ONE,GUU,NU)
      DO 1,I=1,NU
      DO 1,J=1,NU
       GALL(I+NO,J+NO)=GUU(I,J)
 1    CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK XGUO
      SUBROUTINE XGUO(NO,NU,XR0,XL1,XL2,R1,
     *                AUX1,AUX2,TI,GUO,GALL)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION XL1(*),XL2(*),R1(*),
     *          AUX1(*),AUX2(*),TI(*),GUO(NU,NO),
     *          GALL(NO+NU,NO+NU)
      DATA TWO/2.0D+00/,ZERO/0.0D+00/
CCCX      NO2=NO*NO
CCCX      NU2=NU*NU
      NOU=NO*NU
      NO2U2=NOU*NOU
CCCX      NOU2=NO*NU2
CCCX      NO2U=NO2*NU
CCCX      NU3=NU*NU2
      CALL ZEROMA(GUO,1,NOU)
      CALL ZEROMA(AUX2,1,NO2U2)
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23)
      CALL INSITU(NO,NU,NU,NO,TI,AUX2,12)
      CALL DCOPY(NOU,R1,1,AUX1,1)
      CALL TRT1(NO,NU,TI,AUX1)
      CALL DGEMM('N','N',NOU,1,NOU,TWO,AUX2,NOU,AUX1,NOU,
     *           ZERO,GUO,NOU)
      CALL DCOPY(NOU,XL1,1,AUX1,1)
      CALL TRT1(NO,NU,TI,AUX1)
      XFA=TWO*XR0
      CALL DAXPY(NOU,XFA,AUX1,1,GUO,1)
      DO 1,I=1,NU
      DO 1,J=1,NO
       GALL(I+NO,J)=GUO(I,J)
 1    CONTINUE
      RETURN
      END
C
C
C*MODULE EOMCC   *DECK XGOU
      SUBROUTINE XGOU(NO,NU,XL0,XR0,XL1,XL2,R1,R2,
     *                T1,T2,AUX1,AUX2,TI,GOO,GUU,GOU,GALL,IRE,ILE)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION XL1(*),XL2(*),R1(*),R2(*),T1(*),T2(*),
     *          AUX1(*),AUX2(*),TI(*),GOU(NO,NU),
     *          GALL(NO+NU,NO+NU),GOO(*),GUU(*)
      DATA TWO/2.0D+00/,ONE/1.0D+00/,ZERO/0.0D+00/
CCCX      NO2=NO*NO
CCCX      NU2=NU*NU
      NOU=NO*NU
      NO2U2=NOU*NOU
CCCX      NOU2=NO*NU2
CCCX      NO2U=NO2*NU
CCCX      NU3=NU*NU2
C
      IDELK=1
      IF(IRE.NE.ILE) IDELK=0
C DIAG1
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23) !AUX2=(2L2(INTER)-L2)
      CALL RO2(1,NO,NU,T2)
      CALL DCOPY(NOU,R1,1,T1,1)
      CALL FOROU1(NO,NU,T1,T2,AUX2,TI,GOU,GUU,GALL)
C DIAG2
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23) !AUX2=(2L2(INTER)-L2)
      CALL RO2(1,NO,NU,T2)
      CALL DCOPY(NOU,R1,1,T1,1)
      CALL FOROU2(NO,NU,T1,T2,AUX2,GOU,GOO,GALL)
C DIAG5
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23) !AUX2=(2L2(INTER)-L2)
      CALL RO2(1,NO,NU,T2)
      CALL DSCAL(NO2U2,XR0,T2,1)
      CALL RO1(1,NO,NU,T1)
      CALL FOROU1(NO,NU,T1,T2,AUX2,TI,GOU,GUU,GALL)
C DIAG4
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23) !AUX2=(2L2(INTER)-L2)
      CALL RO2(1,NO,NU,T2)
      CALL DSCAL(NO2U2,XR0,T2,1)
      CALL RO1(1,NO,NU,T1)
      CALL FOROU2(NO,NU,T1,T2,AUX2,GOU,GOO,GALL)
C DIAG7
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23) !AUX2=(2L2(INTER)-L2)
      CALL DCOPY(NO2U2,R2,1,T2,1)
      CALL RO1(1,NO,NU,T1)
      CALL FOROU1(NO,NU,T1,T2,AUX2,TI,GOU,GUU,GALL)
C DIAG6
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23) !AUX2=(2L2(INTER)-L2)
      CALL DCOPY(NO2U2,R2,1,T2,1)
      CALL RO1(1,NO,NU,T1)
      CALL FOROU2(NO,NU,T1,T2,AUX2,GOU,GOO,GALL)
C DIAG3
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23) !AUX2=(2L2(INTER)-L2)
      CALL RO1(1,NO,NU,T1)
      CALL PT1R1EX(NO,NU,T1,R1,T2)
      CALL FOROU1(NO,NU,T1,T2,AUX2,TI,GOU,GUU,GALL)
C
      CALL ZEROMA(GOU,1,NOU)
      XFA=TWO*XL0
      CALL DAXPY(NOU,XFA,R1,1,GOU,1)
      CALL RO1(1,NO,NU,T1)
C 2T1
      IF(IDELK.EQ.1) THEN
      CALL DAXPY(NOU,TWO,T1,1,GOU,1)
      END IF
C
      CALL DCOPY(NO2U2,R2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23)
      CALL PT1R1EXX(NO,NU,T1,R1,AUX2,XR0)
      CALL DCOPY(NOU,XL1,1,AUX1,1)
      CALL TRT1(NO,NU,TI,AUX1)
      CALL DGEMM('N','N',NOU,1,NOU,TWO,AUX2,NOU,AUX1,NOU,
     *           ONE,GOU,NOU)
C
C
      CALL RO2(1,NO,NU,T2)
      CALL SYMT21(T2,NO,NU,NU,NO,23)
      CALL DCOPY(NOU,XL1,1,AUX1,1)
      CALL TRT1(NO,NU,TI,AUX1)
      XFA=TWO*XR0
      CALL DGEMM('N','N',NOU,1,NOU,XFA,T2,NOU,AUX1,NOU,
     *           ONE,GOU,NOU)
C T2   = SYMT21(T2)
C AUX2 = SYMT21(L2)
C T1   = R1
C AUX1 = FIRST INTERMEDIATE
      CALL DCOPY(NO2U2,XL2,1,AUX2,1)
      CALL SYMT21(AUX2,NO,NU,NU,NO,23)
      CALL DCOPY(NOU,R1,1,T1,1)
      CALL ZEROMA(AUX1,1,NOU)
      CALL DGEMM('N','N',1,NOU,NOU,TWO,T1,1,AUX2,NOU,
     *           ZERO,AUX1,1)
      CALL DGEMM('N','N',NOU,1,NOU,ONE,T2,NOU,AUX1,NOU,
     *           ONE,GOU,NOU)
C
      DO 1,I=1,NO
      DO 2,J=1,NU
       GALL(I,J+NO)=GALL(I,J+NO)+GOU(I,J)
 2    CONTINUE
 1    CONTINUE
CCCX 1010 CONTINUE
      RETURN
      END
C
C
C*MODULE EOMCC   *DECK PT1R1
      SUBROUTINE PT1R1(NO,NU,T1,R1,AUX2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION T1(NO,NU),R1(NO,NU),AUX2(NO,NU,NU,NO)
      DO 1,I=1,NO
      DO 1,J=1,NO
      DO 1,IA=1,NU
      DO 1,IB=1,NU
       AUX2(I,IA,IB,J)=AUX2(I,IA,IB,J)+T1(I,IA)*R1(J,IB)
 1    CONTINUE
      RETURN
      END
C
C
C*MODULE EOMCC   *DECK PT1R1EX
      SUBROUTINE PT1R1EX(NO,NU,T1,R1,AUX2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION T1(NO,NU),R1(NO,NU),AUX2(NO,NU,NU,NO)
      DO 1,I=1,NO
      DO 1,J=1,NO
      DO 1,IA=1,NU
      DO 1,IB=1,NU
       AUX2(I,IA,IB,J)=T1(J,IB)*R1(I,IA)
 1    CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK PT1R1EXX
      SUBROUTINE PT1R1EXX(NO,NU,T1,R1,AUX2,XR0)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION T1(NO,NU),R1(NO,NU),AUX2(NO,NU,NU,NO)
      DO 1,I=1,NO
      DO 1,J=1,NO
      DO 1,IA=1,NU
      DO 1,IB=1,NU
       AUX2(I,IA,IB,J)=AUX2(I,IA,IB,J)-T1(J,IA)*R1(I,IB)
     *          -T1(I,IB)*R1(J,IA)-T1(I,IB)*T1(J,IA)*XR0
 1    CONTINUE
      RETURN
      END
C
C PROCEDURES FOROU1 AND FOROU2 ARE USED IN XGOU ROUTINE
C
C*MODULE EOMCC   *DECK FOROU1
      SUBROUTINE FOROU1(NO,NU,T1,T2,AUX2,TI,
     *                  GOU,GUU,GALL)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION T1(*),T2(*),AUX2(*),TI(*),GUU(NU,NU),
     *          GALL(NO+NU,NO+NU),GOU(NO,NU)
      DATA XMTWO/-2.0D+00/,ONE/1.0D+00/,ZERO/0.0D+00/
C INPUT: AUX2 => SYMT21(L2,NO,NU,NU,NO,23)
C        T2   => SECOND TERM (WHATEVER IT IS)
C        T1   => THIRD  TERM (WHATEVER IT IS)
C        TI   => AUXILIARY MATRIX
C AUX2*T2 => GUU
      NO2=NO*NO
      NU2=NU*NU
      NOU=NO*NU
CCCX      NO2U2=NOU*NOU
CCCX      NOU2=NO*NU2
      NO2U=NO2*NU
CCCX      NU3=NU*NU2
C
      CALL ZEROMA(GOU,1,NOU)
      CALL ZEROMA(GUU,1,NU2)
      CALL INSITU(NO,NU,NU,NO,TI,T2,13) !T2(NU,NU,NO,NO)
      CALL TRANSQ(AUX2,NOU)
      CALL DGEMM('N','N',NU,NU,NO2U,ONE,T2,NU,AUX2,NO2U,
     *           ZERO,GUU,NU)  !GUU(A,B) (SUM OVER B)
      CALL DGEMM('N','T',NO,NU,NU,ONE,T1,NO,GUU,NU,
     *           ZERO,GOU,NO)
      DO 1,I=1,NO
      DO 1,J=1,NU
       GALL(I,J+NO)=GALL(I,J+NO)+XMTWO*GOU(I,J)
 1    CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK FOROU2
      SUBROUTINE FOROU2(NO,NU,T1,T2,AUX2,
     *                  GOU,GOO,GALL)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION T1(*),T2(*),AUX2(*),GOU(NO,NU),
     *          GOO(NO,NO),GALL(NO+NU,NO+NU)
      DATA XMTWO/-2.0D+00/,ONE/1.0D+00/,ZERO/0.0D+00/
C INPUT: AUX2 => SYMT21(L2,NO,NU,NU,NO,23)
C        T2   => SECOND TERM (WHATEVER IT IS)
C        T1   => THIRD  TERM (WHATEVER IT IS)
C T2*AUX2 => GOO
      NO2=NO*NO
      NU2=NU*NU
      NOU=NO*NU
CCCX      NO2U2=NOU*NOU
      NOU2=NO*NU2
CCCX      NO2U=NO2*NU
CCCX      NU3=NU*NU2
C
      CALL ZEROMA(GOU,1,NOU)
      CALL ZEROMA(GOO,1,NO2)
      CALL DGEMM('N','T',NO,NO,NOU2,ONE,T2,NO,AUX2,NO,ZERO,
     *           GOO,NO)
      CALL DGEMM('N','N',NO,NU,NO,ONE,GOO,NO,T1,NO,ZERO,GOU,NO)
      DO 1,I=1,NO
      DO 1,J=1,NU
       GALL(I,J+NO)=GALL(I,J+NO)+XMTWO*GOU(I,J)
 1    CONTINUE
      RETURN
      END
C
C*MODULE EOMCC   *DECK MODIPS
      SUBROUTINE MODIPS(L1,L2,M1,M2,XM,YM,ZM,WRK,XLAO,VEC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION XM(M2),YM(M2),ZM(M2),
     *          WRK(L1),XLAO(L2),VEC(L1,L1)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C      COMMON /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
C     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
C     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
C     *                IEDINT,IEMINT,IEPINT,IEFINT
C
C
C        PICK UP CURRENT MO COEFICIENTS
C
      CALL DAREAD(IDAF,IODA,VEC,L1*L1,15,0)
C
C
C        X,Y,Z AO DIPOLE INTEGRALS ARE STORED ON RECORDS 95,96,97
C        SEE MTHLIB.SRC FOR DETAILS ABOUT SIMILARITY TRANSFORM
C
      CALL ZEROMA(XLAO,1,L2)
CCCX      CALL RCCFL(10,IODA(95),L2,XLAO)
      CALL DAREAD(IDAF,IODA,XLAO,L2,95,0) !!!DAREAD REPLACED BY RCCFL
      CALL TFTRI(XM,XLAO,VEC,WRK,M1,L1,L1)
C
      CALL ZEROMA(XLAO,1,L2)
CCCX      CALL RCCFL(10,IODA(96),L2,XLAO)
      CALL DAREAD(IDAF,IODA,XLAO,L2,96,0) !!!DAREAD REPLACED BY RCCFL
      CALL TFTRI(YM,XLAO,VEC,WRK,M1,L1,L1)
C
C
        CALL ZEROMA(XLAO,1,L2)
CCCX        CALL RCCFL(10,IODA(97),L2,XLAO)
      CALL DAREAD(IDAF,IODA,XLAO,L2,97,0) !!!DAREAD REPLACED BY RCCFL
      CALL TFTRI(ZM,XLAO,VEC,WRK,M1,L1,L1)
C
      RETURN
      END
C
C*MODULE EOMCC   *DECK CCMOMDP
      SUBROUTINE CCMOMDP(IRE,ILE,NO,NU,L2,GALL,XMOM,CCMOM)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION GALL(NO+NU,NO+NU),XMOM(L2)
      PARAMETER (MXAO=8192)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                MXCCIT,MXRLEIT,NWRDCC,ICCCNV,ICCRST,IDSKCC
C
      CCMOM=0.0D+00
      IF(IRE.EQ.ILE) THEN
      DO 1,I=1,NCCFZC
       IPOS=IA(I)+I
       CCMOM=CCMOM+(2.0D+00)*XMOM(IPOS)
 1    CONTINUE
      END IF
      DO 2,I=1,NO+NU
       IPOS=IA(I+NCCFZC)+I+NCCFZC
       CCMOM=CCMOM+GALL(I,I)*XMOM(IPOS)
 2    CONTINUE
      DO 3,J=1,NO+NU
      DO 4,I=J+1,NO+NU
       IPOS=IA(I+NCCFZC)+J+NCCFZC
       CCMOM=CCMOM+XMOM(IPOS)*(GALL(I,J)+GALL(J,I))
 4    CONTINUE
 3    CONTINUE
C
      RETURN
      END
C
C*MODULE EOMCC   *DECK ENAOPRNT
      SUBROUTINE ENAOPRNT(NO,NU,NCCFZC,WR,WI,VR,INDO,JNDO)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION WR(NO+NU),WI(NO+NU),VR(NO+NU,NO+NU),
     *          INDO(NO+NU),JNDO(NO+NU)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      WRITE(IP,98)
      WRITE(IP,99)
      XTRACE=0.0D+00
C
      DO I=1,NO+NU
         INDO(I)=0
         JNDO(I)=0
      END DO
C
C        THIS IS CURIOUS, AS DGEEV SHOULD PRODUCED NORMALIZED VECTORS?
C
      DO 200 I=1,NO+NU
         ZNORM=0.0D+00
         DO 201 J=1,NO+NU
            ZNORM=ZNORM+VR(J,I)*VR(J,I)
 201     CONTINUE
         ZNORM=SQRT(ZNORM)
         DO 202,J=1,NO+NU
            VR(J,I)=VR(J,I)/ZNORM
 202     CONTINUE
 200  CONTINUE
C
C         OUTPUT THE EIGENVALUES TRACKING THAT EACH RIGHT VECTOR
C         IS USED ONLY ONCE.
C         THIS SEEMS TO BE LOOKING FOR MAXIMUM OVERLAP BETWEEN
C         THE RIGHT EIGENVECTOR AND THE ORIGINAL CANONICAL MO.
C
      DO 1 I=1,NO+NU
         XMAX=0.0D+00
         IMAX=0
         DO 2 J=1,NO+NU
            XXX=ABS(VR(I,J))
            IF(XXX.GT.XMAX) THEN
               IF(INDO(J).EQ.0) THEN
                 XMAX=XXX
                 IMAX=J
               END IF
            END IF
2        CONTINUE
         IF(IMAX.NE.0) THEN
            INDO(IMAX)=I
            JNDO(I)=IMAX
            WRITE(IP,100) WR(IMAX),WI(IMAX)
            XTRACE=XTRACE+WR(IMAX)
         ELSE
            WRITE(IW,101)
            WRITE(IP,101)
         END IF
 1    CONTINUE
C
CCCX       WRITE(IW,*) 'TR(D1) PO DIAGONALIZACJI',XTRACE
C
C         CHECK TO SEE IF ALL ORBITALS HAD AN OCCUPATION CHOSEN
C
      IAG=0
      DO I=1,NO+NU
         IF(INDO(I).GE.1  .AND.  INDO(I).LE.NO+NU) IAG=IAG+1
      END DO
      IF(IAG.NE.NO+NU) THEN
         WRITE(IW,102)
         WRITE(IP,102)
         RETURN
      END IF
C
C          PRINT OCCUPATION INFORMATION FOR THIS STATE
C
      WRITE(IW,9100)
      WRITE(IW,9110) (WR(JNDO(I)),I=1,NO+NU)
      XPNOR = 0.0D+00
      XPNOI = 0.0D+00
      XSNOR = 0.0D+00
      XSNOI = 0.0D+00
      DO I=1,NO
         XPNOR = XPNOR + WR(JNDO(I))
         XPNOI = XPNOI + WI(JNDO(I))
      ENDDO
      DO I=1,NU
         XSNOR = XSNOR + WR(JNDO(I+NO))
         XSNOI = XSNOI + WI(JNDO(I+NO))
      ENDDO
      XCORE = NCCFZC+NCCFZC
      WRITE(IW,9120) XCORE
      WRITE(IW,9130) XPNOR,XPNOI
      WRITE(IW,9140) XSNOR,XSNOI
      RETURN
C
   98 FORMAT('DENSITY MATRIX EIGENVALUES')
   99 FORMAT('      REAL PART     IMAGINARY PART   ')
  100 FORMAT(3X,F12.5,3X,F12.5)
  101 FORMAT(1X,'PROBLEM WITH ASSIGNMENT OF THIS ENTRY')
  102 FORMAT(1X,'PROBLEMS WITH ASSIGNMENT OF OCC. NUM.')
 9100 FORMAT(1X,'THE LEFT/RIGHT NATURAL ORBITALS HAVE OCCUPATION',
     *          ' NUMBERS')
 9110 FORMAT(10F7.4)
 9120 FORMAT(1X,'THERE ARE',F9.2,' UNCORRELATED E- IN FILLED ORBITALS')
 9130 FORMAT(1X,'THERE ARE',F9.2,' REAL E- IN PRINCIPAL NATURAL',
     *          ' ORBITALS (',F5.1,' IMAG. E-)')
 9140 FORMAT(1X,'THERE ARE',F9.2,' REAL E- IN SECONDARY NATURAL',
     *          ' ORBITALS (',F5.1,' IMAG. E-)')
      END
C
C*MODULE EOMCC   *DECK DENS1STO
      SUBROUTINE DENS1STO(NO,NU,IRE,ILE,GALL)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION GALL(NO+NU,NO+NU)
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)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
C        PUNCH DENSITY MATRIX IN MO BASIS TO FILE 7
C     NOTE THAT THIS DENSITY MATRIX IS A SQUARE MATRIX, NOT SYMMETRIC,
C     SINCE THE LEFT AND RIGHT EIGENVECTORS ARE DIFFERENT, EVEN WHEN
C     THEY REPRESENT THE SAME EXCITED STATE.
C
      DATA FEV/27.2113957D+00/
C
      IF(ILE.EQ.0) ENERGYL=0.0D+00
      IF(ILE.NE.0) ENERGYL=XKKEOM(ILE)*FEV
      IF(IRE.EQ.0) ENERGYR=0.0D+00
      IF(IRE.NE.0) ENERGYR=XKKEOM(IRE)*FEV
      WRITE(IP,100)ILE,ENERGYL,IRE,ENERGYR
      WRITE(IP,150)
      IREST3=MOD((NO+NU)*(NO+NU),3)
      ILA3=(NO+NU)*(NO+NU)-IREST3
      ICOUNT=1
C
      DO 1,I=1,NO+NU
      DO 2,J=1,NO+NU
       IF(ICOUNT.LE.ILA3) THEN
        IR3=MOD(ICOUNT,3)
        IF(IR3.EQ.1) THEN
         I11=I
         I21=J
         A1=GALL(I,J)
        END IF
        IF(IR3.EQ.2) THEN
         I12=I
         I22=J
         A2=GALL(I,J)
        END IF
        IF(IR3.EQ.0) THEN
         I13=I
         I23=J
         A3=GALL(I,J)
         WRITE(IP,200) I11,I21,A1, I12,I22,A2, I13,I23,A3
        END IF
       END IF
C
       IF(ICOUNT.GT.ILA3) THEN
        IF(IREST3.EQ.0) GO TO 300
        IR3=MOD(ICOUNT,3)
        IF(IR3.EQ.1) THEN
         I11=I
         I21=J
         A1=GALL(I,J)
         IF(IR3.EQ.IREST3) WRITE(IP,210) I11,I21,A1
         GO TO 300
        END IF
        IF(IR3.EQ.2) THEN
         I12=I
         I22=J
         A2=GALL(I,J)
         IF(IR3.EQ.IREST3) WRITE(IP,220) I11,I21,A1, I12,I22,A2
        END IF
       END IF
       ICOUNT=ICOUNT+1
 2     CONTINUE
 1     CONTINUE
C
  300 CONTINUE
      WRITE(IP,151)
      RETURN
C
  100 FORMAT(//,'LEFT  STATE NR.',I3,' (ENERGY=',F8.3,' EV)',
     *        '  RIGHT STATE NR.',I3,' (ENERGY=',F8.3,' EV)')
  150 FORMAT(' $CCDENS')
  151 FORMAT(' $END')
  200 FORMAT(3(2I5,1X,D17.10,1X))
  210 FORMAT(2I5,1X,D17.10,1X)
  220 FORMAT(2(2I5,1X,D17.10,1X))
      END
C
C---C*MODULE EOMCC   *DECK MAXT1T2
C---       SUBROUTINE MAXT1T2(NO,NU,T1,T2)
C---       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C---       COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C---       DIMENSION T1(NO,NU),T2(NO,NU,NU,NO)
C---       TOL=0.070D+00
C---       WRITE(IW,*) 'MAX. AMP. L1 AND L2'
C---       DO 1,I=1,NO
C---       DO 2,IA=1,NU
C---        XXX=ABS(T1(I,IA))
C---        IF(XXX.GT.TOL) WRITE(IW,100) T1(I,IA),I,IA
C--- 2     CONTINUE
C--- 1     CONTINUE
C---       DO 3,I=1,NO
C---       DO 4,J=1,NO
C---       DO 5,IA=1,NU
C---       DO 6,IB=1,NU
C---        XXX=ABS(T2(I,IA,IB,J))
C---        IF(XXX.GT.TOL) WRITE(IW,101) T2(I,IA,IB,J),I,J,IA,IB
C--- 6     CONTINUE
C--- 5     CONTINUE
C--- 4     CONTINUE
C--- 3     CONTINUE
C---       CALL FLSHBF(IW)
C--- 100   FORMAT(5X,'LA1=',F15.10,' FOR   I -> A   =',2I5)!!!
C--- 101   FORMAT(5X,'LA2=',F15.10,' FOR I,J -> A,B =',4I5)!!!
C---       RETURN
C---       END
C
C*MODULE EOMCC   *DECK BACKNDR
      SUBROUTINE BACKNDR(NO,NU)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      CHARACTER*3 VECREP
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 /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 / X(1)
C
      DATA ONE/1.0D+00/
C
      NOU=NO*NU
      NO2U2=NOU*NOU
      NOUP=NOU+NO2U2
         CALL VALFM(LOADFM)
         I1 = LOADFM + 1
         I2    = I1  +   NOUP        !EV
         LAST  = I2  +   NOUP        !T1
         NEED = LAST-LOADFM-1
         CALL GETFM(NEED)
          DO 1,II=1,NROOT
           IF(KVGEOM(II).EQ.0) GO TO 1
           IF(ISPACE.NE.2) THEN
            CALL RCCFL(NAX,II+2,NOUP,X(I1))
           ELSE
            CALL RCCFL(NAX,II,NOUP,X(I1))
           END IF
           CALL DCOPY(NOUP,X(I1),1,X(I2),1)
           CALL SPINKA(NO,NU,X(I2))
           Z=DDOT(NOUP,X(I1),1,X(I2),1)
           Z=ABS(Z)
           CALL DSCAL(NOUP,ONE/SQRT(Z),X(I1),1)
           EOMR0L(II)=EOMR0L(II)/SQRT(Z)
           EOMR0(II)=EOMR0(II)/SQRT(Z)
C *** DEBUG ***
C           WRITE(IW,1000) EOMR0L(II),EOMR0(II)
C           CALL FLSHBF(IW)
C 1000      FORMAT('RENORMALIZACJA',2X,F17.10,2X,F17.10)
C *************
           IF(ISPACE.NE.2) THEN
            CALL WCCFL(NAX,II+2,NOUP,X(I1))
           ELSE
            CALL WCCFL(NAX,II,NOUP,X(I1))
           END IF
 1        CONTINUE
         CALL RETFM(NEED)
      RETURN
      END
C*MODULE EOMCC   *DECK CCBTDENS
      SUBROUTINE CCBTDENS(NCCFZC,NCCACT,NCCMO,L1,L2,IROOTCC,
     *                    ACTDEN,TOTDEN,AODENS,AOSYM,VEC,WORK)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00)
C
      DIMENSION IROOTCC(2)
      DIMENSION ACTDEN(NCCACT,NCCACT),TOTDEN(NCCMO,NCCMO),
     *          AODENS(L1,L1),AOSYM(L2),WORK(L1,NCCMO)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
C      ---- BACK TRANSFORM CC LEVEL DENSITY MATRIX TO AO BASIS---
C     THE CC DENSITY IN THE MO BASIS IS NOT A SYMMETRIC MATRIX,
C     SINCE THE SIMILARITY TRANSFORMED HAMILTONIAN IS NOT HERMITIAN.
C
C     A SYMMETRIZATION OF THE DENSITY IN THE AO BASIS WILL BE DONE,
C     SEE THE NOTE BELOW AS TO WHY, ALTHOUGH IT IS NOT SYMMETRIC!
C
C     IT IS SENSIBLE TO AVOID CALLING THIS ROUTINE EXCEPT FOR
C     THE ONE (1) STATE WHOSE DENSITY CAN BE SAVED ON RECORD 16,
C     WHICH IS ONLY ONE (1) RECORD.  THERE'S JUST NO POINT TO
C     DOING EITHER THE I/O OR THE ARITHMETIC, IF NOT TO SAVE IT.
C
      WRITE(IW,9100) IROOTCC
C
C     THE MO DENSITY ON ENTRY LACKS CORE ORBITAL CONTRIBUTIONS,
C     SO BEGIN BY GENERATING THE FULL MO DENSITY MATRIX.
C
      CALL VCLR(TOTDEN,1,NCCMO*NCCMO)
      DO I=1,NCCFZC
         TOTDEN(I,I) = TWO
      ENDDO
      DO J=1,NCCACT
         DO I=1,NCCACT
            TOTDEN(I+NCCFZC,J+NCCFZC) = ACTDEN(I,J)
         ENDDO
      ENDDO
C
C        TRANSFORM DENSITY TO AO BASIS, P(AO) = C * P(MO) * C-DAGGER
C
      CALL DAREAD(IDAF,IODA,VEC,L1*L1,15,0)
C
      CALL DGEMM('N','N',L1,NCCMO,NCCMO,ONE,VEC,L1,
     *           TOTDEN,NCCMO,ZERO,WORK,L1)
      CALL DGEMM('N','T',L1,L1,NCCMO,ONE,WORK,L1,
     *           VEC,L1,ZERO,AODENS,L1)
C
C       --- AVERAGE ABOVE AND BELOW DIAGONAL AO DENSITY ELEMENTS ---
C         THE DENSITY WILL BE USED IN A TRACE AGAINST SYMMETRIC
C         OPERATORS (SUCH AS DIPOLE INTEGRALS) IN THE PROPERTY
C         PACKAGE, HENCE THE UNEQUAL I.LT.J AND I.GT.J TERMS SUM TO
C           PIJ*OIJ + PJI*OJI = (PIJ+PJI)*OIJ = 2*[(PIJ+PJI)/2]*OIJ
C         WITH THE DOUBLING OF THE OFF-DIAGONAL TERMS POSTPONED TO
C         THE ROUTINES USED TO TRACING TRIANGULAR DENSITIES AGAINST
C         THE SYMMETRIC INTEGRALS.
C
C         SO, THE DAF RECORD 16 IS ---NOT--- THE CORRECT AO BASIS
C         DENSITY, RATHER 'AODENS' WHICH IS NOT SAVED IS, BUT THE
C         SYMMERIZED FORM WILL GIVE CORRECT PROPERTIES.
C
      IJ=0
      DO I=1,L1
         DO J=1,I
            IJ=IJ+1
            AVG = (AODENS(I,J) + AODENS(J,I))/TWO
            AOSYM(IJ) = AVG
         ENDDO
      ENDDO
C
      CALL DAWRIT(IDAF,IODA,AOSYM,L2,16,0)
      RETURN
C
 9100 FORMAT(1X,'SAVING DENSITY MATRIX FOR STATE IROOT=',2I3,
     *          ' FOR PROPERTIES.')
      END
