      SUBROUTINE T2T1AA1(W,ICORE,MAXCOR,POP,VRT,ISPIN,LAMBDA,LSTOFF)
C
C     THIS SUBROUTINE CALCULATES THE FOLLOWING CONTRIBUTIOBN TO THE
C     T1  INCREMENT (LAMBDA = .FALSE.
C
C      Z(I,A) =  SUM E<F,M T(IM,EF) <AM//EF>
C
C OR   Z(i,a) =  SUM e<f,m T(im,ef) <am//ef)
C
C      OR TO THE L1 INCREMENT (LAMBDA = .TRUE.)
C
C      Z(I,A) =  SUM E<F,M L(IM,EF) <AM//EF>
C
C OR   Z(i,a) =  SUM e<f,m L(im,ef) <am//ef)
C
CEND   
C
C CODED JUNE/90   JG
C 
C  OUT OF CORE ALGORITHM IMPLEMENTED IN SEPT/90
C  
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL LAMBDA
      INTEGER DIRPRD,POP,VRT,DISSYT,DISSYW,DISMAX,DISLEFT,DISREAD
C
      DIMENSION ICORE(MAXCOR),POP(8),VRT(8),W(1),IPT(8),IPZ(8)
C
      COMMON /MACHSP/ IINTLN,IFLTLN,IINTFP,IALONE,IBITWD
      COMMON /SYMINF/ NSTART,NIRREP,IRREPA(255),IRREPB(255),
     &                DIRPRD(8,8)
      COMMON /SYMPOP/ IRPDPD(8,22),ISYTYP(2,500),NTOT(18)
      COMMON /FLAGS/ IFLAGS(100)
C
      DATA ZERO,ONE,ONEM /0.0D0,1.0D0,-1.0D0/
C
C  DETERMINE LIST NUMBERS
C  LISTT = T2 AMPLITUDES,   LISTW = <EF//AM> INTEGRALS
C
C  The iflags(39) flag, reserved for "standard" or "semicanonical" 
C  orbitals, is used here to determine which list is needed for the
C  ROHF-MBPT code, since this routine is called by two others at
C  different times.  The value of "99" is set before the second call
C  to E3S in ROHFPT.
C
      IF(LAMBDA) THEN
       LISTT=143+ISPIN
      ELSEIF(IFLAGS(11).EQ.2.AND.IFLAGS(39).EQ.99) THEN
       LISTT=93+ISPIN
      ELSE
       LISTT=43+ISPIN
      ENDIF
      LISTW=26+ISPIN+LSTOFF
C
C    LOOP OVER IRREPS
C
      DO 1000 IRREP=1,NIRREP
C
C  GET LENGTHS OF VARIOUS ARRAYS AND
C  ALLOCATE CORE MEMORY
C
       NOCCSQ=0
       DO 1001 IRREPJ=1,NIRREP
        NOCCSQ=NOCCSQ+POP(IRREPJ)*POP(DIRPRD(IRREP,IRREPJ))
1001   CONTINUE
       DISSYW=IRPDPD(IRREP,ISYTYP(1,LISTW))
       DISSYT=IRPDPD(IRREP,ISYTYP(1,LISTT))
       NUMSYW=IRPDPD(IRREP,ISYTYP(2,LISTW))
       NUMSYT=IRPDPD(IRREP,ISYTYP(2,LISTT))
       I001=1
       I002=I001+IINTFP*DISSYT*NOCCSQ
       I003=I002+IINTFP*MAX(NUMSYT,NUMSYW,DISSYT,DISSYW)
       I004=I003+IINTFP*MAX(NUMSYT,NUMSYW,DISSYT,DISSYW)
       I005=I004+IINTFP*MAX(NUMSYT,NUMSYW,DISSYT,DISSYW)
       if (I005.LT.0) call trap_intovf('T2T1AA1',1)
       MAXSIZE=(MAXCOR-I005)/IINTFP
       IF(MIN(NUMSYW,NUMSYT,DISSYT).NE.0) THEN
C
C  WE ALWAYS NEED T2 AMPLITUDES. THEY ARE ASSUMED TO FIT INTO THE
C  MEMORY, GET THEM HERE AND EXPAND THE OCC.-OCC. BLOCK
C
       CALL GETLST(ICORE(I001),1,NUMSYT,1,IRREP,LISTT)
       CALL SYMEXP(IRREP,POP,DISSYT,ICORE(I001))
C
C    DETERMINE MAXIMUM NUMBER OF DISTRIBUTIONS WHICH CAN BE HELD IN CORE
C
       MAXDIS=MAXSIZE/DISSYW
C
C  CAN WE DO IT IN CORE ?
C
       IF(MAXDIS.GE.NUMSYW) THEN
C
C  IN CORE ALGORITHM
C
C   GET INTEGRALS <EF//AM> AND TRANSPOSE THE LAST TWO INDICES 
C 
        CALL GETLST(ICORE(I005),1,NUMSYW,2,IRREP,LISTW)
        CALL SYMTR1(IRREP,VRT,POP,DISSYW,ICORE(I005),ICORE(I002),
     &              ICORE(I003),ICORE(I004))
C
C  PERFORM MULTIPLICATION
C
        IOFFT=0
        IOFFW=0 
        IOFFS=1
        DO 100 IRREPJ=1,NIRREP 
         NVRTJ=VRT(IRREPJ)
         NOCCJ=POP(IRREPJ)
         IRREPI=DIRPRD(IRREPJ,IRREP)
         NOCCI=POP(IRREPI)
C 
         IF(MIN(NOCCI,NOCCJ,NVRTJ).NE.0) THEN
          CALL XGEMM('T','N',NVRTJ,NOCCJ,NOCCI*DISSYW,ONEM,
     &               ICORE(I005+IOFFW*IINTFP),DISSYW*NOCCI,
     &               ICORE(I001+IINTFP*IOFFT),DISSYT*NOCCI,ONE,
     &               W(IOFFS),NVRTJ)
         ENDIF
C
C  UPDATE OFFSETS
C
         IOFFT=IOFFT+NOCCI*NOCCJ*DISSYT
         IOFFW=IOFFW+NVRTJ*NOCCI*DISSYW
         IOFFS=IOFFS+NVRTJ*NOCCJ
100     CONTINUE
       ELSE 
C
C  OUT CORE ALGORITHM
C
C    DETERMINE FIRST OFSETS WITHIN THE T1 INCREMENTS
C
       IPT(1)=1
       DO 150 IRREPJ=1,NIRREP-1
        IPT(IRREPJ+1)=IPT(IRREPJ)+POP(IRREPJ)*VRT(IRREPJ)
150    CONTINUE
C
C  OFFSET FOR INTEGRAL LIST  AND FOR T2 AMPLITUDES
C
       IOFFSET=1
       IOFFT2=0
C
C  LOOP OVER THE IRREPS OF THE LAST INDEX
C
       DO 200 IRREPJ=1,NIRREP
C
        NOCCJ=POP(IRREPJ)
        IRREPI=DIRPRD(IRREP,IRREPJ)
        NOCCI=POP(IRREPI)
        NVRTI=VRT(IRREPI)
        IF(MIN(NOCCI,NVRTI,NOCCJ).NE.0) THEN
C
C  MAXIMUM NUMBER OF (A<B,C) BLOCKS WHICH CAN BE HELD IN CORE
C
        DISMAX=MAXDIS/NVRTI
        IF(DISMAX.LE.0) STOP 'W4AA'
C
C  NUMBER OF (A<B,C) BLOCKS TO READ
C
        DISLEFT=NOCCJ 
C
10      CONTINUE
C
C NUMBER OF (A<B,C) BLOCKS WHICH ARE READ IN THIS PASS
C
         DISREAD=MIN(DISLEFT,DISMAX)
         DISLEFT=DISLEFT-DISREAD
C
C GET THE DISTRIBUTIONS FROM DISK
C
         CALL GETLST(ICORE(I005),IOFFSET,DISREAD*NVRTI,2,IRREP,LISTW)
C
C  UPDATE IOFFSET
C
         IOFFSET=IOFFSET+DISREAD*NVRTI
C
C  LOOP OVER ALL DISTRIBUTIONS AND PERFORM MULTIPLICATION
C
         IOFFW=0
         IOFFT1=IPT(IRREPI)
C
         DO 250 NUM=1,DISREAD
C
          CALL XGEMM('T','N',NVRTI,NOCCI,DISSYW,ONE,
     &               ICORE(I005+IINTFP*IOFFW),DISSYW, 
     &               ICORE(I001+IINTFP*IOFFT2),DISSYT,
     &               ONE,W(IOFFT1),NVRTI)
C
C   UPDATE OFFSETS
C
          IOFFW=IOFFW+DISSYW*NVRTI
          IOFFT2=IOFFT2+DISSYT*NOCCI
C
250      CONTINUE
C
C   IF NOT ALL (A<B,C) BLOCKS HAVE BEEN PROCESSED, GO TO 10
C
        IF(DISLEFT.NE.0) GO TO 10
C
        ELSE
C
C   UPDATE OFFSETS IN THE CASE NOTHING HAS BEEN DONE
C
         IOFFT2=IOFFT2+DISSYT*NOCCI*NOCCJ
         IOFFSET=IOFFSET+NOCCJ*NVRTI
        ENDIF
200    CONTINUE
C
      ENDIF    
      ENDIF
1000  CONTINUE
      RETURN
      END
