      SUBROUTINE T1RA01(ICORE,MAXCOR,IUHF,LAMBDA)
C
C THIS SUBROUTINE COMPUTES ONE OF TWO T1*W CONTRIBUTIONS TO THE
C  W(mbej) INTERMEDIATE.  
C
C           W(MBEJ) = - SUM T(J,F) * <FE||BM> + SUM T(N,B) * <NM||JE>    (1)
C           W(mbej) = - SUM T(j,f) * <fe||bm> + SUM T(n,b) * <nm||je>    (2)
C
C ALSO COMPUTED IS THE T1*W CONTRIBUTIONS TO THE F(ea) INTERMEDIATE
C
C           F(EA)   =  SUM T(M,F) * <FE||MA> = - SUM T(M,F) * <FE||AM>  (3)
C           F(ea)   =  SUM T(m,f) * <fe||ma> = - SUM T(m,f) * <fe||am>  (4)
C
C WHICH ARE OBTAINED BY TAKING GENERALIZED TRACES (N**3 DEPENDENCE) OVER THE
C TERMS CALCULATED IN EQS 1 AND 2.
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 SPCASE(2)
      DIMENSION ICORE(MAXCOR),IOFFT1(8,2),ABFULL(8),MNFULL(8),IZOFF(8)
      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 SPCASE /'AAAA','BBBB'/
      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)
C
C SPIN CASES AAAA AND BBBB
C
      LSTFEA=92
      DO 10 ISPIN=1,1+IUHF
       LSTTAR=53+ISPIN
       IF(LAMBDA)THEN
        LSTOUT=122+ISPIN
        FACTOR=ONEM
       ELSE
        LSTOUT=LSTTAR
        FACTOR=ONE
       ENDIF 
C
C COMPUTE A,B DPD SIZE FOR ALL IRREPS
C
       DO 1000 IRREP=1,NIRREP
        ICOUNT=0
        ICOUNT2=0
        DO 1001 IRREPE=1,NIRREP
         IRREPF=DIRPRD(IRREPE,IRREP)
         ICOUNT=ICOUNT+VRT(IRREPF,ISPIN)*VRT(IRREPE,ISPIN)
         ICOUNT2=ICOUNT2+POP(IRREPF,ISPIN)*POP(IRREPE,ISPIN)
1001    CONTINUE
        ABFULL(IRREP)=ICOUNT
        MNFULL(IRREP)=ICOUNT2
1000   CONTINUE
C
C LOOP OVER IRREPS - IN THE FIRST BLOCK OF CODE THIS CORRESPONDS TO BM,
C                    WHILE IT IS JE IN THE SECOND BLOCK.
C
C
C FIRST DO THE   W(MBEJ) =  SUM T(J,F) * <FE||BM>  CONTRIBUTION.
C  THE PRODUCT IS INITIALLY PACKED AS A I(BM;EJ) MATRIX.
C
       DO 20 IRREPDO=1,NIRREP
        ALPHA=ONE*FACTOR
        BETA=ONE
        LSTINT=26+ISPIN
        IF(IUHF.EQ.0)LSTINT=30
        DISTAR=aces_list_cols(IRREPDO,22+ISPIN)
        DSZTAR=aces_list_rows(IRREPDO,22+ISPIN)
        DSZW  =aces_list_rows(IRREPDO,LSTINT)
        DISW  =aces_list_cols(IRREPDO,LSTINT)
        DSZEXP=ABFULL(IRREPDO)
        I000=1
        I010=I000+IINTFP*DISTAR*DSZTAR
        I020=I010+DSZEXP*DISW*IINTFP
        I030=I020+DSZW*IINTFP
        if ((i030.lt.0).or.(i030.gt.maxcor)) then
           call insmem('T1RA01',i030,maxcor)
        end if
        CALL IZERO(ICORE,IINTFP*DISTAR*DSZTAR)
C
C READ IN TRANSPOSE OF INTEGRAL MATRIX
C
C RETURNED MATRIX IS I(BM;F<E) [I(bm;f<e)].
C
        IF(IUHF.NE.0)THEN
         CALL GETTRN(ICORE(I010),ICORE(I020),DSZW,DISW,2,IRREPDO,
     &                LSTINT)
        ELSE
         CALL GETTRN(ICORE(I010),ICORE(I020),DSZEXP,DISW,2,IRREPDO,
     &                LSTINT)
         CALL ASSYM2(IRREPDO,VRT(1,1),DISW,ICORE(I010))
        ENDIF
C
C CHANGE MEANINGS OF DSZ AND DIS.
C
        DSZW=DISW
        DISW=DSZEXP
C
C EXPAND TO I(BM;FE) [I(bm;fe)] AND TRANSPOSE KET INDICES.
C
        CALL SYMEXP(IRREPDO,VRT(1,ISPIN),DSZW,ICORE(I010))
C
C NOW LOOP OVER IRREPS OF F AND FORM THE MATRIX PRODUCT
C
C             Z(BME;J) = I(BME;F)*T(F,J)  [ISPIN=1]
C             Z(bme;j) = I(bme;f)*T(f,j)  [ISPIN=2]
C
        IOFFI=I010
        IOFFZ=I000
        DO 4101 IRREPF=1,NIRREP
C
C FIGURE OUT THE DIMENSIONS OF THE MATRICES INVOLVED IN THE 
C   MULTIPLICATION
C 
         IRREPE=DIRPRD(IRREPF,IRREPDO)
         IRREPJ=IRREPF
         NROWI=DSZW*VRT(IRREPE,ISPIN)
         NROWZ=NROWI
         NCOLZ=POP(IRREPJ,ISPIN)
         NCOLI=VRT(IRREPF,ISPIN)
         NROWT=VRT(IRREPF,ISPIN)
         NCOLT=POP(IRREPJ,ISPIN)
         IOFFT=IOFFT1(IRREPJ,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
4101    CONTINUE
C
C NOW GET CONTRIBUTION TO F(ea) INTERMEDIATE FROM TRACEOO.
C
        I020=I010+ABFULL(1)*IINTFP
        I030=I020+ABFULL(1)*IINTFP
        IF(.NOT.LAMBDA) THEN
        CALL TRACEOO('VOVO',IRREPDO,POP(1,ISPIN),VRT(1,ISPIN),
     &               DISTAR,ABFULL(1),ICORE(I000),
     &               ICORE(I020))
        CALL SYMTRA(1,VRT(1,ISPIN),VRT(1,ISPIN),1,
     &              ICORE(I020),ICORE(I010))
        CALL SUMSYM3(ICORE(I010),ICORE(I020),ABFULL(1),1,ISPIN,LSTFEA)
        ENDIF
C
C NOW REORDER W(BM;EJ) TO W(JE;MB).
C
        I020=I010+IINTFP*MAX(DSZTAR,DISTAR)
        I030=I020+IINTFP*MAX(DSZTAR,DISTAR)
        I040=I030+IINTFP*MAX(DSZTAR,DISTAR)
        CALL SYMTR1(IRREPDO,VRT(1,ISPIN),POP(1,ISPIN),DSZTAR,
     &              ICORE(I000),ICORE(I020),ICORE(I030),
     &              ICORE(I040))
        CALL SYMTR3(IRREPDO,VRT(1,ISPIN),POP(1,ISPIN),DSZTAR,DISTAR,
     &              ICORE(I000),ICORE(I020),ICORE(I030),ICORE(I040))
        CALL MTRAN2(ICORE(I000),DISTAR)
C
C NOW DO THE  -SUM(N,B) * <NM||JE>  CONTRIBUTION - THIS IS ORDERED
C          B,M-J,E
C
        ALPHA=ONEM*FACTOR
        BETA=ONE
        LSTINT=6+ISPIN
        DISW  =aces_list_cols(IRREPDO,LSTINT)
        DSZW  =aces_list_rows(IRREPDO,LSTINT)
        DSZEXP=MNFULL(IRREPDO)
        I020=I010+DSZEXP*DISW*IINTFP
        I030=I020+DSZW*IINTFP
C
C READ IN TRANSPOSE OF INTEGRAL MATRIX
C
C RETURNED MATRIX IS I(JE;N<M) [I(je;n<m)].
C
        CALL GETTRN(ICORE(I010),ICORE(I020),DSZW,DISW,2,IRREPDO,
     &              LSTINT)
C
C CHANGE MEANINGS OF DSZ AND DIS.
C
        DSZW=DISW
        DISW=DSZEXP
C
C EXPAND TO I(JE;NM) [I(je;nm)] AND THEN NEGATE, GIVING
C       I(JE;MN) [I(je;mn)].
C
        CALL SYMEXP(IRREPDO,POP(1,ISPIN),DSZW,ICORE(I010))
C
C NOW LOOP OVER IRREPS OF F AND FORM THE MATRIX PRODUCT
C
C             Z(JEM;B) = I(JEM;N)*T(B,N)(t)  [ISPIN=1]
C             Z(jem;b) = I(jem;n)*T(b,n)(t)  [ISPIN=2]
C
C FIRST CALCULATE Z MATRIX OFFSETS FOR EACH IRREP OF B.
C
        IZOFF(1)=I000
        DO 5100 IRREP=2,NIRREP
         IRREPB=IRREP-1
         IRREPM=DIRPRD(IRREPB,IRREPDO)
         IZOFF(IRREP)=IZOFF(IRREP-1)+DSZW*POP(IRREPM,ISPIN)*
     &                VRT(IRREPB,ISPIN)*IINTFP
5100    CONTINUE
        IOFFI=I010
        DO 5101 IRREPN=1,NIRREP
C
C FIGURE OUT THE DIMENSIONS OF THE MATRICES INVOLVED IN THE 
C   MULTIPLICATION
C
         IRREPM=DIRPRD(IRREPN,IRREPDO)
         IRREPB=IRREPN
         NROWI=DSZW*POP(IRREPM,ISPIN)
         NCOLI=POP(IRREPN,ISPIN)
         NROWT=POP(IRREPN,ISPIN)
         NCOLT=VRT(IRREPB,ISPIN)
         IOFFT=IOFFT1(IRREPB,ISPIN)
         IOFFZ=IZOFF(IRREPB)
         IF(MIN(NROWI,NCOLT,NCOLI).GT.0)THEN
          CALL XGEMM('N','T',NROWI,NCOLT,NCOLI,ALPHA,ICORE(IOFFI),
     &               NROWI,ICORE(IOFFT),NCOLT,BETA,ICORE(IOFFZ),
     &               NROWI)
         ENDIF
         IOFFI=IOFFI+NROWI*NCOLI*IINTFP
5101    CONTINUE
C
C NOW SWITCH ORDERING TO EJBM AND WRITE THESE QUANTITIES TO DISK FOR
C  EACH IRREP.
C
        I020=I010+IINTFP*MAX(DSZTAR,DISTAR)
        I030=I020+IINTFP*MAX(DSZTAR,DISTAR)
        I040=I030+IINTFP*MAX(DSZTAR,DISTAR)
        CALL SYMTR1(IRREPDO,POP(1,ISPIN),VRT(1,ISPIN),DSZTAR,
     &              ICORE(I000),ICORE(I020),ICORE(I030),ICORE(I040))
        CALL SYMTR3(IRREPDO,POP(1,ISPIN),VRT(1,ISPIN),DSZTAR,DISTAR,
     &              ICORE(I000),ICORE(I020),ICORE(I030),ICORE(I040))
        CALL PUTLST(ICORE(I000),1,DISTAR,2,IRREPDO,LSTOUT)
20     CONTINUE
C
C NOW SWITCH ORDERING TO E,M-B,J
C
       ISCSIZ=NOCCO(ISPIN)*NVRTO(ISPIN)*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('T1RAAAAI',I030,MXCOR)
       CALL GETALL(ICORE(I010),TARSIZ,1,LSTOUT)
       CALL SSTRNG(ICORE(I010),ICORE(I000),TARSIZ,TARSIZ,ICORE(I020),
     &             SPCASE(ISPIN))
C
C   FOR LAMBDA UPDATE TARGET LIST AND COPY ORIGINAL INTERMEDIATES
C   TO 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
C
       CALL PUTALL(ICORE(I000),TARSIZ,1,LSTTAR)
10    CONTINUE
      RETURN
      END
