      SUBROUTINE T1T2AA1(ZT,Z,W,ZT1,Z1,T,POP,VRT,DISSYZ,DISSYW,NUMSYZ,
     &                   NUMSYW,NVRTSQ,LISTZ,LISTW,IRREP,TMP)
C
C PRIMITIVE CONTRACTION ROUTINE FOR T2<-T1
C
CEND
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER DISSYZ,DISSYW,DIRPRD,POP,VRT
      DIMENSION Z(DISSYZ,NUMSYZ),W(DISSYW,NUMSYW),T(1)
      DIMENSION ZT(NUMSYZ,NVRTSQ),Z1(DISSYZ,NUMSYZ),ZT1(NUMSYZ,DISSYZ)
      DIMENSION TMP(1),POP(8),VRT(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*NVRTSQ)
C
C   GET INTEGRALS <IJ//MA> FROM LISTW
C
C   TRANSPOSE THEM 
C
      IF(MIN(NUMSYW,DISSYW).EQ.0) RETURN
      CALL GETLST(W,1,NUMSYW,2,IRREP,LISTW)
      CALL SYMTR1(IRREP,POP,VRT,DISSYW,W,TMP,TMP(1+DISSYW),
     &            TMP(1+2*DISSYW))
C
C   PERFORM MULTIPLICATION
C
      JOFFW=1
      JOFFZ=1     
      IOFF=1
      DO 90 IRREPJ=1,NIRREP
C
       NOCCJ=POP(IRREPJ)
       NVRTJ=VRT(IRREPJ)
C
       IRREPI=DIRPRD(IRREPJ,IRREP)
C
       NVRTI=VRT(IRREPI)
C
C
C
       CALL XGEMM('N','T',DISSYW*NVRTI,NVRTJ,NOCCJ,ONE,W(1,JOFFW), 
     &            DISSYW*NVRTI,T(IOFF),NVRTJ,
     &            AZERO,ZT(1,JOFFZ),NUMSYZ*NVRTI)
C
       JOFFW=JOFFW+NVRTI*NOCCJ
       JOFFZ=JOFFZ+NVRTI*NVRTJ
       IOFF=IOFF+NVRTJ*NOCCJ
90    CONTINUE
C
      CALL ASSYM(IRREP,VRT,NUMSYZ,NUMSYZ,ZT1,ZT)
      CALL TRANSP(ZT1,Z,DISSYZ,NUMSYZ)
      CALL GETLST(Z1,1,NUMSYZ,1,IRREP,LISTZ)
      CALL VADD(Z1,Z1,Z,NUMSYZ*DISSYZ,ONE)
      CALL PUTLST(Z1,1,NUMSYZ,1,IRREP,LISTZ)
      RETURN
      END
