C
C     THIS SUBROUTINE CALCULATES THE FOLLOWING CONTRIBUTIOBN TO THE
C     T1 INCREMENT (LAMBDA = .FALSE.)
C
C      Z(I,A) = - SUM M,n,e T(Mn,Ae) <Mn//Ie>
C
C OR   Z(i,a) = - SUM M,n,E T(Mn,Ea) <Mn//Ei)
C
C     OR TO THE L1 INCREMENT (LAMBDA = .TRUE)
C
C      Z(I,A) = - SUM M,n,e L(Mn,Ae) <Mn//Ie>
C
C OR   Z(i,a) = - SUM M,n,E L(Mn,Ea) <Mn//Ei)
C
C  FOR RHF A SPIN ADAPTED CODE HAS BEEN IMPLEMENTED
C
C  CODED JUNE/90  JG
C     
      SUBROUTINE T2T1AB2(W,ICORE,MAXCOR,POP1,POP2,VRT1,VRT2,ISPIN,IUHF,
     &                LAMBDA,LSTOFF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL LAMBDA
      INTEGER DIRPRD,DISSYT,DISSYW,POP1,POP2,VRT1,VRT2
      DIMENSION ICORE(MAXCOR),POP1(8),POP2(8),VRT1(8),VRT2(8)
      DIMENSION W(1)
      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,TWO /0.0D0,1.0D0,-1.0D0,2.D0/
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=11-ISPIN+LSTOFF
C
C    LOOP OVER IRREPS
C
      DO 1000 IRREP=1,NIRREP
      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*NUMSYT*DISSYT
      I003=I002+IINTFP*MAX(NUMSYW*DISSYW,NUMSYT*DISSYT)
      I004=I003+IINTFP*MAX(NUMSYT,NUMSYW,DISSYT,DISSYW)
      I005=I004+IINTFP*MAX(NUMSYT,NUMSYW,DISSYT,DISSYW)
      I006=I005+IINTFP*MAX(NUMSYT,NUMSYW,DISSYT,DISSYW)
      IF(I006.LT.MAXCOR) THEN 
       CALL GETLST(ICORE(I002),1,NUMSYT,1,IRREP,LISTT)
C
C  SPIN ADAPTED CODE FOR RHF
C
       IF(IUHF.EQ.0) THEN
        CALL SYMTRA(IRREP,POP1,POP2,DISSYT,ICORE(I002),ICORE(I001))
        CALL SSCAL(NUMSYT*DISSYT,TWO,ICORE(I002),1)
        CALL SAXPY(NUMSYT*DISSYT,ONEM,ICORE(I001),1,ICORE(I002),1)
       ENDIF
C
       CALL TRANSP(ICORE(I002),ICORE(I001),NUMSYT,DISSYT)
       IF(ISPIN.EQ.1) THEN
        CALL SYMTR1(IRREP,VRT1,VRT2,NUMSYT,ICORE(I001),ICORE(I003),
     &              ICORE(I004),ICORE(I005))
       ENDIF
       CALL GETLST(ICORE(I002),1,NUMSYW,2,IRREP,LISTW)
       IF(ISPIN.EQ.1) THEN
        CALL SYMTR1(IRREP,POP1,VRT2,DISSYW,ICORE(I002),ICORE(I003),
     &              ICORE(I004),ICORE(I005))
       ENDIF
       IOFFT=0
       IOFFW=0 
       IOFFS=1
       DO 100 IRREPJ=1,NIRREP 
        NVRTJ=VRT1(IRREPJ)
        NOCCJ=POP1(IRREPJ)
        IRREPI=DIRPRD(IRREPJ,IRREP)
        NVRTI=VRT2(IRREPI)
C
        IF(NVRTI.EQ.0.OR.NOCCJ.EQ.0.OR.NVRTJ.EQ.0) GO TO 90
        CALL XGEMM('T','N',NVRTJ,NOCCJ,NVRTI*DISSYW,ONEM,
     &              ICORE(I001+IOFFT*IINTFP),NUMSYT*NVRTI,
     &              ICORE(I002+IINTFP*IOFFW),DISSYW*NVRTI,ONE,
     &              W(IOFFS),NVRTJ)
90      CONTINUE
        IOFFT=IOFFT+NVRTI*NVRTJ*NUMSYT
        IOFFW=IOFFW+NVRTI*NOCCJ*DISSYW
        IOFFS=IOFFS+NVRTJ*NOCCJ
100    CONTINUE
      ELSE
       STOP 'W5AB'
      ENDIF
1000  CONTINUE
      RETURN
      END
