      SUBROUTINE T2T1AB1(W,ICORE,MAXCOR,POP1,POP2,VRT1,VRT2,ISPIN,IUHF,
     &                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(Mi,Ef) <Ma//Ef)
C
C     OR 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(Mi,Ef) <Ma//Ef)
C
CEND
C 
C CODED JUNE/90  JG
C     
C SPIN ADAPTED CODE IMPLEMENTED FOR RHF IN AUGUST 90
C
C OUT OF CORE ALGORITHM IMPLEMENTED IN SEPT/90
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL LAMBDA
      INTEGER DIRPRD,DISSYT,DISSYW,DISLEFT,DISREAD,DISMAX,
     &                   POP1,POP2,VRT1,VRT2
C
      DIMENSION ICORE(MAXCOR),POP1(8),POP2(8),VRT1(8),VRT2(8)
      DIMENSION W(1),IPT(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 AZERO,ONE,ONEM,TWO /0.0D0,1.0D0,-1.0D0,2.0D0/
C
C  DETEMINE 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=146
      ELSEIF(IFLAGS(11).EQ.2.AND.IFLAGS(39).EQ.99) THEN
       LISTT=96
      ELSE
       LISTT=46
      ENDIF 
      LISTW=31-ISPIN+LSTOFF
C
C    LOOP OVER IRREPS
C
      DO 1000 IRREP=1,NIRREP
C
C  GET LENGTHS OF VARIOUS ARRAYS AND ALLOCATE CORE
C
      DISSYW=IRPDPD(IRREP,ISYTYP(1,LISTW))
      DISSYT=IRPDPD(IRREP,ISYTYP(1,LISTT))
      NUMSYW=IRPDPD(IRREP,ISYTYP(2,LISTW))
      NUMSYT=IRPDPD(IRREP,ISYTYP(2,LISTT))
      if (NUMSYT*DISSYT.LT.0) call trap_intovf('T2T1AB1',1)
      I001=1
      I002=I001+IINTFP*NUMSYT*DISSYT
      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('T2T1AB1',2)
      MAXSIZE=(MAXCOR-I005)/IINTFP
      IF(MIN(NUMSYT,NUMSYW,DISSYT).NE.0) THEN
C
C  WE ALWAYS NEED THE T2 AMPLITUDES. THEY ARE ASSUMED TO
C  FIT INTO THE AVAILABLE CORE MEMORY. GET THEM HERE.
C
       CALL GETLST(ICORE(I001),1,NUMSYT,1,IRREP,LISTT)
C
C SPIN ADAPTED CODE FOR RHF
C
       IF(IUHF.EQ.0) THEN
        IF(MAXSIZE.LT.DISSYT*NUMSYT) STOP 'W4AB'
        CALL SYMTRA(IRREP,POP1,POP2,DISSYT,ICORE(I001),ICORE(I005))
        CALL SSCAL(NUMSYT*DISSYT,TWO,ICORE(I001),1)
        CALL SAXPY(NUMSYT*DISSYT,ONEM,ICORE(I005),1,ICORE(I001),1)
       ENDIF
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
C
C      FOR SPIN CASE 1 TRANPOSE THE LAST TWO INDICES
C
       IF(ISPIN.EQ.1) THEN
        CALL SYMTR1(IRREP,POP1,POP2,DISSYT,ICORE(I001),ICORE(I002),
     &             ICORE(I003),ICORE(I004))
       ENDIF
C
C      GET INTEGRALS FROM DISK
C
       CALL GETLST(ICORE(I005),1,NUMSYW,2,IRREP,LISTW)
C
C      FOR SPIN CASE 1 TRANSPOSE THE LAST TWO INDICES
C
       IF(ISPIN.EQ.1) THEN
        CALL SYMTR1(IRREP,VRT1,POP2,DISSYW,ICORE(I005),ICORE(I002),
     &              ICORE(I003),ICORE(I004))
       ENDIF
C
C   PERFORM MULTIPLICATION
C
       IOFFT=0
       IOFFW=0 
       IOFFS=1
       DO 100 IRREPJ=1,NIRREP 
        NVRTJ=VRT1(IRREPJ)
        NOCCJ=POP1(IRREPJ)
        IRREPI=DIRPRD(IRREPJ,IRREP)
        NOCCI=POP2(IRREPI)
C
        IF(MIN(NVRTJ,NOCCJ,NOCCI).NE.0) THEN
C
         CALL XGEMM('T','N',NVRTJ,NOCCJ,NOCCI*DISSYW,ONE,
     &               ICORE(I005+IOFFW*IINTFP),DISSYW*NOCCI,
     &               ICORE(I001+IINTFP*IOFFT),DISSYT*NOCCI,ONE,
     &               W(IOFFS),NVRTJ)
C
        ENDIF
C
C  UPDATE OFFSETS
C 
        IOFFT=IOFFT+NOCCI*NOCCJ*DISSYT
        IOFFW=IOFFW+NVRTJ*NOCCI*DISSYW
        IOFFS=IOFFS+NVRTJ*NOCCJ
C
100    CONTINUE
C
      ELSE
C
C  OUT CORE ALGORITHM
C
C   DIFFER HERE BETWEEN THE TWO SPIN CASES
C
       IF(ISPIN.EQ.1) THEN
C
C   HERE <Ef//Am> T(Ef,Im)  WITH E,f ; I,m AND E,f ; A,m ORDERING
C
C   DETERMINE FIRST OFFSETS WITHIN THE T1 INCREMENTS
C
        IPT(1)=1
        DO 150 IRREPJ=1,NIRREP-1
         IPT(IRREPJ+1)=IPT(IRREPJ)+POP1(IRREPJ)*VRT1(IRREPJ)
150     CONTINUE
C
C   OFFSETS 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=POP2(IRREPJ)
         IRREPI=DIRPRD(IRREP,IRREPJ)  
         NOCCI=POP1(IRREPI)
         NVRTI=VRT1(IRREPI)
         IF(MIN(NOCCI,NVRTI,NOCCJ).NE.0) THEN
C
C  MAXIMUM NUMBER OF  (E,F,A) BLOCKS WHICH CAN BE HELD IN CORE
C
         DISMAX=MAXDIS/NVRTI
         IF(DISMAX.LE.0) STOP 'W4AB'
C
C   NUMBER OF (E,f,A) BLOCKS TO READ
C
         DISLEFT=NOCCJ
C
10       CONTINUE
C
C  NUMBER OF (E,f,A) 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 (Ef,A) BLOCKS HAVE BEEN PROCESSED, GO BACK 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
      ELSE IF(ISPIN.EQ.2) THEN
C
C    HERE <Ef//Ma> T(Ef,Mi) IS COMPUTED, THE ORDERING IS E,f ; M,i AND 
C    E,f ; M,a
C
C   OFFSET FOR INTEGRAL LIST AND FOR T2 AMPLITUDES
C
       IOFFSET=1
       IOFFT2=0
       IOFFT1=1
C
C    LOOP OVER IRREPS OF THE LAST INDEX
C
       DO 300 IRREPJ=1,NIRREP
C
        NOCCJ=POP1(IRREPJ)
        NVRTJ=VRT1(IRREPJ)
        IRREPI=DIRPRD(IRREP,IRREPJ)
        NOCCI=POP2(IRREPI)
        IF(MIN(NOCCI,NVRTI,NOCCJ).NE.0) THEN
C
C   MAXIMUM NUMBER OF (Ef,I) BLOCKS WHICH CAN BE HELD IN CORE
C
        DISMAX=MAXDIS/NOCCI
C
C   NUMBER OF(Ef,I) BLOCKS TO READ
C
        DISLEFT=NVRTJ
C
        IOFF=0
C
20      CONTINUE
C
C   NUMBER OF(Ef,I) 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*NOCCI,2,IRREP,LISTW)
C
C  UPDATE IOFFSET
C
         IOFFSET=IOFFSET+DISREAD*NOCCI
C
C        PERFORM MULTIPLICATION
C
         CALL XGEMM('T','N',DISREAD,NOCCJ,DISSYW*NOCCI,ONE,
     &              ICORE(I005),DISSYW*NOCCI,ICORE(I001+
     &              IINTFP*IOFFT2),DISSYT*NOCCI,ONE,W(IOFFT1+IOFF),
     &              NVRTJ)
C
         IOFF=IOFF+DISREAD
C
C   IF NOT ALL (Ef,I) BLOCKS HAVE BEEN PROCESSED, GO BACK TO 20
C
         IF(DISLEFT.NE.0) GO TO 20
C
        ELSE
C
C  UPDATE OFFSETS IN THE CASE NOTHING HAS BEEN DONE
C
         IOFFSET=IOFFSET+NVRTJ*NOCCI
        ENDIF
C
C  UPDATE OFFSETS
C
        IOFFT1=IOFFT1+NOCCJ*NVRTJ
        IOFFT2=IOFFT2+NOCCJ*NOCCI*DISSYT
300    CONTINUE
C
       ENDIF
      ENDIF
      ENDIF
1000  CONTINUE
      RETURN
      END
