      SUBROUTINE T1T2AA2(Z,Z1,W,MAXSIZE,T,POP,VRT,DISSYZ,DISSYW,
     &                   NUMSYZ,NUMSYW,NOCCSQ,LISTZ,LISTW,IRREP,TMP)
C
C PRIMITIVE CONTRACTION ROUTINE FOR T2<-T1
C
CEND
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER DISSYZ,DISSYW,DISMAX,DISREAD,DISLEFT,DIRPRD,POP,VRT
      DIMENSION Z(DISSYZ,NOCCSQ),W(DISSYW,1),T(1),Z1(DISSYZ,NUMSYZ)
      DIMENSION TMP(1),POP(8),VRT(8),IPT(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
C     ZERO FIRST OUTPUT ARRAY (NECCESARY BECAUSE THIS IS NOT NECCESARILY
C     DONE IN THE MATRIX MULTIPLICATION
C
      CALL ZERO(Z,NOCCSQ*DISSYZ)
C
C     IF THERE ARE NO WA INTEGRALS THERE IS NOTHING TO DO
C
      IF(MIN(NUMSYW,DISSYW).EQ.0) RETURN
C
C  DETERMINE MAXIMUM NUMBER OF DISTRIBUTIONS WHICH CAN BE HELD IN CORE
C
      MAXDIS=MAXSIZE/DISSYW
C
C     DETERMINE ALGORITHM BY CHECKING MAXSIZE
C
      IF(MAXDIS.GE.NUMSYW) THEN
C
C   WE CAN DO EVERYTHING IN CORE
C
C   GET INTEGRALS <AB//EI> FROM LISTW
C
       CALL GETLST(W,1,NUMSYW,2,IRREP,LISTW)
       CALL SYMTR1(IRREP,VRT,POP,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
C
        IRREPI=DIRPRD(IRREPJ,IRREP)
C
        NOCCI=POP(IRREPI)
C  
C      NOTHING TO COMPUTE IF ANy Of THE OCCUPATIONS IS ZERO
C
C
         CALL XGEMM('N','N',DISSYW*NOCCI,NOCCJ,NVRTJ,ONEM,W(1,JOFFW), 
     &              DISSYW*NOCCI,T(IOFF),NVRTJ,
     &              ONE,Z(1,JOFFZ),DISSYZ*NOCCI)
C
C
C     UPDATE POINTERS
C
        IOFF=IOFF+NVRTJ*NOCCJ
        JOFFW=JOFFW+NVRTJ*NOCCI
        JOFFZ=JOFFZ+NOCCI*NOCCJ
C
90     CONTINUE
C
      ELSE
C
C    WE HAVE TO DO IT OUT OF CORE
C
C    CALCULATE FIRST OFFSETS FOR THE T1 AMPLITUDES
C
       IPT(1)=1
       DO 50 IRREPJ=1,NIRREP-1
        IRREPI=DIRPRD(IRREP,IRREPJ)
        IPT(IRREPJ+1)=IPT(IRREPJ)+POP(IRREPJ)*VRT(IRREPJ)
50     CONTINUE
C
C  SET OFFSETS FOR INTEGRAL LIST AND FOR Z ARRAY
C
       IOFFSET=1
       IOFFZ=1
C
C  LOOP OVER 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  GET MAXIMUM NUMBER OF (A<B,E) BLOCKS WHICH CAN BE HELD IN CORE
C
         DISMAX=MAXDIS/NVRTI
         IF(DISMAX.LE.0) STOP 'T1T2AA2'
C
C  DETERMINE NUMBER OF (A<B,E) BLOCKS WHICH MUST BE READ
C
         DISLEFT=NOCCJ
C
10       CONTINUE 
C
C  GET NUMBER OF (A<B,E) 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(W,IOFFSET,DISREAD*NVRTI,2,IRREP,LISTW) 
C
C  UPDATE IOFFSET
C
          IOFFSET=IOFFSET+DISREAD*NVRTI
C
C  LOOP OVER ALL DISTRIBUTIONS AND PERFOM MULTIPLICATION
C
          IOFFW=1
          IOFFT1=IPT(IRREPI)
C
          DO 250 NUM=1,DISREAD
C
           CALL XGEMM('N','N',DISSYW,NOCCI,NVRTI,ONE,W(1,IOFFW),
     &                DISSYW,T(IOFFT1),NVRTI,ONE,Z(1,IOFFZ),DISSYZ)
C
C  UPDATE OFFSETS
C
           IOFFW=IOFFW+NVRTI
           IOFFZ=IOFFZ+NOCCI
C
250       CONTINUE
C
C   IF NOT ALL (A<B,E) 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
         IOFFZ=IOFFZ+NOCCI*NOCCJ
         IOFFSET=IOFFSET+NOCCJ*NVRTI
        ENDIF
C
200    CONTINUE
      ENDIF
C
C  ANTISYMMETRIZE THE Z(IJ,AB) ARRAY IN ORDER TO GET THE
C  T2 INCREMENTS
C
      CALL ASSYM(IRREP,POP,DISSYZ,DISSYZ,Z1,Z)
C
C  UPDATE THE T2 INCREMENTS ON DISK
C
      CALL GETLST(Z,1,NUMSYZ,1,IRREP,LISTZ)
      CALL VADD(Z,Z,Z1,NUMSYZ*DISSYZ,ONE)
      CALL PUTLST(Z,1,NUMSYZ,1,IRREP,LISTZ)
C   
      RETURN
      END
