      SUBROUTINE T1T2AB2(Z,Z1,W,MAXSIZE,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,DISMAX,DISLEFT,DISREAD,
     &        DIRPRD,POP1,POP2,VRT1,VRT2
      COMMON/MACHSP/IINTLN,IFLTLN,IINTFP,IALONE,IBITWD
      DIMENSION Z(DISSYZ,NUMSYZ),W(DISSYWA,1),TA(NTASIZ)
      DIMENSION Z1(DISSYZ,NUMSYZ),TB(NTBSIZ),IPT(8)
      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
C     ZERO FIRST OUTPUT ARRAY (NECCESARY BECAUSE THIS IS NOT NECCESARILY
C     DONE IN THE MATRIX MULTIPLICATION
C
      if (NUMSYZ*DISSYZ.LT.0) call trap_intovf('T1T2AB2',1)
      CALL ZERO(Z,NUMSYZ*DISSYZ)
C
C     IF THERE ARE NO WA INTEGRALS THERE IS NOTHING TO DO
C
      IF(MIN(NUMSYWA,DISSYWA).NE.0) THEN
C
C  DETERMINE MAXIMUM NUMBER OF DISTRIBUTIONS WHICH CAN BE HELD IN CORE
C
      MAXDIS=MAXSIZE/DISSYWA
C
C     DETERMINE ALGORITHM BY CHECKING MAXSIZE
C
      IF(MAXDIS.GE.NUMSYWA) THEN
C
C   WE CAN DO EVERYTHING IN CORE
C
C   GET INTEGRALS <Ab//Ei> FROM LISTWA 
C
       CALL GETLST(W,1,NUMSYWA,2,IRREP,LISTWA)
       CALL SYMTR1(IRREP,VRT1,POP2,DISSYWA,W,TMP,TMP(1+DISSYWA),
     &             TMP(1+2*DISSYWA))
C
C   PERFORM MULTIPLICATION
C
      JOFFW=1
      JOFFZ=1     
      IOFF=1
      DO 90 IRREPJ=1,NIRREP
C
       NOCCJ=POP1(IRREPJ)
       NVRTJ=VRT1(IRREPJ)
C
       IRREPI=DIRPRD(IRREPJ,IRREP)
C
       NOCCI=POP2(IRREPI)
C  
C      NOTHING TO COMPUTE IF ANY OF THE OCCUPATIONS IS ZERO
C
C
        CALL XGEMM('N','N',DISSYWA*NOCCI,NOCCJ,NVRTJ,ONE,W(1,JOFFW), 
     &             DISSYWA*NOCCI,TA(IOFF),NVRTJ,
     &             ONE,Z(1,JOFFZ),DISSYZ*NOCCI)
C
C     UPDATE POINTERS
C
       IOFF=IOFF+NVRTJ*NOCCJ
       JOFFW=JOFFW+NVRTJ*NOCCI
       JOFFZ=JOFFZ+NOCCI*NOCCJ
90    CONTINUE
C
      IF(IUHF.EQ.0) THEN
       CALL SYMTRA(IRREP,POP2,POP1,DISSYZ,Z,Z1)
      ELSE
       CALL SYMTR1(IRREP,POP2,POP1,DISSYZ,Z,TMP,TMP(1+DISSYZ),
     &             TMP(1+2*DISSYZ))
      ENDIF
      ELSE
C
C    WE HAVE TO DO IT OUT OF CORE
C
C    CALCULATE FIRST POINTERS FOR T1
C
       IPT(1)=1
       DO 50 IRREPJ=1,NIRREP-1
        IRREPI=DIRPRD(IRREP,IRREPJ)
        IPT(IRREPJ+1)=IPT(IRREPJ)+POP1(IRREPJ)*VRT1(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=POP2(IRREPJ)
        IRREPI=DIRPRD(IRREP,IRREPJ)
        NOCCI=POP1(IRREPI)
        NVRTI=VRT1(IRREPI)
        IF(MIN(NOCCI,NVRTI,NOCCJ).NE.0) THEN
C
C  GET MAXIMUM NUMBER OF (A,b,E) BLOCKS WHICH CAN BE HELD IN
C  CORE
C
        DISMAX=MAXDIS/NVRTI
        IF(DISMAX.LE.0) STOP 'T1T2AB2'
C
C  DETERMINE NUMBER OF (A,b,E) BLOCKS WHICH MUST BE READ
C
        DISLEFT=NOCCJ
C
10      CONTINUE
C
C  GET NUMBER OF (Ab,E) BLOCKS WHICH ARE READ IN DURING 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,LISTWA)
C
C  UPDATE IOFFSET
C
         IOFFSET=IOFFSET+DISREAD*NVRTI
C
C  LOOP OVER ALL DISTRIBUTIONS AND PERFORM MULTIPLICATION
C
         IOFFW=1
         IOFFT1=IPT(IRREPI)
C
         DO 250 NUM=1,DISREAD
C
          CALL XGEMM('N','N',DISSYWA,NOCCI,NVRTI,ONE,W(1,IOFFW),
     &               DISSYWA,TA(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 (Ab,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
c YAU : old
c      IF(IUHF.EQ.0) CALL ICOPY(NUMSYZ*DISSYZ*IINTFP,Z,1,Z1,1)
c YAU : new
       IF(IUHF.EQ.0) CALL DCOPY(NUMSYZ*DISSYZ,Z,1,Z1,1)
c YAU : end
      ENDIF
      ENDIF
C
C
      IF(IUHF.EQ.0) THEN
C
C      RHF CASE :
C
C     WE HAVE NOTHING DONE, SO WE HAVE NOT TO UPDATE Z
C
      IF(MIN(NUMSYWA,DISSYWA).EQ.0) RETURN
C
C   IN RHF THIS IS SIMPLY A TRANSPOSITION
C
       CALL GETLST(Z,1,NUMSYZ,1,IRREP,LISTZ)
       CALL VADD(Z,Z,Z1,NUMSYZ*DISSYZ,ONE)
C
       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
C
C      IF THERE ARE NO INTEGRALS SKIP MULTIPLICATION
C
       IF(MIN(NUMSYWB,DISSYWB).NE.0) THEN
C
C  DETERMINE MAXIMUM NUMBER OF DISTRIBUTIONS WHICH CAN BE HELD IN CORE
C
       MAXDIS=MAXSIZE/DISSYWB
C
C    DECIDE ABOUT ALGORITHM
C
       IF(MAXDIS.GE.NUMSYWB) THEN
C
C  IN CORE ALGORITHM
C
C   GET INTEGRALS <Ab//Ie> FROM LISTWB1
C
     
        CALL GETLST(W,1,NUMSYWB,2,IRREP,LISTWB)
C
       JOFFW=1     
       JOFFZ=1
       IOFF=1
       DO 190 IRREPI=1,NIRREP
C
        NOCCI=POP2(IRREPI)
        NVRTI=VRT2(IRREPI)
C
        IRREPJ=DIRPRD(IRREPI,IRREP)
C
        NOCCJ=POP1(IRREPJ)
C
C    PERFORM  MULTIPLICATION
C
        CALL XGEMM('N','N',DISSYWB*NOCCJ,NOCCI,NVRTI,ONE,W(1,JOFFW), 
     &             NOCCJ*DISSYWB,TB(IOFF),NVRTI,
     &             ONE,Z(1,JOFFZ),NOCCJ*DISSYZ)
C
C  UPDATE OFFSETS
C
       IOFF=IOFF+NVRTI*NOCCI
       JOFFW=JOFFW+NVRTI*NOCCJ
       JOFFZ=JOFFZ+NOCCI*NOCCJ
190    CONTINUE
C
      ELSE
C
C  OUT OF CORE ALGORITHM
C
C  OFFSET FOR INTEGRAK LIST, T1 AMPLITUDES AND T2 INCREMENTS
C
       IOFFSET=1
       IOFFT1=1
       IOFFZ=1
C
C   LOOP OVER IRREPS OF THE LAST INDEX
C
       DO 300 IRREPJ=1,NIRREP 
C
        NOCCJ=POP2(IRREPJ)
        NVRTJ=VRT2(IRREPJ)
        IRREPI=DIRPRD(IRREP,IRREPJ)
        NOCCI=POP1(IRREPI)
        IF(MIN(NOCCI,NOCCJ,NVRTJ).NE.0) THEN
C 
C  DETERMINE THE NUMBER OF (Ab,I) BLOCKS WHICH CAN BE HELD IN
C  CORE
C
        DISMAX=MAXDIS/NOCCI
C
C  NUMBER OF (Ab,I) BLOCKS TO READ
C
        DISLEFT=NVRTJ
C
        IOFF=0
C
20      CONTINUE 
C
C  DETERMINE NUMBER OF (Ab,I) BLOCKS WHICH ARE PROCESSED IN THIS PASS
C
         DISREAD=MIN(DISLEFT,DISMAX)
         DISLEFT=DISLEFT-DISREAD
C
C  GET THE CONTRIBUTIONS FROM DISK
C
         CALL GETLST(W,IOFFSET,DISREAD*NOCCI,2,IRREP,LISTWB)
C
C   UPDATE OFFSET
C 
         IOFFSET=IOFFSET+DISREAD*NOCCI
C
C    PERFORM MULTIPLICATION
C
         CALL XGEMM('N','N',DISSYWB*NOCCI,NOCCJ,DISREAD,ONE,
     &              W,DISSYWB*NOCCI,TB(IOFFT1+IOFF),NVRTJ,
     &              ONE,Z(1,IOFFZ),DISSYZ*NOCCI)
C
         IOFF=IOFF+DISREAD
C
C   IF NOT ALL (Ab,I) BLOCKS HAVE BEEN PROCESSES, 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+NOCCI*NVRTJ
       IOFFZ=IOFFZ+NOCCJ*NOCCI
300   CONTINUE
      ENDIF
      ENDIF
      CALL GETLST(Z1,1,NUMSYZ,2,IRREP,LISTZ)
      CALL VADD(Z1,Z1,Z,NUMSYZ*DISSYZ,ONE)
      CALL PUTLST(Z1,1,NUMSYZ,2,IRREP,LISTZ)
      ENDIF
      RETURN
      END
