      SUBROUTINE SYMEXP3(IRREP,NUM2,NUM1,DIS,NUM,A,B)
C
C  THIS ROUTINE EXPANDS A COMPRESSED ARRAY T(IJ,AB) WITH I.LE.J  
C  TO THE FULL ARRAY USING THE SYMMETRY RELATION
C
C       T(IJ,AB) = T(JI,BA)
C
C  THIS ROUTINE IS USEFUL FOR THE LADDER PART IN THE RHF CASE
C
CEND
C
C  CODED JG JUNE/90
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER DIS,DIRPRD
      DIMENSION A(DIS,1),B(DIS,1),NUM1(8),NUM2(8)
      DIMENSION IPOLD(8),IPNEW(8)
C
      COMMON /SYMINF/NSTART,NIRREP,IRREPA(255),IRREPB(255),
     &DIRPRD(8,8)
C
      IND(J,I)=((J-1)*J)/2+I
C 
      DATA ZERO /0.0D0/
C
      CALL SYMTRA2(IRREP,NUM2,NUM2,DIS,NUM,A,B)
C
C     TAKE HERE CARE, IF WE ARE HANDLING IRREP=1 (TOTAL SYMMETRIC)
C     OR IRREP=1 (OTHERWISE)
C
      IF(IRREP.EQ.1) THEN
C
C     GET FIRST POINTERS FOR OLD AND NEW INDICES
C
       IPOLD(1)=0
       IPNEW(1)=0
       DO 10 IRREPJ=1,(NIRREP-1)
        IPOLD(IRREPJ+1)=IPOLD(IRREPJ)+(NUM1(IRREPJ)*(NUM1(IRREPJ)+1))/2
        IPNEW(IRREPJ+1)=IPNEW(IRREPJ)+NUM1(IRREPJ)**2
10     CONTINUE
C
C     NOW LOOP BACKWARDS FROM THE HIGHEST TO THE LOWEST IRREP
C
       DO 1 IRREPJ=NIRREP,1,-1
        NUMJ=NUM1(IRREPJ)
        IPO=IPOLD(IRREPJ)
        IPN=IPNEW(IRREPJ)
C
C     LOOP OVER ORBITALS, BUT ALSO IN BACKWARD ORDER
C
        DO 100 J=NUMJ,1,-1
         DO 100 I=J,1,-1
          IND1=IND(J,I)+IPO
          IND2=(J-1)*NUMJ+I+IPN
          DO 50 IAB=1,DIS
           A(IAB,IND2)=A(IAB,IND1)
50        CONTINUE
100     CONTINUE
C
C     EXPAND NOW THE ARRAY
C
       DO 300 I=2,NUMJ
        DO 300 J=1,I-1
         IND1=IND(I,J)+IPO
         IND2=(J-1)*NUMJ+I+IPN
         DO 250 IAB=1,DIS
          A(IAB,IND2)=B(IAB,IND1)
250      CONTINUE
300    CONTINUE
1      CONTINUE
C
      ELSE
C
C     FILL THE POINTERS OF THE OLD AND NEW ARRAY
C
      IPOLD(1)=0
      IPNEW(1)=0
      DO 1000 IRREPJ=1,NIRREP-1
       IRREPI=DIRPRD(IRREP,IRREPJ)
       NUMJ=NUM1(IRREPJ)
       NUMI=NUM1(IRREPI)
       IPNEW(IRREPJ+1)=IPNEW(IRREPJ)+NUMJ*NUMI
       IF(IRREPI.LT.IRREPJ) THEN
        IPOLD(IRREPJ+1)=IPOLD(IRREPJ)+NUMJ*NUMI
       ELSE
        IPOLD(IRREPJ+1)=IPOLD(IRREPJ)
       ENDIF
1000  CONTINUE
C
C     NOW COPY OLD ARRAYS TO NEW LOCATION
C
      DO 2000 IRREPJ=NIRREP,1,-1
       IRREPI=DIRPRD(IRREP,IRREPJ)
       NUMJ=NUM1(IRREPJ)
       NUMI=NUM1(IRREPI)
       IF(IRREPJ.GT.IRREPI) THEN
        IPN=IPNEW(IRREPJ)
        IPO=IPOLD(IRREPJ)
        DO  2100 IJ=NUMJ*NUMI,1,-1
        IPNN=IPN+IJ
        IPOO=IPO+IJ
         DO 2050 IAB=1,DIS
        A(IAB,IPNN)=A(IAB,IPOO)

2050     CONTINUE
2100    CONTINUE
       ELSE
        IPN=IPNEW(IRREPJ)
        IPO=IPOLD(IRREPI)
        DO 2200 J=1,NUMJ
         DO 2200 I=1,NUMI
          IND1=(I-1)*NUMJ+J+IPO
          IND2=(J-1)*NUMI+I+IPN
          DO 2150 IAB=1,DIS
           A(IAB,IND2)=B(IAB,IND1)
2150      CONTINUE
2200    CONTINUE
       ENDIF
2000  CONTINUE
      ENDIF
      RETURN
      END
