      SUBROUTINE T1RB01(ICORE,MAXCOR,IUHF,LAMBDA)
C
C THIS SUBROUTINE COMPUTES TWO T1*W CONTRIBUTIONS TO THE
C  W(mbej) INTERMEDIATE.  
C
C     W(mBEj) =  SUM T(j,f) * <fE|mB> - SUM T(N,B) * <mN|jE>
C     W(MbeJ) =  SUM T(J,F) * <Fe|Mb> - SUM T(n,b) * <Mn|Je> (UHF only)
C
C ALSO COMPUTE ONE OF THE CONTRIBUTIONS TO THE F(ea) INTERMEDIATE:
C
C     F(EA)   = SUM T(m,f) * <fE|mA> 
C     F(EA)   = SUM T(M,F) * <Fe|Ma>  (UHF only)
C
C BY TAKING A GENERALIZED TRACE OVER THE FIRST TERM IN THE FIRST TWO EQUATIONS
C  ABOVE.
C
C THIS ROUTINE USES IN-CORE ALGORITHMS
C
CEND
      IMPLICIT INTEGER (A-Z)
      LOGICAL LAMBDA
      DOUBLE PRECISION ONE,ONEM,ZILCH,ALPHA,BETA,FACTOR
      CHARACTER*4 SSTSPN(2)
      LOGICAL RHF
      DIMENSION ICORE(MAXCOR),IOFFT1(8,2),SIZEVV(2)
      COMMON /MACHSP/ IINTLN,IFLTLN,IINTFP,IALONE,IBITWD
      COMMON /SYMINF/ NSTART,NIRREP,IRREPS(255,2),
     &                DIRPRD(8,8)
      COMMON /SYMPOP/ IRPDPD(8,22),ISYTYP(2,500),ID(18)
      COMMON /SYM/ POP(8,2),VRT(8,2),NTAA,NTBB,NF1AA,NF2AA,
     &             NF1BB,NF2BB
      COMMON /INFO/ NOCCO(2),NVRTO(2)
      DATA ONE /1.0/
      DATA ZILCH /0.0/
      DATA ONEM /-1.0/
      DATA SSTSPN /'ABAB','BABA'/
      integer  aces_list_rows, aces_list_cols
      external aces_list_rows, aces_list_cols
C
C FIRST PICK UP T1 VECTOR.
C
      CALL GETT1(ICORE,MAXCOR,MXCOR,IUHF,IOFFT1)
      RHF=.FALSE.
      IF(IUHF.EQ.0)RHF=.TRUE.
      LSTFEA=92
C
C COMPUTE SIZES OF A FULL VV DISTRIBUTION WHICH TRANSFORMS AS THE
C  TOTALLY SYMMETRIC REP.
C
      CALL IZERO(SIZEVV,2)
      DO 3000 ISPIN=1,2
       DO 3001 IRREP=1,NIRREP
        SIZEVV(ISPIN)=SIZEVV(ISPIN)+VRT(IRREP,ISPIN)*VRT(IRREP,ISPIN)
3001   CONTINUE
3000  CONTINUE

C
C SPIN CASES BAAB AND ABBA, RESPECTIVELY.
C
      DO 10 ISPIN=1,1+IUHF
       LSTTAR=57+ISPIN
       IF(LAMBDA)THEN
        LSTOUT=124+ISPIN
        FACTOR=ONEM
       ELSE
        LSTOUT=LSTTAR
        FACTOR=ONE
       ENDIF
C
C LOOP OVER IRREPS - IN THE FIRST BLOCK OF CODE THIS CORRESPONDS TO mB,
C                    WHILE IT IS jE IN THE SECOND BLOCK.
C
C
       DO 20 IRREPDO=1,NIRREP
C
C COMPUTE DIMENSIONS OF TARGET MATRIX.
C
        DISTAR=aces_list_cols(IRREPDO,LSTTAR)
        DSZTAR=aces_list_rows(IRREPDO,LSTTAR)
        TARSIZ=DISTAR*DSZTAR
C
C FIRST DO  W(mBEj) =   SUM T(j,f) * <Ef|Bm>  
C           W(MbeJ) =   SUM T(J,F) * <Fe|Mb>  (UHF only)
C
C THIS PRODUCT IS INITIALLY PACKED Bm-Ej [Mb-eJ].
C
        ALPHA=ONE*FACTOR
        BETA=ONE
        LISTW1=31-ISPIN
        DISW  =aces_list_cols(IRREPDO,LISTW1)
        DSZW  =aces_list_rows(IRREPDO,LISTW1)
        I000  =1
        I010  =I000+IINTFP*DISTAR*DSZTAR
        I020  =I010+IINTFP*DISW*DSZW
        I030  =I020+IINTFP*DSZW
        CALL IZERO(ICORE,IINTFP*DISTAR*DSZTAR)
C
C PICK UP THE INTEGRALS AND HOLD THEM IN A MATRIX I(Bm;Ef) [Mb;Fe].
C
        CALL GETTRN(ICORE(I010),ICORE(I020),DSZW,DISW,2,IRREPDO,
     &              LISTW1)
C
C CHANGE MEANINGS OF DSZ AND DIS AND TRANSPOSE KET INDICES OF
C   THE INTEGRALS IF ISPIN=2.  THIS GIVES
C
C               I(Bm;Ef) [ISPIN=1]
C               I(Mb,eF) [ISPIN=2]
C
        ITMP=DISW
        DISW=DSZW
        DSZW=ITMP
        IF(ISPIN.EQ.2)THEN
         I030=I020+IINTFP*DSZW
         I040=I030+IINTFP*DSZW
         I050=I040+IINTFP*DSZW
         CALL SYMTR1(IRREPDO,VRT(1,1),VRT(1,2),DSZW,
     &              ICORE(I010),ICORE(I020),ICORE(I030),
     &              ICORE(I040))
        ENDIF
C
C PERFORM PREAMBLE FOR THE MATRIX PRODUCT 
C
C      Z(Bm;Ej) = I(BmE;f) * T(f,j)
C      Z(Mb;eJ) = I(Mbe;F) * T(F,J)  
C
        IOFFI=I010
        IOFFZ=I000
        DO 100 IRREPF=1,NIRREP
         IRREPE=DIRPRD(IRREPF,IRREPDO)
         IRREPJ=IRREPF
         NROWI=DSZW*VRT(IRREPE,ISPIN) 
         NCOLI=VRT(IRREPF,3-ISPIN)
         NROWT=VRT(IRREPF,3-ISPIN)
         NCOLT=POP(IRREPF,3-ISPIN)
         NROWZ=NROWI
         NCOLZ=NCOLT
         IOFFT=IOFFT1(IRREPJ,3-ISPIN)
         IF(MIN(NROWI,NCOLT,NCOLI).GT.0)THEN
          CALL XGEMM('N','N',NROWZ,NCOLZ,NCOLI,ALPHA,ICORE(IOFFI),
     &               NROWI,ICORE(IOFFT),NROWT,BETA,ICORE(IOFFZ),
     &               NROWZ)
         ENDIF
         IOFFI=IOFFI+NROWI*NCOLI*IINTFP
         IOFFZ=IOFFZ+NROWZ*NCOLZ*IINTFP
100     CONTINUE
C
C NOW GET CONTRIBUTION TO THE F(EA) [F(ea)] INTERMEDIATE
C
        ABFULL=SIZEVV(ISPIN)
        I020=I010+ABFULL*IINTFP
        I030=I020+ABFULL*IINTFP
        IF(.NOT.LAMBDA) THEN
         IF(ISPIN.EQ.1)THEN
          CALL TRACEOO('VOVO',IRREPDO,POP(1,2),VRT(1,1),
     &                  DISTAR,ABFULL,ICORE(I000),ICORE(I010))
         ELSE
          CALL TRACEOO('OVVO',IRREPDO,POP(1,1),VRT(1,2),
     &                  DISTAR,ABFULL,ICORE(I000),ICORE(I010))
         ENDIF
         CALL SUMSYM3(ICORE(I010),ICORE(I020),ABFULL,1,ISPIN,LSTFEA)
        ENDIF
C
C THE CODE ABOVE PRODUCES mbej INTERMEDIATES IN THE ORDER:
C
C                   Bm-Ej (ISPIN=1)
C                   Mb-eJ (ISPIN=2)
C
C NOW DO SECOND CONTRACTION:
C
C           W(mBEj) = W(mBEj) - SUM T(N,B) * <Nm|Ej> (ISPIN=1)
C           W(MbeJ) = W(MbeJ) - SUM T(n,b) * <Mn|Je> (ISPIN=2 OR RHF)
C
C WE NEED TO REORDER WHAT WE HAVE SO THAT IT WILL MATCH UP AND
C  CAN BE ACCUMULATED BY XGEMM. 
C
C THIS PRODUCT WILL BE PACKED Ej-mB [Je-Mb], SO WE NEED TO SWITCH
C  TO THIS ORDERING.
C
        IF(ISPIN.EQ.1.AND..NOT.RHF)THEN
         I020=I010+IINTFP*DSZTAR*DISTAR
         CALL TRANSP(ICORE(I000),ICORE(I010),DISTAR,DSZTAR)
c YAU : old
c        CALL ICOPY(IINTFP*DISTAR*DSZTAR,ICORE(I010),1,ICORE(I000),1)
c YAU : new
         CALL DCOPY(DISTAR*DSZTAR,ICORE(I010),1,ICORE(I000),1)
c YAU : end
         I020=I010+IINTFP*DSZTAR 
         I030=I020+IINTFP*DSZTAR 
         I040=I030+IINTFP*DSZTAR 
         CALL SYMTR1(IRREPDO,VRT(1,1),POP(1,2),DSZTAR,
     &               ICORE(I000),ICORE(I010),ICORE(I020),
     &               ICORE(I030))
        ELSE
         I020=I010+IINTFP*DSZTAR 
         I030=I020+IINTFP*DSZTAR 
         I040=I030+IINTFP*DSZTAR 
         CALL SYMTR1(IRREPDO,VRT(1,2),POP(1,1),DSZTAR,
     &               ICORE(I000),ICORE(I010),ICORE(I020),
     &               ICORE(I030))
         I020=I010+IINTFP*DSZTAR*DISTAR
         CALL TRANSP(ICORE(I000),ICORE(I010),DISTAR,DSZTAR)
c YAU : old
c        CALL ICOPY(IINTFP*DISTAR*DSZTAR,ICORE(I010),1,ICORE(I000),1)
c YAU : new
         CALL DCOPY(DISTAR*DSZTAR,ICORE(I010),1,ICORE(I000),1)
c YAU : end
        ENDIF
        IF(RHF)THEN
         I020=I010+IINTFP*DSZTAR 
         I030=I020+IINTFP*DSZTAR 
         I040=I030+IINTFP*DSZTAR 
         CALL SYMTR1(IRREPDO,VRT(1,1),POP(1,1),DSZTAR,
     &               ICORE(I000),ICORE(I010),ICORE(I020),
     &               ICORE(I030))
        ENDIF  
C 
C  
C
C NOW DO    W(mBEj) = W(mBEj) - SUM T(N,B) * <Nm|Ej> (ISPIN=1)
C           W(MbeJ) = W(MbeJ) - SUM T(n,b) * <Mn|Je> (ISPIN=2 OR RHF)
C
        LISTW2=8+ISPIN
        IF(RHF)LISTW2=10
        ALPHA=ONEM*FACTOR
        BETA=ONE
        DISW  =aces_list_cols(IRREPDO,LISTW2)
        DSZW  =aces_list_rows(IRREPDO,LISTW2)
        I020  =I010+IINTFP*DSZW*DISW
        I030  =I020+IINTFP*DSZW
C
C GET THE INTEGRALS AND PLACE INTO A MATRIX 
C
C            I(Ej,Nm)   [ISPIN=1]
C            I(Je,Mn)   [ISPIN=2 OR RHF]
C
        CALL GETTRN(ICORE(I010),ICORE(I020),DSZW,DISW,2,IRREPDO,
     &              LISTW2)
        ITMP=DISW
        DISW=DSZW
        DSZW=ITMP
C
C TRANSPOSE KET INDICES FOR ISPIN=1.  THIS GIVES
C
C               I(Ej,mN) [ISPIN=1]
C               I(Je,Mn) [ISPIN=2 OR RHF]
C
        IF(ISPIN.EQ.1.AND..NOT.RHF)THEN
         I030=I020+IINTFP*DSZW
         I040=I030+IINTFP*DSZW
         I050=I040+IINTFP*DSZW
         CALL SYMTR1(IRREPDO,POP(1,1),POP(1,2),DSZW,
     &              ICORE(I010),ICORE(I020),ICORE(I030),
     &              ICORE(I040))
        ENDIF
C
C NOW DO MATRIX MULTIPLICATION AS ABOVE, WITH THE MATRICES
C
C                                   t
C       Z(Ej,mB) = I(Ejm,N) * T(B,N)
C         
C                                   t
C       Z(Je,Mb) = I(JeM,n) * T(b,n)
C
        IOFFI=I010
        IOFFZ=I000
        DO 200 IRREPN=1,NIRREP
         IRREPM=DIRPRD(IRREPN,IRREPDO)
         IRREPB=IRREPN
         NROWI=DSZW*POP(IRREPM,3-ISPIN)
         NCOLI=POP(IRREPN,ISPIN)
         NROWT=VRT(IRREPB,ISPIN)
         NCOLT=POP(IRREPB,ISPIN)
         NROWZ=NROWI
         NCOLZ=NROWT
         IOFFT=IOFFT1(IRREPN,ISPIN)
         IF(MIN(NROWI,NCOLT,NCOLI).GT.0)THEN
          CALL XGEMM('N','T',NROWZ,NCOLZ,NCOLI,ALPHA,ICORE(IOFFI),
     &               NROWI,ICORE(IOFFT),NROWT,BETA,ICORE(IOFFZ),
     &               NROWZ)
         ENDIF
         IOFFI=IOFFI+NROWI*NCOLI*IINTFP
         IOFFZ=IOFFZ+NROWZ*NCOLZ*IINTFP
200     CONTINUE
C
C WE NOW HAVE
C                   Z(Ej,mB)  [ISPIN=1]
C                   Z(Je,Mb)  [ISPIN=2 OR RHF]
C
C AND WE WANT TO RESORT THESE FIRST TO
C
C                   Z(Ej,Bm)  [ISPIN=1]
C                   Z(eJ,bM)  [ISPIN=2]
C
C NOW TRANSPOSE BRA INDICES FOR TARGET IF ISPIN=2, AND KET INDICES IN
C  EITHER CASE
C
        IF(ISPIN.EQ.2.OR.RHF)THEN
         I020=I010+IINTFP*MAX(DSZTAR,DISTAR)
         I030=I020+IINTFP*MAX(DSZTAR,DISTAR)
         I040=I030+IINTFP*MAX(DSZTAR,DISTAR)
         CALL SYMTR3(IRREPDO,POP(1,1),VRT(1,2),DSZTAR,DISTAR,
     &              ICORE(I000),ICORE(I010),ICORE(I020),
     &              ICORE(I030))
        ENDIF
        I020=I010+IINTFP*DSZTAR
        I030=I020+IINTFP*DSZTAR
        I040=I030+IINTFP*DSZTAR
        CALL SYMTR1(IRREPDO,POP(1,3-ISPIN),VRT(1,ISPIN),DSZTAR,
     &              ICORE(I000),ICORE(I010),ICORE(I020),
     &              ICORE(I030))
C
C NOW DUMP THESE TO DISK IRREP BY IRREP
C
C
        CALL PUTLST(ICORE(I000),1,DISTAR,1,IRREPDO,LSTOUT)
20     CONTINUE
C
C NOW SWITCH ORDERING FROM 
C
C             Z(Ej,Bm) -> Z(Em,Bj) [ISPIN=1]
C             Z(eJ,bM) -> Z(eM,bJ) [ISPIN=2 OR RHF]
C
C AND PUT BACK ON DISK.
C
       ISCSIZ=(NVRTO(1)+NVRTO(2))*(NOCCO(1)+NOCCO(2))
       TARSIZ=ISYMSZ(ISYTYP(1,LSTTAR),ISYTYP(2,LSTTAR))
       I000=1
       I010=I000+TARSIZ*IINTFP
       I020=I010+TARSIZ*IINTFP
       I030=I020+ISCSIZ
       IF(I030.GT.MXCOR)CALL INSMEM('T1RB01',I030,MXCOR)
       CALL GETALL(ICORE(I010),TARSIZ,1,LSTOUT)
       CALL SSTRNG(ICORE(I010),ICORE(I000),TARSIZ,TARSIZ,ICORE(I020),
     &             SSTSPN(ISPIN))
C
C   FOR LAMBDA UPDATE TARGET LSIT AND COPY ORIGINAL INTERMEDIATES TO
C   LSTOUT
C
       IF(LAMBDA) THEN
        CALL GETALL(ICORE(I010),TARSIZ,1,LSTTAR)
        CALL PUTALL(ICORE(I010),TARSIZ,1,LSTOUT)
        CALL SAXPY(TARSIZ,ONE,ICORE(I010),1,ICORE(I000),1)
       ENDIF
       CALL PUTALL(ICORE(I000),TARSIZ,1,LSTTAR)
10    CONTINUE
      RETURN
      END
