      SUBROUTINE T1T2AB1(ZT,Z1,W,Z,TA,TB,POP1,POP2,VRT1,VRT2,DISSYZ,
     &                   DISSYWA,DISSYWB,NUMSYZ,NUMSYWA,NUMSYWB,
     &                   NTASIZ,NTBSIZ,LISTZ,LISTWA,LISTWB,IRREP,
     &                   IUHF,TMP)
C
C PRIMITIVE CONTRACTION ROUTINE FOR T2<-T1
C
CEND
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER DISSYZ,DISSYWA,DISSYWB,DIRPRD,POP1,POP2,VRT1,VRT2
      DIMENSION Z(DISSYZ,NUMSYZ),W(DISSYWA,1),TA(NTASIZ)
      DIMENSION ZT(NUMSYZ,DISSYZ),Z1(DISSYZ,NUMSYZ),TB(NTBSIZ)
      DIMENSION TMP(1),POP1(8),POP2(8),VRT1(8),VRT2(8)
C
      COMMON /SYMINF/ NSTART,NIRREP,IRREPA(255),IRREPB(255),
     &                DIRPRD(8,8)
C
      DATA AZERO,ONE,ONEM /0.0D0,1.0D0,-1.0D0/
C
      CALL ZERO(ZT,NUMSYZ*DISSYZ)
C
C   GET INTEGRALS <Ij//Am> FROM (LISTWA1,LISTWA2)
C
C   NOTE IN THE RHF CASE WE GET ACTUALLY THE INTEGRALS <Ij//Ma>
C   WE TRANSPOSE THEM AND TRANSPOSE AS WELL THE RESULT
C
      IF(MIN(NUMSYWA,DISSYWA).NE.0) THEN
      CALL GETLST(W,1,NUMSYWA,2,IRREP,LISTWA)
      IF(IUHF.EQ.0) THEN
       CALL SYMTR1(IRREP,POP1,VRT2,DISSYWA,W,TMP,TMP(1+DISSYWA),
     &             TMP(1+2*DISSYWA))
      ENDIF
C
C   PERFORM MULTIPLICATION
C
      JOFFW=1
      JOFFZ=1     
      IOFF=1
      DO 90 IRREPJ=1,NIRREP
C
       NOCCJ=POP2(IRREPJ)
       NVRTJ=VRT2(IRREPJ)
C
       IRREPI=DIRPRD(IRREPJ,IRREP)
C
       NVRTI=VRT1(IRREPI)
C
       IF(NVRTI.EQ.0) GO TO 80 
C
       IF(NOCCJ.EQ.0) GO TO 80
C
       CALL XGEMM('N','T',DISSYWA*NVRTI,NVRTJ,NOCCJ,ONEM,W(1,JOFFW), 
     &            DISSYWA*NVRTI,TB(IOFF),NVRTJ,
     &            AZERO,ZT(1,JOFFZ),NUMSYZ*NVRTI)
C
       JOFFW=JOFFW+NVRTI*NOCCJ
80     CONTINUE
       JOFFZ=JOFFZ+NVRTI*NVRTJ
       IOFF=IOFF+NVRTJ*NOCCJ
90    CONTINUE
      ENDIF
C
      IF(IUHF.EQ.0) THEN
      IF(MIN(NUMSYWA,DISSYWA).EQ.0) RETURN
C
C   IN RHF THIS IS SIMPLY A TRANSPOSITION
C
       CALL SYMTRA(IRREP,VRT2,VRT1,NUMSYZ,ZT,Z)
       CALL TRANSP(Z,Z1,DISSYZ,NUMSYZ)
       CALL GETLST(Z,1,NUMSYZ,1,IRREP,LISTZ)
       CALL VADD(Z,Z,Z1,NUMSYZ*DISSYZ,ONE)
       CALL SYMTR1(IRREP,POP1,POP2,DISSYZ,Z1,TMP,TMP(1+DISSYZ),
     &            TMP(1+2*DISSYZ))
       CALL SYMTR3(IRREP,VRT1,VRT2,DISSYZ,NUMSYZ,Z1,TMP,
     &             TMP(1+NUMSYZ),TMP(1+2*NUMSYZ))
       CALL VADD(Z,Z,Z1,NUMSYZ*DISSYZ,ONE)
       CALL PUTLST(Z,1,NUMSYZ,1,IRREP,LISTZ)
    
      ELSE
       CALL SYMTR1(IRREP,VRT1,VRT2,NUMSYZ,ZT,TMP,TMP(1+NUMSYZ),
     &             TMP(1+2*NUMSYZ))
       IF(MIN(NUMSYWB,DISSYWB).NE.0) THEN
C
C   GET INTEGRALS <Ij//Mb> FROM (LISTWB1,LISTWB2)
C
      CALL GETLST(W,1,NUMSYWB,2,IRREP,LISTWB)
      CALL SYMTR1(IRREP,POP1,VRT2,DISSYWB,W,TMP,TMP(1+DISSYWB),
     &            TMP(1+2*DISSYWB))
C
       JOFFZ=1  
       JOFFW=1   
       IOFF=1
       DO 190 IRREPI=1,NIRREP
C
        NOCCI=POP1(IRREPI)
        NVRTI=VRT1(IRREPI)
C
C
        IRREPJ=DIRPRD(IRREPI,IRREP)
C
        NVRTJ=VRT2(IRREPJ)
C
C
        CALL XGEMM('N','T',DISSYWB*NVRTJ,NVRTI,NOCCI,ONEM,W(1,JOFFW), 
     &             NVRTJ*DISSYWB,TA(IOFF),NVRTI,
     &             ONE,ZT(1,JOFFZ),NVRTJ*NUMSYZ)
C
        JOFFZ=JOFFZ+NVRTJ*NVRTI
        JOFFW=JOFFW+NVRTJ*NOCCI
        IOFF=IOFF+NVRTI*NOCCI
190    CONTINUE
       ENDIF
       CALL SYMTRA(IRREP,VRT2,VRT1,NUMSYZ,ZT,Z)
       CALL TRANSP(Z,Z1,DISSYZ,NUMSYZ)
       CALL GETLST(Z,1,NUMSYZ,1,IRREP,LISTZ)
       CALL VADD(Z,Z,Z1,NUMSYZ*DISSYZ,ONE)
       CALL PUTLST(Z,1,NUMSYZ,1,IRREP,LISTZ)
       ENDIF
       RETURN
       END
