C  2 FEB 06 - MWS - DON'T OVERWRITE GUGA CI'S IROOT IN DETWFN COMMON
C 14 NOV 05 - DGF - PAD COMMON BLOCK ENRGYS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  1 JUN 05 - MWS - GUG2DM: SA-MC DERIV. TRAP ALLOWS NUM. DIFFERENCING
C  5 FEB 05 - MWS - GUG2DM: IROOT PICKS MCSCF SPECIFIC STATE ENERGY
C  7 SEP 04 - MWS - PAD COMMON BLOCK INTFIL
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  3 SEP 03 - MWS - LBLDM2: ALWAYS WRITE RECORD 320
C 19 SEP 01 - MWS - CONVERT MXAOCI PARAMTER TO MXAO
C  6 SEP 01 - MWS - GUG2DM: ADD BACKDOOR TO PERMIT DEGENERATE STATE OPTS
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER
C 21 DEC 99 - MWS - MAKE GUGWFN COMMON CONSISTENT
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C  6 JAN 98 - MWS - CHANGE CALL TO RACLOS
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C  3 FEB 97 - MWS - LBLDM2: CHECK FOR EMPTY ACTIVE ORBITALS ADDED
C  8 JAN 97 - GMC - GUG2DM,ORD2DM,LBLDM2: CHANGES FOR DROPPING MCC ORBS
C 26 NOV 96 - VAG - INCREASE CI AO'S TO 768
C 30 OCT 96 - MWS - LBLDM2: DEBUG INSERTION OF CORE DENSITY VALUES
C 23 OCT 96 - SPW - LBLDM2: ALWAYS WRITE 1-PARTICLE DENSITY TO DAF
C 17 OCT 96 - MWS - LBLDM2: MOVE 1E- PARTS BELOW INTEGRAL GROUP LOOP
C 29 SEP 96 - GMC - LBLDM2: GLOBAL SUM BEFORE CORE TERMS IN 1PDM
C 19 SEP 96 - KRG - ADDED SOME ERROR MESSAGES BEFORE ABRT CALLS
C 22 JUN 96 - GMC - LBLDM2: CHANGES FOR FOCAS CORE DENSITY
C 31 MAY 95 - MWS - GUG2DM: USE DERCHK CALL
C 25 JAN 95 - MWS - LBLDM2: FIX VAX PACKING BUG
C 10 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  9 AUG 94 - MWS - ORDD2C,LBLDM2,ORDDMA,ORDDMB: DOUBLE LABEL PACKING
C 13 DEC 93 - TLW - ORDD2C,LBLDM2: GLOBAL SUM DENSITY MATRICES
C 16 JUL 93 - MWS - INCREASE MAXIMUM CI ROOTS TO 100
C  2 APR 92 - MWS,TLW - COMMON ENRGYS MADE PURE FLOATING POINT
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C 11 JAN 92 - TLW - MAKE READS PARALLEL
C 10 JAN 92 - TLW - CHANGE REWINDS TO CALL SEQREW
C  6 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR
C  7 OCT 91 - MWS - CHANGE UNIX BYTE UNPACKING
C  3 JUN 90 - JAM - CHANGE VAX BYTE PACKING TO FULL 8 BITS
C 15 DEC 89 - MWS - CALL TO LOOPY USES IH20, NOT I20
C 12 DEC 89 - MWS - GUG2DM: USE /ORBSET/ TO REPLACE /DRTBUF/ IN
C 23 OCT 89 - MWS - DELETE /FUNCT/ SAVE
C 26 SEP 89 - MWS - ADD NFT13,NFT14 TO /CIFILS/
C 12 AUG 89 - MWS - ORDDMA,ORDDMB: REMOVE STORAGE OVERLAP BUGS
C 28 APR 89 - MWS - COPY MICHEL'S STATE AVERAGING FROM HONDO7,
C                   GENERAL CLEANUP, ELIMINATING /DM2BUF/.
C 28 MAR 89 - MWS - ORD2DM: EXETYP=CHECK NOW CALLS RAOPEN, VCLR'S DM1.
C  7 OCT 88 - MWS - INCREASE AO NUMBER FROM 128 TO 256
C  8 MAY 88 - MWS - UP AO-S FROM 255 TO 2047
C 18 NOV 87 - STE - USE EXETYP; SAVE /FUNCT/
C  6 AUG 87 - MWS - INCLUDE ETA VERSION
C  8 MAY 87 - STE - ORD2DM: USE CORRECT OFFSET TO COPY DM1
C 31 OCT 86 - STE - LAB2DM: CREATE /S2DMSV/; USE PARAMETERS
C 30 JUL 86 - MWS - PAD COMMON ENRGYS
C 21 JUL 86 - MWS - SAVE STATEMENT REPLACES /SDM2SV/
C  8 JUL 86 - JAB - ADD BIT PACKING/UNPACKING FOR CRAY, CELERITY
C  7 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS
C 24 APR 86 - MWS - ALIGN COMMON /SDM2SV/
C 23 OCT 85 - LAM - CHANGE DIMENSIONS IN /DM2BUF/ FROM 1875 TO 2725
C                   DELETE /DM2BUF/ IN ORDDMB
C 16 DEC 85 - STE - REPLACE OUT2DM WITH TR2OUT
C 30 OCT 85 - STE - ORD2DM,LAB2DM: FIX GETFM ARGUMENT  NEED
C 16 OCT 85 - STE - /CIFILS/ IN GUG2DM,SETDM2; /SDM2SV/ IN SETDM2
C                   USE GENERIC ABS,MAX,MIN,SQRT
C 11 JUL 85 - MWS - CHANGE IBM INDEX PACKING
C 30 MAY 85 - MWS - ADD NPRINT TO RAOPEN CALL
C 15 MAR 85 - MWS - USE RASIZE TO GET LDAR
C  9 JUL 84 - STE - MOVE ENERGY ISTATE TO /FUNCT/E IN GUG2DM
C  5 MAY 84 - STE - DELETE DRTDM2,EXTER2,LOOPY2,OUTDM2,/DM2OUT,DM2DRT/
C 23 FEB 84 - STE - ALLOCATE ONLY AMOUNT OF MEMORY NEEDED IN GUG2DM
C 11 JAN 84 - STE - SAVE VARIABLES IN SETDM2
C 28 DEC 83 - STE - USE SQREAD,SQWRIT; DELETE CIVDM2,RDDM2,WRTDM2
C  9 DEC 83 - STE - INITIALIZE NWORD IN GUG2DM
C 18 NOV 83 - STE - FPS PACK/UNPACK IN ORDD2C,LBLDM2,ORDDMA,ORDDMB
C  7 NOV 83 - STE - DELETE EXTDM2,THREX2, LEAVING EXTER2 AS A ROUTINE
C  5 NOV 83 - STE - DELETE CALL DARTRN FROM ORD2DM
C 20 MAY 83 - MWS - FIX ADDRESSING ERROR IN SETDM2
C 29 OCT 82 - MWS - RESTORE LINES AROUND DO 160 IN ORDD2C
C 27 OCT 82 - MWS - FIX LABEL PACKING IN ORDD2C, CALL ABRT-S
C 21 OCT 82 - MWS - ADD DMY ARGUMENTS TO NAMEIO CALL
C 29 SEP 82 - MWS - CONVERT TO IBM
C
C*MODULE GUGDM2  *DECK LAB2DM
      SUBROUTINE LAB2DM(NPRINT,CUTOFF,NFT11,NFT15,NFT16,
     *                  XX,IXX,NINTMX,M1,M2,MN,GIJKL,GIJ,
     *                  NSYM,NORBMX,NORBS,NCORBS,NGRPS,MXNINT,
     *                  ISYM,MAP,IJADD,IJGRP,KADD,LADD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT,SOME,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXAO=8192)
C
      DIMENSION GIJKL(MXNINT),GIJ(M2),IJADD(M2),
     *          IJGRP(M2),KADD(MN),LADD(MN),ISYM(MXAO),MAP(MXAO),
     *          XX(NINTMX),IXX(NINTMX)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA CHECK/8HCHECK   /, DEBUG/8HDEBUG   /, DBUGME/8HLAB2DM  /
C
      SOME = NPRINT .NE. -5 .AND. MASWRK
      OUT = NPRINT .GT. 0 .AND. MASWRK
      IF (EXETYP .EQ. DEBUG  .OR.  EXETYP .EQ. DBUGME) THEN
         SOME = .TRUE. .AND. MASWRK
         OUT = .TRUE. .AND. MASWRK
      END IF
C
C     ----- READ IN -DRT- DATA -----
C
      CALL SEQREW(NFT11)
      READ (NFT11)
      READ (NFT11)
      READ (NFT11) MAP
      READ (NFT11) ISYM
      DO 100 I = 1,12
         READ (NFT11)
  100 CONTINUE
      READ (NFT11) IJADD
      READ (NFT11) IJGRP
      READ (NFT11) KADD
      READ (NFT11) LADD
      CALL SEQREW(NFT11)
C
C     ----- LABEL -DM2- ELEMENTS -----
C
      NFTI = NFT15
      NFTO = NFT16
      IF (EXETYP .NE. CHECK)
     *    CALL LBLDM2(GIJKL,GIJ,M1,M2,MN,NFTI,NFTO,XX,IXX,NINTMX,
     *                IJADD,IJGRP,KADD,LADD,ISYM,MAP,NSYM,
     *                NORBMX,NORBS,NCORBS,NGRPS,MXNINT,SOME,OUT,CUTOFF)
      CALL SEQREW(NFTI)
      CALL SEQREW(NFTO)
      RETURN
      END
C*MODULE GUGDM2  *DECK LBLDM2
      SUBROUTINE LBLDM2(GIJKL,GIJ,L1,L2,MN,NFTI,NFTO,X,IX,NINTMX,
     *                  IJADD,IJGRP,KADD,LADD,ISYM,MAP,
     *                  NSYM,NORBMX,NORBS,NCORBS,NGRPS,MXNINT,
     *                  SOME,OUT,CUTOFF)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT,GOPARR,DSKWRK,MASWRK,FOCAS,SOSCF,DROPC
C
      PARAMETER (MXAO=8192)
C
      DIMENSION GIJKL(MXNINT),GIJ(L2),X(NINTMX),IX(NINTMX),
     *          IJADD(L2),IJGRP(L2),KADD(MN),LADD(MN),ISYM(MXAO),
     *          MAP(MXAO)
      DIMENSION MULT8(8),LKUPSM(64),KLOFF(8)
C
      COMMON /CASOPT/ CASHFT,CASDII,NRMCAS,FOCAS,SOSCF,DROPC
      COMMON /GUGWFN/ NFZC,NMCC,NDOC,NAOS,NBOS,NALP,NVAL,NEXT,NFZV,
     *                IFORS,IEXCIT,ICICI,NOIRR
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00, TWO=2.0D+00)
C
      DATA MULT8 /0,8,16,24,32,40,48,56/
      DATA LKUPSM /1,2,3,4,5,6,7,8,
     +             2,1,4,3,6,5,8,7,
     +             3,4,1,2,7,8,5,6,
     +             4,3,2,1,8,7,6,5,
     +             5,6,7,8,1,2,3,4,
     +             6,5,8,7,2,1,4,3,
     +             7,8,5,6,3,4,1,2,
     +             8,7,6,5,4,3,2,1/
C
C     ----- LABEL -DM2- ELEMENTS -----
C
      NCORBS = 0
      DO 100 I = 1,NORBMX
         IF (MAP(I) .LT. 0) NCORBS = NCORBS+1
  100 CONTINUE
C
      DO 120 I = 1,L1
  120 IA(I) = (I*I - I)/2
C
      DO 140 I = 1,NSYM
  140 KLOFF(I) = (I-1)*NORBS
C
      CALL VCLR(GIJ,1,L2)
C
C     ----- SKIP HEADER RECORD ON -DM2- FILE -----
C
      M = 0
      NRECI=0
      NRECO=0
      CALL SEQREW(NFTI)
      READ (NFTI)
      CALL SEQREW(NFTO)
C
      IGRP = 0
  180 CONTINUE
      IGRP = IGRP+1
      IF (IGRP .GT. NGRPS) GO TO 500
C
      CALL SQREAD(NFTI,GIJKL,MXNINT)
      NRECI=NRECI+1
C
C     ----- PROCESS 1E-DM FIRST -----
C
      DO 220 K0 = 1,L1
         DO 200 L0 = 1,K0
            KL0 = IA(K0)+L0
            KMAP = MAP(K0+NCORBS)
            LMAP = MAP(L0+NCORBS)
            K = MAX(KMAP,LMAP)
            L = MIN(KMAP,LMAP)
            MB = 3
            IF (K .EQ. L) MB = 2
            KL = IA(K)+K
            KKSYM = ISYM(K)
            IF (KKSYM .NE. ISYM(L)) GO TO 200
            LSMPT = L + KLOFF(KKSYM)
            LAD = IJADD(KL)+KADD(K)+LADD(LSMPT)+MB
            LGRP = IJGRP(KL)
            IF (LGRP .NE. IGRP) GO TO 200
            VAL = GIJKL(LAD)
            IF (L0 .NE. K0) VAL = VAL*HALF
            GIJ(KL0) = VAL
            IF(OUT) WRITE (IW,9028) K0,L0,K,L,LAD,LGRP,VAL
  200    CONTINUE
  220 CONTINUE
C
C     ----- PROCESS 2E-DM NOW -----
C
      DO 480 I0 = 1,L1
      DO 460 J0 = 1,I0
      DO 440 K0 = 1,I0
      L0MAX = K0
      IF (K0 .EQ. I0) L0MAX = J0
      DO 420 L0 = 1,L0MAX
C
      IMAP = MAP(I0+NCORBS)
      JMAP = MAP(J0+NCORBS)
      KMAP = MAP(K0+NCORBS)
      LMAP = MAP(L0+NCORBS)
      I = MAX(IMAP,JMAP)
      J = MIN(IMAP,JMAP)
      K = MAX(KMAP,LMAP)
      L = MIN(KMAP,LMAP)
      IF (I-K) 240,260,280
  240 N = K
      K = I
      I = N
      N = L
      L = J
      J = N
      GO TO 280
C
  260 IF (J-L) 240,280,280
  280 CONTINUE
      IF (J-K) 300,320,340
  300 II = I
      JJ = K
      KK = J
      LL = L
      IF (KK .GE. LL) GO TO 380
      KK = L
      LL = J
      IF (JJ .GT. KK) GO TO 360
      MB = 2
      GO TO 400
C
  320 II = I
      JJ = J
      KK = K
      LL = L
      IF (JJ .GT. LL) GO TO 380
      IF (II .EQ. JJ) GO TO 380
      JJ = I
      KK = I
      MB = 2
      GO TO 400
C
  340 II = I
      JJ = J
      KK = K
      LL = L
      MB = 2
      GO TO 400
C
  360 MB = 3
      GO TO 400
C
  380 MB = 1
  400 CONTINUE
      IJ = IA(II)+JJ
      IISYM = ISYM(II)
      IJMUL = MULT8(IISYM)+ISYM(JJ)
      IJSYM = LKUPSM(IJMUL)
      IJKMUL = MULT8(IJSYM)+ISYM(KK)
      IJKSYM = LKUPSM(IJKMUL)
      LSYM = ISYM(LL)
      IF (LSYM .NE. IJKSYM) GO TO 420
      KSMPT = KK+KLOFF(IJSYM)
      LSMPT = LL+KLOFF(IJKSYM)
      LAD = IJADD(IJ)+KADD(KSMPT)+LADD(LSMPT)+MB
      LGRP = IJGRP(IJ)
      IF (LGRP .NE. IGRP) GO TO 420
      VAL = GIJKL(LAD)
C
      VAL = VAL+VAL
      IF (J0 .NE. I0) VAL = VAL*HALF
      IF (L0 .NE. K0) VAL = VAL*HALF
      IF (K0 .NE. I0 .OR. L0 .NE. J0) VAL = VAL*HALF
C
      IF(ABS(VAL).LT.CUTOFF) GO TO 420
      IF(OUT)
     *  WRITE(IW,9008) I0,J0,K0,L0,I,J,K,L,II,JJ,KK,LL,LAD,LGRP,VAL
C
      M    = M+1
      X(M) = VAL
C
               NPACK = M
               IPACK = I0
               JPACK = J0
               KPACK = K0
               LPACK = L0
               IF (LABSIZ .EQ. 2) THEN
*I32             IX( 2*NPACK-1 ) = ISHFT( IPACK, 16 ) + JPACK
*I32             IX( 2*NPACK   ) = ISHFT( KPACK, 16 ) + LPACK
*I64             LABEL = ISHFT( IPACK, 48 ) + ISHFT( JPACK, 32 ) +
*I64 *                   ISHFT( KPACK, 16 ) + LPACK
*I64             IX(NPACK) = LABEL
               ELSE IF (LABSIZ .EQ. 1) THEN
*I32             LABEL = ISHFT( IPACK, 24 ) + ISHFT( JPACK, 16 ) +
*I32 *                   ISHFT( KPACK,  8 ) + LPACK
*I32             IX(NPACK) = LABEL
*I64             IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64               LABEL = ISHFT( IPACK, 24 ) + ISHFT( JPACK, 16 ) +
*I64 *                     ISHFT( KPACK,  8 ) + LPACK
*I64               IX( NPACK/2 ) = IX( NPACK/2 ) + LABEL
*I64             ELSE
*I64               LABEL = ISHFT( IPACK, 56 ) + ISHFT( JPACK, 48 ) +
*I64 *                     ISHFT( KPACK, 40 ) + ISHFT( LPACK, 32 )
*I64               IX( (NPACK/2)+1 ) = LABEL
*I64             END IF
               END IF
C
      IF(M.GE.NINTMX) THEN
         CALL PWRIT(NFTO,X,IX,NINTMX,NINTMX)
         NRECO=NRECO+1
         M = 0
      END IF
  420 CONTINUE
  440 CONTINUE
  460 CONTINUE
  480 CONTINUE
      GO TO 180
C
C     ----- DONE PROCESSING, FLUSH OUT THE FINAL -DM2- BUFFER -----
C
  500 CONTINUE
      M = -M
      CALL PWRIT(NFTO,X,IX,M,NINTMX)
      NRECO=NRECO+1
      IF(SOME) WRITE(IW,9000) NRECI,MXNINT,NFTI,
     *                        NRECO,NINTMX,NFTO
C
C     ----- COMPLETE THE ONE PARTICLE DENSITY -----
C
      IF (GOPARR) CALL DDI_GSUMF(1900,GIJ,L2)
C
C     ADD CORE PART OF 1E DENSITY
C
      IF (DROPC) THEN
         CALL DAWRIT(IDAF,IODA,GIJ,L2,320,0)
         DO 520 I=NORBS,1,-1
            DO 510 J=I,1,-1
               GIJ(IA(I+NCORBS)+J+NCORBS) = GIJ(IA(I)+J)
  510       CONTINUE
  520    CONTINUE
         DO 550 I=1,NCORBS+NORBS
            JMAX = MIN(I,NCORBS)
            DO 540 J=1,JMAX
               GIJ(IA(I)+J) = ZERO
  540       CONTINUE
  550    CONTINUE
         DO 580 I=1,NCORBS
            GIJ(IA(I)+I) = TWO
  580    CONTINUE
      ELSE
         CALL DAWRIT(IDAF,IODA,GIJ,L2,320,0)
      END IF
C
C     ---- WRITE -DM1- AT THE END OF THE -DM2- FILE AND ON THE DAF ----
C
      NOCC= NORBS+NCORBS
      NOCC2= (NOCC*NOCC+NOCC)/2
      CALL SQWRIT(NFTO,GIJ,NOCC2)
      CALL DAWRIT(IDAF,IODA,GIJ,NOCC2,68,0)
C
C     IF WE HAVE ANY EMPTY MCSCF ORBITALS, SOMETHING IS REALLY WRONG
C
      IF(ICICI.NE.0) RETURN
C
      II = 0
      NERR = 0
      SMALL = 1.0D-07
      DO 610 I=1,NOCC
         II = II+I
         IF(ABS(GIJ(II)).LT.SMALL) THEN
            IF(MASWRK) WRITE(IW,9040) I,GIJ(II)
            NERR = NERR+1
         END IF
  610 CONTINUE
      IF(NERR.GT.0) THEN
         IF(MASWRK) WRITE(IW,*) 'CHECK YOUR ACTIVE SPACE CAREFULLY'
         CALL ABRT
      END IF
      RETURN
C
 9000 FORMAT(1X,I10,' RECORDS OF LENGTH',I6,'  READ FROM FILE',I3/
     *       1X,I10,' RECORDS OF LENGTH',I6,' WRITTEN TO FILE',I3)
 9008 FORMAT(12I5,I10,I5,E20.12)
 9028 FORMAT(4I5,I10,I5,E20.12)
 9040 FORMAT(1X,'ORBITAL',I5,' HAS VERY SMALL OCCUPANCY=',1P,E15.7)
      END
C*MODULE GUGDM2  *DECK GUG2DM
      SUBROUTINE GUG2DM(NPRINT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      EXTERNAL PUTEX2,PUTOU2,NXGRP2,FINOU2
C
      LOGICAL DBG,SOME,AVG,PACK2E,GOPARR,DSKWRK,MASWRK,WTSOK
C
      PARAMETER (MXATM=2000, MXRT=100, MXAO=8192)
C
      DIMENSION TITLE1(10),WSTATE(MXRT)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
C               NEXT COMMON IS USED STRICTLY FOR -IROOT- PASSING
      COMMON /DETWFN/ WSTDET(MXRT),SPINS(MXRT),CRIT,PRTTOL,SDET,SZDET,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),
     *                NCORDETSV,NCORDET,NACTDET,NORBDT,
     *                NADET,NBDET,KDET,KSTDET,IROOT,IPURES,MAXW1,NITDET,
     *                MAXP,NCIDET,IGPDET,KSTSYM,NFTGCI
      COMMON /DM2AVG/ WAVG(MXRT),IAVG(MXRT),NAVG,AVG
      COMMON /DM2DM2/ IH00,IH01,NWKS
      COMMON /EMPRT / ILEVEL,JLEVEL,KLEVEL,LLEVEL,DBG,SOME
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / H(1)
      COMMON /FUNCT / E,EG(3,MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /LOOPS / X(5),IX(12),INTSAD,MXNINT,NGRPS
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NA,NB,NC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),ICODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),
     *                NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PSILVL/ IPSI
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
C     ----- SET UP NAMELIST SIMULATION -----
C
      PARAMETER (NNAM=9)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA GUGDM2/8HGUGDM2  /
      DATA QNAM/8HCUTOFF  ,8HNWORD   ,8HWSTATE  ,8HNDAR    ,
     *          8HLDAR    ,8HNBOXMX  ,8HNOMEM   ,8HWTSOK   ,
     *          8HIROOT   /
      DATA KQNAM/3,1,-3,1,1,1,1,0,1/
C
      DATA CHECK,DEBUG,DBUGME/8HCHECK   ,8HDEBUG   ,8HGUGDM2  /
C
C     ----- MAIN DRIVER FOR SECOND ORDER DENSITY MATRIX -----
C         THERE ARE THREE STEPS CARRIED OUT BY THIS FILE:
C     GUG2DM ---> SETDM2, WITH LOOPY  (GENERATES THE DM2)
C            ---> LAB2DM ---> LBLDM2  (RELABEL MO INDICES)
C            ---> ORD2DM ---> ORDD2C  (SORT TO CANONICAL ORDER, IN MEM)
C                        ---> ORDDMA,ORDDMB  (SORT OUT OF MEMORY)
C     THE RELABELING IS THE INVERSE OF -GUGSRT-, TO MAP ORBITAL INDICES
C     BACK TO THE STANDARD GAMESS ORDER, NOT THE INTERNAL GUGA ORDER.
C
      SOME = NPRINT .NE. -5 .AND. MASWRK
      DBG = NPRINT.GT.0 .AND. MASWRK
      IF (EXETYP .EQ. DEBUG  .OR.  EXETYP .EQ. DBUGME) THEN
         SOME = .TRUE. .AND. MASWRK
         DBG = .TRUE. .AND. MASWRK
      END IF
      IF(SOME) WRITE (IW,9000)
C
C       GUGA CI GRADIENT EXECUTES THIS CODE, BUT SHOULD NOT
C       BE ALLOWED TO TRASH $GUGDM'S VALUE OF IROOT.
C
      IF(IPSI.EQ.1) IROOTSV = IROOT
C
C     ----- READ NAMELIST -$GUGDM2- -----
C
      CUTOFF=1.0D-09
      NWORD=0
      KQNAM(3) = 10*MXRT + 3
      CALL VCLR(WSTATE,1,MXRT)
      WSTATE(1) = ONE
      WTSOK = .FALSE.
      NDAR=4000
      NBOXMX=200
      CALL RASIZE(LDAR)
      NOMEM=0
      IROOT=0
C
      CALL NAMEIO(IR,JRET,GUGDM2,NNAM,QNAM,KQNAM,
     *            CUTOFF,NWORD,WSTATE,NDAR,LDAR,NBOXMX,NOMEM,WTSOK,
     *            IROOT,0,0,0,0,0,
     *            0,0,0,0,0,  0,0,0,0,0,
     *            0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     *            0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0)
      IF(JRET.EQ.2) THEN
         IF (MASWRK) WRITE (IW,9010)
         CALL ABRT
      END IF
C
C     ----- NORMALIZE THE STATE WEIGHTS -----
C
      NAVG = 0
      WSUM = ZERO
      DO 100 I=1,MXRT
         IF(WSTATE(I).LT.ZERO) THEN
           IF(MASWRK)
     *         WRITE(IW,*) 'STATE ',I,' HAS WEIGHT ',WSTATE(I)
           CALL ABRT
         END IF
         WSUM = WSUM + WSTATE(I)
         IF(WSTATE(I).EQ.ZERO) GO TO 100
            NAVG = NAVG+1
            IAVG(NAVG) = I
            WAVG(NAVG) = WSTATE(I)
  100 CONTINUE
C
      DO 110 I=1,NAVG
         WAVG(I) = WAVG(I)/WSUM
  110 CONTINUE
      MXSTAT = NAVG
C
C     THE COMPUTATION OF THE ENERGY GRADIENT REQUIRES A SYMMETRIC
C     LAGRANGIAN (SINCE GAMESS DOES NOT AT PRESENT DO THE CPHF
C     PROBLEM TO OBTAIN ORBITAL PERTURBATIONS).  ALTHOUGH A STATE
C     AVERAGED MCSCF RUN RESULTS IN A SYMMETRIC "AVERAGE LAGRANGIAN",
C     THE LAGRANGIAN FOR ANY SINGLE STATE USING THE AVERAGED ORBITALS
C     WILL *NOT* BE SYMMETRIC.  HENCE ANY JOB THAT ATTEMPTS TO STATE
C     AVERAGE AND ALSO DO A NUCLEAR GRADIENT SHOULD BE FLUSHED.
C     THERE IS A SECRET INPUT KEYWORD TO AVOID BEING FLUSHED, WHICH
C     MAY BE REASONABLE IF THE STATES BEING AVERAGED ARE DEGENERATE.
C
      CALL DERCHK(MAXDER)
      IF(MXSTAT.GT.1  .AND.  MAXDER.GT.0) THEN
         IF(MAXDER.EQ.1  .AND.  NGLEVL.NE.1) THEN
            IF(WTSOK) THEN
               IF (SOME) WRITE(IW,9061) RUNTYP,MXSTAT
            ELSE
               IF (SOME) WRITE(IW,9062) RUNTYP,MXSTAT
               CALL ABRT
            END IF
         END IF
         IF(MAXDER.EQ.2  .AND.  NHLEVL.NE.2) THEN
            IF (SOME) WRITE(IW,9063) RUNTYP,MXSTAT
            CALL ABRT
         END IF
         IF(IROOT.EQ.0   .AND.  NGLEVL+NHLEVL.GT.0) THEN
            IF(SOME) WRITE(IW,9064)
            CALL ABRT
         END IF
      END IF
C
C     ----- READ IN -DRT- DATA -----
C
      CALL SEQREW(NFT11)
      NORBMX = 0
      NROWS = 0
      READ (NFT11) NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,
     *             NREFS,IEXCT,NFOCI,INTACT,NCORBS
      READ (NFT11) TITLE1
C
C     ----- GET FAST MEMORY -----
C     OFFSETS TO CI VECTORS (IH00) AND INDEX ARRAY (IH01)
C     PASS TO OTHER ROUTINES IN THE COMMON /DMDDM2/.
C
      LOADFM = 0
      CALL VALFM(LOADFM)
      IH00 = 1 + LOADFM
      IH01 = IH00+NWKS*NAVG
      IH1 = IH01+NWKS
      IH2 = IH1+4*NROWS
      IH3 = IH2+NROWS
      IH4 = IH3+NROWS
      IH5 = IH1
      IH6 = IH4+NROWS
      IH7 = IH6+NROWS
      IH8 = IH7+NROWS
      IH11 = IH8+NROWS
      IH12 = IH11+NROWS*4
      NKL = NSYM*NORBS
      NIJ = (NORBS*(NORBS+1))/2
      IH13 = IH12+NIJ
      IH14 = IH13+NIJ
      IH15 = IH14+NKL
      IH16 = IH15+NKL
      IH17 = IH16+200
      IH18 = IH17+200
      IH19 = IH18+200
      NLNG = LEVFRM*NSYM
      IH20 = IH19+NLNG
      IH21 = IH20+NLNG
      IH22 = IH21+NLNG
      IH23 = IH22+NLNG
      IBUFFR = IH23+NLNG-1
      IBFFOI = IBUFFR + NEMEMX
      LBUFOV = IBFFOI + NEMEMX
      IBFFDI = LBUFOV + NEMEMX
      LBUFDV = IBFFDI + NEMEMX
      LAST   = LBUFDV + NEMEMX
      NROWS4 = NROWS*4
      NEED = LAST-LOADFM
      CALL GETFM(NEED)
      NEXT = 0
      CALL DRTTAP(NFT11,NROWS,NROWS4,NKL,NIJ,H(IH2),H(IH3),H(IH4),
     *            H(IH5),H(IH6),H(IH7),H(IH8),H(IH01),H(IH11),
     *            H(IH12),H(IH13),H(IH14),H(IH15),H(IH16),H(IH17),
     *            H(IH18),NWKS,NEXT,NGRPS,MXNINT)
      CALL SEQREW(NFT11)
C
C     ----- WRITE HEADER RECORD ON -DM2- FILE -----
C
      CALL SEQREW(NFT15)
      ITAP = 3
      WRITE (NFT15) ITAP,NWKS,MXNINT,TITLE,TITLE1
C
C     ----- READ CI WAVEFUNCTION DATA -----
C
      CALL SEQREW(NFT12)
      READ (NFT12) NSTATE,NWKS,TITLE,TITLE1
      IF(DBG) WRITE (IW,9020) TITLE,TITLE1,NWKS
      IF(NSTATE.LT.IAVG(NAVG)) THEN
         IF (MASWRK) WRITE(IW,9030) NSTATE,IAVG(NAVG)
         CALL ABRT
      END IF
C
      JOFF = IH00
      IST = 1
      DO 200 I=1,NSTATE
         IF(I.EQ.IAVG(IST)) THEN
               CALL SQREAD(NFT12,H(JOFF),NWKS)
               JOFF = JOFF + NWKS
               IST = IST+1
            ELSE
               READ (NFT12)
            END IF
  200 CONTINUE
C
C     ----- CALCULATE WEIGHTED ENERGY -----
C
      IF(SOME) WRITE(IW,9040) NAVG
      E = ZERO
      DO 300 I=1,NAVG
         IF(SOME) WRITE(IW,9050) IAVG(I),WAVG(I),ESTATE(IAVG(I))
         E = E + WAVG(I) * ESTATE(IAVG(I))
  300 CONTINUE
C
C     ----- CALCULATE 2-PARTICLE DENSITY MATRIX -----
C
      CALL SETDM2
      IF (EXETYP .EQ. CHECK) THEN
            CALL FINOU2
         ELSE
            CALL LOOPY(NROWS,H(IH3),H(IH6),H(IH7),H(IH8),H(IH11),H(IH2),
     *                 H(IH12),H(IH13),H(IH14),H(IH15),H(IH16),H(IH17),
     *                 H(IH18),H(IH5),NEXT,NROWS4,NIJ,NKL,
     *                 PUTEX2,PUTOU2,NXGRP2,FINOU2,H(IBUFFR),H(IBFFOI),
     *                 H(LBUFOV),H(IBFFDI),H(LBUFDV))
         END IF
C
C     ----- RESET FAST MEMORY -----
C
      CALL RETFM(NEED)
      IF(SOME) WRITE (IW,9060)
      IF(SOME) CALL TEXIT(2,2)
C
C     ----- LABEL -DM2- ELEMENTS -----
C
      IF(SOME) WRITE (IW,9070)
      CALL SEQREW(NFT11)
      READ (NFT11) NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,
     *             NREFS,IEXCT,NFOCI,INTACT,NCORBS
      DO 400 I=1,14
         READ(NFT11)
  400 CONTINUE
      READ (NFT11) NGRPS,NEXT,MXNINT
C
      M1 = NORBS
      M2 = (M1*M1+M1)/2
      MN = M1*NSYM
      MIJ= (NORBS+NCORBS)*(NORBS+NCORBS+1)/2
C
      CALL VALFM(LOADFM)
      LXX    = LOADFM + 1
      LIXX   = LXX    + NINTMX
      LGIJKL = LIXX   + NINTMX
      LGIJ   = LGIJKL + MXNINT
      LISYM  = LGIJ   + MIJ
      LMAP   = LISYM  + MXAO
      LIJADD = LMAP   + MXAO
      LIJGRP = LIJADD + M2/NWDVAR + 1
      LKADD  = LIJGRP + M2/NWDVAR + 1
      LLADD  = LKADD  + MN/NWDVAR + 1
      LAST   = LLADD  + MN/NWDVAR + 1
      NEED = LAST - LXX
      IF(SOME) WRITE(IW,9080) NEED
      CALL GETFM(NEED)
      CALL LAB2DM(NPRINT,CUTOFF,NFT11,NFT15,NFT16,H(LXX),H(LIXX),
     *            NINTMX,M1,M2,MN,H(LGIJKL),H(LGIJ),
     *            NSYM,NORBMX,NORBS,NCORBS,NGRPS,MXNINT,H(LISYM),
     *            H(LMAP),H(LIJADD),H(LIJGRP),H(LKADD),H(LLADD))
      CALL RETFM(NEED)
      IF(SOME) WRITE (IW,9090)
      IF(SOME) CALL TEXIT(2,2)
C
C     ----- ORDER -DM2- ELEMENTS -----
C
      CALL ORD2DM(NPRINT,NDAR,LDAR,NBOXMX,NWORD,NORBS,NCORBS,NINTMX,
     *            NFT15,NFT16,IDAF20,NOMEM)
C
      IF(IPSI.EQ.1) IROOT = IROOTSV
      RETURN
C
 9000 FORMAT(/10X,37(1H-)/
     *        10X,'2-PARTICLE DENSITY MATRIX CALCULATION'/
     *        10X,37(1H-))
 9010 FORMAT(1X,'**** ERROR READING $GUGDM2.')
 9020 FORMAT(/1X,'NAME OF HAMILTONIAN IS ',10A8/
     *        1X,'NAME OF THE -DRT-   IS ',10A8/
     *        1X,'NUMBER OF CONFIGURATIONS =',I10)
 9030 FORMAT(1X,'YOU ASKED FOR ONLY',I5,' STATES IN $GUGDIA,'/
     *       1X,'BUT YOU ARE TRYING TO AVERAGE UP TO STATE',I5)
 9040 FORMAT(1X,'2 BODY DENSITY IS AN AVERAGE OF',I3,' STATE(S).'/
     *       1X,2X,'STATE',4X,'WEIGHT',10X,'ENERGY')
 9050 FORMAT(1X,I5,F12.6,F20.10)
 9060 FORMAT(1X,'...... END OF 2-PARTICLE DENSITY MATRIX ',
     *          'CALCULATION ......' )
 9061 FORMAT(/1X,'**** WARNING ****'/
     *        1X,'RUNTYP=',A8,' INVOLVING A NUCLEAR GRADIENT'/
     *        1X,'HAS BEEN REQUESTED FOR A RUN AVERAGING OVER',I4,
     *           ' STATES.'/
     *        1X,'THIS MAKES SENSE ONLY IF THE STATES ARE DEGENERATE.'/
     *        1X,'THE RUN IS ALLOWED TO PROCEED BECAUSE USER INPUT'/
     *        1X,'REQUESTS THIS.  PLEASE CHECK THAT THE STATES ARE IN'/
     *        1X,'FACT DEGENERATE, AFTER THEY ARE COMPUTED BELOW.'//)
 9062 FORMAT(/1X,'**** ERROR, RUNTYP=',A8,' REQUIRES NUCLEAR GRADIENT.'/
     *        1X,'THIS IS IMPOSSIBLE WHILE STATE AVERAGING. NAVG=',I5/
     *        1X,'A POSSIBLE RECOURSE, FOR VERY SMALL MOLECULES, IS',
     *           ' TO SELECT'/
     *        1X,'A SPECIFIC STATE ENERGY TO BE NUMERICALLY',
     *           ' DIFFERENTIATED:'/
     *        1X,' $GUGDM2 IROOT=NNN'/
     *        1X,' $CONTRL NUMGRD=.TRUE.'//)
 9063 FORMAT(/1X,'**** ERROR, RUNTYP=',A8,' REQUIRES NUCLEAR HESSIAN.'/
     *        1X,'THIS IS IMPOSSIBLE WHILE STATE AVERAGING. NAVG=',I5/
     *        1X,'A POSSIBLE RECOURSE, FOR VERY SMALL MOLECULES, IS',
     *           ' TO SELECT'/
     *        1X,'A SPECIFIC STATE ENERGY TO BE NUMERICALLY',
     *           ' DIFFERENTIATED:'/
     *        1X,' $GUGDM2 IROOT=NNN'/
     *        1X,' $HESS   METHOD=FULLNUM'//)
 9064 FORMAT(/1X,'**** ERROR, YOUR SA-MCSCF REQUESTS ENERGY',
     *           ' DERIVATIVES, BUT YOU DID'/
     *        1X,'NOT SPECIFY BY -IROOT- WHICH SPECIFIC STATE YOU',
     *           ' WANT.')
 9070 FORMAT(/10X,34(1H-)/10X,'2-PARTICLE DENSITY MATRIX LABELING'/
     *        10X,34(1H-))
 9080 FORMAT(1X,I10,' WORDS NEEDED TO LABEL DM2 MATRIX')
 9090 FORMAT(' ...... END OF 2-PARTICLE DENSITY MATRIX LABELING ......')
      END
C*MODULE GUGDM2  *DECK ORD2DM
      SUBROUTINE ORD2DM(NPRINT,NDAR,LDAR,NBOXMX,NWORD,NORBS,NCORBS,
     *                  NINTMX,NFT15,NFT16,IDAF20,NOMEM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT,SOME,GOPARR,DSKWRK,MASWRK
      LOGICAL FOCAS,SOSCF,DROPC
C
      COMMON /CASOPT/ CASHFT,CASDII,NRMCAS,FOCAS,SOSCF,DROPC
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /FMCOM / X(1)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA CHECK/8HCHECK   /, DEBUG/8HDEBUG   /, DBUGME/8HORD2DM  /
C
      SOME = NPRINT .NE. -5 .AND. MASWRK
      OUT = NPRINT .GT. 0 .AND. MASWRK
      IF (EXETYP .EQ. DEBUG  .OR.  EXETYP .EQ. DBUGME) THEN
         OUT = .TRUE. .AND. MASWRK
         SOME = .TRUE. .AND. MASWRK
      END IF
      IF(SOME) WRITE (IW,9008)
C
      NRECI=0
      NRECO=0
      NDM2O=0
C
C     ----- GET FAST MEMORY -----
C
      LOADFM = 0
      CALL VALFM(LOADFM)
      CALL GOTFM(NGOTMX)
      NGOT = NWORD
      IF (NGOT .LE. 0) NGOT = NGOTMX
C
      L1 = NORBS
      L2 = (L1*(L1+1))/2
      L4 = (L2*(L2+1))/2
C
      NFTI = NFT16
      NFTO = NFT15
      CALL SEQREW(NFTI)
      CALL SEQREW(NFTO)
C
      LOX  = 1    + LOADFM
      LIA  = LOX  + L4
      LXX  = LIA  + L2
      LIXX = LXX  + NINTMX
      LAST = LIXX + NINTMX
      NEED = LAST-LOADFM
C
      IF(SOME) WRITE (IW,9028) NEED,NGOT
      IF (NOMEM.NE.0) GO TO 100
      IF (NEED .GT. NGOT) GO TO 100
C
C     ----- ORDER THE -DM2- IN FAST MEMORY -----
C
      IF(SOME) WRITE (IW,9048)
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 180
      CALL ORDD2C(X(LOX),X(LIA),X(LXX),X(LIXX),NINTMX,
     *            L1,L2,L4,NFTI,NFTO,NRECI,NRECO,NDM2O,OUT)
      GO TO 180
C
C     ----- 2 STEP ORDERING TECHNIQUE -----
C
  100 CONTINUE
      IF(SOME) WRITE (IW,9068)
C
C     NDAR          = # OF -DA- RECORDS
C     LDAR          = # OF INT. / -DA- RECORD
C
C     NBOX          = # OF BOXES IN 1 PASS
C     LBOX          = # OF INT. / BOX
C
C     NBIN          = # OF BINS IN 1 BOX
C     LBIN          = # OF INT. / BIN
C
C     NPASS         = # OF PASSES
C     LPASS         = # OF INT. / PASS
C
C     NBOXMX        = MAXIMUM # OF BOXES
C
C     L4            = MAXIMUM # OF  -DM2-  S
C
C     ----- STEP -A-
C      LXO         -DM2-   BUFFER FOR -NFTI-
C      LIXO       INDEX    BUFFER FOR -NFTI-
C      LIORA      -DA- FILE INDEX
C      LICHAN     BIN CHAINING INDEX
C      LICOUN     BIN FILLING COUNTER
C      LLOCBX     BOX LOCATION BIAS
C      LIJKLA     BOX ADDRESS BIAS
C      LIA        PAIR INDEX ARRAY
C      LIJKLX     BIN SPACE
C
C     ----- STEP -B-
C      LXO         -DM2-   BUFFER FOR -NFTO-
C      LIXO       INDEX    BUFFER FOR -NFTO-
C      LIORA      -DA- FILE INDEX
C      LICHAN     BIN CHAINING INDEX
C      LXIJKL     BOX SPACE
C      LXX        -DM2- BUFFER FOR -IDAF20-
C
      LWORDA = NGOT-2*NINTMX-(NDAR+1)-4*NBOXMX-L2
      LWORDB = NGOT-2*NINTMX-(NDAR+1)-NBOXMX-(2*LDAR+2)
      IF (LWORDA .GT. 0) GO TO 120
         MORE = -LWORDA
         IF (MASWRK) WRITE (IW,9088) NGOT,MORE
         CALL ABRT
  120 CONTINUE
C
      LBOX = LWORDB
      LBIN = LDAR
      NBIN = LBOX/LBIN
      IF (NBIN .GT. NDAR) NBIN = NDAR
      LBOX = LBIN*NBIN
C
      N1 = NDAR/NBIN
      N2 = LWORDA/(2*LDAR+2)
      N3 = (L4-1)/LBOX+1
      NBOX = MIN(N1,N2,N3,NBOXMX)
      IF (NBOX .LE. 0) THEN
         IF (MASWRK) WRITE (IW,9128) NDAR,LDAR,NGOT,NBOXMX
         CALL ABRT
         STOP
      END IF
C
C     PARAMETERS GIVEN -   L4,     NDAR,   LDAR,   LWORDA
C                USED  -   L4,NBOX*NBIN,   LDAR,NBOX*LBIN
C
C     # OF PASSES               NPASS
C     # INT./PASS               LPASS=LBOX*NBOX=(LBIN*NBIN)*NBOX
C     # OF BOXES /PASS          NBOX
C     # INT./BOX                LBOX=LBIN*NBIN
C     # OF BINS  /BOX           NBIN
C     # INT./BIN                LBIN=LDAR
C
      NBOXU = NBOX
      NBINU = NBIN
      LBINU = LBIN
      LBOXU = LBINU*NBINU
      LPASSU = LBOXU*NBOXU
      NPASSU = (L4-1)/LPASSU+1
      LDARU = LDAR
      NDARU = NBINU*NBOXU
      LWORDA = 2*NINTMX+(NDARU+1)+4*NBOXU+L2+NBOXU*(2*LBINU+2)
      LWORDB = 2*NINTMX+(NDARU+1)+NBOXU+LBOXU+(2*LDARU+2)
      LWORDU = MAX(LWORDA,LWORDB)
      MXBOXU = NBOXU*NPASSU
      IF(SOME) WRITE (IW,9108) L4,NDAR,LDAR,NGOT,NDARU,LDARU,LWORDU,
     *                         NPASSU,LPASSU,NBOXU,NBOXMX,
     *                         LBOXU,NBINU,LBINU,MXBOXU
      IF(GOPARR) THEN
         IF(MASWRK) WRITE(IW,9109)
         CALL ABRT
      END IF
C
C     ----- GET FAST MEMORY -----
C
      LXO    = 1 + LOADFM
      LIXO   = LXO    + NINTMX
      LIORA  = LIXO   + NINTMX
      LICHAN = LIORA  + NDARU+1
      LICOUN = LICHAN + NBOXU
C                              ARRAYS FOR STEP A ONLY
      LLOCBX = LICOUN + NBOXU
      LIJKLA = LLOCBX + NBOXU
      LIA    = LIJKLA + NBOXU
      LIJKLX = LIA    + L2
      LASTA  = LIJKLX + NBOXU*(2*LBINU+2)
C                              ARRAYS FOR STEP B ONLY
      LXIJKL = LICOUN + NBOXU
      LXX    = LXIJKL + LBOXU
      LASTB  = LXX    + (2*LDARU+2)
      LAST = MAX(LASTA,LASTB)
      NEED = LAST - LOADFM
      CALL GETFM(NEED)
C
C     ----- OPEN DIRECT ACCESS FILE -IDAF20- -----
C
      NDAF20 = NDARU+1
      LEND = 2*LBINU + 2
      CALL RAOPEN(IDAF20,X(LIORA),0,NDAF20,LEND,NPRINT)
      IF (EXETYP .EQ. CHECK) GO TO 170
C
C     ----- LOOP OVER PASSES -----
C
      NXO = 1
      I0 = 1
      J0 = 1
      K0 = 1
      L0 = 1
      ILOW = 1
      IHIGH = LPASSU
      MBOX = NBOXU
C
C        LOOP OVER PASSES
C
      DO 160 IBOX = 1,MXBOXU,NBOXU
         IF (IBOX+NBOXU .GT. MXBOXU) MBOX = MXBOXU-IBOX+1
         CALL ORDDMA(ILOW,IHIGH,NFTI,X(LXO),X(LIXO),NINTMX,IDAF20,
     *               X(LIORA),X(LICHAN),X(LICOUN),X(LLOCBX),
     *               X(LIJKLA),X(LIA),X(LIJKLX),
     *               NBOXU,LBOXU,LBINU,L2,NRECI)
         CALL ORDDMB(MBOX,NFTO,X(LXO),X(LIXO),NINTMX,IDAF20,
     *               X(LIORA),X(LICHAN),X(LXIJKL),X(LXX),
     *               LBOXU,LBINU,L1,I0,J0,K0,L0,NXO,OUT,NRECO,NDM2O)
         ILOW = ILOW+LPASSU
         IHIGH = IHIGH+LPASSU
  160 CONTINUE
C
C     ----- CLOSE -IDAF20- -----
C
  170 CONTINUE
      CALL RACLOS(IDAF20,'DELETE')
C
C     ----- IN OR OUT OF CORE SORT OF -DM2- IS NOW DONE -----
C
  180 CONTINUE
      IF(SOME) WRITE(IW,9000) NRECI,NINTMX,NFTI,
     *                        NDM2O,NRECO,NINTMX,NFTO
      CALL RETFM(NEED)
C
C     ----- WRITE -DM1- AT THE END OF -DM2- FILE -----
C
      IF (DROPC) THEN
         NORBS=NORBS+NCORBS
         L1=NORBS
         L2 = (L1*(L1+1))/2
      END IF
      LDM1 = LOADFM + 1
      LAST = LDM1 + L2
      NEED = LAST - LDM1
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) THEN
         CALL VCLR(X(LDM1),1,L2)
      ELSE
         CALL SQREAD(NFT16,X(LDM1),L2)
      END IF
      CALL SQWRIT(NFT15,X(LDM1),L2)
      CALL SEQREW(NFT15)
      CALL SEQREW(NFT16)
C
C     ----- RESET FAST MEMORY -----
C
      CALL RETFM(NEED)
      IF(SOME) WRITE (IW,9148)
      IF(SOME) CALL TEXIT(2,2)
      RETURN
C
 9000 FORMAT(1X,24X,I7,' RECORDS OF LENGTH',I6,
     *              '  READ FROM FILE',I3/
     *       1X,I10,' DM2 VALUES IN',I7,' RECORDS OF LENGTH',I6,
     *              ' WRITTEN TO FILE',I3)
 9008 FORMAT(/10X,14(1H-)/10X,14H-DM2- ORDERING/10X,14(1H-))
 9028 FORMAT(1X,I10,' WORDS NEEDED (',I10,' AVAILABLE) TO ORDER',
     *      ' DM2 IN MEMORY')
 9048 FORMAT(1X,'CHOOSING IN MEMORY ORDERING...')
 9068 FORMAT(1X,'CHOOSING OUT OF MEMORY ORDERING...')
 9088 FORMAT(' ***** ERROR: NOT ENOUGH MEMORY AVAILABLE. NGOT =',2I10
     *      ,' NEEDED FOR STEP A OF OUT OF MEMORY SORT')
 9108 FORMAT(/,27H NUMBER OF -DM2-         = ,I10/
     +     27H GIVEN NDAR,LDAR,LWORD   = ,3I10/
     +     27H USED  NDAR,LDAR,LWORD   = ,3I10/
     +     27H NUMBER OF PASSES        = ,I10/
     +     27H NUMBER OF   -DM2-  /PASS= ,I10/
     +     27H NUMBER OF BOXES/PASS    = ,I10,17H MAXIMUM GIVEN = ,I10/
     +     27H NUMBER OF   -DM2-  /BOX = ,I10/
     +     27H NUMBER OF BINS/BOX      = ,I10/
     +     27H NUMBER OF   -DM2-  /BIN = ,I10/
     +     27H TOTAL NUMBER OF BOXES   = ,I10/)
 9109 FORMAT(1X,'---- DM2 ORDERING IN PARALLEL MUST BE IN MEMORY ----'/
     *       1X,'PLEASE RESUBMIT JOB WITH MORE MEMORY ALLOCATED.')
 9128 FORMAT(48H INCOHERENT PARAMETERS IN THE ORDERING OF -DM2-., /,
     +     34H GIVEN NDAR, LDAR, NGOT, NBOXMX = ,4I10,
     +     39H REEVALUATE THE INPUT PARAMETERS. STOP.)
 9148 FORMAT(37H ...... END OF -DM2- ORDERING ...... )
      END
C*MODULE GUGDM2  *DECK ORDD2C
      SUBROUTINE ORDD2C(OX,IA,X,IX,NINTMX,L1,L2,L4,NFTI,NFTO,
     *                  NRECI,NRECO,NDM2O,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT,GOPARR,DSKWRK,MASWRK
C
      DIMENSION OX(L4),IA(L2),X(NINTMX),IX(NINTMX)
C
      PARAMETER (ZERO=0.0D+00)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
C
C     ----- ORDER -DM2- IN CORE MEMORY -----
C
      DO 100 I = 1,L2
  100 IA(I) = (I*(I-1))/2
      CALL VCLR(OX,1,L4)
      IF(OUT) CALL TR2OUT(0,0,0,0,0,ZERO,-1)
C
C     ----- READ IN -DM2- FROM -NFTI- -----
C
  140 CONTINUE
      NX = 0
      CALL PREAD(NFTI,X,IX,NX,NINTMX)
      NRECI=NRECI+1
      IF(NX.EQ.0) GO TO 180
      MX=ABS(NX)
      IF(MX.GT.NINTMX) THEN
         IF(MASWRK) WRITE(IW,*) 'MX.GT.NINTMX IN ORDD2C'
         CALL ABRT
      END IF
      DO 160 M=1,MX
C
                       NPACK = M
                       IF (LABSIZ .EQ. 2) THEN
*I32                     LABEL = IX( 2*NPACK - 1 )
*I32                     IPACK = ISHFT( LABEL, -16 )
*I32                     JPACK = IAND(  LABEL, 65535 )
*I32                     LABEL = IX( 2*NPACK     )
*I32                     KPACK = ISHFT( LABEL, -16 )
*I32                     LPACK = IAND(  LABEL, 65535 )
*I64                     LABEL = IX(NPACK)
*I64                     IPACK = ISHFT( LABEL, -48 )
*I64                     JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64                     KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64                     LPACK = IAND( LABEL, 65535 )
                       ELSE IF (LABSIZ .EQ. 1) THEN
*I32                     LABEL = IX(NPACK)
*I32                     IPACK = ISHFT( LABEL, -24 )
*I32                     JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32                     KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32                     LPACK = IAND( LABEL, 255 )
*I64                     IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                       LABEL = IX( NPACK/2 )
*I64                       IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64                       JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64                       LPACK = IAND( LABEL, 255 )
*I64                     ELSE
*I64                       LABEL = IX( (NPACK/2)+1 )
*I64                       IPACK = ISHFT( LABEL, -56 )
*I64                       JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64                       LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64                     END IF
                       END IF
                       I = IPACK
                       J = JPACK
                       K = KPACK
                       L = LPACK
C
         IJ   = IA(I)  + J
         KL   = IA(K)  + L
         IJKL = IA(IJ) + KL
         OX(IJKL) = X(M)
  160 CONTINUE
      IF (NX .GT. 0) GO TO 140
C
C     ----- WRITE OUT -DM2- ON -NFTO- -----
C     ALL NODES NOW GET A DUPLICATE COPY OF THE TOTAL DM2 MATRIX
C
  180 CONTINUE
      IF (GOPARR) CALL DDI_GSUMF(1905,OX,L4)
C
      N = 0
      NX = 1
      DO 260 I = 1,L1
      DO 240 J = 1,I
      DO 220 K = 1,I
      LMAX = K
      IF (K .EQ. I) LMAX = J
      DO 200 L = 1,LMAX
         N = N+1
         VAL = OX(N)
         IF(VAL.EQ.ZERO) GO TO 200
C
               NPACK = NX
               IPACK = I
               JPACK = J
               KPACK = K
               LPACK = L
               IF (LABSIZ .EQ. 2) THEN
*I32             IX( 2*NPACK-1 ) = ISHFT( IPACK, 16 ) + JPACK
*I32             IX( 2*NPACK   ) = ISHFT( KPACK, 16 ) + LPACK
*I64             LABEL = ISHFT( IPACK, 48 ) + ISHFT( JPACK, 32 ) +
*I64 *                   ISHFT( KPACK, 16 ) + LPACK
*I64             IX(NPACK) = LABEL
               ELSE IF (LABSIZ .EQ. 1) THEN
*I32             LABEL = ISHFT( IPACK, 24 ) + ISHFT( JPACK, 16 ) +
*I32 *                   ISHFT( KPACK,  8 ) + LPACK
*I32             IX(NPACK) = LABEL
*I64             IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64               LABEL = ISHFT( IPACK, 24 ) + ISHFT( JPACK, 16 ) +
*I64 *                     ISHFT( KPACK,  8 ) + LPACK
*I64               IX( NPACK/2 ) = IX( NPACK/2 ) + LABEL
*I64             ELSE
*I64               LABEL = ISHFT( IPACK, 56 ) + ISHFT( JPACK, 48 ) +
*I64 *                     ISHFT( KPACK, 40 ) + ISHFT( LPACK, 32 )
*I64               IX( (NPACK/2)+1 ) = LABEL
*I64             END IF
               END IF
C
         X(NX) = VAL
         IF (OUT) CALL TR2OUT(I,J,K,L,NX,VAL,0)
         NX = NX+1
         IF(NX.GT.NINTMX) THEN
            CALL PWRIT(NFTO,X,IX,NINTMX,NINTMX)
            NRECO=NRECO+1
            NDM2O=NDM2O+NINTMX
            NX = 1
         END IF
  200 CONTINUE
  220 CONTINUE
  240 CONTINUE
  260 CONTINUE
C
C         OUTPUT THE FINAL PARTIAL BUFFER OF DM2
C
      IF (OUT) CALL TR2OUT(0,0,0,0,0,ZERO,1)
      NX = NX-1
      NDM2O=NDM2O+NX
      NX = -NX
      CALL PWRIT(NFTO,X,IX,NX,NINTMX)
      NRECO=NRECO+1
C
      RETURN
      END
C*MODULE GUGDM2  *DECK ORDDMA
      SUBROUTINE ORDDMA(ILOW,IHIGH,NFTI,X,IX,NINTMX,IDAF20,IORA,
     *                  ICHAIN,ICOUNT,LOCBOX,IJKLAD,IA,
     *                  XIJKL,NBOX,LBOX,LBIN,L2,NRECI)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C             NOTE THAT IJKLX AND XIJKL ARE EQUIVALENT BY CALL
C
      DIMENSION IORA(*),IA(L2),ICOUNT(*),ICHAIN(*),XIJKL(*),
     *          LOCBOX(*),IJKLAD(*),X(NINTMX),IX(NINTMX)
C
      COMMON /PCKLAB/ LABSIZ
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
C
      LENGTH = 2*LBIN+2
      NDAF = 1
      DO 100 IBOX = 1,NBOX
         LOCBOX(IBOX) = (IBOX-1)*LENGTH
         IJKLAD(IBOX) = (IBOX-1)*LBOX +ILOW-1
         ICOUNT(IBOX) = 1
         ICHAIN(IBOX) = 0
  100 CONTINUE
      DO 120 I = 1,L2
         IA(I) = (I*I-I)/2
  120 CONTINUE
C
      I = 0
      J = 0
      K = 0
      L = 0
C
C     ----- READ IN -DM2- FROM -NFTI- -----
C
  140 CONTINUE
      NX = 0
      CALL PREAD(NFTI,X,IX,NX,NINTMX)
      NRECI=NRECI+1
      IF(NX.EQ.0) GO TO 200
      MX = ABS(NX)
      IF(MX.GT.NINTMX) THEN
         IF(MASWRK) WRITE(IW,*)' MX .GT. NINTMX IN ORDDMA'
         CALL ABRT
      END IF
      DO 180 M = 1,MX
C
                       NPACK = M
                       IF (LABSIZ .EQ. 2) THEN
*I32                     LABEL = IX( 2*NPACK - 1 )
*I32                     IPACK = ISHFT( LABEL, -16 )
*I32                     JPACK = IAND(  LABEL, 65535 )
*I32                     LABEL = IX( 2*NPACK     )
*I32                     KPACK = ISHFT( LABEL, -16 )
*I32                     LPACK = IAND(  LABEL, 65535 )
*I64                     LABEL = IX(NPACK)
*I64                     IPACK = ISHFT( LABEL, -48 )
*I64                     JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64                     KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64                     LPACK = IAND( LABEL, 65535 )
                       ELSE IF (LABSIZ .EQ. 1) THEN
*I32                     LABEL = IX(NPACK)
*I32                     IPACK = ISHFT( LABEL, -24 )
*I32                     JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32                     KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32                     LPACK = IAND( LABEL, 255 )
*I64                     IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                       LABEL = IX( NPACK/2 )
*I64                       IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64                       JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64                       LPACK = IAND( LABEL, 255 )
*I64                     ELSE
*I64                       LABEL = IX( (NPACK/2)+1 )
*I64                       IPACK = ISHFT( LABEL, -56 )
*I64                       JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64                       LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64                     END IF
                       END IF
                       I = IPACK
                       J = JPACK
                       K = KPACK
                       L = LPACK
C
         IJ = IA(I)+J
         KL = IA(K)+L
         IJKL = IA(IJ)+KL
C
         IF (IJKL .LT. ILOW .OR. IJKL .GT. IHIGH) GO TO 180
         IBOX = (IJKL-ILOW)/LBOX+1
         LCOUNT = ICOUNT(IBOX)
         LOCB = LOCBOX(IBOX)
         LOC = LOCB+LCOUNT
C
         XIJKL(LOC ) = X(M)
         XIJKL(LOC+LBIN) = IJKL-IJKLAD(IBOX)
C
         LCOUNT = LCOUNT+1
         IF (LCOUNT .GT. LBIN) THEN
            LCOUNT = LCOUNT-1
            LOC = LOCB+(LBIN+LBIN)
            XIJKL(LOC+1) = LCOUNT
            XIJKL(LOC+2) = ICHAIN(IBOX)
            CALL RAWRIT(IDAF20,IORA,XIJKL(LOCB+1),LENGTH,NDAF,0)
            ICHAIN(IBOX) = NDAF
            NDAF = NDAF+1
            LCOUNT = 1
         END IF
         ICOUNT(IBOX) = LCOUNT
  180 CONTINUE
      IF (NX .GT. 0) GO TO 140
C
C     ----- DRAIN ALL THE BOXES -----
C
  200 CONTINUE
      DO 220 IBOX = 1,NBOX
         LOCB = LOCBOX(IBOX)
         LOC = LOCB+(LBIN+LBIN)
         LCOUNT = ICOUNT(IBOX)
         XIJKL(LOC+1) = LCOUNT-1
         XIJKL(LOC+2) = ICHAIN(IBOX)
         CALL RAWRIT(IDAF20,IORA,XIJKL(LOCB+1),LENGTH,NDAF,0)
         ICHAIN(IBOX) = NDAF
         NDAF = NDAF+1
  220 CONTINUE
      RETURN
      END
C*MODULE GUGDM2  *DECK ORDDMB
      SUBROUTINE ORDDMB(NBOX,NFTO,XO,IX,NINTMX,IDAF20,IORA,ICHAIN,
     *                  XIJKL,XX,LBOX,LBIN,L1,
     *                  I0,J0,K0,L0,NXO,OUT,NRECO,NDM2O)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT
C
      DIMENSION XO(NINTMX),IX(*),IORA(*),ICHAIN(*),XIJKL(*),XX(*)
C
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (ZERO=0.0D+00)
C
      LENGTH = 2*LBIN+2
C
      IBOX = 0
      IF(OUT) CALL TR2OUT(0,0,0,0,0,ZERO,-1)
  100 IBOX = IBOX+1
      IF (IBOX .GT. NBOX) GO TO 280
      CALL VCLR(XIJKL,1,LBOX)
C
C     ----- READ IN BINS FROM -DAF- -----
C
      NDAF = ICHAIN(IBOX)
  140 CONTINUE
      CALL RAREAD(IDAF20,IORA,XX,LENGTH,NDAF,0)
      NINT = INT(XX(LENGTH-1))
      NDAF = INT(XX(LENGTH  ))
      DO 160 INTS = 1,NINT
         IVAL        = INT(XX(INTS+LBIN))
         XIJKL(IVAL) = XX(INTS)
  160 CONTINUE
      IF (NDAF .GT. 0) GO TO 140
C
C     ----- WRITE -DM2- OUT ON -NFTO- -----
C
      LCOUNT = 0
      I  = I0
      J  = J0
      K  = K0
      L  = L0
      IST = I0
      DO 240 I = IST,L1
      JST = J0
      DO 220 J = JST,I
      J0 = 1
      KST = K0
      DO 200 K = KST,I
      K0 = 1
      LMAX = K
      IF (K .EQ. I) LMAX = J
      LST = L0
      DO 180 L = LST,LMAX
      L0 = 1
      LCOUNT = LCOUNT+1
      IF (LCOUNT .GT. LBOX) GO TO 260
      VAL = XIJKL(LCOUNT)
      IF (VAL.EQ.ZERO) GO TO 180
C
               NPACK = NXO
               IPACK = I
               JPACK = J
               KPACK = K
               LPACK = L
               IF (LABSIZ .EQ. 2) THEN
*I32             IX( 2*NPACK-1 ) = ISHFT( IPACK, 16 ) + JPACK
*I32             IX( 2*NPACK   ) = ISHFT( KPACK, 16 ) + LPACK
*I64             LABEL = ISHFT( IPACK, 48 ) + ISHFT( JPACK, 32 ) +
*I64 *                   ISHFT( KPACK, 16 ) + LPACK
*I64             IX(NPACK) = LABEL
               ELSE IF (LABSIZ .EQ. 1) THEN
*I32             LABEL = ISHFT( IPACK, 24 ) + ISHFT( JPACK, 16 ) +
*I32 *                   ISHFT( KPACK,  8 ) + LPACK
*I32             IX(NPACK) = LABEL
*I64             IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64               LABEL = ISHFT( IPACK, 24 ) + ISHFT( JPACK, 16 ) +
*I64 *                     ISHFT( KPACK,  8 ) + LPACK
*I64               IX( NPACK/2 ) = IX( NPACK/2 ) + LABEL
*I64             ELSE
*I64               LABEL = ISHFT( IPACK, 56 ) + ISHFT( JPACK, 48 ) +
*I64 *                     ISHFT( KPACK, 40 ) + ISHFT( LPACK, 32 )
*I64               IX( (NPACK/2)+1 ) = LABEL
*I64             END IF
               END IF
C
      XO(NXO) = VAL
C
      IF(OUT) CALL TR2OUT(I,J,K,L,NXO,VAL,0)
      NXO = NXO+1
      IF(NXO.GT.NINTMX) THEN
         CALL PWRIT(NFTO,XO,IX,NINTMX,NINTMX)
         NRECO=NRECO+1
         NDM2O=NDM2O+NINTMX
         NXO = 1
      END IF
  180 CONTINUE
  200 CONTINUE
  220 CONTINUE
  240 CONTINUE
C
  260 CONTINUE
      I0 = I
      J0 = J
      K0 = K
      L0 = L
      IF (I0 .LE. L1) GO TO 100
C
C        WRITE FINAL BUFFER OF SORTED DM2 VALUES
C
      NINT = NXO-1
      NDM2O= NDM2O+NINT
      NINT = -NINT
      CALL PWRIT(NFTO,XO,IX,NINT,NINTMX)
      NRECO=NRECO+1
      IF(OUT) CALL TR2OUT(0,0,0,0,0,ZERO,1)
C
C        ALL BOXES ARE FINISHED
C
  280 CONTINUE
      RETURN
      END
C*MODULE GUGDM2  *DECK SETDM2
      SUBROUTINE SETDM2
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXRT=100)
C
      LOGICAL OUT,SOME,AVG
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /DM2AVG/ WAVG(MXRT),IAVG(MXRT),NAVG,AVG
      COMMON /DM2DM2/ IH00,IH01,NWKS
      COMMON /EMPRT / ILEVEL,JLEVEL,KLEVEL,LLEVEL,OUT,SOME
      COMMON /FMCOM / GIJKL(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /LOOPS / A,C,D,VAL,CUTOFF,LAD,NUWK,NLWK,IUWK,JUWK,ITRACK,
     +                IX(6),INTSAD,MXNINT,NGRPS
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /SDM2SV/ SQRT2,LGRP,NLEXT,NLINT,NRECO
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION CIVEC(1),INDX(1)
C
      EQUIVALENCE (CIVEC(1),GIJKL(1)),(INDX(1),GIJKL(1))
C
      PARAMETER (ZERO=0.0D+00, TWO=2.0D+00)
C
      SQRT2 = SQRT(TWO)
      LGRP = 1
      NLEXT = 0
      NLINT = 0
C
C           GET GIJKL BUFFER SPACE
C
      LOADFM = 0
      CALL VALFM(LOADFM)
      INTSAD=LOADFM+1
      CALL GETFM(MXNINT)
      CALL VCLR(GIJKL(INTSAD),1,MXNINT)
      RETURN
C
C     ------------
      ENTRY NXGRP2
C     ------------
C     ----- INITIALIZE DM2 ELEMENTS FOR NEXT GROUP -LGRP- -----
C
      IF (LGRP .GT. NGRPS) THEN
           IF(MASWRK)WRITE(IW,*)' LGRP .GT. NGRPS IN ENTRY NXGRP2'
           CALL ABRT
      END IF
      CALL SQWRIT(NFT15,GIJKL(INTSAD),MXNINT)
      NRECO=NRECO + 1
      LGRP = LGRP+1
      CALL VCLR(GIJKL(INTSAD),1,MXNINT)
      RETURN
C
C     ------------
      ENTRY PUTEX2
C     ------------
      NLEXT = NLEXT+1
      IF (NUWK .EQ. 0) RETURN
      GO TO 140
C
C     ------------
      ENTRY PUTOU2
C     ------------
C     ----- OBTAIN WEIGHTED PRODUCT OF CI COEFFICIENTS -----
C     IOFF AND JOFF ACCOUNT FOR POSITION OF INDX AND CIVEC ARRAYS
C
      NLINT = NLINT+1
  140 CONTINUE
      IOFF = (IH01-1) * NWDVAR
      VAL = ZERO
      DO 190 MAVG=1,NAVG
         IND = IUWK+IOFF
         JND = JUWK+IOFF
         JOFF = IH00 + NWKS*(MAVG-1) - 1
         CCVAL = ZERO
         DO 180 I = 1,NLWK
            II = INDX(IND) + JOFF
            JJ = INDX(JND) + JOFF
            DO 160 J = 1,NUWK
               CCVAL = CCVAL+CIVEC(II)*CIVEC(JJ)
               II = II+1
               JJ = JJ+1
  160       CONTINUE
            IND = IND+1
            JND = JND+1
  180    CONTINUE
         VAL = VAL + WAVG(MAVG)*CCVAL
  190 CONTINUE
C
      IF (IUWK .NE. JUWK) VAL = VAL+VAL
C
C     ----- CALCULATE DENSITY MATRIX ELEMENTS -----
C
      GO TO (200,220,240,260,280,300,320,340,360,380,400,420,440,460,
     +     480,500,520,540),ITRACK
C
  200 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL * A
      GO TO 560
C
  220 GIJKL(LAD+2) = GIJKL(LAD+2) + VAL * A
      GO TO 560
C
  240 GIJKL(LAD+3) = GIJKL(LAD+3) + VAL * A
      GO TO 560
C
  260 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL
      GIJKL(LAD+2) = GIJKL(LAD+2) + VAL
      GO TO 560
C
  280 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL
      GIJKL(LAD+2) = GIJKL(LAD+2) +(VAL + VAL)
      GO TO 560
C
  300 GIJKL(LAD+2) = GIJKL(LAD+2) + VAL
      GIJKL(LAD+3) = GIJKL(LAD+3) + VAL
      GO TO 560
C
  320 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL * A
      GIJKL(LAD+3) = GIJKL(LAD+3) + VAL * A
      GO TO 560
C
  340 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL * A
      GIJKL(LAD+2) = GIJKL(LAD+2) + VAL * A
      GIJKL(LAD+3) = GIJKL(LAD+3) + VAL * A
      GO TO 560
C
  360 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL * A
      GIJKL(LAD+2) = GIJKL(LAD+2) + VAL * A * D
      GO TO 560
C
  380 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL * A * D
      GIJKL(LAD+2) = GIJKL(LAD+2) + VAL * A
      GO TO 560
C
  400 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL * A
      GIJKL(LAD+3) = GIJKL(LAD+3) + VAL * A * D
      GO TO 560
C
  420 GIJKL(LAD+2) = GIJKL(LAD+2) + VAL * A * D
      GIJKL(LAD+3) = GIJKL(LAD+3) + VAL * A
      GO TO 560
C
  440 GIJKL(LAD+2) = GIJKL(LAD+2) + VAL * A
      GIJKL(LAD+3) = GIJKL(LAD+3) + VAL * A
      GO TO 560
C
  460 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL
      GIJKL(LAD+3) = GIJKL(LAD+3) + VAL
      GO TO 560
C
  480 GIJKL(LAD+2) = GIJKL(LAD+2) + VAL
      GIJKL(LAD+3) = GIJKL(LAD+3) - VAL
      GO TO 560
C
  500 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL * SQRT2
      GO TO 560
C
  520 GIJKL(LAD+1) = GIJKL(LAD+1) + VAL * A
      GIJKL(LAD+2) = GIJKL(LAD+2) + VAL * A
      GO TO 560
C
  540 GIJKL(LAD+2) = GIJKL(LAD+2) + VAL * A
      GIJKL(LAD+3) = GIJKL(LAD+3) - VAL * A
C
  560 CONTINUE
      NAD = LAD-(INTSAD-1)
      IF(OUT) WRITE (IW,9068) NLINT,NLEXT,ILEVEL,JLEVEL,KLEVEL,LLEVEL,
     +     NAD,NUWK,NLWK,IUWK,JUWK,ITRACK,A,D,VAL,GIJKL(LAD+1),
     +     GIJKL(LAD+2),GIJKL(LAD+3)
      RETURN
C
C     ------------
      ENTRY FINOU2
C     ------------
      CALL SQWRIT(NFT15,GIJKL(INTSAD),MXNINT)
      NRECO=NRECO + 1
      CALL DDI_GSUMI(1906,NLINT,1)
      CALL DDI_GSUMI(1907,LNEXT,1)
      NLTOT = NLINT+NLEXT
      IF(SOME) WRITE(IW,9008) NLTOT
      IF(SOME) WRITE(IW,9028) NLINT
      IF(SOME) WRITE(IW,9048) NLEXT
      IF(SOME) WRITE(IW,9058) NRECO,MXNINT,NFT15
      CALL RETFM(MXNINT)
      RETURN
C
 9008 FORMAT(1X,I12,' -DM2- LOOPS WERE GENERATED')
 9028 FORMAT(1X,I12,' WERE CREATED BY THE LOOP-DRIVEN ALGORITHM')
 9048 FORMAT(1X,I12,' WERE CREATED IMPLICITLY')
 9058 FORMAT(1X,I10,' RECORDS OF LENGTH',I6,' WRITTEN TO FILE',I3)
 9068 FORMAT(1X,2I10,4I4,5I6,I3,2F12.6,E16.8/1X,3E16.8)
      END
