      SUBROUTINE SYMTR1(IRREP,NUM1,NUM2,DISSIZE,A,SCR1,SCR2,ISCR)
C
C  THIS ROUTINE TRANSPOSES THE LAST TWO INDICES OF A FOUR INDEX ARRAY
C  WITHIN ONE GIVEN IRREP :
C
C   A(I,J,K,L) --> A(I,J,L,K)    WITH G(K)*G(L) = IRREP
C
C  THE TRANPOSITION IS DONE IN PLACE AND REQUIRES ONLY THREE SCRATCH
C  VECTORS OF LENGTH DISSIZE
C
C  INPUT :  IRREP  ...   IRREP OF   G(K)*G(L)
C           NUM1   ....  POPULATION VECTOR FOR K
C           NUM2   ....  POPULATION VECTOR FOR L
C           DISSIZE ...  DISTRIBUTION SIZE
C           A      ....  HOLDS THE MATRIX A         
C           SCR1,SCR2,ISCR ... THREE SCRATCH ARRAYS OF SIZE DISSIZE
C
C  OUTPUT :  A     ....  TRANSPOSED MATRIX
C
CEND
C
C  WRITTEN IN JUNE/90   JG
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL ICONT
      INTEGER DISSIZE,DIRPRD
      DIMENSION A(DISSIZE,1),SCR1(1),SCR2(1),ISCR(2),NUM1(8),NUM2(8)
      COMMON /SYMINF/NSTART,NIRREP,IRREPA(255),IRREPB(255),
     &DIRPRD(8,8)
      DIMENSION IPI(8),IPJ(8)
C
      IPI(1)=0
      IPJ(1)=0          
      DO 10 IRREPJ=1,NIRREP-1
       IRREPI=DIRPRD(IRREP,IRREPJ)
       IPJ(IRREPJ+1)=IPJ(IRREPJ)+NUM2(IRREPJ)*NUM1(IRREPI)
       IPI(IRREPJ+1)=IPI(IRREPJ)+NUM1(IRREPJ)*NUM2(IRREPI)
10    CONTINUE
       
C
C  GET FIRST THE NEW ADDRESSES AND STORE THEM IN ISCR
C
      NTOTAL=0
      DO 20  IRREPJ=1,NIRREP
       NUMJ=NUM2(IRREPJ)
       IRREPI=DIRPRD(IRREP,IRREPJ)
       NUMI=NUM1(IRREPI)
        NTOTAL=NTOTAL+NUMI*NUMJ
        DO 15 J=1,NUMJ
        DO 15 I=1,NUMI
         IND1=IPJ(IRREPJ)+(J-1)*NUMI+I
         IND2=IPI(IRREPI)+(I-1)*NUMJ+J
         ISCR(IND1)=IND2
15      CONTINUE
20      CONTINUE
C
C  NOW TRANSPOSE
C
      DO 100 IJ=1,NTOTAL
       IF(ISCR(IJ).EQ.0) GO TO 100
       INDNEW2=IJ
       DO 2 L=1,DISSIZE
        SCR1(L)=A(L,IJ)    
2      CONTINUE
1      CONTINUE
       INDOLD1=INDNEW2
       INDNEW1=ISCR(INDOLD1) 
       ISCR(INDOLD1)=0
       ICONT=.FALSE.  
       IF(ISCR(INDNEW1).NE.0) THEN
        DO 3 L=1,DISSIZE
         SCR2(L)=A(L,INDNEW1)
3       CONTINUE
        ICONT=.TRUE.
       ENDIF
       DO 4 L=1,DISSIZE
        A(L,INDNEW1)=SCR1(L)
4      CONTINUE
       IF(.NOT.ICONT) GO TO 100
       INDOLD2=INDNEW1
       INDNEW2=ISCR(INDOLD2)
       ISCR(INDOLD2)=0
       ICONT=.FALSE. 
       IF(ISCR(INDNEW2).NE.0) THEN
        DO 5 L=1,DISSIZE
         SCR1(L)=A(L,INDNEW2)
5       CONTINUE
        ICONT=.TRUE.
       ENDIF
       DO 6 L=1,DISSIZE
        A(L,INDNEW2)=SCR2(L)
6      CONTINUE
       IF(ICONT) GO TO 1
100   CONTINUE
      RETURN
      END
