C  5 Jul 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  1 Jun 05 - MWS - add CCTMATMULT; CC(t)MATMUL(t): declare MONE d.p.
C 30 Apr 05 - KK  - EXWRVM/E,EXRDVM/E,WREXXVM/E,REXXVM/E: left EOMCCSD
C 30 Apr 05 - DGF - synchronise common block CCENGY
C  7 APR 04 - MWS - ADD SOME MORE UTILITIES FOR EOM TRIPLES CODE
C  4 NOV 03 - KK,MWS - ADD SOME MORE UTILITIES FOR EOM CODES
C 14 JAN 03 - KK  - SYNCH COMMON BLOCK CCINFO
C 22 MAY 02 - PP,KK - UTILITY ROUTINES FOR CC CALCULATIONS
C
C               ORIGINALLY AUXRT.F
C
C*MODULE CCAUX   *DECK TRANSQ
      SUBROUTINE TRANSQ(A,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N,N)
C
      DO 10 I=1,N
      DO 10 J=1,I
      X=A(I,J)
      A(I,J)=A(J,I)
      A(J,I)=X
   10 CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK VECADD
      SUBROUTINE VECADD(A,B,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(*),B(*)
C
      DO 10 I=1,N
         A(I)=A(I)+B(I)
   10 CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK VECCOP
      SUBROUTINE VECCOP(N,A,B)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N),B(N)
C
      CALL DCOPY(N,B,1,A,1)
      RETURN
      END
C*MODULE CCAUX   *DECK VECMUL
      SUBROUTINE VECMUL(A,N,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N)
C
      CALL DSCAL(N,X,A,1)
      RETURN
      END
C*MODULE CCAUX   *DECK VECSUB
      SUBROUTINE VECSUB(A,B,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(*),B(*)
C
      DO 10 I=1,N
         A(I)=A(I)-B(I)
   10 CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK TRANMD
      SUBROUTINE TRANMD(A,N1,N2,N3,N4,IJ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(1)
C
      N12=N1*N2
      N123=N12*N3
      IF(IJ.EQ.12) GO TO 12
      IF(IJ.EQ.13) GO TO 13
      IF(IJ.EQ.14) GO TO 14
      IF(IJ.EQ.23) GO TO 23
      IF(IJ.EQ.24) GO TO 24
      IF(IJ.EQ.34) GO TO 34
      IF(IJ.EQ.231) GO TO 231
      IF(IJ.EQ.312) GO TO 312
      IF(IJ.EQ.341) GO TO 341
      IF(IJ.EQ.413) GO TO 413
      IF(IJ.EQ.1234) GO TO 1234
      GOTO 100
   12 CONTINUE
      DO 10 L=1,N4
         N123L=N123*(L-1)
      DO 10 K=1,N3
         N12K=(K-1)*N12+N123L
      DO 10 I=1,N1
         N1I=(I-1)*N1
      DO 10 J=1,I
         IJKL=N12K+(J-1)*N1+I
         JIKL=N12K+N1I+J
      X=A(IJKL)
      A(IJKL)=A(JIKL)
      A(JIKL)=X
   10 CONTINUE
      GO TO 100
   13 CONTINUE
      DO 20 L=1,N4
         N123L=N123*(L-1)
      DO 20 I=1,N1
         N12I=N123L+N12*(I-1)
      DO 20 J=1,N2
         N1J=N1*(J-1)
      DO 20 K=1,I
         IJKL=N123L+(K-1)*N12+N1J+I
         KJIL=N12I+N1J+K
      X=A(IJKL)
      A(IJKL)=A(KJIL)
      A(KJIL)=X
   20 CONTINUE
      GO TO 100
   14 CONTINUE
      DO 25 I=1,N1
         N123I=N123*(I-1)
      DO 25 J=1,N2
         N1J=N1*(J-1)
      DO 25 K=1,N3
         N12K=N12*(K-1)+N1J
      DO 25 L=1,I
         IJKL=(L-1)*N123+N12K+I
         LJKI=N123I     +N12K+L
      X=A(IJKL)
      A(IJKL)=A(LJKI)
      A(LJKI)= X
   25 CONTINUE
      GO TO 100
   23 CONTINUE
      DO 30 J=1,N2
         J1=J-1
         N1J=N1*J1
         N12J=N12*J1
      DO 30 K=1,J
         K1=K-1
         N1K=N1*K1
         N12K=N12*K1
      DO 30 L=1,N4
         N123L=N123*(L-1)
      DO 30 I=1,N1
         N123LI=N123L+I
         IJKL=N123LI+N12K+N1J
         IKJL=N123LI+N12J+N1K
      X=A(IJKL)
      A(IJKL)=A(IKJL)
      A(IKJL)=X
   30 CONTINUE
      GO TO 100
   24 CONTINUE
      DO 40 J=1,N2
         J1=J-1
         N123J=N123*J1
         N1J  =N1*J1
      DO 40 L=1,J
         L1=L-1
         N123L=N123*L1
         N1L=N1*L1
      DO 40 K=1,N3
         N12K=N12*(K-1)
      DO 40 I=1,N1
         N12KI=N12K+I
         IJKL=N123L+N12KI+N1J
         ILKJ=N123J+N12KI+N1L
      X=A(IJKL)
      A(IJKL)=A(ILKJ)
      A(ILKJ)=X
   40 CONTINUE
      GO TO 100
   34 CONTINUE
      DO 50 K=1,N3
         K1=K-1
         N12K=N12*K1
         N123K=N123*K1
      DO 50 L=1,K
         L1=L-1
         N12L=N12*L1
         N123L=N123*L1
      DO 50 J=1,N2
         J1=J-1
         N1J=N1*(J-1)
      DO 50 I=1,N1
         N1JI=N1J+I
         IJKL=N123L+N12K+N1JI
         IJLK=N123K+N12L+N1JI
      X=A(IJKL)
      A(IJKL)=A(IJLK)
      A(IJLK)=X
   50 CONTINUE
      GO TO 100
 231  CONTINUE
      DO 60 L=1,N4
         N123L=N123*(L-1)
      DO 60 J=1,N1
         J1=J-1
         N12J=N12*J1
         N1J=N1*J1
      DO 60 K=1,J
         N12JK=N12J+K
         K1=K-1
         N12K=N12*K1
         N1K=N1*K1
      DO 60 I=1,K
         I1=I-1
         IJKL=N123L+N12K+N1J+I
         JKIL=N123L+I1*N12+N1K+J
         KIJL=N123L+N12JK +I1*N1
      X=A(IJKL)
      A(IJKL)=A(JKIL)
      A(JKIL)=A(KIJL)
      A(KIJL)=X
      IF(J.EQ.K.OR.K.EQ.I) GOTO 60
         JIKL=N123L+N12K  +N1*I1+J
         IKJL=N123L+N12J  +N1K  +I
         KJIL=N123L+N12*I1+N1J  +K
      X=A(JIKL)
      A(JIKL)=A(IKJL)
      A(IKJL)=A(KJIL)
      A(KJIL)=X
 60   CONTINUE
      GOTO 100
 312  CONTINUE
      DO 70 L=1,N4
         N123L=N123*(L-1)
      DO 70 I=1,N1
         I1=I-1
         N1I=N1*I1
         N12I=N12*I1
      DO 70 J=1,I
         J1=J-1
         N1J =N1*J1
         N12J=N12*J1
      DO 70 K=1,J
         K1=K-1
         N1K=N1*K1
         N12K=N12*K1
         IJKL=N123L+N12K+N1J+I
         JKIL=N123L+N12I+N1K+J
         KIJL=N123L+N12J+N1I+K
      X=A(JKIL)
      A(JKIL)=A(IJKL)
      A(IJKL)=A(KIJL)
      A(KIJL)=X
      IF (I.EQ.J.OR.J.EQ.K)GOTO 70
         IKJL=N123L+N12J+N1K+I
         JIKL=N123L+N12K+N1I+J
         KJIL=N123L+N12I+N1J+K
      X=A(IKJL)
      A(IKJL)=A(JIKL)
      A(JIKL)=A(KJIL)
      A(KJIL)=X
 70   CONTINUE
      GOTO 100
 341  CONTINUE
      DO 80 L=1,N2
      DO 80 J=1,N1
      DO 80 K=1,J
      DO 80 I=1,K
         ILJK=(K-1)*N123+(J-1)*N12+(L-1)*N1+I
         JLKI=(I-1)*N123+(K-1)*N12+(L-1)*N1+J
         KLIJ=(J-1)*N123+(I-1)*N12+(L-1)*N1+K
      X=A(ILJK)
      A(ILJK)=A(JLKI)
      A(JLKI)=A(KLIJ)
      A(KLIJ)=X
      IF(J.EQ.K.OR.K.EQ.I) GOTO 80
         ILKJ=(J-1)*N123+(K-1)*N12+(L-1)*N1+I
         JLIK=(K-1)*N123+(I-1)*N12+(L-1)*N1+J
         KLJI=(I-1)*N123+(J-1)*N12+(L-1)*N1+K
      X=A(JLIK)
      A(JLIK)=A(ILKJ)
      A(ILKJ)=A(KLJI)
      A(KLJI)=X
 80   CONTINUE
      GOTO 100
 413  CONTINUE
      DO 90 L=1,N2
      DO 90 I=1,N1
      DO 90 J=1,I
      DO 90 K=1,J
         JLKI=(I-1)*N123+(K-1)*N12+(L-1)*N1+J
         ILJK=(K-1)*N123+(J-1)*N12+(L-1)*N1+I
         KLIJ=(J-1)*N123+(I-1)*N12+(L-1)*N1+K
      X=A(JLKI)
      A(JLKI)=A(ILJK)
      A(ILJK)=A(KLIJ)
      A(KLIJ)=X
      IF (I.EQ.J.OR.J.EQ.K)GOTO 90
         ILKJ=(J-1)*N123+(K-1)*N12+(L-1)*N1+I
         JLIK=(K-1)*N123+(I-1)*N12+(L-1)*N1+J
         KLJI=(I-1)*N123+(J-1)*N12+(L-1)*N1+K
      X=A(ILKJ)
      A(ILKJ)=A(JLIK)
      A(JLIK)=A(KLJI)
      A(KLJI)=X
 90   CONTINUE
      GO TO 100
 1234 CONTINUE
C--      WRITE(6,76) A
C-- 76   FORMAT(4F15.10)
      DO 95 I=1,N1
      DO 95 J=1,N2
      DO 95 K=1,J
      DO 95 L=1,I
         IJKL=(L-1)*N123+(K-1)*N12+(J-1)*N1+I
         LKJI=(I-1)*N123+(J-1)*N12+(K-1)*N1+L
      X=A(IJKL)
      A(IJKL)=A(LKJI)
      A(LKJI)=X
      IF (I.EQ.L.OR.K.EQ.J) GOTO 95
         LJKI=(I-1)*N123+(K-1)*N12+(J-1)*N1+L
         IKJL=(L-1)*N123+(J-1)*N12+(K-1)*N1+I
      X=A(LJKI)
      A(LJKI)=A(IKJL)
      A(IKJL)=X
 95   CONTINUE
 100  CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK INSI12
      SUBROUTINE INSI12(N1,N2,N3,TI,O2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(N1,N2,N3),O2(N2,N1,N3)
C
      N=N1*N2*N3
      CALL VECCOP(N,TI,O2)
      DO 10 K=1,N3
      DO 10 I=1,N1
      DO 10 J=1,N2
      O2(J,I,K)=TI(I,J,K)
 10   CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK INSI13
      SUBROUTINE INSI13(N1,N2,N3,TI,O2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(N1,N2,N3),O2(N3,N2,N1)
C
      N=N1*N2*N3
      CALL VECCOP(N,TI,O2)
      DO 10 I=1,N1
      DO 10 J=1,N2
      DO 10 K=1,N3
      O2(K,J,I)=TI(I,J,K)
 10   CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK INSI23
      SUBROUTINE INSI23(N1,N2,N3,TI,O2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(N1,N2,N3),O2(N1,N3,N2)
C
      N=N1*N2*N3
      CALL VECCOP(N,TI,O2)
      DO 10 J=1,N2
      DO 10 K=1,N3
      DO 10 I=1,N1
      O2(I,K,J)=TI(I,J,K)
 10   CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK INSITU
      SUBROUTINE INSITU(N1,N2,N3,N4,TI,O2,IC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TI(N1,N2,N3),O2(N1,N2,N3,N4)
C
      DO 10 I=1,N4
      IF (IC.EQ.12)GOTO 12
      IF (IC.EQ.23)GOTO 23
      GOTO 13
 12   CALL INSI12(N1,N2,N3,TI,O2(1,1,1,I))
      GOTO 10
 23   CALL INSI23(N1,N2,N3,TI,O2(1,1,1,I))
      GOTO 10
 13   CALL INSI13(N1,N2,N3,TI,O2(1,1,1,I))
 10   CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK TRT1
      SUBROUTINE TRT1(NO,NU,TI,T1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A
      DIMENSION TI(NO,NU),T1(NU,NO)
C
      NOU=NO*NU
      CALL VECCOP(NOU,TI,T1)
      DO 10 I=1,NO
      DO 10 A=1,NU
      T1(A,I)=TI(I,A)
 10   CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK SYMETR
      SUBROUTINE SYMETR(T2HPPH,NH,NP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B
      DIMENSION T2HPPH(NH,NP,NP,NH)
C
      DO 10 I=1,NH
      DO 10 J=1,I
      DO 10 A=1,NP
      LIMB=NP
      IF(I.EQ.J)LIMB=A
      DO 10 B=1,LIMB
      X=T2HPPH(I,A,B,J)
      Y=T2HPPH(J,B,A,I)
      T2HPPH(I,A,B,J)=X+Y
      T2HPPH(J,B,A,I)=X+Y
   10 CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK SYMT21
      SUBROUTINE SYMT21(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.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
 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 CCAUX   *DECK DESM21
      SUBROUTINE DESM21(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.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
 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*MODULE CCAUX   *DECK ZEROMA
      SUBROUTINE ZEROMA(WORK,NF,NL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION WORK(NL)
C
      DO 1 I=NF,NL
1     WORK(I)=0.0D+00
      RETURN
      END
C*MODULE CCAUX   *DECK MTRANS
      SUBROUTINE MTRANS(V,NU,ID)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      DIMENSION V(NU,NU,NU,NU)
C
      IF(ID.EQ.7)GOTO 7
      IF(ID.EQ.11)GOTO 11
      IF(ID.EQ.19)GOTO 19
      IF(ID.EQ.23)GOTO 23
    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
 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
 19   CONTINUE
      CALL MTRA1(V,NU)
      GOTO 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*MODULE CCAUX   *DECK T1SQ
      SUBROUTINE T1SQ(NO,NU,O1,T1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(NO,NU),T1(1)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
      COMMON /CCRENO/ OSS,ODS,ODD,OTS,OTD,OTT,ODS_S,ODS_D,ODS_T,
     *                OQS,OQDS,OQDD,OQTS,ESD,ETD,ETS,ETTM,ESD_TM
      DATA TWO/2.0D+00/
C
      NOU = NO*NU
      READ(NT1,REC=1) O1
      ETS=TWO*DDOT(NOU,O1,1,T1,1)
      RETURN
      END
C*MODULE CCAUX   *DECK MTRA1
      SUBROUTINE MTRA1(V,NU)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      LOGICAL AEB,CED
      DIMENSION V(1)
C
      NU2=NU*NU
      NU3=NU2*NU
      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
                  IB1=IB1+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
      RETURN
      END
C*MODULE CCAUX   *DECK BLKCPY
      SUBROUTINE BLKCPY(MATFRM,NROWFRM,NCOLFRM,MATTAR,NROWTAR,NCOLTAR,
     &                  IROWTAR,ICOLTAR)
C
C THIS ROUTINE COPIES AN NROWFRM BY NCOLFRM BLOCK MATRIX (MATFRM)
C  INTO AN NROWTAR BY NCOLTAR TARGET MATRIX (MATTAR) SUCH THAT
C  THE (1,1) ELEMENT IN MATFRM BECOMES THE IROWTAR,ICOLTAR ELEMENT
C  IN MATTAR.
C
      IMPLICIT INTEGER (A-Z)
      DOUBLE PRECISION MATTAR(NROWTAR*NCOLTAR),MATFRM(NROWFRM,NCOLFRM)
      INDX(I,J)=I+(J-1)*NROWTAR
      ISTART=INDX(IROWTAR,ICOLTAR)
      DO 10 ICOL=1,NCOLFRM
       CALL DCOPY(NROWFRM,MATFRM(1,ICOL),1,MATTAR(ISTART),1)
       ISTART=ISTART+NROWTAR
10    CONTINUE
      RETURN
      END
C
C          ORIGINALLY RLE.F
C
C*MODULE CCAUX   *DECK DRRLEN
      SUBROUTINE DRRLEN(NO,NU,O1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(*)
      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
C
      NRLE0=MXRLE
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NOU2  = NO*NU2
      NO2U2 = NO2*NU2
C
      L1=NOU2
      L2=NO2U2+NOU
      IO1  = 1
      IO2  = IO1    + L1
      IO3  = IO2    + L2
      IO4  = IO3    + L2
      LAST = IO4    + NRLE0
C          SINCE THERE IS NO FORMAL MEMORY ALLOCATION, LAST IS UNUSED.
C          SO NEXT LINE IS SILLY, ITS JUST TO AVOID AN FTNCHEK MESSAGE
      IF(LAST.LT.0) WRITE(6,*) 'LAST=',LAST
C
C        O1=TI ARRAY,     O2      T2      CRLE
      CALL NEWRLE(NO,NU,O1(IO2),O1(IO3),O1(IO4))
C
      RETURN
      END
C*MODULE CCAUX   *DECK NEWRLE
      SUBROUTINE NEWRLE(NO,NU,O2,T2,CRLE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL CNVR
      DIMENSION T2(1),O2(1),CRLE(*)
      DIMENSION XR(1000)
C
      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 /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      COMMON /CCRLE / MXRLE,NRLE0,NRLE,IRLE,ITRLE
C
      NO2   = NO*NO
      NU2   = NU*NU
      NOU   = NO*NU
      NO2U2 = NO2*NU2
C
      IF(ITRLE.EQ.1)THEN
         CALL ZEROMA(XR,1,1000)
         NRLE=1
         IRLE=1
      ENDIF
      LEN=NOU+NO2U2
      INOU=NOU+1
      IF(MET.LT.2)THEN
      INOU=1
      LEN=NO2U2
      ENDIF
      LENTOT=LEN
      IO=2*IRLE-1
      ID=2*IRLE
      IF(MET.GT.1)CALL RO1(1,NO,NU,O2)
      CALL RO2(1,NO,NU,O2(INOU))
      CALL WRRLE(NFRLE,IO,LEN,O2)
      IF(MET.GT.1)CALL RO1(2,NO,NU,T2)
      CALL RO2(2,NO,NU,T2(INOU))
      CALL VECSUB(T2,O2,LEN)
      DIFMAX=T2(IDAMAX(LEN,T2,1))
      CALL WRRLE(NFRLE,ID,LEN,T2)
      DO 10 I=1,NRLE
         ID=2*I
         CALL RDRLE(NFRLE,ID,LEN,O2)
         DO 11 J=1,I
            JD=2*J
            IJ=I+(J-1)*NRLE0
            JI=J+(I-1)*NRLE0
            CALL RDRLE(NFRLE,JD,LEN,T2)
            X=DDOT(LENTOT,O2,1,T2,1)
            XR(JI)=X
            XR(IJ)=X
 11      CONTINUE
 10   CONTINUE
      CALL DODIIS(XR,O2,CRLE,NRLE0,NRLE)
      CALL ZEROMA (O2,1,LENTOT)
      DO 20 I=1,NRLE
      ID=2*I
      FX=CRLE(I)
      CALL RDRLE(NFRLE,ID,LEN,T2)
      CALL DAXPY(LENTOT,FX,T2,1,O2,1)
 20   CONTINUE
      IF (NRLE.EQ.1)GOTO 90
      DO 30 I=1,NRLE
      FX=CRLE(I)
      IO=2*I-1
      CALL RDRLE(NFRLE,IO,LEN,T2)
      CALL DAXPY(LENTOT,FX,T2,1,O2,1)
 30   CONTINUE
      IF(MET.GT.1)CALL WO1(1,NO,NU,O2)
      CALL WO2(1,NO,NU,O2(INOU))
 90   CONTINUE
      NRLE=NRLE+1
      IF(NRLE.GT.NRLE0)NRLE=NRLE0
      IRLE =IRLE+1
      IF(IRLE.GT.NRLE)IRLE=1
      RETURN
      END
C
C*MODULE CCAUX   *DECK DODIIS
      SUBROUTINE DODIIS(ERR,AUGERR,TMP,NPHYS,NDIM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION ERR(NPHYS,NPHYS),AUGERR(NPHYS+1,NPHYS+2)
      DIMENSION TMP(*)
C
      CALL ZEROMA(AUGERR,1,(NPHYS+1)*(NPHYS+2))
      CALL BLKCPY(ERR,NPHYS,NPHYS,AUGERR,NPHYS+1,NPHYS+1,2,2)
      DO 10 I=2,NDIM+1
       AUGERR(I,1)=-1.0D+00
       AUGERR(1,I)=-1.0D+00
10    CONTINUE
      AUGERR(1,NDIM+2)=-1.0D+00
      CALL ZEROMA(AUGERR(2,NDIM+2),1,NDIM)
      CALL MINV(AUGERR,NDIM+1,NPHYS+1,TMP,DET,1)
      CALL DCOPY(NDIM,AUGERR(2,NDIM+2),1,TMP,1)
      RETURN
      END
C*MODULE CCAUX   *DECK MINV
      SUBROUTINE MINV(AB,N,LDA,SCRATCH,DET,M)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION AB(LDA,1),SCRATCH(1),X(2)
C
      IOFF=1+N
      CALL DGECO(AB,LDA,N,SCRATCH,X,SCRATCH(IOFF))
      IF(M.EQ.1)CALL DGESL(AB,LDA,N,SCRATCH,AB(1,N+1),0)
      IF(M.GT.1)THEN
       WRITE(6,1000)
1000   FORMAT(1X,'MINV: ONLY ONE SYSTEM CAN BE SOLVED AT A TIME.')
       CALL ABRT
      ENDIF
      IF(M.EQ.0)CALL DGEDI(AB,LDA,N,SCRATCH,X,SCRATCH(IOFF),11)
      DET=X(1)
      RETURN
      END
C
C          ORIGINALLY TRMD.F
C
C*MODULE CCAUX   *DECK TRMD
      SUBROUTINE TRMD(VP,TI,NU,NO,ID)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION VP(1),TI(1)
C
      NOU=NO*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,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40),ID
 1    CONTINUE
      CALL TRANMD(VP,NU,NO,NU,NO,24)
      GO TO 10000
 2    CONTINUE
      CALL TRANSQ(VP,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VP,12)
      GO TO 10000
 3    CONTINUE
      CALL TRANMD(VP,NU,NO,NU,NO,24)
      GO TO 10000
 4    CONTINUE
      CALL INSITU(NO,NU,NO,NU,TI,VP,12)
      CALL TRANSQ(VP,NOU)
      GO TO 10000
 5    CONTINUE
      CALL TRT1(NU,NO,TI,VP)
      GO TO 10000
 6    CONTINUE
      CALL TRANSQ(VP,NO)
      GO TO 10000
 7    CONTINUE
      CALL INSITU(NU,NO,NU,NO,TI,VP,23)
      CALL TRANMD(VP,NU,NU,NO,NO,34)
      GO TO 10000
 8    CONTINUE
      CALL TRANMD(VP,NU,NU,NO,NO,34)
      CALL INSITU(NU,NU,NO,NO,TI,VP,23)
      GO TO 10000
 9    CONTINUE
      CALL TRT1(NO,NU,TI,VP)
      GO TO 10000
 10   CONTINUE
      CALL INSITU(NO,NU,NU,NO,TI,VP,13)
      GO TO 10000
 11   CONTINUE
      CALL INSITU(NU,NU,NO,NO,TI,VP,13)
      CALL TRANSQ(VP,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VP,13)
      GO TO 10000
 12   CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,VP,13)
      CALL TRANSQ(VP,NOU)
      GO TO 10000
 13   CONTINUE
      CALL INSITU(NU,NO,NU,NO,TI,VP,23)
      GO TO 10000
 14   CONTINUE
      CALL INSITU(NO,NU,NO,NU,TI,VP,23)
      GO TO 10000
 15   CONTINUE
      CALL TRANMD(VP,NO,NO,NO,NO,14)
      GO TO 10000
 16   CONTINUE
      CALL MTRANS(VP,NO,23)
      GO TO 10000
 17   CONTINUE
      CALL TRANMD(VP,NO,NO,NU,NU,12)
      GO TO 10000
 18   CONTINUE
      CALL INSITU(NO,NU,NO,NU,TI,VP,12)
      CALL INSITU(NU,NO,NO,NU,TI,VP,13)
      GO TO 10000
 19   CONTINUE
      CALL MTRANS(VP,NU,5)
C      CALL MTRANS(VP,NU,1)
C      CALL TRANMD(VP,NU,NU,NU,NU,14)
      GO TO 10000
 20   CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,VP,13)
      CALL TRANSQ(VP,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VP,12)
      CALL TRANMD(VP,NU,NO,NU,NO,24)
      GO TO 10000
 21   CONTINUE
      CALL INSITU(NU,NU,NO,NO,TI,VP,23)
      CALL TRANMD(VP,NU,NO,NU,NO,13)
      GO TO 10000
 22   CONTINUE
      CALL TRANMD(VP,NO,NO,NO,NU,13)
      GO TO 10000
 23   CONTINUE
      CALL INSITU(NU,NO,NU,NO,TI,VP,12)
      CALL TRANMD(VP,NO,NU,NU,NO,14)
      CALL TRANSQ(VP,NOU)
      GO TO 10000
 24   CONTINUE
      CALL TRANSQ(VP,NOU)
      GO TO 10000
 25   CONTINUE
      CALL TRANMD(VP,NU,NU,NU,NO,13)
      GO TO 10000
 26   CONTINUE
      CALL INSITU(NO,NU,NU,NO,TI,VP,12)
      CALL TRANMD(VP,NU,NO,NU,NO,24)
      GO TO 10000
 27   CONTINUE
      CALL TRANMD(VP,NU,NO,NU,NO,24)
      CALL INSITU(NU,NO,NU,NO,TI,VP,12)
      CALL TRANMD(VP,NO,NU,NU,NO,23)
      GO TO 10000
 28   CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,VP,13)
      CALL TRANSQ(VP,NOU)
      CALL TRANMD(VP,NO,NU,NU,NO,23)
      GO TO 10000
 29   CONTINUE
      CALL TRANMD(VP,NO,NU,NU,NO,23)
      GO TO 10000
 30   CONTINUE
      CALL TRANMD(VP,NU,NO,NU,NO,13)
      GO TO 10000
 31   CONTINUE
      CALL INSITU(NO,NU,NU,NO,TI,VP,12)
      GO TO 10000
 32   CONTINUE
      CALL TRANMD(VP,NU,NO,NU,NO,13)
      GO TO 10000
 33   CONTINUE
      CALL TRANSQ(VP,NOU)
      CALL INSITU(NU,NO,NU,NO,TI,VP,12)
      GO TO 10000
 34   CONTINUE
      CALL TRANMD(VP,NO,NU,NU,NO,14)
      CALL TRANSQ(VP,NOU)
      CALL TRANMD(VP,NU,NO,NO,NU,14)
      GO TO 10000
 35   CONTINUE
      CALL TRANSQ(VP,NOU)
      CALL INSITU(NO,NU,NU,NO,TI,VP,12)
      GO TO 10000
 36   CONTINUE
      CALL TRANMD(VP,NU,NO,NU,NO,13)
      CALL INSITU(NU,NO,NU,NO,TI,VP,12)
      GO TO 10000
 37   CONTINUE
      CALL INSITU(NU,NO,NU,NO,TI,VP,12)
      GO TO 10000
 38   CONTINUE
      CALL TRANMD(VP,NU,NU,NU,NO,12)
      GO TO 10000
 39   CONTINUE
      CALL TRANSQ(VP,NOU)
      CALL INSITU(NU,NO,NO,NU,TI,VP,13)
      GO TO 10000
 40   CONTINUE
      CALL INSITU(NO,NO,NU,NU,TI,VP,13)
      CALL TRANMD(VP,NU,NO,NO,NU,23)
      CALL TRANSQ(VP,NOU)
      GO TO 10000
10000 CONTINUE
      RETURN
      END
C
C          ORIGINALLY REST.F
C
C*MODULE CCAUX   *DECK DRREST
      SUBROUTINE DRREST(IOPT,NO,NU,TREST,ITREST)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TREST(*),ITREST(*)
C        SIZE OF TREST IS NO2U2, ITREST IS NOU
C
      IF(IOPT.EQ.0)THEN
         CALL REARES(NO,NU,TREST,ITREST)
      ELSE
         CALL WRIRES(NO,NU,TREST,ITREST)
      ENDIF
      RETURN
      END
C*MODULE CCAUX   *DECK REAPAKRES
      SUBROUTINE REAPAKRES(IADR,NINT,VEC,IVEC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VEC(1),IVEC(1)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      N=NINT
      LREC=NRESL
      NREC=N/LREC+1
      NOFF=0
      IF (NREC.EQ.1)THEN
         IREC=IADR
         CALL RRRES(IREC,N,VEC,IVEC)
      ELSE
      DO 10 IR=1,NREC-1
         IREC=IADR+IR-1
         CALL RRRES(IREC,LREC,VEC(NOFF+1),IVEC(NOFF+1))
         NOFF=NOFF+LREC
 10   CONTINUE
      IREST=N-(NREC-1)*LREC
      IREC=IADR+NREC-1
      CALL RRRES(IREC,IREST,VEC(NOFF+1),IVEC(NOFF+1))
      ENDIF
      IADR=IREC+1
      RETURN
      END
C*MODULE CCAUX   *DECK WRIRES
      SUBROUTINE WRIRES(NO,NU,T,IT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T(*),IT(*)
      DIMENSION ISZ(3)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NOU   = NO*NU
      NO2U2 = NOU*NOU
C
      IAD=2
      CALL RO1(1,NO,NU,T)
      CALL STORE(NOU,NNN,T,IT)
      ISZ(1)=NNN
      IF(NNN.GT.0) THEN
         CALL VRIPAKRES(IAD,NNN,T,IT)
      ELSE
         IAD=IAD+1
      END IF
C
      CALL RO2(1,NO,NU,T)
      CALL STORE(NO2U2,NNN,T,IT)
      ISZ(2)=NNN
      CALL VRIPAKRES(IAD,NNN,T,IT)
C
      ISZ(3)=0
      WRITE(NRESF,REC=1) ISZ
      RETURN
      END
C*MODULE CCAUX   *DECK REARES
      SUBROUTINE REARES(NO,NU,T,IT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION T(1),IT(1)
      DIMENSION ISZ(3)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      DATA ZERO/0.0D+00/
C
      NOU  = NO*NU
      NO2U2= NOU*NOU
      READ(NRESF,REC=1) ISZ
      IAD=2
      NNN=ISZ(1)
C
      IF(MET.GT.1  .AND.  NNN.GT.0) THEN
         CALL REAPAKRES(IAD,NNN,T,IT)
         IF (TSH.GT.ZERO)CALL THRSHSEL(NNN,T)
         CALL SCATTR(NOU,NNN,T,IT)
      ELSE
         IAD=IAD+1
         CALL ZEROMA(T,1,NOU)
      ENDIF
      CALL WO1(1,NO,NU,T)
C
      NNN=ISZ(2)
      CALL REAPAKRES(IAD,NNN,T,IT)
      IF (TSH.GT.ZERO)CALL THRSHSEL(NNN,T)
      CALL SCATTR(NO2U2,NNN,T,IT)
      CALL WO2(1,NO,NU,T)
      RETURN
      END
C*MODULE CCAUX   *DECK THRSHSEL
      SUBROUTINE THRSHSEL(N,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N)
      COMMON /CCINFO/ TSH,NH,NP,MET,MEM,ICONV,MAXIT,IREST,IDISC
      DATA ZERO/0.0D+00/
C
      DO I=1,N
         IF(ABS(A(I)).LT.TSH) A(I)=ZERO
      ENDDO
      RETURN
      END
C*MODULE CCAUX   *DECK VRIPAKRES
      SUBROUTINE VRIPAKRES(IADR,N,VEC,IVEC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VEC(*),IVEC(*)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      LREC=NRESL
      NREC=N/LREC+1
      NOFF=0
      IF (NREC.EQ.1)THEN
         IREC=IADR
         CALL WWRES(IREC,N,VEC,IVEC)
      ELSE
         DO 10 IR=1,NREC-1
            IREC=IADR+IR-1
            CALL WWRES(IREC,LREC,VEC(NOFF+1),IVEC(NOFF+1))
            NOFF=NOFF+LREC
 10      CONTINUE
         IREST=N-(NREC-1)*LREC
         IREC=IADR+NREC-1
         CALL WWRES(IREC,IREST,VEC(NOFF+1),IVEC(NOFF+1))
      ENDIF
      IADR=IREC+1
      RETURN
      END
C*MODULE CCAUX   *DECK SCATTR
      SUBROUTINE SCATTR(N,NN,B,IB)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION B(*),IB(*)
      DATA ZERO/0.0D+00/
C
      ID1=N-IB(NN)
      DO 10 I=NN,1,-1
         IBI=IB(I)
         B(IBI)=B(I)
         DO 11 J=1,ID1
            B(IBI+J)=ZERO
 11      CONTINUE
         ID1=IB(I)-IB(I-1)-1
 10   CONTINUE
      B(IB(1))=B(1)
      IB1=IB(1)-1
      DO 12 I=1,IB1
         B(I)=ZERO
 12   CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK STORE
      SUBROUTINE STORE(N,NN,B,IB)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION B(N),IB(N)
      DATA TR/0.1D-12/
C
      IN=0
      DO 10 I =1,N
         X=B(I)
         IF (ABS(X).GT.TR)THEN
            IN=IN+1
            B(IN)=X
            IB(IN)=I
         ENDIF
 10   CONTINUE
      NN=IN
      RETURN
      END
C*MODULE CCAUX   *DECK CCMATMUL
      SUBROUTINE CCMATMUL(A,B,C,NI,NJ,NK,IACC,IFUN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NI,NK),B(NK,NJ),C(NI,NJ)
      DOUBLE PRECISION MONE
      DATA ONE,ZERO,MONE/1.0D+0,0.0D+0,-1.0D+0/
C
C     this is just an interface to dgemm MATRIX MULTIPLY ROUTINE.
C
C     DEPENDING ON THE VALUES OF IACC AND IFUN, FOUR SORTS
C     OF MATRIX MULTIPLICATIONS MAY BE CARRIED OUT :
C
C     IACC=  0, IFUN= 0    C = C + A*B
C     IACC=  0, IFUN><0    C = C - A*B
C     IACC=><0, IFUN= 0    C =     A*B
C     IACC=><0, IFUN><0    C =   - A*B
C
      IF (IACC.EQ.0.AND.IFUN.EQ.0) THEN
         ALPHA=ONE
         BETA=ONE
      ELSE
      IF (IACC.EQ.0.AND.IFUN.NE.0) THEN
         ALPHA=MONE
         BETA=ONE
      ELSE
      IF (IACC.NE.0.AND.IFUN.EQ.0) THEN
         ALPHA=ONE
         BETA=ZERO
      ELSE
         ALPHA=MONE
         BETA=ZERO
      ENDIF
      ENDIF
      ENDIF
C
      CALL DGEMM('N','N',NI,NJ,NK,ALPHA,A,NI,B,NK,BETA,C,NI)
      RETURN
      END
C*MODULE CCAUX   *DECK CCMATMULT
      SUBROUTINE CCMATMULT(A,B,C,NI,NJ,NK,IACC,IFUN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NI,NK),B(NK,NJ),C(NI,NJ)
      DOUBLE PRECISION MONE
      DATA ONE,ZERO,MONE/1.0D+0,0.0D+0,-1.0D+0/
C
C     this is just an interface to dgemm MATRIX MULTIPLY ROUTINE.
C
C     THE ARGUMENT TOL IS NOT USED. IN THE VAX VERSION IT
C     IS A TOLERANCE FOR SAXPYS.
C
C     DEPENDING ON THE VALUES OF IACC AND IFUN, FOUR SORTS
C     OF MATRIX MULTIPLICATIONS MAY BE CARRIED OUT :
C
C     IACC=  0, IFUN= 0    C = C + A*B
C     IACC=  0, IFUN><0    C = C - A*B
C     IACC=><0, IFUN= 0    C =     A*B
C     IACC=><0, IFUN><0    C =   - A*B
C
      IF (IACC.EQ.0.AND.IFUN.EQ.0) THEN
         ALPHA=ONE
         BETA=ONE
      ELSE
      IF (IACC.EQ.0.AND.IFUN.NE.0) THEN
         ALPHA=MONE
         BETA=ONE
      ELSE
      IF (IACC.NE.0.AND.IFUN.EQ.0) THEN
         ALPHA=ONE
         BETA=ZERO
      ELSE
         ALPHA=MONE
         BETA=ZERO
      ENDIF
      ENDIF
      ENDIF
C
      CALL DGEMM('N','T',NI,NJ,NK,ALPHA,A,NI,B,NJ,BETA,C,NI)
      RETURN
      END
C*MODULE CCAUX   *DECK CCTMATMUL
      SUBROUTINE CCTMATMUL(A,B,C,NI,NJ,NK,IACC,IFUN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NI,NK),B(NK,NJ),C(NI,NJ)
      DOUBLE PRECISION MONE
      DATA ONE,ZERO,MONE/1.0D+0,0.0D+0,-1.0D+0/
C
C     this is just an interface to dgemm MATRIX MULTIPLY ROUTINE.
C
C     DEPENDING ON THE VALUES OF IACC AND IFUN, FOUR SORTS
C     OF MATRIX MULTIPLICATIONS MAY BE CARRIED OUT :
C
C     IACC=  0, IFUN= 0    C = C + A*B
C     IACC=  0, IFUN><0    C = C - A*B
C     IACC=><0, IFUN= 0    C =     A*B
C     IACC=><0, IFUN><0    C =   - A*B
C
      IF (IACC.EQ.0.AND.IFUN.EQ.0) THEN
         ALPHA=ONE
         BETA=ONE
      ELSE
      IF (IACC.EQ.0.AND.IFUN.NE.0) THEN
         ALPHA=MONE
         BETA=ONE
      ELSE
      IF (IACC.NE.0.AND.IFUN.EQ.0) THEN
         ALPHA=ONE
         BETA=ZERO
      ELSE
         ALPHA=MONE
         BETA=ZERO
      ENDIF
      ENDIF
      ENDIF
C
      CALL DGEMM('T','N',NI,NJ,NK,ALPHA,A,NK,B,NK,BETA,C,NI)
      RETURN
      END
C
C*MODULE CCAUX   *DECK CCTMATMULT
      SUBROUTINE CCTMATMULT(A,B,C,NI,NJ,NK,IACC,IFUN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NI,NK),B(NK,NJ),C(NI,NJ)
      DOUBLE PRECISION MONE
      DATA ONE,ZERO,MONE/1.0D+0,0.0D+0,-1.0D+0/
C
C   CALL MAX BOARD MATRIX MULTIPLY ROUTINE.
C
C     THE ARGUMENT TOL IS NOT USED. IN THE VAX VERSION IT
C     IS A TOLERANCE FOR SAXPYS.
C
C     DEPENDING ON THE VALUES OF IACC AND IFUN, FOUR SORTS
C     OF MATRIX MULTIPLICATIONS MAY BE CARRIED OUT :
C
C     IACC=  0, IFUN= 0    C = C + A*B
C     IACC=  0, IFUN><0    C = C - A*B
C     IACC=><0, IFUN= 0    C =     A*B
C     IACC=><0, IFUN><0    C =   - A*B
C
      IF (IACC.EQ.0.AND.IFUN.EQ.0) THEN
         ALPHA=ONE
         BETA=ONE
      ELSE
      IF (IACC.EQ.0.AND.IFUN.NE.0) THEN
         ALPHA=MONE
         BETA=ONE
      ELSE
      IF (IACC.NE.0.AND.IFUN.EQ.0) THEN
         ALPHA=ONE
         BETA=ZERO
      ELSE
         ALPHA=MONE
         BETA=ZERO
      ENDIF
      ENDIF
      ENDIF
C
      CALL DGEMM('T','T',NI,NJ,NK,ALPHA,A,NK,B,NJ,BETA,C,NI)
      RETURN
      END
C
C*MODULE CCAUX   *DECK FIXSYM
      SUBROUTINE FIXSYM(NO,NU,R1,R2,SYM)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION R1(NO,NU),R2(NO,NU,NU,NO)
      CHARACTER*3 SYM,REP
      DIMENSION IVEC1(8),IVEC2(8)
C
      PARAMETER (MXAO=8192)
C
      COMMON /EOMSYM/ IG,NRE(4),MC(8,8,4),ISORB(MXAO),REP(8)
C
      TOL=0.10D+00
      DO 100 I=1,8
        IVEC1(I)=0
        IVEC2(I)=0
 100  CONTINUE
      IFIND=0
      DO 1,I=1,NO
      DO 1,IA=1,NU
       XXX=ABS(R1(I,IA))
       IF(XXX.GT.TOL) THEN
       IFIND=0
         DO 6 K=1,NRE(IG)
          IVEC1(K)=MC(K,ISORB(I),IG)*MC(K,ISORB(NO+IA),IG)
 6       CONTINUE
         DO 7,JSYM=1,NRE(IG)
           DO 8,III=1,NRE(IG)
            IVEC2(III)=MC(III,JSYM,IG)
 8         CONTINUE
           IDIFF=0
           DO 9,III=1,8
            IDIFF=IDIFF+ABS(IVEC1(III)-IVEC2(III))
 9         CONTINUE
           IF(IDIFF.EQ.0) THEN
            IFIND=1
            SYM=REP(JSYM)
            RETURN
           END IF
 7       CONTINUE
       END IF
 1    CONTINUE
C
      IF(IFIND.NE.0) GO TO 111
      DO 11,I=1,NO
      DO 11,J=1,NO
      DO 11,IA=1,NU
      DO 11,IB=1,NU
       XXX=ABS(R2(I,IA,IB,J))
       IF(XXX.GT.TOL) THEN
         DO 12 K=1,NRE(IG)
          IVEC1(K)=MC(K,ISORB(I),IG)*MC(K,ISORB(J),IG)*
     &             MC(K,ISORB(IA+NO),IG)*MC(K,ISORB(IB+NO),IG)
 12      CONTINUE
         DO 27,JSYM=1,NRE(IG)
           DO 28,III=1,NRE(IG)
            IVEC2(III)=MC(III,JSYM,IG)
 28        CONTINUE
           IDIFF=0
           DO 29,III=1,8
            IDIFF=IDIFF+ABS(IVEC1(III)-IVEC2(III))
 29        CONTINUE
           IF(IDIFF.EQ.0) THEN
            IFIND=1
            SYM=REP(JSYM)
            RETURN
           END IF
 27      CONTINUE
       END IF
 11   CONTINUE
C
 111  CONTINUE
      RETURN
      END
C
C*MODULE CCAUX   *DECK INDEXX
       SUBROUTINE INDEXX(N,ARR,INDX,M,ISTACK,NSTACK)
       INTEGER N,INDX(N),M,NSTACK
       DOUBLE PRECISION ARR(N)
       INTEGER ISTACK(NSTACK)
       DOUBLE PRECISION A
C
       DO 11,J=1,N
        INDX(J)=J
 11    CONTINUE
       JSTACK=0
       L=1
       IR=N
 1     IF(IR-L.LT.M) THEN
        DO 13,J=L+1,IR
         INDXT=INDX(J)
         A=ARR(INDXT)
         DO 12,I=J-1,L,-1
          IF(ARR(INDX(I)).LE.A) GO TO 2
          INDX(I+1)=INDX(I)
 12      CONTINUE
         I=L-1
 2       INDX(I+1)=INDXT
 13     CONTINUE
C
        IF(JSTACK.EQ.0) RETURN
        IR=ISTACK(JSTACK)
        L=ISTACK(JSTACK-1)
        JSTACK=JSTACK-2
       ELSE
        K=(L+IR)/2
        ITEMP=INDX(K)
        INDX(K)=INDX(L+1)
        INDX(L+1)=ITEMP
        IF(ARR(INDX(L)).GT.ARR(INDX(IR))) THEN
         ITEMP=INDX(L)
         INDX(L)=INDX(IR)
         INDX(IR)=ITEMP
        ENDIF
        IF(ARR(INDX(L+1)).GT.ARR(INDX(IR))) THEN
         ITEMP=INDX(L+1)
         INDX(L+1)=INDX(IR)
         INDX(IR)=ITEMP
        ENDIF
        IF(ARR(INDX(L)).GT.ARR(INDX(L+1))) THEN
         ITEMP=INDX(L)
         INDX(L)=INDX(L+1)
         INDX(L+1)=ITEMP
        END IF
        I=L+1
        J=IR
        INDXT=INDX(L+1)
        A=ARR(INDXT)
 3      CONTINUE
            I=I+1
        IF(ARR(INDX(I)).LT.A) GO TO 3
 4      CONTINUE
            J=J-1
        IF(ARR(INDX(J)).GT.A) GO TO 4
        IF(J.LT.I) GO TO 5
        ITEMP=INDX(I)
        INDX(I)=INDX(J)
        INDX(J)=ITEMP
        GO TO 3
 5      INDX(L+1)=INDX(J)
        INDX(J)=INDXT
        JSTACK=JSTACK+2
        IF(JSTACK.GT.NSTACK) THEN
          WRITE(6,*)'NSTACK TOO SMALL IN INDEXX'
          CALL FLSHBF(6)
          CALL ABRT
        END IF
        IF(IR-I+1.GE.J-L) THEN
         ISTACK(JSTACK)=IR
         ISTACK(JSTACK-1)=I
         IR=J-1
        ELSE
         ISTACK(JSTACK)=J-1
         ISTACK(JSTACK-1)=L
         L=1
        ENDIF
       ENDIF
       GO TO 1
       END
C
C          I/O ROUTINES
C
C*MODULE CCAUX   *DECK WRRLE
      SUBROUTINE WRRLE(NF,IR,N,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N)
C
      WRITE(NF,REC=IR)A
      RETURN
      END
C*MODULE CCAUX   *DECK RDRLE
      SUBROUTINE RDRLE(NF,IR,N,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N)
C
      READ(NF,REC=IR)A
      RETURN
      END
C*MODULE CCAUX   *DECK WWRES
      SUBROUTINE WWRES(IR,N,V,IV)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(N),IV(N)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      WRITE(NRESF,REC=IR) V,IV
      RETURN
      END
C*MODULE CCAUX   *DECK RRRES
      SUBROUTINE RRRES(IR,N,V,IV)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(N),IV(N)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      READ(NRESF,REC=IR) V,IV
      RETURN
      END
C*MODULE CCAUX   *DECK WRVE
      SUBROUTINE WRVE(NR,NO,NU,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VE(NU,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NU3=NU*NU*NU
      LAST=NO*(NR-1)
      DO I=1,NO
         IR=LAST+I
         CALL WCCFL(NVE,IR,NU3,VE(1,1,1,I))
      ENDDO
      RETURN
      END
C*MODULE CCAUX   *DECK RDVE
      SUBROUTINE RDVE(NR,NO,NU,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VE(NU,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NU3=NU*NU*NU
      LAST=NO*(NR-1)
      DO I=1,NO
         IR=LAST+I
         CALL RCCFL(NVE,IR,NU3,VE(1,1,1,I))
      ENDDO
      RETURN
      END
C*MODULE CCAUX   *DECK RDVVE
      SUBROUTINE RDVVE(I,NR,NO,NU,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VE(NU,NU,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NU3=NU*NU*NU
      IR=NO*(NR-1)+I
      CALL RCCFL(NVE,IR,NU3,VE)
      RETURN
      END
C*MODULE CCAUX   *DECK WRVM
      SUBROUTINE WRVM(NR,NO,NU,VM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VM(NO,NO,NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      WRITE(NVM,REC=NR) VM
      RETURN
      END
C*MODULE CCAUX   *DECK RDVM
      SUBROUTINE RDVM(NR,NO,NU,VM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VM(NO,NO,NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      READ(NVM,REC=NR) VM
      RETURN
      END
C*MODULE CCAUX   *DECK RDVE3
      SUBROUTINE RDVE3(NR,NO,NU,TI,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VE(NU,NU,NO,NU),TI(NU,NU,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NU3=NU*NU*NU
      LAST=NO*(NR-1)
      DO 1 I=1,NO
      IR=LAST+I
      CALL RCCFL(NVE,IR,NU3,TI)
      DO 10 J=1,NU
      DO 10 K=1,NU
      DO 10 L=1,NU
      VE(J,K,I,L)=VE(J,K,I,L)+TI(J,K,L)
 10   CONTINUE
 1    CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK RDVEM3
      SUBROUTINE RDVEM3(IN,NO,NU,TI,VEM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C
      DIMENSION TI(NU,NU,NU),VEM(NU,NU,NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NLAST=3*NO
      DO 1 I=1,NO
      IASV=NLAST+NU*IN+I
      READ(INTG,REC=IASV)TI
      DO 1 A=1,NU
      DO 1 B=1,NU
      DO 1 C=1,NU
      VEM(A,B,I,C)=TI(A,B,C)
 1    CONTINUE
      RETURN
      END
C 06/23/2004 QUADRUPLES ----
C*MODULE CCAUX   *DECK RDVEM3X
      SUBROUTINE RDVEM3X(IN,NO,NU,TI,VEM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C
      DIMENSION TI(NU,NU,NU),VEM(NU,NU,NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NNO=NO
      IF(IN.EQ.1)NNO=NU
      NLAST=3*NNO
      DO 1 I=1,NO
      IASV=NLAST+NU*IN+I
      READ(INTG,REC=IASV)TI
      DO 1 A=1,NU
      DO 1 B=1,NU
      DO 1 C=1,NU
      VEM(A,B,I,C)=TI(A,B,C)
 1    CONTINUE
      RETURN
      END
C ----------------------------
C*MODULE CCAUX   *DECK RDVEM4
      SUBROUTINE RDVEM4(IN,NO,NU,TI,VEM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C
      DIMENSION TI(NU,NU,NU),VEM(NU,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NNO=NO
      IF (IN.EQ.1) NNO=NU
      NLAST=3*NNO
      DO 1 I=1,NO
      IASV=NLAST+NU*IN+I
      READ(INTG,REC=IASV)TI
      DO 1 A=1,NU
      DO 1 B=1,NU
      DO 1 C=1,NU
      VEM(A,B,C,I)=TI(A,B,C)
 1    CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK RDOV4
      SUBROUTINE RDOV4(INO,NO,NU,TI,V)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B,C,D
      DIMENSION TI(NU,NU,NU),V(NU,NU,NU,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NNO=NO
      NNU=NU
      INN=INO
      IF(INO.EQ.1.OR.INO.EQ.11)THEN
      NNO=NU
      NNU=NO
      ENDIF
      NLAST=4*NNO+NNU
      IF (INO.GE.10) THEN
      INN=INO-10
      NLAST=6*NNO+3*NNU+7
      ENDIF
      INO1=1-INN
      DO 1 A=1,NU
      IASV=NLAST+INO1*NNO+A
      READ(INTG,REC=IASV)TI
      DO 1 B=1,NU
      DO 1 C=1,NU
      DO 1 D=1,NU
      V(D,C,B,A)=TI(B,C,D)
 1    CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK WRVPP
      SUBROUTINE WRVPP(A,NU,VPP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A
      DIMENSION VPP(NU,NU,NU)
      COMMON /EOMFIL/ NSTAR,NC1,NC2,NHC1,NHC2,NHH,NPP,NAX,NAXX,NDIAG,
     *                ITAPP,IFAX,NRR1,NRR2,NEXM,NEXE,NW2C,NW4C,
     *                NW4D,NW2BD,NW4B,NROO,NREXM,NREXE,
     *                JCISD,KCIF,JCISDNX
C
      IAS=A
      WRITE(NPP,REC=IAS) VPP
      RETURN
      END
C*MODULE CCAUX   *DECK RDVPP
      SUBROUTINE RDVPP(A,NO,NU,VPP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A
      DIMENSION VPP(NU,NU,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      IAS=5*NO+NU+A
      READ(INTG,REC=IAS) VPP
      CALL TRANT3(VPP,NU,4)
      RETURN
      END
C*MODULE CCAUX   *DECK RDVPPT
      SUBROUTINE RDVPPT(A,NO,NU,VPP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A
      DIMENSION VPP(NU,NU,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      IAS=5*NO+NU+A
      READ(INTG,REC=IAS) VPP
      RETURN
      END
C*MODULE CCAUX   *DECK RDVPPI
      SUBROUTINE RDVPPI(A,NU,VPP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER A
      DIMENSION VPP(NU,NU,NU)
      COMMON /EOMFIL/ NSTAR,NC1,NC2,NHC1,NHC2,NHH,NPP,NAX,NAXX,NDIAG,
     *                ITAPP,IFAX,NRR1,NRR2,NEXM,NEXE,NW2C,NW4C,
     *                NW4D,NW2BD,NW4B,NROO,NREXM,NREXE,
     *                JCISD,KCIF,JCISDNX
C
      IAS=A
      READ(NPP,REC=IAS) VPP
      RETURN
      END
C*MODULE CCAUX   *DECK RO2HPP
      SUBROUTINE RO2HPP(INO,NO,NU,TI,T2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER A,B
      DIMENSION TI(NU,NU,NO),T2(NO,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NLAST=0
      INN=INO
      IF(INO.GE.10) THEN
      INN=INO-10
      NLAST=6*NO+4*NU+7
      ENDIF
      DO 1 I=1,NO
      IASV=NLAST+I+INN*NO
      READ(INTG,REC=IASV)TI
      DO 1 J=1,NO
      DO 1 A=1,NU
      DO 1 B=1,NU
      T2(I,A,B,J)=TI(A,B,J)
 1    CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK WRT3
      SUBROUTINE WRT3(KK,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
      WRITE(NT3,REC=KK) T3
      RETURN
      END
C*MODULE CCAUX   *DECK RDT3
      SUBROUTINE RDT3(KK,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
      READ(NT3,REC=KK) T3
      RETURN
      END
C*MODULE CCAUX   *DECK WSTAR
      SUBROUTINE WSTAR(IR,N,A)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(N)
      COMMON /EOMFIL/ NSTAR,NC1,NC2,NHC1,NHC2,NHH,NPP,NAX,NAXX,NDIAG,
     *                ITAPP,IFAX,NRR1,NRR2,NEXM,NEXE,NW2C,NW4C,
     *                NW4D,NW2BD,NW4B,NROO,NREXM,NREXE,
     *                JCISD,KCIF,JCISDNX
C
      WRITE(NSTAR,REC=IR) A
      RETURN
      END
C*MODULE CCAUX   *DECK RSTAR
      SUBROUTINE RSTAR(IR,N,A)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(N)
      COMMON /EOMFIL/ NSTAR,NC1,NC2,NHC1,NHC2,NHH,NPP,NAX,NAXX,NDIAG,
     *                ITAPP,IFAX,NRR1,NRR2,NEXM,NEXE,NW2C,NW4C,
     *                NW4D,NW2BD,NW4B,NROO,NREXM,NREXE,
     *                JCISD,KCIF,JCISDNX
C
      READ(NSTAR,REC=IR) A
      RETURN
      END
C*MODULE CCAUX   *DECK WO1
      SUBROUTINE WO1(NR,NO,NU,O1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      WRITE(NT1,REC=NR) O1
      RETURN
      END
C*MODULE CCAUX   *DECK RO1
      SUBROUTINE RO1(NR,NO,NU,O1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      READ(NT1,REC=NR) O1
      RETURN
      END
C*MODULE CCAUX   *DECK WO2
      SUBROUTINE WO2(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
      WRITE(NT2,REC=NR) T2
      RETURN
      END
C*MODULE CCAUX   *DECK RO2
      SUBROUTINE RO2(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*MODULE CCAUX   *DECK WCCFL
      SUBROUTINE WCCFL(NFL,IR,LN,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(LN)
      WRITE(NFL,REC=IR) A
      RETURN
      END
C*MODULE CCAUX   *DECK RCCFL
      SUBROUTINE RCCFL(NFL,IR,LN,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(LN)
      READ(NFL,REC=IR) A
      RETURN
      END
C
C*MODULE CCAUX   *DECK WREXXVE
      SUBROUTINE WREXXVE(NR,NO,NU,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VE(NU,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NU3=NU*NU*NU
      LAST=NO*(NR-1)
      DO 1 I=1,NO
      IR=LAST+I
      CALL WCCFL(NVE,IR,NU3,VE(1,1,1,I))
 1    CONTINUE
      RETURN
      END
C
C*MODULE CCAUX   *DECK REXXVE
      SUBROUTINE REXXVE(NR,NO,NU,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VE(NU,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NU3=NU*NU*NU
      LAST=NO*(NR-1)
      DO 1 I=1,NO
      IR=LAST+I
      CALL RCCFL(NVE,IR,NU3,VE(1,1,1,I))
 1    CONTINUE
      RETURN
      END
C
C*MODULE CCAUX   *DECK EXWRVE
      SUBROUTINE EXWRVE(NR,NO,NU,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VE(NU,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NU3=NU*NU*NU
      LAST=NO*(NR-1)
      DO 1 I=1,NO
      IR=LAST+I
      CALL WCCFL(NVE,IR,NU3,VE(1,1,1,I))
 1    CONTINUE
      RETURN
      END
C*MODULE CCAUX   *DECK EXRDVE
      SUBROUTINE EXRDVE(NR,NO,NU,VE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VE(NU,NU,NU,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NU3=NU*NU*NU
      LAST=NO*(NR-1)
      DO 1 I=1,NO
      IR=LAST+I
      CALL RCCFL(NVE,IR,NU3,VE(1,1,1,I))
 1    CONTINUE
      RETURN
      END
C
C*MODULE CCAUX   *DECK WREXXVM
      SUBROUTINE WREXXVM(NR,NO,NU,VM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VM(NO,NO,NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      WRITE(NVM,REC=NR)VM
      RETURN
      END
C
C*MODULE CCAUX   *DECK REXXVM
      SUBROUTINE REXXVM(NR,NO,NU,VM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VM(NO,NO,NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      READ(NVM,REC=NR)VM
      RETURN
      END
C
C*MODULE CCAUX   *DECK EXWRVM
      SUBROUTINE EXWRVM(NR,NO,NU,VM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VM(NO,NO,NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      WRITE(NVM,REC=NR)VM
      RETURN
      END
C
C*MODULE CCAUX   *DECK EXRDVM
      SUBROUTINE EXRDVM(NR,NO,NU,VM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VM(NO,NO,NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      READ(NVM,REC=NR)VM
      RETURN
      END
C
C*MODULE CCAUX   *DECK R4C
      SUBROUTINE R4C(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
      NRX=11
      READ(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK W4C
      SUBROUTINE W4C(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
      NRX=11
      WRITE(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK R4D
      SUBROUTINE R4D(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
      NRX=12
      READ(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK W4D
      SUBROUTINE W4D(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
      NRX=12
      WRITE(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK R2BD
      SUBROUTINE R2BD(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
      NRX=13
      READ(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK W2BD
      SUBROUTINE W2BD(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
      NRX=13
      WRITE(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK R2C
      SUBROUTINE R2C(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
      NRX=10
      READ(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK W2C
      SUBROUTINE W2C(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
      NRX=10
      WRITE(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK R4B
      SUBROUTINE R4B(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
      NRX=14
      READ(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK W4B
      SUBROUTINE W4B(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
      NRX=14
      WRITE(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK ROO1
      SUBROUTINE ROO1(NO,NU,O1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NRX=7
      READ(NT1,REC=NRX)O1
      RETURN
      END
C
C*MODULE CCAUX   *DECK WOO1
      SUBROUTINE WOO1(NO,NU,O1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NRX=7
      WRITE(NT1,REC=NRX)O1
      RETURN
      END
C
C*MODULE CCAUX   *DECK WRR1
      SUBROUTINE WRR1(NO,NU,O1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NRX=6
      WRITE(NT1,REC=NRX)O1
      RETURN
      END
C
C*MODULE CCAUX   *DECK RR1
      SUBROUTINE RR1(NO,NU,O1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION O1(NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
      NRX=6
      READ(NT1,REC=NRX)O1
      RETURN
      END
C
C*MODULE CCAUX   *DECK WRR2
      SUBROUTINE WRR2(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
      NRX=9
      WRITE(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK RR2
      SUBROUTINE RR2(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
      NRX=9
      READ(NT2,REC=NRX)T2
      RETURN
      END
C
C*MODULE CCAUX   *DECK XRF
      SUBROUTINE XRF(NO,NU,FHP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION FHP(NO,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
C        RF READS ONLY FHP
C
      NLAST=5*NO+2*NU
      READ(INTG,REC=NLAST+3)FHP
      RETURN
      END
C
C*MODULE CCAUX   *DECK RFHH
      SUBROUTINE RFHH(NO,NU,FHH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION FHH(NO,NO)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
C        RFHH READS ONLY FHH
C
      NLAST=5*NO+2*NU
      READ(INTG,REC=NLAST+1)FHH
      RETURN
      END
C
C*MODULE CCAUX   *DECK RFPP
      SUBROUTINE RFPP(NO,NU,FPP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION FPP(NU,NU)
      COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL
C
C        RFPP READS ONLY FPP
C
      NLAST=5*NO+2*NU
      READ(INTG,REC=NLAST+2)FPP
      RETURN
      END
