C  1 JUN 05 - MWS - USE CC(T)MATMUL(T) MATRIX MULTIPLY NAMES ONLY
C 30 APR 05 - SK,KK - AUXILIARY ROUTINES FOR CC NON-ITERATIVE QUADRUPLES
C
C*MODULE CCQAUX  *DECK WW
      SUBROUTINE WW(NF,IR,N,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N)
      WRITE(NF,REC=IR)A
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RR
      SUBROUTINE RR(NF,IR,N,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N)
      READ(NF,REC=IR)A
      RETURN
      END
C
C*MODULE CCQAUX  *DECK WWP
      SUBROUTINE WWP(NFILE,N,IRC,V)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION V(N)
      COMMON/BUFORV/BUF(341),IBUF(341),IIIII
      DATA TR/0.1D-13/
      IN=0
      NR=0
      IREC=IRC
      DO 10 I=1,N
         X=V(I)
         IF (ABS(X).GT.TR) THEN
            IN=IN+1
            BUF(IN)=X
            IBUF(IN)=I
         ENDIF
         IF (IN.EQ.341) THEN
            NR=NR+1
            WRITE(NFILE,REC=IREC)BUF,IBUF,IN
            IN=0
            IREC=IREC+1
         ENDIF
 10   CONTINUE
      WRITE(NFILE,REC=IREC)BUF,IBUF,IN
      IRC=NR+1
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RDVV
      SUBROUTINE RDVV(NFILE,N,IFST,V)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/BUFORV/BUF(341),IBUF(341),IIIII
      DIMENSION V(1)
      CALL ZEROMA(V,1,N)
      IRE=1
 10   CONTINUE
         IREC=IFST+IRE-1
         READ(NFILE,REC=IREC)BUF,IBUF,IN
         DO 41 II=1,IN
            K=IBUF(II)
            V(K)=BUF(II)
 41      CONTINUE
         IRE=IRE+1
         IF(IN.EQ.341)GOTO 10
         IFST=IREC+1
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RO2NN
      SUBROUTINE RO2NN(NR,NO,NU,T2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T2(NO,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      READ(NT2,REC=NR) T2
      RETURN
      END
C
C*MODULE CCQAUX  *DECK MTRA1Q
      SUBROUTINE MTRA1Q(V,NU,IDENT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      LOGICAL AEB,AEC,AED,BEC,BED,CED,ACD,ABD
      DIMENSION V(1)
      NU2=NU*NU
      NU3=NU2*NU
      GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     *22,23),IDENT
    1 CONTINUE
      DO 100 J=1,NU
         J1=(J-1)*NU
         DO 101 K=1,NU
            K0=K-1
            K2=K0*NU2
            K3=K0*NU3
            DO 102 L=1,K
               L0=L-1
               JKL=J1+K2+L0*NU3
               JLK=J1+K3+L0*NU2
               DO 103 I=1,NU
                  IJKL=JKL+I
                  IJLK=JLK+I
                  X=V(IJKL)
                  V(IJKL)=V(IJLK)
                  V(IJLK)=X
 103           CONTINUE
 102        CONTINUE
 101     CONTINUE
 100  CONTINUE
      GO TO 1000
 2    CONTINUE
      DO 120 B=1,NU
         IB=B-1
         IB1=IB*NU
         IB2=IB*NU2
         IB3=IB*NU3
         DO 121 C=1,B
            BEC=B.EQ.C
            IC=C-1
            IC1=IC*NU
            IC2=IC*NU2
            IC3=IC*NU3
            DO 122 D=1,C
               CED=C.EQ.D
               ID=D-1
               ID1=ID*NU
               ID2=ID*NU2
               ID3=ID*NU3
               IDBC=ID1+IB2+IC3
               IBCD=IB1+IC2+ID3
               ICDB=IC1+ID2+IB3
               IF(BEC.OR.CED)GOTO 124
               IBDC=IB1+ID2+IC3
               IDCB=ID1+IC2+IB3
               ICBD=IC1+IB2+ID3
 124           CONTINUE
               DO 123 A=1,NU
                  IADBC=IDBC+A
                  IABCD=IBCD+A
                  IACDB=ICDB+A
                  X=V(IADBC)
                  V(IADBC)=V(IABCD)
                  V(IABCD)=V(IACDB)
                  V(IACDB)=X
                  IF(BEC.OR.CED)GO TO 123
                  IABDC=A+IBDC
                  IADCB=A+IDCB
                  IACBD=A+ICBD
                  X=V(IABDC)
                  V(IABDC)=V(IADCB)
                  V(IADCB)=V(IACBD)
                  V(IACBD)=X
 123           CONTINUE
 122        CONTINUE
 121     CONTINUE
 120  CONTINUE
      GO TO 1000
    3 CONTINUE
      DO 300 B=1,NU
         IB=B-1
         IB1=IB*NU
         IB2=IB*NU2
         IB3=IB*NU3
         DO 301 C=1,B
            IC=C-1
            IC1=IC*NU
            IC2=IC*NU2
            IC3=IC*NU3
            DO 302 D=1,C
               ID=D-1
               ID1=ID*NU
               ID2=ID*NU2
               ID3=ID*NU3
               ICDB=IC1+ID2+IB3
               IBCD=IB1+IC2+ID3
               IDBC=ID1+IB2+IC3
               IF(B.NE.C.AND.C.NE.D) THEN
                  IBDC=IB1+ID2+IC3
                  ICBD=IC1+IB2+ID3
                  IDCB=ID1+IC2+IB3
               ENDIF
               DO 303 A=1,NU
                  IACDB=A+ICDB
                  IABCD=A+IBCD
                  IADBC=A+IDBC
                  X=V(IACDB)
                  V(IACDB)=V(IABCD)
                  V(IABCD)=V(IADBC)
                  V(IADBC)=X
                  IF (B.EQ.C.OR.C.EQ.D)GO TO 303
                  IABDC=A+IBDC
                  IACBD=A+ICBD
                  IADCB=A+IDCB
                  X=V(IABDC)
                  V(IABDC)=V(IACBD)
                  V(IACBD)=V(IADCB)
                  V(IADCB)=X
 303           CONTINUE
 302        CONTINUE
 301     CONTINUE
 300  CONTINUE
      GO TO 1000
    4 CONTINUE
      DO 400 A=1,NU
         IA=A-1
         IA1=IA*NU
         IA2=IA*NU2
         IA3=IA*NU3
         DO 401 B=1,A
            AEB=A.EQ.B
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            IB3=IB*NU3
            DO 402 C=1,A
               AEC=A.EQ.C
               IC=C-1
               IC1=IC*NU
               IC2=IC*NU2
               IC3=IC*NU3
               ICAB=IC1+IA2+IB3
               IABC=A  +IB1+IC2
               ICBA=C  +IB2+IA3
               IBAC=B  +IA1+IC3
               LC=C
               IF (AEC)LC=B
               ID1=-NU
               ID2=-NU2
               ID3=-NU3
               DO 403 D=1,LC
                  CED=C.EQ.D
                  BED=B.EQ.D
C                  ID=D-1
C                  ID1=ID*NU
C                  ID2=ID*NU2
C                  ID3=ID*NU3
                  ID1=ID1+NU
                  ID2=ID2+NU2
                  ID3=ID3+NU3
                  IDCAB=D   +ICAB
                  IABCD=IABC+ID3
                  ICDBA=ICBA+ID1
                  IBADC=IBAC+ID2
                  X=V(IDCAB)
                  V(IDCAB)=V(IABCD)
                  V(IABCD)=V(ICDBA)
                  V(ICDBA)=V(IBADC)
                  V(IBADC)=X
                  IF (CED.OR.AEC.AND.BED.OR.AEB)GO TO 403
                  ICDAB=C+ID1+IA2+IB3
                  IABDC=A+IB1+ID2+IC3
                  IDCBA=D+IC1+IB2+IA3
                  IBACD=B+IA1+IC2+ID3
                  X=V(ICDAB)
                  V(ICDAB)=V(IABDC)
                  V(IABDC)=V(IDCBA)
                  V(IDCBA)=V(IBACD)
                  V(IBACD)=X
 403           CONTINUE
 402        CONTINUE
 401     CONTINUE
 400  CONTINUE
      GO TO 1000
    5 CONTINUE
      DO 500 A=1,NU
         IA=A-1
         IA2=IA*NU2
         IA3=IA*NU3
         DO 501 C=1,A
            AEC=A.EQ.C
            IC=C-1
            IC2=IC*NU2
            IC3=IC*NU3
            DO 502 D=1,C
               ACD=AEC.OR.C.EQ.D
               ID=D-1
               ID2=ID*NU2
               ID3=ID*NU3
               ICDA=C+ID2+IA3
               IACD=A+IC2+ID3
               IDAC=D+IA2+IC3
               IF(ACD)GOTO 504
               IADC=A+ID2+IC3
               ICAD=C+IA2+ID3
               IDCA=D+IC2+IA3
 504           CONTINUE
               IB1=-NU
              DO 503 B=1,NU
                  IB1=IB1+NU
C                  IB=B-1
C                  IB1=IB*NU
                  ICBDA=IB1+ICDA
                  IABCD=IB1+IACD
                  IDBAC=IB1+IDAC
                  X=V(ICBDA)
                  V(ICBDA)=V(IABCD)
                  V(IABCD)=V(IDBAC)
                  V(IDBAC)=X
                  IF (ACD)GO TO 503
                  IABDC=IB1+IADC
                  ICBAD=IB1+ICAD
                  IDBCA=IB1+IDCA
                  X=V(IABDC)
                  V(IABDC)=V(ICBAD)
                  V(ICBAD)=V(IDBCA)
                  V(IDBCA)=X
 503           CONTINUE
 502        CONTINUE
 501     CONTINUE
 500  CONTINUE
      GO TO 1000
 6    CONTINUE
      DO 600 D=1,NU
         ID=D-1
         ID3=ID*NU3
         DO 601 C=1,NU
            IC=C-1
            IC2=IC*NU2
            DO 602 A=1,NU
               IA=A-1
               IA1=IA*NU
               IACD =IA1+IC2+ID3
               IACD_=A+IC2+ID3
               IB1=-NU
               IB2=-NU2
               IB3=-NU3
               DO 603 B=1,A
                  IB1=IB1+NU
                  IB2=IB2+NU2
                  IB3=IB3+NU3
C                  IB=B-1
C                  IB1=IB*NU
C                  IB2=IB*NU2
C                  IB3=IB*NU3
                  IBACD=B  +IACD
                  IABCD=IB1+IACD_
                  X=V(IBACD)
                  V(IBACD)=V(IABCD)
                  V(IABCD)=X
 603           CONTINUE
 602        CONTINUE
 601     CONTINUE
 600  CONTINUE
      GO TO 1000
    7 CONTINUE
      DO 700 D=1,NU
         ID=D-1
         ID3=ID*NU3
         DO 701 B=1,NU
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            DO 702 C=1,B
               IC=C-1
               IC1=IC*NU
               IC2=IC*NU2
               IBCD=IB1+IC2+ID3
               ICBD=IC1+IB2+ID3
               DO 703 A=1,NU
                  IABCD=A+IBCD
                  IACBD=A+ICBD
                  X=V(IABCD)
                  V(IABCD)=V(IACBD)
                  V(IACBD)=X
 703           CONTINUE
 702        CONTINUE
 701     CONTINUE
 700  CONTINUE
      GO TO 1000
 8    CONTINUE
      DO 800 D=1,NU
         ID=D-1
         ID3=ID*NU3
         DO 801 B=1,NU
            IB=B-1
            IB1=IB*NU
            DO 802 A=1,NU
               IA=A-1
               IA2=IA*NU2
               IABD=A  +IB1+ID3
               IBAD=IB1+IA2+ID3
               IC2=-NU2
               DO 803 C=1,A
C                  IC=C-1
C                  IC2=IC*NU2
                  IC2=IC2+NU2
                  IABCD=IABD+IC2
                  ICBAD=C   +IBAD
                  X=V(IABCD)
                  V(IABCD)=V(ICBAD)
                  V(ICBAD)=X
 803           CONTINUE
 802        CONTINUE
 801     CONTINUE
 800  CONTINUE
      GO TO 1000
    9 CONTINUE
      DO 900 A=1,NU2
         IA=A-1
         IA2=IA*NU2
         IB2=-NU2
         DO 901 B=1,A
            IB2=IB2+NU2
C            IB=B-1
C            IB2=IB*NU2
            IAB=A+IB2
            IBA=B+IA2
            X=V(IAB)
            V(IAB)=V(IBA)
            V(IBA)=X
 901     CONTINUE
 900  CONTINUE
      GO TO 1000
 10   CONTINUE
      DO 950 B=1,NU
         IB=B-1
         IB1=IB*NU
         IB3=IB*NU3
         DO 951 D=1,B
            ID=D-1
            ID1=ID*NU
            ID3=ID*NU3
            DO 952 C=1,NU
               IC=C-1
               IC2=IC*NU2
               IBCD=IB1+IC2+ID3
               IDCB=ID1+IC2+IB3
               DO 953 A=1,NU
                  IABCD=A+IBCD
                  IADCB=A+IDCB
                  X=V(IABCD)
                  V(IABCD)=V(IADCB)
                  V(IADCB)=X
 953           CONTINUE
 952        CONTINUE
 951     CONTINUE
 950  CONTINUE
      GOTO 1000
 11   CONTINUE
      DO 960 A=1,NU
         IA=A-1
         IA3=IA*NU3
         DO 961 D=1,A
            ID=D-1
            ID3=ID*NU3
            IC2=-NU2
            IAD=A+ID3
            IDA=D+IA3
            DO 962 C=1,NU
C               IC2=N2(C)
               IC2=IC2+NU2
C               IC=C-1
C               IC2=IC*NU2
               IACD=IC2+IAD
               IDCA=IC2+IDA
               IB1=-NU
               DO 963 B=1,NU
                  IB1=IB1+NU
C                  IB1=N1(B)
                  IABCD=IB1+IACD
                  IDBCA=IB1+IDCA
                  X=V(IABCD)
                  V(IABCD)=V(IDBCA)
                  V(IDBCA)=X
 963           CONTINUE
 962        CONTINUE
 961     CONTINUE
 960  CONTINUE
      GOTO 1000
 12   CONTINUE
      CALL TRANMD(V,NU,NU,NU,NU,231)
      GOTO 1000
 13   CONTINUE
      CALL TRANMD(V,NU,NU,NU,NU,312)
      GOTO 1000
 14   CONTINUE
      DO 970 A=1,NU
         IA=A-1
         IA2=IA*NU2
         IA3=IA*NU3
         DO 971 C=1,A
            AEC=A.EQ.C
            IC=C-1
            IC2=IC*NU2
            IC3=IC*NU3
            DO 972 D=1,C
               ID=D-1
               ID2=ID*NU2
               ID3=ID*NU3
               ACD=AEC.OR.C.EQ.D
               IDAC=D+IA2+IC3
               IACD=A+IC2+ID3
               ICDA=C+ID2+IA3
               IF (ACD)GOTO 974
               IDCA=D+IC2+IA3
               ICAD=C+IA2+ID3
               IADC=A+ID2+IC3
 974           CONTINUE
               IB1=-NU
               DO 973 B=1,NU
                  IB1=IB1+NU
C                  IB=B-1
C                  IB1=IB*NU
                  IDBAC=IB1+IDAC
                  IABCD=IB1+IACD
                  ICBDA=IB1+ICDA
                  X=V(IDBAC)
                  V(IDBAC)=V(IABCD)
                  V(IABCD)=V(ICBDA)
                  V(ICBDA)=X
                  IF (ACD)GO TO 973
                  IDBCA=IB1+IDCA
                  ICBAD=IB1+ICAD
                  IABDC=IB1+IADC
                  X=V(IDBCA)
                  V(IDBCA)=V(ICBAD)
                  V(ICBAD)=V(IABDC)
                  V(IABDC)=X
 973           CONTINUE
 972        CONTINUE
 971     CONTINUE
 970  CONTINUE
      GO TO 1000
 15   CONTINUE
      DO 980 A=1,NU
         IA=A-1
         IA1=IA*NU
         IA2=IA*NU2
         IA3=IA*NU3
         DO 981 B=1,A
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            IB3=IB*NU3
            AEB=A.EQ.B
            DO 982 D=1,B
               ID=D-1
               ID1=ID*NU
               ID2=ID*NU2
               ID3=ID*NU3
               IDAB=D+IA1+IB3
               IABD=A+IB1+ID3
               IBDA=B+ID1+IA3
               ABD=AEB.OR.B.EQ.D
               IF(ABD)GOTO 984
               IDBA=D+IB1+IA3
               IBAD=B+IA1+ID3
               IADB=A+ID1+IB3
 984           CONTINUE
               IC2=-NU2
               DO 983 C=1,NU
                  IC2=IC2+NU2
C                  IC=C-1
C                  IC2=IC*NU2
                  IDACB=IC2+IDAB
                  IABCD=IC2+IABD
                  IBDCA=IC2+IBDA
                  X=V(IDACB)
                  V(IDACB)=V(IABCD)
                  V(IABCD)=V(IBDCA)
                  V(IBDCA)=X
                  IF (ABD)GO TO 983
                  IDBCA=IC2+IDBA
                  IBACD=IC2+IBAD
                  IADCB=IC2+IADB
                  X=V(IDBCA)
                  V(IDBCA)=V(IBACD)
                  V(IBACD)=V(IADCB)
                  V(IADCB)=X
 983           CONTINUE
 982        CONTINUE
 981     CONTINUE
 980  CONTINUE
      GO TO 1000
 16   CONTINUE
      DO 990 A=1,NU
         IA=A-1
         IA1=IA*NU
         IA2=IA*NU2
         IA3=IA*NU3
         DO 991 B=1,A
            AEB=A.EQ.B
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            IB3=IB*NU3
            DO 992 D=1,B
               ABD=AEB.OR.B.EQ.D
               ID=D-1
               ID1=ID*NU
               ID2=ID*NU2
               ID3=ID*NU3
               IBDA=B+ID1+IA3
               IABD=A+IB1+ID3
               IDAB=D+IA1+IB3
               IF (ABD)GO TO 994
               IADB=A+ID1+IB3
               IBAD=B+IA1+ID3
               IDBA=D+IB1+IA3
 994           CONTINUE
               IC2=-NU2
               DO 993 C=1,NU
                  IC2=IC2+NU2
C                  IC=C-1
C                  IC2=IC*NU2
                  IBDCA=IC2+IBDA
                  IABCD=IC2+IABD
                  IDACB=IC2+IDAB
                  X=V(IBDCA)
                  V(IBDCA)=V(IABCD)
                  V(IABCD)=V(IDACB)
                  V(IDACB)=X
                  IF (ABD)GO TO 993
                  IADCB=IC2+IADB
                  IBACD=IC2+IBAD
                  IDBCA=IC2+IDBA
                  X=V(IADCB)
                  V(IADCB)=V(IBACD)
                  V(IBACD)=V(IDBCA)
                  V(IDBCA)=X
 993           CONTINUE
 992        CONTINUE
 991     CONTINUE
 990  CONTINUE
      GO TO 1000
 17   CONTINUE
      DO 170 A=1,NU
         IA=A-1
         IA1=IA*NU
         IA2=IA*NU2
         IA3=IA*NU3
         DO 171 B=1,A
            AEB=A.EQ.B
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            IB3=IB*NU3
            DO 172 C=1,A
               AEC=A.EQ.C
               IC=C-1
               IC1=IC*NU
               IC2=IC*NU2
               IC3=IC*NU3
               LD=C
               IF (AEC)LD=B
               IABC=A  +IB1+IC2
               ICAB=IC1+IA2+IB3
               IBAC=B  +IA1+IC3
               ICBA=C  +IB2+IA3
               IF (AEB)GO TO 174
               IABC_=A  +IB1+IC3
               ICAB_=C  +IA2+IB3
               IBAC_=B  +IA1+IC2
               ICBA_=IC1+IB2+IA3
 174           CONTINUE
               ID1=-NU
               ID2=-NU2
               ID3=-NU3
               DO 173 D=1,LD
                  CED=C.EQ.D
                  BED=B.EQ.D
                  ID1=ID1+NU
                  ID2=ID2+NU2
                  ID3=ID3+NU3
C                  ID=D-1
C                  ID1=ID*NU
C                  ID2=ID*NU2
C                  ID3=ID*NU3
                  IABCD=ID3+IABC
                  IDCAB=D  +ICAB
                  IBADC=ID2+IBAC
                  ICDBA=ID1+ICBA
                  X=V(IABCD)
                  V(IABCD)=V(IDCAB)
                  V(IDCAB)=V(IBADC)
                  V(IBADC)=V(ICDBA)
                  V(ICDBA)=X
                  IF (CED.OR.AEC.AND.BED.OR.AEB)GO TO 173
                  IABDC=ID2+IABC_
                  ICDAB=ID1+ICAB_
                  IBACD=ID3+IBAC_
                  IDCBA=D  +ICBA_
                  X=V(IABDC)
                  V(IABDC)=V(ICDAB)
                  V(ICDAB)=V(IBACD)
                  V(IBACD)=V(IDCBA)
                  V(IDCBA)=X
 173           CONTINUE
 172        CONTINUE
 171     CONTINUE
 170  CONTINUE
      GO TO 1000
 18   CONTINUE
      DO 180 A=1,NU
         IA=A-1
         IA3=IA*NU3
         DO 181 B=1,NU
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            DO 182 D=1,A
               ID=D-1
               ID3=ID*NU3
               IABD=A+IB1+ID3
               IDBA=D+IB2+IA3
               LC=NU
               IF (A.EQ.D)LC=B
               IC1=-NU
               IC2=-NU2
               DO 183 C=1,LC
                  IC1=IC1+NU
                  IC2=IC2+NU2
C                  IC=C-1
C                  IC1=IC*NU
C                  IC2=IC*NU2
                  IABCD=IC2+IABD
                  IDCBA=IC1+IDBA
                  X=V(IABCD)
                  V(IABCD)=V(IDCBA)
                  V(IDCBA)=X
 183           CONTINUE
 182        CONTINUE
 181     CONTINUE
 180  CONTINUE
      GO TO 1000
 19   CONTINUE
      DO 190 C=1,NU
         IC=C-1
         IC2=IC*NU2
         IC3=IC*NU3
         DO 191 D=1,C
            CED=C.EQ.D
            ID=D-1
            ID2=ID*NU2
            ID3=ID*NU3
            DO 192 A=1,NU
               IA=A-1
               IA1=IA*NU
               IACD=A  +IC2+ID3
               IADC=IA1+ID2+IC3
               IF(CED)GOTO 194
               IADC_=A  +ID2+IC3
               IACD_=IA1+IC2+ID3
 194           CONTINUE
               IB1=-NU
               DO 193 B=1,A
                  AEB=A.EQ.B
C                  IB=B-1
                  IB1=IB1+NU
C                  IB1=IB*NU
                  IABCD=IB1+IACD
                  IBADC=B  +IADC
                  X=V(IABCD)
                  V(IABCD)=V(IBADC)
                  V(IBADC)=X
                  IF(AEB.OR.CED)GOTO 193
                  IABDC=IB1+IADC_
                  IBACD=B  +IACD_
                  X=V(IABDC)
                  V(IABDC)=V(IBACD)
                  V(IBACD)=X
 193           CONTINUE
 192        CONTINUE
 191     CONTINUE
 190  CONTINUE
      GO TO 1000
 20   CONTINUE
      DO 200 A=1,NU
         IA=A-1
         IA1=IA*NU
         IA2=IA*NU2
         IA3=IA*NU3
         DO 201 B=1,A
            AEB=A.EQ.B
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            IB3=IB*NU3
            DO 202 C=1,A
               AEC=A.EQ.C
               IC=C-1
               IC1=IC*NU
               IC2=IC*NU2
               IC3=IC*NU3
               IABC =A  +IB1+IC2
               IBCA =B  +IC1+IA3
               ICAB =C  +IA2+IB3
               IABC_=IA1+IB2+IC3
               LD=B
               IF (A.EQ.B)LD=C
               IF(AEC)GOTO 204
               IACB=A  +IC2+IB3
               ICBA=IC1+IB2+IA3
               ICBA_=C +IB1+IA2
               IBAC =B +IA1+IC3
 204           CONTINUE
               ID1=-NU
               ID2=-NU2
               ID3=-NU3
               DO 203 D=1,LD
                  BED=B.EQ.D
                  CED=C.EQ.D
                  ID1=ID1+NU
                  ID2=ID2+NU2
                  ID3=ID3+NU3
C                  ID=D-1
C                  ID1=ID*NU
C                  ID2=ID*NU2
C                  ID3=ID*NU3
                  IABCD=ID3+IABC
                  IBCDA=ID2+IBCA
                  ICDAB=ID1+ICAB
                  IDABC=D  +IABC_
                  X=V(IABCD)
                  V(IABCD)=V(IBCDA)
                  V(IBCDA)=V(ICDAB)
                  V(ICDAB)=V(IDABC)
                  V(IDABC)=X
                  IF (BED.OR.AEB.AND.CED.OR.AEC)GO TO 203
                  IADCB=ID1+IACB
                  IDCBA=D  +ICBA
                  ICBAD=ID3+ICBA_
                  IBADC=ID2+IBAC
                  X=V(IADCB)
                  V(IADCB)=V(IDCBA)
                  V(IDCBA)=V(ICBAD)
                  V(ICBAD)=V(IBADC)
                  V(IBADC)=X
 203           CONTINUE
 202        CONTINUE
 201     CONTINUE
 200  CONTINUE
      GO TO 1000
 21   CONTINUE
      DO 210 A=1,NU
         IA=A-1
         IA1=IA*NU
         IA2=IA*NU2
         IA3=IA*NU3
         DO 211 B=1,A
            AEB=A.EQ.B
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            IB3=IB*NU3
            DO 212 C=1,A
               AEC=A.EQ.C
               IC=C-1
               IC1=IC*NU
               IC2=IC*NU2
               IC3=IC*NU3
               IABC =A  +IB1+IC2
               IABC_=IA1+IB2+IC3
               ICAB =C  +IA2+IB3
               IBCA =B  +IC1+IA3
               IF (AEC)GO TO 214
               IACB =A  +IC2+IB3
               IBAC =B  +IA1+IC3
               ICBA =C  +IB1+IA2
               ICBA_=IC1+IB2+IA3
 214           CONTINUE
               LD=B
               IF (AEB)LD=C
               ID1=-NU
               ID2=-NU2
               ID3=-NU3
               DO 213 D=1,LD
                  BED=B.EQ.D
                  CED=C.EQ.D
                  ID1=ID1+NU
                  ID2=ID2+NU2
                  ID3=ID3+NU3
C                  ID=D-1
C                  ID1=ID*NU
C                  ID2=ID*NU2
C                  ID3=ID*NU3
                  IABCD=ID3+IABC
                  IDABC=D  +IABC_
                  ICDAB=ID1+ICAB
                  IBCDA=ID2+IBCA
                  X=V(IABCD)
                  V(IABCD)=V(IDABC)
                  V(IDABC)=V(ICDAB)
                  V(ICDAB)=V(IBCDA)
                  V(IBCDA)=X
                  IF (BED.OR.AEB.AND.CED.OR.AEC)GO TO 213
                  IADCB=ID1+IACB
                  IBADC=ID2+IBAC
                  ICBAD=ID3+ICBA
                  IDCBA=D  +ICBA_
                  X=V(IADCB)
                  V(IADCB)=V(IBADC)
                  V(IBADC)=V(ICBAD)
                  V(ICBAD)=V(IDCBA)
                  V(IDCBA)=X
 213           CONTINUE
 212        CONTINUE
 211     CONTINUE
 210  CONTINUE
      GO TO 1000
 22   CONTINUE
      DO 220 A=1,NU
         IA=A-1
         IA1=IA*NU
         IA2=IA*NU2
         IA3=IA*NU3
         DO 221 B=1,A
            AEB=A.EQ.B
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            IB3=IB*NU3
            DO 222 D=1,A
               AED=A.EQ.D
               ID=D-1
               ID1=ID*NU
               ID2=ID*NU2
               ID3=ID*NU3
               IABD=A  +IB1+ID3
               IBDA=B  +ID1+IA2
               IDBA=D  +IB2+IA3
               IADB=IA1+ID2+IB3
               IF (AED)GO TO 224
               IABD_=A  +IB2+ID3
               IDAB =ID1+IA2+IB3
               IDBA_=D  +IB1+IA3
               IBAD =B  +IA1+ID2
 224           CONTINUE
               LC=B
               IF (AEB)LC=D
               IC1=-NU
               IC2=-NU2
               IC3=-NU3
               DO 223 C=1,LC
                  BEC=B.EQ.C
                  CED=C.EQ.D
                  IC1=IC1+NU
                  IC2=IC2+NU2
                  IC3=IC3+NU3
C                  IC=C-1
C                  IC1=IC*NU
C                  IC2=IC*NU2
C                  IC3=IC*NU3
                  IABCD=IC2+IABD
                  IBDAC=IC3+IBDA
                  IDCBA=IC1+IDBA
                  ICADB=C  +IADB
                  X=V(IABCD)
                  V(IABCD)=V(IBDAC)
                  V(IBDAC)=V(IDCBA)
                  V(IDCBA)=V(ICADB)
                  V(ICADB)=X
                  IF (BEC.OR.AEB.AND.CED.OR.AED)GO TO 223
                  IACBD=IC1+IABD_
                  ICDAB=C  +IDAB
                  IDBCA=IC2+IDBA_
                  IBADC=IC3+IBAD
                  X=V(IACBD)
                  V(IACBD)=V(ICDAB)
                  V(ICDAB)=V(IDBCA)
                  V(IDBCA)=V(IBADC)
                  V(IBADC)=X
 223           CONTINUE
 222        CONTINUE
 221     CONTINUE
 220  CONTINUE
      GO TO 1000
 23   CONTINUE
      DO 230 A=1,NU
         IA=A-1
         IA1=IA*NU
         IA2=IA*NU2
         IA3=IA*NU3
         DO 231 B=1,A
            AEB=A.EQ.B
            IB=B-1
            IB1=IB*NU
            IB2=IB*NU2
            IB3=IB*NU3
            DO 232 D=1,A
               AED=A.EQ.D
               ID=D-1
               ID1=ID*NU
               ID2=ID*NU2
               ID3=ID*NU3
               IABD=A  +IB1+ID3
               IADB=IA1+ID2+IB3
               IDBA=D  +IB2+IA3
               IBDA=B  +ID1+IA2
               IF (AED)GO TO 234
               IABD_=A  +IB2+ID3
               IBAD =B  +IA1+ID2
               IDBA_=D  +IB1+IA3
               IDAB =ID1+IA2+IB3
 234           CONTINUE
               LC=B
               IF (AEB)LC=D
               IC1=-NU
               IC2=-NU2
               IC3=-NU3
               DO 233 C=1,LC
                  BEC=B.EQ.C
                  CED=C.EQ.D
                  IC1=IC1+NU
                  IC2=IC2+NU2
                  IC3=IC3+NU3
C                  IC=C-1
C                  IC1=IC*NU
C                  IC2=IC*NU2
C                  IC3=IC*NU3
                  IABCD=IC2+IABD
                  ICADB=C  +IADB
                  IDCBA=IC1+IDBA
                  IBDAC=IC3+IBDA
                  X=V(IABCD)
                  V(IABCD)=V(ICADB)
                  V(ICADB)=V(IDCBA)
                  V(IDCBA)=V(IBDAC)
                  V(IBDAC)=X
                  IF (BEC.OR.AEB.AND.CED.OR.AED)GO TO 233
                  IACBD=IC1+IABD_
                  IBADC=IC3+IBAD
                  IDBCA=IC2+IDBA_
                  ICDAB=C  +IDAB
                  X=V(IACBD)
                  V(IACBD)=V(IBADC)
                  V(IBADC)=V(IDBCA)
                  V(IDBCA)=V(ICDAB)
                  V(ICDAB)=X
 233           CONTINUE
 232        CONTINUE
 231     CONTINUE
 230  CONTINUE
      GO TO 1000
 1000 CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK MTRANREC
      SUBROUTINE MTRANREC(V,NU,ID)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      DIMENSION V(NU,NU,NU,NU)
      GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     *22,23),ID
    1 CONTINUE
      DO 100 K=1,NU
      DO 100 L=1,K
      DO 100 J=1,NU
      DO 100 I=1,NU
      X=V(I,J,K,L)
      V(I,J,K,L)=V(I,J,L,K)
      V(I,J,L,K)=X
  100 CONTINUE
      GO TO 1000
    2 CONTINUE
      DO 200 B=1,NU
      DO 200 C=1,B
      DO 200 D=1,C
      DO 200 A=1,NU
      X=V(A,D,B,C)
      V(A,D,B,C)=V(A,B,C,D)
      V(A,B,C,D)=V(A,C,D,B)
      V(A,C,D,B)=X
      IF(B.EQ.C.OR.C.EQ.D)GO TO 200
      X=V(A,B,D,C)
      V(A,B,D,C)=V(A,D,C,B)
      V(A,D,C,B)=V(A,C,B,D)
      V(A,C,B,D)=X
  200 CONTINUE
      GO TO 1000
    3 CONTINUE
      DO 300 B=1,NU
      DO 300 C=1,B
      DO 300 D=1,C
      DO 300 A=1,NU
      X=V(A,C,D,B)
      V(A,C,D,B)=V(A,B,C,D)
      V(A,B,C,D)=V(A,D,B,C)
      V(A,D,B,C)=X
      IF (B.EQ.C.OR.C.EQ.D)GO TO 300
      X=V(A,B,D,C)
      V(A,B,D,C)=V(A,C,B,D)
      V(A,C,B,D)=V(A,D,C,B)
      V(A,D,C,B)=X
  300 CONTINUE
      GO TO 1000
    4 CONTINUE
        CALL MTRANSNEW(V,NU,3)
        CALL MTRANSNEW(V,NU,8)
        GOTO 1000
    5 CONTINUE
      DO 500 A=1,NU
      DO 500 C=1,A
      DO 500 D=1,C
      DO 500 B=1,NU
      X=V(C,B,D,A)
      V(C,B,D,A)=V(A,B,C,D)
      V(A,B,C,D)=V(D,B,A,C)
      V(D,B,A,C)=X
      IF (A.EQ.C.OR.C.EQ.D)GO TO 500
      X=V(A,B,D,C)
      V(A,B,D,C)=V(C,B,A,D)
      V(C,B,A,D)=V(D,B,C,A)
      V(D,B,C,A)=X
  500 CONTINUE
      GO TO 1000
    6 CONTINUE
      DO 600 D=1,NU
      DO 600 C=1,NU
      DO 600 A=1,NU
      DO 600 B=1,A
      X=V(B,A,C,D)
      V(B,A,C,D)=V(A,B,C,D)
      V(A,B,C,D)=X
  600 CONTINUE
C      DO 600 D=1,NU
C      DO 600 C=1,NU
C      CALL TRANSQ(V(1,1,C,D),NU)
C 600  CONTINUE
      GO TO 1000
    7 CONTINUE
      DO 700 D=1,NU
      DO 700 B=1,NU
      DO 700 C=1,B
      DO 700 A=1,NU
      X=V(A,B,C,D)
      V(A,B,C,D)=V(A,C,B,D)
      V(A,C,B,D)=X
  700 CONTINUE
      GO TO 1000
    8 CONTINUE
      DO 800 D=1,NU
      DO 800 B=1,NU
      DO 800 A=1,NU
      DO 800 C=1,A
      X=V(A,B,C,D)
      V(A,B,C,D)=V(C,B,A,D)
      V(C,B,A,D)=X
  800 CONTINUE
      GO TO 1000
    9 CONTINUE
C      DO 900 A=1,NU
CV      DO 900 B=1,NU
C      DO 900 C=1,A
C      LIMD=NU
C      IF (A.EQ.C)LIMD=B
C      DO 900 D=1,LIMD
C      X=V(A,B,C,D)
C      V(A,B,C,D)=V(C,D,A,B)
C      V(C,D,A,B)=X
C  900 CONTINUE
CCCX      NU2=NU*NU
C      CALL TRANSQ1(V,NU2)
      GO TO 1000
 10   CONTINUE
      DO 950 A=1,NU
      DO 950 B=1,NU
      DO 950 C=1,NU
      DO 950 D=1,B
      X=V(A,B,C,D)
      V(A,B,C,D)=V(A,D,C,B)
      V(A,D,C,B)=X
 950  CONTINUE
      GOTO 1000
 11   CONTINUE
      DO 960 A=1,NU
      DO 960 B=1,NU
      DO 960 C=1,NU
      DO 960 D=1,A
      X=V(A,B,C,D)
      V(A,B,C,D)=V(D,B,C,A)
      V(D,B,C,A)=X
 960  CONTINUE
      GOTO 1000
 12   CONTINUE
      CALL TRANMD(V,NU,NU,NU,NU,231)
      GOTO 1000
 13   CONTINUE
      CALL TRANMD(V,NU,NU,NU,NU,312)
      GOTO 1000
 14   CONTINUE
      DO 970 A=1,NU
      DO 970 B=1,NU
      DO 970 C=1,A
      DO 970 D=1,C
      X=V(D,B,A,C)
      V(D,B,A,C)=V(A,B,C,D)
      V(A,B,C,D)=V(C,B,D,A)
      V(C,B,D,A)=X
      IF (A.EQ.C.OR.C.EQ.D)GO TO 970
      X=V(D,B,C,A)
      V(D,B,C,A)=V(C,B,A,D)
      V(C,B,A,D)=V(A,B,D,C)
      V(A,B,D,C)=X
  970 CONTINUE
      GO TO 1000
 15   CONTINUE
      DO 980 A=1,NU
      DO 980 B=1,A
      DO 980 C=1,NU
      DO 980 D=1,B
      X=V(D,A,C,B)
      V(D,A,C,B)=V(A,B,C,D)
      V(A,B,C,D)=V(B,D,C,A)
      V(B,D,C,A)=X
      IF (A.EQ.B.OR.B.EQ.D)GO TO 980
      X=V(D,B,C,A)
      V(D,B,C,A)=V(B,A,C,D)
      V(B,A,C,D)=V(A,D,C,B)
      V(A,D,C,B)=X
 980  CONTINUE
      GO TO 1000
 16   CONTINUE
      DO 990 A=1,NU
      DO 990 B=1,A
      DO 990 C=1,NU
      DO 990 D=1,B
      X=V(B,D,C,A)
      V(B,D,C,A)=V(A,B,C,D)
      V(A,B,C,D)=V(D,A,C,B)
      V(D,A,C,B)=X
      IF (A.EQ.B.OR.B.EQ.D)GO TO 990
      X=V(A,D,C,B)
      V(A,D,C,B)=V(B,A,C,D)
      V(B,A,C,D)=V(D,B,C,A)
      V(D,B,C,A)=X
  990 CONTINUE
      GO TO 1000
 17   CONTINUE
      DO 991 A=1,NU
      DO 991 B=1,A
      DO 991 C=1,A
      LC=C
      IF (A.EQ.C)LC=B
      DO 991 D=1,LC
      X=V(A,B,C,D)
      V(A,B,C,D)=V(D,C,A,B)
      V(D,C,A,B)=V(B,A,D,C)
      V(B,A,D,C)=V(C,D,B,A)
      V(C,D,B,A)=X
      IF (C.EQ.D.OR.A.EQ.C.AND.B.EQ.D.OR.A.EQ.B)GO TO 991
      X=V(A,B,D,C)
      V(A,B,D,C)=V(C,D,A,B)
      V(C,D,A,B)=V(B,A,C,D)
      V(B,A,C,D)=V(D,C,B,A)
      V(D,C,B,A)=X
 991  CONTINUE
      GO TO 1000
 18   CONTINUE
      DO 992 A=1,NU
      DO 992 B=1,NU
      DO 992 D=1,A
      LC=NU
      IF (A.EQ.D)LC=B
      DO 992 C=1,LC
      X=V(A,B,C,D)
      V(A,B,C,D)=V(D,C,B,A)
      V(D,C,B,A)=X
 992  CONTINUE
      GO TO 1000
 19   CONTINUE
      DO 993 A=1,NU
C      WRITE(6,*)'A=',A
      DO 993 B=1,A
      DO 993 C=1,NU
      DO 993 D=1,C
      X=V(A,B,C,D)
      V(A,B,C,D)=V(B,A,D,C)
      V(B,A,D,C)=X
      IF(A.EQ.B.OR.C.EQ.D)GOTO 9993
      X=V(A,B,D,C)
      V(A,B,D,C)=V(B,A,C,D)
      V(B,A,C,D)=X
 9993 CONTINUE
C      WRITE(6,909)A,B,C,D,V(A,B,C,D),B,A,D,C,V(B,A,D,C)
 993  CONTINUE
CCCX 909  FORMAT('A,B,C,D,V:',4I3,I8,5X,4I3,I8)
      GO TO 1000
 20   CONTINUE
      DO 994 A=1,NU
      DO 994 B=1,A
      DO 994 C=1,A
      LD=B
      IF (A.EQ.B)LD=C
      DO 994 D=1,LD
      X=V(A,B,C,D)
      V(A,B,C,D)=V(B,C,D,A)
      V(B,C,D,A)=V(C,D,A,B)
      V(C,D,A,B)=V(D,A,B,C)
      V(D,A,B,C)=X
      IF (B.EQ.D.OR.A.EQ.B.AND.C.EQ.D.OR.A.EQ.C)GO TO 994
      X=V(A,D,C,B)
      V(A,D,C,B)=V(D,C,B,A)
      V(D,C,B,A)=V(C,B,A,D)
      V(C,B,A,D)=V(B,A,D,C)
      V(B,A,D,C)=X
 994  CONTINUE
      GO TO 1000
 21   CONTINUE
      DO 995 A=1,NU
      DO 995 B=1,A
      DO 995 C=1,A
      LD=B
      IF (A.EQ.B)LD=C
      DO 995 D=1,LD
      X=V(A,B,C,D)
      V(A,B,C,D)=V(D,A,B,C)
      V(D,A,B,C)=V(C,D,A,B)
      V(C,D,A,B)=V(B,C,D,A)
      V(B,C,D,A)=X
      IF (B.EQ.D.OR.A.EQ.B.AND.C.EQ.D.OR.A.EQ.C)GO TO 995
      X=V(A,D,C,B)
      V(A,D,C,B)=V(B,A,D,C)
      V(B,A,D,C)=V(C,B,A,D)
      V(C,B,A,D)=V(D,C,B,A)
      V(D,C,B,A)=X
 995  CONTINUE
      GO TO 1000
 22   CONTINUE
      DO 996 A=1,NU
      DO 996 B=1,A
      DO 996 D=1,A
      LC=B
      IF (A.EQ.B)LC=D
      DO 996 C=1,LC
      X=V(A,B,C,D)
      V(A,B,C,D)=V(B,D,A,C)
      V(B,D,A,C)=V(D,C,B,A)
      V(D,C,B,A)=V(C,A,D,B)
      V(C,A,D,B)=X
      IF (B.EQ.C.OR.A.EQ.B.AND.C.EQ.D.OR.A.EQ.D)GO TO 996
      X=V(A,C,B,D)
      V(A,C,B,D)=V(C,D,A,B)
      V(C,D,A,B)=V(D,B,C,A)
      V(D,B,C,A)=V(B,A,D,C)
      V(B,A,D,C)=X
 996  CONTINUE
      GO TO 1000
 23   CONTINUE
      DO 997 A=1,NU
      DO 997 B=1,A
      DO 997 D=1,A
      LC=B
      IF (A.EQ.B)LC=D
      DO 997 C=1,LC
      X=V(A,B,C,D)
      V(A,B,C,D)=V(C,A,D,B)
      V(C,A,D,B)=V(D,C,B,A)
      V(D,C,B,A)=V(B,D,A,C)
      V(B,D,A,C)=X
      IF (B.EQ.C.OR.A.EQ.B.AND.C.EQ.D.OR.A.EQ.D)GO TO 997
      X=V(A,C,B,D)
      V(A,C,B,D)=V(B,A,D,C)
      V(B,A,D,C)=V(D,B,C,A)
      V(D,B,C,A)=V(C,D,A,B)
      V(C,D,A,B)=X
 997  CONTINUE
      GO TO 1000
 1000 CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK MTRANSQ
      SUBROUTINE MTRANSQ(V,NU,ID)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      DIMENSION V(NU,NU,NU,NU)
      GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     *22,23),ID
    1 CONTINUE
      DO 100 K=1,NU
      DO 100 L=1,K
      DO 100 J=1,NU
      DO 100 I=1,NU
      X=V(I,J,K,L)
      V(I,J,K,L)=V(I,J,L,K)
      V(I,J,L,K)=X
  100 CONTINUE
      GO TO 1000
    2 CONTINUE
      DO 200 B=1,NU
      DO 200 C=1,B
      DO 200 D=1,C
      DO 200 A=1,NU
      X=V(A,D,B,C)
      V(A,D,B,C)=V(A,B,C,D)
      V(A,B,C,D)=V(A,C,D,B)
      V(A,C,D,B)=X
      IF(B.EQ.C.OR.C.EQ.D)GO TO 200
      X=V(A,B,D,C)
      V(A,B,D,C)=V(A,D,C,B)
      V(A,D,C,B)=V(A,C,B,D)
      V(A,C,B,D)=X
  200 CONTINUE
      GO TO 1000
    3 CONTINUE
      DO 300 B=1,NU
      DO 300 C=1,B
      DO 300 D=1,C
      DO 300 A=1,NU
      X=V(A,C,D,B)
      V(A,C,D,B)=V(A,B,C,D)
      V(A,B,C,D)=V(A,D,B,C)
      V(A,D,B,C)=X
      IF (B.EQ.C.OR.C.EQ.D)GO TO 300
      X=V(A,B,D,C)
      V(A,B,D,C)=V(A,C,B,D)
      V(A,C,B,D)=V(A,D,C,B)
      V(A,D,C,B)=X
  300 CONTINUE
      GO TO 1000
    4 CONTINUE
        CALL MTRANREC(V,NU,3)
        CALL MTRANREC(V,NU,8)
        GOTO 1000
    5 CONTINUE
        CALL MTRANREC(V,NU,8)
        CALL MTRANREC(V,NU,1)
        GOTO 1000
    6 CONTINUE
      DO 600 D=1,NU
      DO 600 C=1,NU
      DO 600 A=1,NU
      DO 600 B=1,A
      X=V(B,A,C,D)
      V(B,A,C,D)=V(A,B,C,D)
      V(A,B,C,D)=X
  600 CONTINUE
C      DO 600 D=1,NU
C      DO 600 C=1,NU
C      CALL TRANSQ(V(1,1,C,D),NU)
C 600  CONTINUE
      GO TO 1000
    7 CONTINUE
      DO 700 D=1,NU
      DO 700 B=1,NU
      DO 700 C=1,B
      DO 700 A=1,NU
      X=V(A,B,C,D)
      V(A,B,C,D)=V(A,C,B,D)
      V(A,C,B,D)=X
  700 CONTINUE
      GO TO 1000
    8 CONTINUE
      DO 800 D=1,NU
      DO 800 B=1,NU
      DO 800 A=1,NU
      DO 800 C=1,A
      X=V(A,B,C,D)
      V(A,B,C,D)=V(C,B,A,D)
      V(C,B,A,D)=X
  800 CONTINUE
      GO TO 1000
    9 CONTINUE
        CALL MTRA1Q(V,NU,10)
        CALL MTRANREC(V,NU,8)
        GOTO 1000
 10   CONTINUE
        CALL MTRA1Q(V,NU,10)
        GOTO 1000
 11   CONTINUE
        CALL MTRANREC(V,NU,1)
        CALL MTRANREC(V,NU,8)
        CALL MTRANREC(V,NU,1)
        GOTO 1000
 12   CONTINUE
        CALL MTRANREC(V,NU,7)
        CALL MTRANREC(V,NU,6)
        GOTO 1000
 13   CONTINUE
        CALL MTRANREC(V,NU,6)
        CALL MTRANREC(V,NU,7)
        GOTO 1000
 14   CONTINUE
        CALL MTRANREC(V,NU,1)
        CALL MTRANREC(V,NU,8)
      GO TO 1000
 15   CONTINUE
      CALL MTRA1Q(V,NU,10)
      CALL MTRANREC(V,NU,6)
      GO TO 1000
 16   CONTINUE
      CALL MTRANREC(V,NU,6)
      CALL MTRA1Q(V,NU,10)
      GO TO 1000
 17   CONTINUE
      CALL MTRANREC(V,NU,8)
      CALL MTRANREC(V,NU,2)
      GO TO 1000
 18   CONTINUE
        CALL MTRANREC(V,NU,1)
        CALL MTRANREC(V,NU,8)
        CALL MTRANREC(V,NU,2)
      GO TO 1000
 19   CONTINUE
        CALL MTRA1Q(V,NU,19)
        GOTO 1000
 20   CONTINUE
      CALL MTRANREC(V,NU,2)
      CALL MTRANREC(V,NU,6)
      GO TO 1000
 21   CONTINUE
      CALL MTRANREC(V,NU,6)
      CALL MTRANREC(V,NU,3)
      GO TO 1000
 22   CONTINUE
      CALL MTRANREC(V,NU,3)
      CALL MTRANREC(V,NU,6)
      GO TO 1000
 23   CONTINUE
      CALL MTRANREC(V,NU,2)
      CALL MTRANREC(V,NU,8)
      GO TO 1000
 1000 CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK MTRANSNEW
      SUBROUTINE MTRANSNEW(V,NU,ID)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      DIMENSION V(NU,NU,NU,NU)
      GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     *22,23),ID
    1 CONTINUE
      DO 100 K=1,NU
      DO 100 L=1,K
      DO 100 J=1,NU
      DO 100 I=1,NU
      X=V(I,J,K,L)
      V(I,J,K,L)=V(I,J,L,K)
      V(I,J,L,K)=X
  100 CONTINUE
      GO TO 1000
    2 CONTINUE
      DO 200 B=1,NU
      DO 200 C=1,B
      DO 200 D=1,C
      DO 200 A=1,NU
      X=V(A,D,B,C)
      V(A,D,B,C)=V(A,B,C,D)
      V(A,B,C,D)=V(A,C,D,B)
      V(A,C,D,B)=X
      IF(B.EQ.C.OR.C.EQ.D)GO TO 200
      X=V(A,B,D,C)
      V(A,B,D,C)=V(A,D,C,B)
      V(A,D,C,B)=V(A,C,B,D)
      V(A,C,B,D)=X
  200 CONTINUE
      GO TO 1000
    3 CONTINUE
      DO 300 B=1,NU
      DO 300 C=1,B
      DO 300 D=1,C
      DO 300 A=1,NU
      X=V(A,C,D,B)
      V(A,C,D,B)=V(A,B,C,D)
      V(A,B,C,D)=V(A,D,B,C)
      V(A,D,B,C)=X
      IF (B.EQ.C.OR.C.EQ.D)GO TO 300
      X=V(A,B,D,C)
      V(A,B,D,C)=V(A,C,B,D)
      V(A,C,B,D)=V(A,D,C,B)
      V(A,D,C,B)=X
  300 CONTINUE
      GO TO 1000
    4 CONTINUE
        CALL MTRANREC(V,NU,3)
        CALL MTRANREC(V,NU,8)
        GOTO 1000
    5 CONTINUE
        CALL MTRANREC(V,NU,8)
        CALL MTRANREC(V,NU,1)
        GOTO 1000
    6 CONTINUE
      DO 600 D=1,NU
      DO 600 C=1,NU
      DO 600 A=1,NU
      DO 600 B=1,A
      X=V(B,A,C,D)
      V(B,A,C,D)=V(A,B,C,D)
      V(A,B,C,D)=X
  600 CONTINUE
C      DO 600 D=1,NU
C      DO 600 C=1,NU
C      CALL TRANSQ(V(1,1,C,D),NU)
C 600  CONTINUE
      GO TO 1000
    7 CONTINUE
      DO 700 D=1,NU
      DO 700 B=1,NU
      DO 700 C=1,B
      DO 700 A=1,NU
      X=V(A,B,C,D)
      V(A,B,C,D)=V(A,C,B,D)
      V(A,C,B,D)=X
  700 CONTINUE
      GO TO 1000
    8 CONTINUE
      DO 800 D=1,NU
      DO 800 B=1,NU
      DO 800 A=1,NU
      DO 800 C=1,A
      X=V(A,B,C,D)
      V(A,B,C,D)=V(C,B,A,D)
      V(C,B,A,D)=X
  800 CONTINUE
      GO TO 1000
    9 CONTINUE
        CALL MTRA1Q(V,NU,10)
        CALL MTRANREC(V,NU,8)
        GOTO 1000
 10   CONTINUE
        CALL MTRA1Q(V,NU,10)
        GOTO 1000
 11   CONTINUE
        CALL MTRANREC(V,NU,1)
        CALL MTRANREC(V,NU,8)
        CALL MTRANREC(V,NU,1)
        GOTO 1000
 12   CONTINUE
        CALL MTRANREC(V,NU,7)
        CALL MTRANREC(V,NU,6)
        GOTO 1000
 13   CONTINUE
        CALL MTRANREC(V,NU,6)
        CALL MTRANREC(V,NU,7)
        GOTO 1000
 14   CONTINUE
        CALL MTRANREC(V,NU,1)
        CALL MTRANREC(V,NU,8)
      GO TO 1000
 15   CONTINUE
      CALL MTRA1Q(V,NU,10)
      CALL MTRANREC(V,NU,6)
      GO TO 1000
 16   CONTINUE
      CALL MTRANREC(V,NU,6)
      CALL MTRA1Q(V,NU,10)
      GO TO 1000
 17   CONTINUE
      CALL MTRANREC(V,NU,8)
      CALL MTRANREC(V,NU,2)
      GO TO 1000
 18   CONTINUE
        CALL MTRANREC(V,NU,1)
        CALL MTRANREC(V,NU,8)
        CALL MTRANREC(V,NU,2)
      GO TO 1000
 19   CONTINUE
        CALL MTRA1Q(V,NU,19)
        GOTO 1000
 20   CONTINUE
      CALL MTRANREC(V,NU,2)
      CALL MTRANREC(V,NU,6)
      GO TO 1000
 21   CONTINUE
      CALL MTRANREC(V,NU,6)
      CALL MTRANREC(V,NU,3)
      GO TO 1000
 22   CONTINUE
      CALL MTRANREC(V,NU,3)
      CALL MTRANREC(V,NU,6)
      GO TO 1000
 23   CONTINUE
      CALL MTRANREC(V,NU,2)
      CALL MTRANREC(V,NU,8)
      GO TO 1000
 1000 CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK PPEX
      SUBROUTINE PPEX(NU,TL,TK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TL(NU,NU,NU),TK(NU,NU,NU)
      DO 78 L=1,NU
      CALL RDVPPI(L,NU,TL)
      DO 77 K=1,L-1
      CALL RDVPPI(K,NU,TK)
      DO 76 I=1,NU
      DO 76 J=1,NU
      X=TL(I,J,K)
      TL(I,J,K)=TK(I,J,L)
      TK(I,J,L)=X
 76   CONTINUE
      CALL WRVPP(K,NU,TK)
 77   CONTINUE
      CALL WRVPP(L,NU,TL)
 78   CONTINUE
      RETURN
      END
C*MODULE CCQAUX  *DECK WRT3Q
      SUBROUTINE WRT3Q(KK,NO,NU,T3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T3(NU,NU,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      KKK=IT3(NO,NO,NO-1)+KK
      WRITE(NT3,REC=KKK) T3
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RINTHH
      SUBROUTINE RINTHH(IP,N,TI)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
CCCX      INTEGER A,B
      DIMENSION TI(N,N)
      IF(IP.EQ.1.OR.IP.EQ.2) THEN
         N2=N*N
         IR=IP
         CALL RDD(NHH,IR,N2,TI)
      ELSE
         DO 10 I=1,N
            IR=I+2+(IP-3)*N
         CALL RDD(NHH,IR,N,TI(1,I))
 10      CONTINUE
      ENDIF
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RINTPP
      SUBROUTINE RINTPP(IP,N,TI)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
CCCX      INTEGER A,B
      DIMENSION TI(N,N)
C      NPP=59
      N2=N*N
      IF(IP.EQ.1) THEN
         IR=1
         CALL RDD(NPP,IR,N2,TI)
      ELSE
         DO 10 I=1,N
            IR=I+1
         CALL RDD(NPP,IR,N,TI(1,I))
 10      CONTINUE
      ENDIF
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RINTVO
      SUBROUTINE RINTVO(IP,NO,NU,TI,T2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
      DIMENSION TI(NU,NU,NO),T2(NO,NU,NU,NO)
      DATA ZERO/0.0D+0/
      IVO=IABS(IP)
      NLAST=NO*(IVO-1)
      DO 1 I=1,NO
      IASV=NLAST+I
      READ(NTVOE,REC=IASV)TI
      DO 1 J=1,NO
      DO 1 A=1,NU
      DO 1 B=1,NU
         X=ZERO
         IF (IP.LT.0)X=T2(I,A,B,J)
      T2(I,A,B,J)=X+TI(A,B,J)
 1    CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RDT3N
      SUBROUTINE RDT3N(I,J,K,NU,V)
      IMPLICIT DOUBLE PRECISION  (A-H,O-Z)
CCCX      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
      DIMENSION V(NU,NU,NU)
CCCX      NU3=NU*NU*NU
      IF (I.GT.J) THEN
      IF(J.GT.K) THEN
         IAS=IT3(I,J,K)
         CALL RDT3(IAS,NU,V)
      ELSE
      IF(I.GT.K) THEN
      IAS=IT3(I,K,J)
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,23)
      ELSE
      IAS=IT3(K,I,J)
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,312)
      ENDIF
      ENDIF
      ELSE
      IF (I.GT.K) THEN
      IAS=IT3(J,I,K)
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,12)
      ELSE
      IF(J.GT.K) THEN
      IAS=IT3(J,K,I)
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,231)
      ELSE
      IAS=IT3(K,J,I)
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,13)
      ENDIF
      ENDIF
      ENDIF
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RDT3Q
      SUBROUTINE RDT3Q(I,J,K,NO,NU,V)
      IMPLICIT DOUBLE PRECISION  (A-H,O-Z)
CCCX      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
      DIMENSION V(NU,NU,NU)
CCCX      NU3=NU*NU*NU
      KK=IT3(NO,NO,NO-1)
      IF (I.GT.J) THEN
      IF(J.GT.K) THEN
         IAS=IT3(I,J,K)+KK
         CALL RDT3(IAS,NU,V)
      ELSE
      IF(I.GT.K) THEN
      IAS=IT3(I,K,J)+KK
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,23)
      ELSE
      IAS=IT3(K,I,J)+KK
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,312)
      ENDIF
      ENDIF
      ELSE
      IF (I.GT.K) THEN
      IAS=IT3(J,I,K)+KK
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,12)
      ELSE
      IF(J.GT.K) THEN
      IAS=IT3(J,K,I)+KK
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,231)
      ELSE
      IAS=IT3(K,J,I)+KK
      CALL RDT3(IAS,NU,V)
      CALL TRANMD(V,NU,NU,NU,1,13)
      ENDIF
      ENDIF
      ENDIF
      RETURN
      END
C
C*MODULE CCQAUX  *DECK VRINTHH
      SUBROUTINE VRINTHH(IP,N,TI)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
CCCX      INTEGER A,B
      DIMENSION TI(N,N)
      IF(IP.EQ.1.OR.IP.EQ.2) THEN
         N2=N*N
         IR=IP
            CALL WRT(NHH,IR,N2,TI)
      ELSE
         DO 10 I=1,N
            IR=I+2+N*(IP-3)
            CALL WRT(NHH,IR,N,TI(1,I))
 10      CONTINUE
      ENDIF
      RETURN
      END
C
C*MODULE CCQAUX  *DECK VRINTPP
      SUBROUTINE VRINTPP(IP,N,TI)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
CCCX      INTEGER A,B
      DIMENSION TI(N,N)
      N2=N*N
      IF(IP.EQ.1) THEN
         IR=1
            CALL WRT(NPP,IR,N2,TI)
         WRITE(NPP,REC=IR)TI
      ELSE
         DO 10 I=1,N
            IR=I+1
            CALL WRT(NPP,IR,N,TI(1,I))
 10      CONTINUE
      ENDIF
      RETURN
      END
C
C*MODULE CCQAUX  *DECK VRINTVO
      SUBROUTINE VRINTVO(IP,NO,NU,TI,T2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
      DIMENSION TI(NU,NU,NO),T2(NO,NU,NU,NO)
      NLAST=NO*(IP-1)
      DO 1 I=1,NO
      IASV=NLAST+I
      DO 2 J=1,NO
      DO 2 A=1,NU
      DO 2 B=1,NU
      TI(A,B,J)=T2(I,A,B,J)
 2    CONTINUE
      WRITE(NTVOE,REC=IASV)TI
 1    CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RDD
      SUBROUTINE RDD(NPP,IR,N,T)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T(N)
      READ(NPP,REC=IR)T
      RETURN
      END
C
C*MODULE CCQAUX  *DECK WRT
      SUBROUTINE WRT(NPP,IR,N,T)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T(N)
      WRITE(NPP,REC=IR)T
      RETURN
      END
C
C*MODULE CCQAUX  *DECK SYMT3
      SUBROUTINE SYMT3(V,NU,ID)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      DIMENSION V(NU,NU,NU)
      DATA TWO/2.0D+0/
      GO TO (1,2,3,4,5,6),ID
    1 CONTINUE
      DO 100 A=1,NU
      DO 100 B=1,A
      DO 100 C=1,B
      XAB=V(A,B,C)
      XAC=V(A,C,B)
      XBA=V(B,A,C)
      XBC=V(B,C,A)
      XCA=V(C,A,B)
      XCB=V(C,B,A)
      V(A,B,C)=TWO*XAB-XAC-XBA
      V(A,C,B)=TWO*XAC-XAB-XCA
      V(B,A,C)=TWO*XBA-XBC-XAB
      V(B,C,A)=TWO*XBC-XBA-XCB
      V(C,A,B)=TWO*XCA-XCB-XAC
      V(C,B,A)=TWO*XCB-XCA-XBC
  100 CONTINUE
      GO TO 1000
 3    CONTINUE
      DO 300 A=1,NU
      DO 300 B=1,A
      DO 300 C=1,B
      XAB=V(A,B,C)
      XAC=V(A,C,B)
      XBA=V(B,A,C)
      XBC=V(B,C,A)
      XCA=V(C,A,B)
      XCB=V(C,B,A)
      V(A,B,C)=TWO*XAB-XCB-XBA
      V(A,C,B)=TWO*XAC-XBC-XCA
      V(B,A,C)=TWO*XBA-XCA-XAB
      V(B,C,A)=TWO*XBC-XAC-XCB
      V(C,A,B)=TWO*XCA-XBA-XAC
      V(C,B,A)=TWO*XCB-XAB-XBC
  300 CONTINUE
      GO TO 1000
 6    CONTINUE
      DO 101 A=1,NU
      DO 101 B=1,A
      DO 101 C=1,B
      XAB=V(A,B,C)
      XAC=V(A,C,B)
      XBA=V(B,A,C)
      XBC=V(B,C,A)
      XCA=V(C,A,B)
      XCB=V(C,B,A)
      V(A,B,C)=TWO*XAB-XAC-XCB
      V(A,C,B)=TWO*XAC-XAB-XBC
      V(B,A,C)=TWO*XBA-XBC-XCA
      V(B,C,A)=TWO*XBC-XBA-XAC
      V(C,A,B)=TWO*XCA-XCB-XBA
      V(C,B,A)=TWO*XCB-XCA-XAB
 101  CONTINUE
      GOTO 1000
    2 CONTINUE
      DO 200 A=1,NU
      DO 200 B=1,A
      DO 200 C=1,NU
      X=V(A,B,C)
      Y=V(B,A,C)
      V(A,B,C)=TWO*X-Y
      V(B,A,C)=TWO*Y-X
  200 CONTINUE
      GO TO 1000
    4 CONTINUE
      DO 400 B=1,NU
      DO 400 C=1,B
      DO 400 A=1,C
      X=V(A,B,C)
      V(A,B,C)=V(B,C,A)
      V(B,C,A)=V(C,A,B)
      V(C,A,B)=X
      IF(B.EQ.C.OR.C.EQ.A)GO TO 400
      X=V(B,A,C)
      V(B,A,C)=V(A,C,B)
      V(A,C,B)=V(C,B,A)
      V(C,B,A)=X
  400 CONTINUE
      GO TO 1000
    5 CONTINUE
      DO 500 A=1,NU
      DO 500 C=1,A
      DO 500 D=1,C
      X=V(C,D,A)
      V(C,D,A)=V(A,C,D)
      V(A,C,D)=V(D,A,C)
      V(D,A,C)=X
      IF (A.EQ.C.OR.C.EQ.D)GO TO 500
      X=V(A,D,C)
      V(A,D,C)=V(C,A,D)
      V(C,A,D)=V(D,C,A)
      V(D,C,A)=X
  500 CONTINUE
      GO TO 1000
 1000 CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK T2DEN
      SUBROUTINE T2DEN(T2HPPH,EH,EP,NH,NP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B
CCCX      COMMON/ITRAT/ITER,MAXIT,ICCNV
      DIMENSION T2HPPH(NH,NP,NP,NH),EH(NH),EP(NP)
CCCX      DATA ZERO/0.0D+0/,TRES/1.0D-10/,ONE/1.0D+0/
      DO 10 I=1,NH
      DO 10 A=1,NP
      DO 10 B=1,NP
      DO 10 J=1,NH
      DEN=EH(I)+EH(J)-EP(A)-EP(B)
      XT2=T2HPPH(I,A,B,J)
      T2HPPH(I,A,B,J)=XT2/DEN
   10 CONTINUE
      RETURN
      END
CCCX      SUBROUTINE T2DENA(T2HPPH,EH,EP,NH,NP)
CCCX      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B
CCCX      COMMON/ITRAT/ITER,MAXIT,ICCNV
CCCX      DIMENSION T2HPPH(NH,NP,NP,NH),EH(NH),EP(NP)
CCCX      DATA ZERO/0.0D+0/,TRES/1.0D-10/,ONE/1.0D+0/
CCCX      DO 10 I=1,NH
CCCX      DO 10 A=1,NP
CCCX      DO 10 B=1,NP
CCCX      DO 10 J=1,NH
CCCX      DEN=EH(I)+EH(J)-EP(A)-EP(B)
CCCX      XT2=T2HPPH(I,A,B,J)
CCCX      WRITE(6,30)I,A,B,J,XT2,DEN
CCCX      T2HPPH(I,A,B,J)=XT2/DEN
CCCX   10 CONTINUE
CCCX 30   FORMAT('IABJ:',4I3,2F15.8)
CCCX      RETURN
CCCX      END
CCCX
C
C*MODULE CCQAUX  *DECK DRSUMAQ
      SUBROUTINE DRSUMAQ
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
CCCX      DIMENSION O1(1),OEH(NO),OEP(NU)
      LOGICAL CNVR
      LOGICAL QDR,QDCR
      COMMON/QUADRUPLE/QDR,QDCR
      COMMON /CCENGY/ ENRG,EREF,EMP2,ECCN,ETOT(6),ECORR(6),
     *                DIAGS(3),AMPMX(5,2),IAMPMX(5,4,2),XO1,XO2,
     *                DIFMAX,DIFFENG,ITER,CNVR
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
CCCX      COMMON/ET3/ET4A,ET4B
CCCX      COMMON/T4/QE1,QE2,QO1,QO2
      COMMON/T4TOT/ETT2,ETS2,EQ1A,EQ1B,EQ2A,EQ2B,EQ3A,EQ3B,EQ4A,
     *EQ4B,O4A,O4B,ECORQ(8),ETOTQ(8)
CCCX      COMMON/SCFEN/Y1
      DATA ONE/1.0D+0/
      XO1=ONE+OSS+ODS+ODD+OTS+OTD
      XO2=ONE+OSS+ODS+ODD+OTS+OTD+ODS_S+ODS_D
CCCX      X3=ESD+(ETD+ETS+QE1)/(XO2+QO1)
CCCX      X4=ESD+(ETD+ETS+QE2)/(XO2+QO2)
CCCX      X5=ESD+(ETTM2+ESD_TM2+ET4B)/(XO2+QO1)
CCCX      X6=ESD+(ETTM2+ESD_TM2+ET4A)/(XO2+QO2)
CCCX      X7=ESD+(ETTM2+ESD_TM2+ET4BCR)/(XO2+QO1)
CCCX      X8=ESD+(ETTM2+ESD_TM2+ET4ACR)/(XO2+QO2)
      ECORQ(1)=ESD+ETD+ETS+EQ1A
      ECORQ(2)=ESD+ETD+ETS+EQ1B
      ECORQ(3)=ESD+(ETD+ETS+EQ1A)/(XO2+O4A)
      ECORQ(4)=ESD+(ETD+ETS+EQ1B)/(XO2+O4B)
      ECORQ(5)=ESD+(ETT2+ETS2+EQ2B)/(XO2+O4A)
      ECORQ(6)=ESD+(ETT2+ETS2+EQ2A)/(XO2+O4B)
      ECORQ(7)=0.0D+0
      ECORQ(8)=0.0D+0
        IF(QDCR) THEN
      ECORQ(7)=ESD+(ETTM+ESD_TM+EQ3B)/(XO2+O4A)
      ECORQ(8)=ESD+(ETTM+ESD_TM+EQ3A)/(XO2+O4B)
        ENDIF
C      WRITE(6,*)'ETTM,ESD_TM,EQ3A,EQ3B,XO2,XO4A,XO4B'
C      WRITE(6,98)ETTM,ESD_TM,EQ3A,EQ3B,XO2,O4A,O4B
CCCX 98    FORMAT(F15.10)
      DO 101 I=1,8
      ETOTQ(I)=EREF+ECORQ(I)
  101 CONTINUE
CCCX 9001 FORMAT('     CCSD(TQF) CORRELATION ENERGY:',F17.12)
CCCX 9002 FORMAT('   B-CCSD(TQF) CORRELATION ENERGY:',F17.12)
CCCX 9003 FORMAT(' R1A-CCSD(TQF) CORRELATION ENERGY:',F17.12)
CCCX 9004 FORMAT(' R1B-CCSD(TQF) CORRELATION ENERGY:',F17.12)
CCCX 9005 FORMAT(' R2A-CCSD(TQF) CORRELATION ENERGY:',F17.12)
CCCX 9006 FORMAT(' R2B-CCSD(TQF) CORRELATION ENERGY:',F17.12)
CCCX 9007 FORMAT(' CRA-CCSD(TQF) CORRELATION ENERGY:',F17.12)
CCCX 9008 FORMAT(' CRB-CCSD(TQF) CORRELATION ENERGY:',F17.12)
CCCX 9021 FORMAT(T11,'     CCSD(TQF)  ENERGY:',F18.12)
CCCX 9022 FORMAT(T11,'   B-CCSD(TQF)  ENERGY:',F18.12)
CCCX 9023 FORMAT(T11,' R1A-CCSD(TQF)  ENERGY:',F18.12)
CCCX 9024 FORMAT(T11,' R1B-CCSD(TQF)  ENERGY:',F18.12)
CCCX 9025 FORMAT(T11,' R2A-CCSD(TQF)  ENERGY:',F18.12)
CCCX 9026 FORMAT(T11,' R2B-CCSD(TQF)  ENERGY:',F18.12)
CCCX 9027 FORMAT(T11,' CRA-CCSD(TQF)  ENERGY:',F18.12)
CCCX 9028 FORMAT(T11,' CRB-CCSD(TQF)  ENERGY:',F18.12)
CCCX 295  FORMAT(//,T30,'FINAL RESULTS'/)
CCCX 296  FORMAT(/,T11,'  REFERENCE  ENERGY:',F18.12)
CCCX 297  FORMAT(/,T11, '  MBPT(2)    ENERGY:',F18.12)
CCCX 298  FORMAT(/,T11,A10,'   ENERGY:',F18.12)
      RETURN
      END
C
C*MODULE CCQAUX  *DECK OVR1
      SUBROUTINE OVRL(NO,NU,T2,VO,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NO,NU,NU,NO),VO(NO,NU,NU,NO)
CCCX      DATA ZERO/0.0D+0/,TWO/2.0D+0/
      CALL SYMT21(VO,NO,NU,NU,NO,23)
      X=DDOT(NO2U2,T2,1,VO,1)
      CALL DESM21(VO,NO,NU,NU,NO,23)
      RETURN
      END
CCCX      SUBROUTINE ENGY2(NO,NU)
CCCX      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B
CCCX    DIMENSION T2(NO,NU,NU,NO),VO(NO,NU,NU,NO),TI(1),OEH(NO),OEP(NU)
CCCX      DATA ZERO/0.0D+0/,TWO/2.0D+0/,HALF/0.5D+0/
CCCX      NO2U2=NO*NO*NU*NU
CCCX      RETURN
C      CALL SYMETR(T2,NO,NU)
C      CALL RO2(1,NO,NU,VO)
C      CALL SYMT21(VO,NO,NU,NU,NO,23)
C      X=DDOT(NO2U2,T2,1,VO,1)
C      CALL RO2HPP(1,NO,NU,TI,VO)
C      CALL ADDDEN(NO,NU,VO,OEH,OEP)
C      CALL SYMT21(VO,NO,NU,NU,NO,23)
C      Y=DDOT(NO2U2,T2,1,VO,1)
C      WRITE(6,10)X,Y
C      CALL FLSHBF(6)
C10    FORMAT('X:',F15.10,'Y:',F15.10)
C      CALL VECMUL(T2,NO2U2,HALF)
C      CALL ZEROMA(T2,1,NO2U2)
C      RETURN
CCCX      END
C
C*MODULE CCQAUX  *DECK ENGY3
      SUBROUTINE ENGY3(NO,NU,T2,VO,TI,OEH,OEP,ISELECT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NO,NU,NU,NO),VO(NO,NU,NU,NO),TI(1),OEH(NO),OEP(NU)
      COMMON/RENOQ/XO1,XO2,XO3,XO4
      COMMON/T4/QE1,QE2,QO1,QO2
      COMMON/ZAPA/XQ1,XQ2,YQ1,YQ2
      COMMON/T4TOT/ETT2,ETS2,EQ1A,EQ1B,EQ2A,EQ2B,EQ3A,EQ3B,EQ4A,
     *EQ4B,O4A,O4B,ECORQ(8),ETOTQ(8)
      DATA TWO/2.0D+0/,THREE/3.0D+0/,FOUR/4.0D+0/
C      CALL CHKSUMSK('T2N     ',T2,NO2U2)
      CALL SYMT21(T2,NO,NU,NU,NO,23)
      CALL RO2(1,NO,NU,VO)
      X=DDOT(NO2U2,T2,1,VO,1)
      CALL RO2HPP(1,NO,NU,TI,VO)
      CALL ADDDEN(NO,NU,VO,OEH,OEP)
      Y=DDOT(NO2U2,T2,1,VO,1)
      X1=(XO1*XO2+XO3*XO4)/FOUR
      Y1=(XO1*XO3)/TWO
      XFIN=X1+Y/TWO
      YFIN=Y1+X/TWO
      IF(ISELECT.EQ.1)XQ1=XFIN
      IF(ISELECT.EQ.2)XQ2=XFIN
      IF(ISELECT.EQ.1)YQ1=YFIN
      IF(ISELECT.EQ.2)YQ2=YFIN
      IF(ISELECT.EQ.2) THEN
      QO1=XQ1-XQ2*TWO/THREE
      QO2=YQ1-YQ2*TWO/THREE
      O4A=QO1
      O4B=QO2
      ENDIF
      RETURN
      END
C
C*MODULE CCQAUX  *DECK ENGY1
      SUBROUTINE ENGY1(NO,NU,TI,T2,VO,OEH,OEP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B
      COMMON/EN51/EC1,EC2
CCCX      COMMON/MBPT5EN/EC
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      DIMENSION T2(NO,NU,NU,NO),VO(NO,NU,NU,NO),TI(1)
CCCX      DATA ZERO/0.0D+0/,TWO/2.0D+0/
      CALL RO2(1,NO,NU,VO)
      CALL SYMT21(VO,NO,NU,NU,NO,23)
      X=DDOT(NO2U2,T2,1,VO,1)
      EC1=EC1+X
      CALL RO2HPP(1,NO,NU,TI,VO)
      CALL ADDDEN(NO,NU,VO,OEH,OEP)
      CALL SYMT21(VO,NO,NU,NU,NO,23)
      X=DDOT(NO2U2,T2,1,VO,1)
      EC2=EC2+X
CCCX10    FORMAT('X:',F15.10,'Y:',F15.10)
C      WRITE(6,10)EC1,EC2
C      WRITE(6,*)'ENGY:',EC1,EC2
      RETURN
      END
C
C*MODULE CCQAUX  *DECK ENGY1CR
      SUBROUTINE ENGY1CR(NO,NU,T2,TI,VO,OEH,OEP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B
CCCX      COMMON/EN51CR/EC1,EC2
      COMMON/ENTEMP/ET2,EV
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      COMMON/T4TOT/ETT2,ETS2,EQ1A,EQ1B,EQ2A,EQ2B,EQ3A,EQ3B,EQ4A,
     *EQ4B,O4A,O4B,ECORQ(8),ETOTQ(8)
      DIMENSION T2(NO,NU,NU,NO),VO(NO,NU,NU,NO),TI(1),OEH(1),OEP(1)
      DATA HALF/0.5D+0/
      CALL SYMETR(T2,NO,NU)
      CALL RO2(1,NO,NU,VO)
      CALL SYMT21(VO,NO,NU,NU,NO,23)
      X=DDOT(NO2U2,T2,1,VO,1)
      EQ3A=EQ3A+X+ET2
      CALL RO2HPP(1,NO,NU,TI,VO)
      CALL ADDDEN(NO,NU,VO,OEH,OEP)
      CALL SYMT21(VO,NO,NU,NU,NO,23)
      X=DDOT(NO2U2,T2,1,VO,1)
      EQ3B=EQ3B+X+EV
      CALL VECMUL(T2,NO2U2,HALF)
CCCX10    FORMAT('XCR:',F15.10,'Y:',F15.10)
CCCX      WRITE(6,10)EQ3A,EQ3B
      RETURN
      END
C
C*MODULE CCQAUX  *DECK ENGY1CRA
      SUBROUTINE ENGY1CRA(NO,NU,T2N,T2NN,VO)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B
CCCX      COMMON/EN51CR/EC1,EC2
      COMMON/ENTEMP/ET2,EV
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
CCCX      COMMON/T4TOT/ETT2,ETS2,EQ1A,EQ1B,EQ2A,EQ2B,EQ3A,EQ3B,EQ4A,
CCCX     *EQ4B,O4A,O4B
      DIMENSION T2N(NO,NU,NU,NO),T2NN(NO,NU,NU,NO),VO(NO,NU,NU,NO)
      DATA HALF/0.5D+0/
      NO2U2=NO*NO*NU*NU
      CALL SYMETR(T2N,NO,NU)
      CALL SYMETR(T2NN,NO,NU)
      CALL RO2(1,NO,NU,VO)
      CALL SYMT21(VO,NO,NU,NU,NO,23)
      ET2=DDOT(NO2U2,T2N,1,VO,1)
      EV=DDOT(NO2U2,T2NN,1,VO,1)
      CALL VECMUL(T2N,NO2U2,HALF)
      CALL VECMUL(T2NN,NO2U2,HALF)
C      WRITE(6,9)ET2,EV
C9     FORMAT('ENGY1CRA:',2F15.10)
      RETURN
      END
C
C*MODULE CCQAUX  *DECK ENGY
      SUBROUTINE ENGY
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CCCX      INTEGER A,B
      COMMON/T4/QE1,QE2,QO1,QO2
      COMMON/EN51/EC1,EC2
      COMMON/ET3/ET4A,ET4B
CCCX      COMMON/MBPT5EN/EC
      COMMON/T4TOT/ETT2,ETS2,EQ1A,EQ1B,EQ2A,EQ2B,EQ3A,EQ3B,EQ4A,
     *EQ4B,O4A,O4B,ECORQ(8),ETOTQ(8)
CCCX      DIMENSION T2(NO,NU,NU,NO),VO(NO,NU,NU,NO),TI(1)
CCCX      DATA ZERO/0.0D+0/,TWO/2.0D+0/
      ET4A=EC1-ET4A
      ET4B=EC2-ET4B
      QE1=EC2
      QE2=EC1
C
CCCX      ENTOT=0.0D+00
C
      EQ1A=EC2
      EQ1B=EC1
      EQ2A=ET4A
      EQ2B=ET4B
C      WRITE(6,*)'QE1,QE2',QE1,QE2
C      WRITE(6,*)'QO1,QO2',QO1,QO2
C      WRITE(6,*)'ET4A,ET4B',ET4A,ET4B
C      CALL GETREC(20,'JOBARC','TOTENERG',2,ENTOT)
CCCX      ETOTPLUS5=ENTOT+EC
C      CALL PUTREC(20,'JOBARC','TOTENERG',2,ETOTPLUS5)
      RETURN
      END
C
C*MODULE CCQAUX  *DECK TRANDS
      SUBROUTINE TRANDS(NO,NU,VT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
      DIMENSION VT(NU,NU,NO,NO,NO)
      INTEGER A,B
      NO2=NO*NO
      NO2U2=NO2*NU*NU
      DO 10 I=1,NO
      DO 11 J=1,NO
      KK=NO*(J-1)+I
      CALL RDGEN(NVT,KK,NO2U2,VT(1,1,1,1,J))
11    CONTINUE
      DO 105 J=1,NO
      DO 105 K=1,J
      DO 105 L=1,NO
      DO 105 A=1,NU
      DO 105 B=1,NU
      X=VT(A,B,L,K,J)
      VT(A,B,L,K,J)=VT(A,B,L,J,K)
      VT(A,B,L,J,K)=X
105   CONTINUE
      DO 12 J=1,NO
      KK=NO2+NO*(J-1)+I
      CALL WRGEN(NVT,KK,NO2U2,VT(1,1,1,1,J))
12    CONTINUE
10    CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK WRGEN
      SUBROUTINE WRGEN(NTAP,IREC,N,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N)
      WRITE(NTAP,REC=IREC)A
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RDGEN
      SUBROUTINE RDGEN(NTAP,IREC,N,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N)
      READ(NTAP,REC=IREC)A
      RETURN
      END
C
C*MODULE CCQAUX  *DECK RDVTIJ
      SUBROUTINE RDVTIJ(IR,NO,NU,I,J,VT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
      DIMENSION VT(NU,NU,NO,NO)
      NO2=NO*NO
CCCX      NO3=NO*NO2
      NOU2=NO*NU*NU
      NO2U2=NO*NOU2
      KK=IR*NO2+NO*(I-1)+J
      CALL RDGEN(NVT,KK,NO2U2,VT)
      RETURN
      END
C
C*MODULE CCQAUX  *DECK SYMVT
      SUBROUTINE SYMVT(NO,NU,VTIJ,VTJI)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/NEWIO/L46,NHH,NPP,NTVOE,NVT
      COMMON/NN/NO2,NO3,NO4,NU2,NU3,NU4,NOU,NO2U,NO3U,NOU2,NOU3,NO2U2
      INTEGER A,B
      DIMENSION VTIJ(NU,NU,NO,NO),VTJI(NU,NU,NO,NO)
      NO2U2=NO*NO*NU*NU
      DO 11 I=1,NO
      DO 11 J=1,I
      KK=NO*(I-1)+J
      CALL RDGEN(NVT,KK,NO2U2,VTIJ)
      KK=NO*(J-1)+I
      CALL RDGEN(NVT,KK,NO2U2,VTJI)
      DO 10 K=1,NO
      DO 10 L=1,NO
      DO 10 A=1,NU
      LIMB=NU
      IF(I.EQ.J)LIMB=A
      DO 10 B=1,LIMB
      X=VTIJ(B,A,L,K)
      Y=VTJI(A,B,L,K)
      Z=X+Y
      VTIJ(B,A,L,K)=Z
      IF (I.EQ.J) THEN
      VTIJ(A,B,L,K)=Z
      ELSE
      VTJI(A,B,L,K)=Z
      ENDIF
 10   CONTINUE
      KK=NO*(J-1)+I
      CALL WRGEN(NVT,KK,NO2U2,VTIJ)
      KK=NO*(I-1)+J
      IF(I.NE.J) CALL WRGEN(NVT,KK,NO2U2,VTJI)
 11   CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK SYMT21
      SUBROUTINE SYMT21Q(A,N1,N2,N3,N4,IJ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N1,N2,N3,N4)
      DATA TWO/2.0D+00/
C
      IF(IJ.EQ.23)GOTO 23
      IF(IJ.EQ.24)GOTO 24
      IF(IJ.EQ.14)GOTO 14
      IF(IJ.EQ.12)GOTO 12
      IF(IJ.EQ.34)GOTO 34
      IF(IJ.EQ.13)GOTO 13
 23   CONTINUE
      DO 10 I=1,N1
      DO 10 J=1,N2
      DO 10 K=1,J
      DO 10 L=1,N4
      X=A(I,J,K,L)
      Y=A(I,K,J,L)
      A(I,J,K,L)=TWO*X-Y
      A(I,K,J,L)=TWO*Y-X
   10 CONTINUE
      GOTO 1000
 24   CONTINUE
      DO 1024 I=1,N1
      DO 1024 J=1,N2
      DO 1024 K=1,N3
      DO 1024 L=1,J
      X=A(I,J,K,L)
      Y=A(I,L,K,J)
      A(I,J,K,L)=TWO*X-Y
      A(I,L,K,J)=TWO*Y-X
 1024 CONTINUE
      GOTO 1000
 14   CONTINUE
      DO 11 I=1,N1
      DO 11 J=1,N2
      DO 11 K=1,N3
      DO 11 L=1,I
      X=A(I,J,K,L)
      Y=A(L,J,K,I)
      A(I,J,K,L)=TWO*X-Y
      A(L,J,K,I)=TWO*Y-X
 11   CONTINUE
      GOTO 1000
 12   CONTINUE
      DO 112 I=1,N1
      DO 112 J=1,I
      DO 112 K=1,N3
      DO 112 L=1,N4
      X=A(I,J,K,L)
      Y=A(J,I,K,L)
      A(I,J,K,L)=TWO*X-Y
      A(J,I,K,L)=TWO*Y-X
 112  CONTINUE
      GOTO 1000
 13   CONTINUE
      DO 113 I=1,N1
      DO 113 J=1,N2
      DO 113 K=1,I
      DO 113 L=1,N4
      X=A(I,J,K,L)
      Y=A(K,J,I,L)
      A(I,J,K,L)=TWO*X-Y
      A(K,J,I,L)=TWO*Y-X
 113  CONTINUE
      GOTO 1000
 34   CONTINUE
      DO 134 I=1,N1
      DO 134 J=1,N2
      DO 134 K=1,N3
      DO 134 L=1,K
      X=A(I,J,K,L)
      Y=A(I,J,L,K)
      A(I,J,K,L)=TWO*X-Y
      A(I,J,L,K)=TWO*Y-X
 134  CONTINUE
 1000 CONTINUE
      RETURN
      END
C*MODULE CCQAUX  *DECK DESM21
      SUBROUTINE DESM21Q(A,N1,N2,N3,N4,IJ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N1,N2,N3,N4)
      DATA THIRD /.33333333333333D+00/,HALF/0.5D+00/
C
      IF(IJ.EQ.23)GOTO 23
      IF(IJ.EQ.24)GOTO 24
      IF(IJ.EQ.14)GOTO 14
      IF(IJ.EQ.12)GOTO 12
      IF(IJ.EQ.13)GOTO 13
      IF(IJ.EQ.34)GOTO 34
 23   CONTINUE
      DO 10 I=1,N1
      DO 10 J=1,N2
      DO 10 K=1,J
      DO 10 L=1,N4
      A1=A(I,J,K,L)
      A2=A(I,K,J,L)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(I,K,J,L)=(X-Y)*HALF
   10 CONTINUE
      GOTO 100
 24   CONTINUE
      DO 1024 I=1,N1
      DO 1024 J=1,N2
      DO 1024 K=1,N3
      DO 1024 L=1,J
      A1=A(I,J,K,L)
      A2=A(I,L,K,J)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(I,L,K,J)=(X-Y)*HALF
 1024 CONTINUE
      GOTO 100
 14   CONTINUE
      DO 101 I=1,N1
      DO 101 J=1,N2
      DO 101 K=1,N3
      DO 101 L=1,I
      A1=A(I,J,K,L)
      A2=A(L,J,K,I)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(L,J,K,I)=(X-Y)*HALF
 101  CONTINUE
      GOTO 100
 34   CONTINUE
      DO 102 I=1,N1
      DO 102 J=1,N2
      DO 102 K=1,N3
      DO 102 L=1,K
      A1=A(I,J,K,L)
      A2=A(I,J,L,K)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(I,J,L,K)=(X-Y)*HALF
 102  CONTINUE
      GOTO 100
 12   CONTINUE
      DO 103 I=1,N1
      DO 103 J=1,I
      DO 103 K=1,N3
      DO 103 L=1,N4
      A1=A(I,J,K,L)
      A2=A(J,I,K,L)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(J,I,K,L)=(X-Y)*HALF
 103  CONTINUE
      GOTO 100
 13   CONTINUE
      DO 113 I=1,N1
      DO 113 J=1,N2
      DO 113 K=1,I
      DO 113 L=1,N4
      A1=A(I,J,K,L)
      A2=A(K,J,I,L)
      X=A1+A2
      Y=(A1-A2)*THIRD
      A(I,J,K,L)=(X+Y)*HALF
      A(K,J,I,L)=(X-Y)*HALF
 113  CONTINUE
      GOTO 100
 100  CONTINUE
      RETURN
      END
C
C*MODULE CCQAUX  *DECK TRNS
      SUBROUTINE TRNS(NO,NU,VT,VO)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B
      DIMENSION VT(NU,NU,NO,NO),VO(NO,NU,NO,NU)
      DO 10 I=1,NO
      DO 10 J=1,NO
      DO 10 A=1,NU
      DO 10 B=1,NU
      VO(I,A,J,B)=VT(A,B,I,J)
  10  CONTINUE
      RETURN
C---      END
C---      SUBROUTINE CHKSUMSK(A,T,N)
C---      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---      DIMENSION T(N)
C---      DATA ZERO/0.0D+0/
C---C      RETURN
C---      X=ZERO
C---      Y=ZERO
C---      ZY=ZERO
C---      XT=ZERO
C---      DO 10 I=1,N
C---      X=X+ABS(T(I))
C---      XT=XT+T(I)
C--- 10   CONTINUE
C---      DO 20 I=2,N,2
C---      Z=T(I-1)+T(I)
C---      Y=Y+Z*Z
C--- 20   CONTINUE
C---      DO 30 I=5,N,5
C---      Z=T(I-4)+T(I-3)+T(I-2)+T(I-1)+T(I)
C---      ZY=ZY+Z*Z
C--- 30   CONTINUE
C---CCCX 100  FORMAT(1X,A8,'ABS:',D15.10)
C---C      WRITE(6,100)A,X
C--- 200  FORMAT(A8,' ',D16.11,' ',D16.11,' ',D16.11,' ',D16.10)
C---      WRITE(6,200)A,X,Y,ZY,XT
C---      RETURN
      END
