C 19 SEP 05 - MWS - ADD TRUE NUCLEAR CHARGE ARRAY TO INFOA COMMON
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL
C  7 SEP 04 - MWS - PAD COMMON BLOCK INTFIL
C 23 JUL 04 - SK  - GRDDMA: SPELLING TO AVOID RESERVED WORD IN PGIF77
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C  6 JAN 98 - MWS - CHANGE CALL TO RACLOS
C 17 OCT 96 - SPW - RESURRECT TRFDM2 AND PARTS OF TRFINT FOR CI GRADS
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C 11 JAN 92 - TLW - TRF2DM: MAKE READ PARALLEL
C 10 JAN 92 - TLW - CHANGE REWINDS TO CALL SEQREW
C  8 JAN 92 - TLW - MAKE WRITES PARALLEL; ADD COMMON PAR
C  7 OCT 91 - MWS - CHANGE UNIX BYTE UNPACKING
C  6 OCT 90 - MWS - KILL OUT OF CORE TRANSFORMS, IN LIEU OF A FIX
C  7 AUG 90 - TLW - ADD CF AND CG TO COMMON NSHEL
C 20 JUN 90 - MWS - ADJUST NDAR TO AVOID MULTIPASS DM2 SORTS
C  3 JUN 90 - JAM - CHANGE VAX BYTE PACKING TO FULL 8 BITS
C 16 DEC 89 - MWS - GRDDMA: FIX TYPO, 9993,9994 USE NSH2, NOT NSHL2
C 26 SEP 89 - MWS - ADD NFT13,NFT14 TO /CIFILS/
C 14 AUG 89 - MWS - GRDDM2,GRDDMA,GRDDMB: SIMPLIFIED STORAGE ALLOCATION.
C 28 MAR 89 - MWS - TRF2DM,GRDDM2: CALLS TO RAOPEN ON EXETYP=CHECK RUNS
C  8 MAR 89 - MWS - GRDDMB,WT2DM1: WRITE SYMMETRY UNIQUE VALUES OF DM2,
C                   WEIGHTED BY Q4, SO GRADIENT RUNS CAN USE SYMMETRY.
C                   PASS CUTOFF TO GRDDMB TO AVOID TINY DISK STORES.
C 20 FEB 89 - STE - DEFINE I24 POINTER IN TRFDM2
C 13 OCT 88 - MWS - ALLOCATE ARRAYS FOR VECTOR VERSION (PASSRS,RSTOKL),
C                   USE LOOKUP TABLE IADDS RATHER THAN ROUTINE GRDDMO.
C 10 AUG 88 - MWS - MXSH,MXGSH,MXGTOT FROM 120,10,440 TO 1000,30,5000
C 30 MAY 88 - MWS - USE PARAMETER TO DIMENSION COMMONS
C 14 NOV 87 - STE - USE EXETYP
C  6 AUG 87 - MWS - INCLUDE ETA VERSION
C 18 JUL 87 - MWS - RENAME $TRFDM2 VARIABLE NOCORE TO NOMEM (STE)
C  4 NOV 86 - STE - USE PARAMETERS
C 11 JUL 86 - MWS - PACKING FOR CELERITY AND CRAY VERSIONS
C  7 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS
C 14 DEC 85 - STE - DELETE DM2SQU,PQ2DM,RS2DM,SQU2DM,TSP2DM,WT2DM2
C                   CREATE PASTPQ
C  4 DEC 85 - STE - DELETE OUT2DM,/PRTDM2/; USE GENERIC ABS,MAX,MIN
C                   TRF2DM: DYNAMIC MEMORY FIX FOR OUT-OF-MEM SECTION
C 11 JUL 85 - MWS - CHANGE IBM INDEX PACKING
C 30 MAY 85 - MWS - ADD NPRINT TO RAOPEN CALLS
C 15 MAR 85 - MWS - CALL RASIZE TO GET LDAR
C 24 FEB 84 - STE - ALLOCATE ONLY MEMORY NEEDED IN TRF2DM,GRDDM2
C 20 FEB 84 - STE - CHANGE RAREAD TO DAREAD IN TRF2DM
C 18 JAN 84 - STE - DELETE /OUTPUT/ IN GRDDM2,TRF2DM
C 10 DEC 83 - STE - INITIALIZE NPFLG IN TRF2DM
C 17 NOV 83 - STE - FPS PACKING/UNPACKING
C  7 NOV 83 - STE - DELETE WT2DM0 CODE
C  5 NOV 83 - STE - DELETE CALL DARTRN IN GRDDM2 AND TRF2DM
C 29 OCT 82 - MWS - FIX PACKING ERROR IN WT2DM1
C 21 OCT 82 - MWS - ADD DMY ARGUMENTS TO NAMEIO CALL
C  4 OCT 82 - MWS - CONVERT TO IBM
C
C*MODULE TRFDM2  *DECK GRDDM2
      SUBROUTINE GRDDM2(NDAR,LDAR,NBOXMX,NWORD,CUTOFF,DBUG,OUT,SOME)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DBUG,OUT,SOME,FIN,PACK2E,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      PARAMETER (ZERO=0.0D+00)
C
      DATA CHECK/8HCHECK    /
C
      IF(SOME) WRITE(IW,9999)
C
      L1     = NUM
      NSH1   = NSHELL
      NSH2   = (NSH1*NSH1+NSH1)/2
      NSH2P1 = NSH2+1
C
C     ----- 2 STEP SORTING TECHNIQUE -----
C
      CALL VALFM(LOADFM)
      CALL GOTFM(NGOT)
      NDARMX=NDAR+5000
      LDAF20 = 2*LDAR+2
      IF(NWORD.GT.0) NGOT=MIN(NGOT,NWORD)
C
      LMIN  = L1 + 3*NSH2 + NSH2P1 + 4*NINTMX
     *        + 6*NBOXMX + LDAF20 + NDARMX
      LWORD = NGOT-LMIN
      IF(LWORD.LE.0) THEN
         IF (MASWRK) WRITE(IW,9995) NGOT,LMIN
         CALL ABRT
         STOP
      END IF
C
      NDARU = NDAR
      NTRY  = 0
  110 CONTINUE
      LBIN=LDAR
      NBIN=LWORD/LBIN
      IF(NBIN.GT.NDARU) NBIN=NDARU
      LBOX=LBIN*NBIN
      IF(NBIN.LE.0) THEN
         IF (MASWRK) WRITE(IW,9996) LBOX,LBIN
         CALL ABRT
         STOP
      END IF
C
C     ----- CALCULATE MAXIMUM NUMBER OF BOXES NEEDED -----
C
      N3    =0
      NDM2  =0
      NDM2MX=0
      DO 130 II=1,NSHELL
      NI=(KMAX(II)-KMIN(II)+1)
      DO 130 JJ=1,II
      NJ=(KMAX(JJ)-KMIN(JJ)+1)
      NIJ=NI*NJ
      DO 130 KK=1,II
      NK=(KMAX(KK)-KMIN(KK)+1)
      NIJK=NIJ*NK
      LLMAX=KK
      IF(KK.EQ.II) LLMAX=JJ
      DO 130 LL=1,LLMAX
      NL=(KMAX(LL)-KMIN(LL)+1)
      NIJKL=NIJK*NL
      IF(NDM2+NIJKL.LE.LBOX) GO TO 120
      N3=N3+1
      NDM2=0
  120 NDM2  =NDM2  +NIJKL
      NDM2MX=NDM2MX+NIJKL
  130 CONTINUE
      N3=N3+1
C
      N1=NDARU/NBIN
      N2=LWORD/LDAF20
      NBOX=MIN(N1,N2,N3,NBOXMX)
      IF(NBOX.LE.0) THEN
         IF (MASWRK) WRITE(IW,9993) NDARU,LDAR,NGOT,NBOXMX
         CALL ABRT
         STOP
      END IF
C
C     NUMBER OF PASSES               NPASS
C     NUMBER DM2 /PASS               LPASS=LBOX*NBOX=(LBIN*NBIN)*NBOX
C     NUMBER OF BOXES /PASS          NBOX
C     NUMBER DM2 /BOX                LBOX=LBIN*NBIN
C     NUMBER OF BINS  /BOX           NBIN
C     NUMBER DM2 /BIN                LBIN=LDAR
C
      NBOXU = NBOX
      NBINU = NBIN
      LBINU = LBIN
      LBOXU = LBINU*NBINU
      LPASSU= LBOXU*NBOXU
      NPASSU= (N3-1)/NBOXU+1
      NDAF20= NBINU*NBOXU
      MXBOXU = NBOXU*NPASSU
C
C        ADJUST -NDAR- SO ONLY ONE PASS IS USED.
C
      IF(NPASSU.GT.1) THEN
         NTRY=NTRY+1
         IF(NTRY.GT.5) THEN
            IF (MASWRK) THEN
            WRITE(IW,*) 'FAILED TO ADJUST -NDAR- IN DM2 SORTING.'
            WRITE(IW,*) 'ADJUST $TRFDM2 FOR NDAR GREATER THAN',NDAR
            ENDIF
            CALL ABRT
         END IF
         NDARU=NDARU+1000
         GO TO 110
      END IF
C
C     ----- ASSIGN MEMORY -----
C     ---- SMALL ARRAYS, ALLOCATED FOR BOTH STEPS -----
C
C     LMAPSH      AO'S TO SHELL MAPPING
C     LIA         PAIR INDEX ARRAY
C     LIJN        SHELL INDEXING
C     LIJADD      SHELL INDEXING
C     LIADDS      SHELL INDEXING
C     LXI         -DM2-    BUFFER FOR -NFTI-
C     LIXI        INDEX    BUFFER FOR -NFTI-
C     LXO         -DM2-    BUFFER FOR -NFTO-
C     LIXO        INDEX    BUFFER FOR -NFTO-
C     LSHBXI      BOX INITIAL SHELLS POINTER
C     LSHBXF      BOX FINAL   SHELLS POINTER
C     LBXADR      BOX ADDRESS
C     LLOCBX      BOX LOCATION BIAS (A ONLY)
C     LICOUN      BIN FILLING COUNTER (A ONLY)
C     LICHAN      BIN CHAINING INDEX
C     LIODA       DASORT FILE INDEX
C     LXX         DASORT BUFFER (B ONLY)
C
C     ----- STEP -A-
C     LXIJKL      BIN SPACE
C
C     ----- STEP -B-
C     LXIJKL      BOX SPACE
C
      LMAPSH = LOADFM + 1
      LIA    = LMAPSH + L1
      LIJN   = LIA    + NSH2
      LIJADD = LIJN   + NSH2
      LIADDS = LIJADD + NSH2
      LXI    = LIADDS + NSH2P1
      LIXI   = LXI    + NINTMX
      LXO    = LIXI   + NINTMX
      LIXO   = LXO    + NINTMX
      LSHBXI = LIXO   + NINTMX
      LSHBXF = LSHBXI + NBOXU
      LBXADR = LSHBXF + NBOXU
      LLOCBX = LBXADR + NBOXU
      LICOUN = LLOCBX + NBOXU
      LICHAN = LICOUN + NBOXU
      LIODA  = LICHAN + NBOXU
      LXX    = LIODA  + NDAF20
      LXIJKL = LXX    + LDAF20
      LASTA  = LXIJKL + NBOXU*LDAF20
      LASTB  = LXIJKL + LBOXU
      LAST = MAX(LASTA,LASTB)
      NEED = LAST-LOADFM
C
      IF(SOME) WRITE(IW,9994) NDM2MX,NDARU,LDAR,NGOT,NDAF20,
     *                        LDAF20,NEED,NPASSU,LPASSU,NBOXU,
     *                        NBOXMX,LBOXU,NBINU,LBINU,MXBOXU
C
      CALL GETFM(NEED)
C
C     ----- OPEN DIRECT ACCESS FILE -IDAF20- -----
C
      CALL RAOPEN(IDAF20,X(LIODA),0,NDAF20,LDAF20,NPRINT)
      IF(EXETYP.EQ.CHECK) GO TO 700
C
C     ----- LOOP OVER PASSES -----
C
      NFTI=NFT15
      NFTO=NFT16
      CALL SEQREW(NFTO)
      IF(OUT) CALL TR2OUT(0,0,0,0,0,ZERO,-1)
C
      FIN = .FALSE.
      MBOX =0
      NRECO=0
      NXO  =1
      ISH0 = 1
      JSH0 = 1
      KSH0 = 1
      LSH0 = 1
      ISH1 = 0
      JSH1 = 0
      KSH1 = 0
      LSH1 = 0
      LENX = NBOXU*LDAF20
C
C     ----- LOOP OVER PASSES -----
C
  250 CONTINUE
      CALL GRDDMA(NFTI,X(LXI),X(LIXI),NINTMX,IDAF20,X(LIODA),
     *            NDAF20,LDAF20,X(LXIJKL),LENX,X(LSHBXI),
     *            X(LSHBXF),X(LBXADR),X(LLOCBX),X(LICOUN),
     *            X(LICHAN),NBOXU,X(LMAPSH),L1,X(LIA),X(LIJN),
     *            X(LIJADD),X(LIADDS),NSH2,NSH2P1,
     *            ISH0,JSH0,KSH0,LSH0,ISH1,JSH1,KSH1,LSH1,
     *            MBOX,LBOXU,LBINU,FIN,OUT,DBUG)
      CALL GRDDMB(NFTO,NXO,NRECO,X(LXO),X(LIXO),NINTMX,
     *            IDAF20,X(LIODA),NDAF20,X(LICHAN),X(LSHBXI),
     *            X(LSHBXF),X(LBXADR),NBOXU,X(LIA),X(LIJN),
     *            X(LIJADD),X(LIADDS),NSH2,NSH2P1,X(LXIJKL),LBOXU,
     *            X(LXX),LDAF20,MBOX,LBINU,
     *            ISH0,JSH0,KSH0,LSH0,ISH1,JSH1,KSH1,LSH1,
     *            CUTOFF,OUT,DBUG)
      IF(.NOT.FIN) GO TO 250
C
      NDM2=(NRECO-1)*NINTMX+(NXO-1)
      IF(SOME) WRITE(IW,9997) NDM2,NRECO,NINTMX,NFTO
C
C     ----- CLOSE -IDAF20- -----
C
      CALL RACLOS(IDAF20,'DELETE')
C
  700 CONTINUE
      CALL RETFM(NEED)
      IF(SOME) WRITE(IW,9992)
      CALL TIMIT(1)
      RETURN
C
 9999 FORMAT(/10X,13(1H-)/10X,'-DM2- SORTING'/10X,13(1H-))
 9997 FORMAT(1X,'TOTAL NUMBER OF SORTED -DM2- ELEMENTS IN AO BASIS =',
     *          I10/
     *       1X,I10,' RECORD(S) OF ',I5,' ELEMENTS WRITTEN TO FILE',I5)
 9996 FORMAT(' NOT ENOUGH MEMORY TO FIT ONE BIN INTO ONE BOX.',
     1 ' LBOX,LBIN = ',2I10)
 9995 FORMAT(' NOT ENOUGH MEMORY AVAILABLE. NGOT = ',I10,
     *       ' LMIN=',I10,' NOT INCLUDING BOX SPACE!')
 9994 FORMAT(/,' NUMBER OF -DM2-         = ',I10/
     1 ' GIVEN NDAR,LDAR,LWORD   = ',3I10/
     2 ' USED  NDAR,LDAR,LWORD   = ',3I10/
     3 ' NUMBER OF PASSES        = ',I10/
     4 ' NUMBER OF -DM2- PER PASS= ',I10/
     5 ' NUMBER OF BOXES PER PASS= ',I10,' MAXIMUM GIVEN = ',I10/
     6 ' NUMBER OF -DM2- PER BOX = ',I10/
     7 ' NUMBER OF BINS PER BOX  = ',I10/
     8 ' NUMBER OF -DM2- PER BIN = ',I10/
     9 ' TOTAL NUMBER OF BOXES   = ',I10)
 9993 FORMAT(' INCOHERENT PARAMETERS IN THE SORTING OF -DM2-.',
     1 /,' GIVEN NDAR, LDAR, NGOT, NBOXMX = ',4I10,
     2 ' REEVALUATE THE INPUT PARAMETERS. STOP.')
 9992 FORMAT(' ...... END OF -DM2- SORTING ...... ')
      END
C*MODULE TRFDM2  *DECK GRDDMA
      SUBROUTINE GRDDMA(NFTI,XI,IX,NINTMX,IDAF20,IODA20,NDAF20,
     *                  LDAF20,XIJKL,LENX,NSHBXI,NSHBXF,NBXADR,
     *                  LOCBOX,ICOUNT,ICHAIN,NBOX,MAPAO,L1,
     *                  IA,IJN,IJADD,IADDS,NSH2,NSH2P1,
     *                  ISH0,JSH0,KSH0,LSH0,ISH1,JSH1,KSH1,LSH1,
     *                  MBOX,LBOX,LBIN,FIN,OUT,DBUG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL FIN,OUT,DBUG
      LOGICAL IANDJ,KANDL,IJNDKL
C
      DIMENSION IA(NSH2),IJN(NSH2),IJADD(NSH2),IADDS(NSH2P1),
     *          NSHBXI(NBOX),NSHBXF(NBOX),NBXADR(NBOX),
     *          LOCBOX(NBOX),ICOUNT(NBOX),ICHAIN(NBOX),
     *          XI(NINTMX),IX(NINTMX),IODA20(NDAF20),
     *          MAPAO(L1),XIJKL(LENX)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PCKLAB/ LABSIZ
C
C     ----- SET BOX POINTERS -----
C
      NDAF=1
      DO 10 IBOX=1,NBOX
         LOCBOX(IBOX)=(IBOX-1)*LDAF20
         ICOUNT(IBOX)=1
         ICHAIN(IBOX)=0
   10 CONTINUE
C
      DO 20 I=1,NSH2
         IA(I)=(I*(I-1))/2
   20 CONTINUE
C
C     ----- GENERATE AO'S TO SHELL MAPPING -----
C
      DO 35 II=1,NSHELL
         MINI=KMIN(II)
         MAXI=KMAX(II)
         LOCI=KLOC(II)-MINI
         DO 30 I=MINI,MAXI
            MAPAO(LOCI+I)=II
   30    CONTINUE
   35 CONTINUE
      NIJADD=0
C
      DO 42 II=1,NSHELL
         NI=(KMAX(II)-KMIN(II)+1)
         DO 40 JJ=1,II
            NJ=(KMAX(JJ)-KMIN(JJ)+1)
            NIJ=NI*NJ
            IJSH=IA(II)+JJ
            IJN(IJSH)=NIJ
            NIJADD=NIJADD+NIJ
            IJADD(IJSH)=NIJADD
   40    CONTINUE
   42 CONTINUE
C
      IADDS(1)=0
      DO 45 M=1,NSH2
         IADDS(M+1) = IADDS(M) + IJN(M)*IJADD(M)
   45 CONTINUE
C
C     ----- FIGURE OUT LIMITS FOR EACH BOX -----
C
      FIN=.FALSE.
      IJSH0=IA(ISH0)+JSH0
      KLSH0=IA(KSH0)+LSH0
      NSHBX0=IA(IJSH0)+KLSH0
      IJKLAD = IADDS(IJSH0)
      IF(KLSH0.GT.1) IJKLAD = IJKLAD + IJN(IJSH0)*IJADD(KLSH0-1)
      IBOX=0
      NDM2=0
      JST=JSH0
      KST=KSH0
      LST=LSH0
      JJ=JST
      KK=KST
      LL=LST
      DO 50 II=ISH0,NSHELL
      NI=(KMAX(II)-KMIN(II)+1)
      JJ0=JST
      DO 50 JJ=JJ0,II
      JST=1
      NJ=(KMAX(JJ)-KMIN(JJ)+1)
      NIJ=NI*NJ
      KK0=KST
      DO 50 KK=KK0,II
      KST=1
      NK=(KMAX(KK)-KMIN(KK)+1)
      NIJK=NIJ*NK
      LLMAX=KK
      IF(KK.EQ.II) LLMAX=JJ
      LL0=LST
      DO 50 LL=LL0,LLMAX
      LST=1
      NL=(KMAX(LL)-KMIN(LL)+1)
      NIJKL=NIJK*NL
      IF(NDM2+NIJKL.LE.LBOX) GO TO 50
      IBOX=IBOX+1
      IJSH=IA(II)+JJ
      KLSH=IA(KK)+LL
      NSHBX=IA(IJSH)+KLSH
      NSHBXI(IBOX)=NSHBX0
      NSHBXF(IBOX)=NSHBX - 1
      NSHBX0=NSHBX
      NBXADR(IBOX)=IJKLAD
      IJKLAD = IADDS(IJSH)
      IF(KLSH.GT.1) IJKLAD = IJKLAD + IJN(IJSH)*IJADD(KLSH-1)
      NDM2=0
      IF(IBOX.EQ.NBOX) GO TO 60
   50 NDM2=NDM2+NIJKL
      IBOX=IBOX+1
      IJSH=IA(NSHELL)+NSHELL
      KLSH=IA(NSHELL)+NSHELL
      NSHBX=IA(IJSH)+KLSH
      NSHBXI(IBOX)=NSHBX0
      NSHBXF(IBOX)=NSHBX
      NBXADR(IBOX)=IJKLAD
      FIN=.TRUE.
   60 CONTINUE
      MBOX=IBOX
      ILOW =NSHBXI(   1)
      IHIGH=NSHBXF(MBOX)
      IF(OUT) THEN
         WRITE(IW,9999) ISH0,JSH0,KSH0,LSH0,II,JJ,KK,LL
         WRITE(IW,9998) MBOX
         WRITE(IW,9997) (NSHBXI(IBOX),IBOX=1,MBOX)
         WRITE(IW,9996) (NSHBXF(IBOX),IBOX=1,MBOX)
         WRITE(IW,9994) (IJN(I),I=1,NSH2)
         WRITE(IW,9993) (IJADD(I),I=1,NSH2)
         WRITE(IW,9992) (NBXADR(I),I=1,MBOX)
      END IF
      ISH1=II
      JSH1=JJ
      KSH1=KK
      LSH1=LL
C
      I=0
      J=0
      K=0
      L=0
C
C     ----- READ IN -DM2- FROM -NFTI- -----
C
      CALL SEQREW(NFTI)
      NX = 0
  100 CALL PREAD(NFTI,XI,IX,NX,NINTMX)
      MX=ABS(NX)
      IF(MX.EQ.0) GO TO 200
      IF(MX.GT.NINTMX) CALL ABRT
      DO 160 M=1,MX
      VAL  = XI(M)
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
      IF (I .NE. J) VAL = VAL + VAL
      IF (K .NE. L) VAL = VAL + VAL
      IF (I .GT. K) GO TO 102
         N=I
         I=K
         K=N
         N=J
         J=L
         L=N
         IF (I .GE. K) GO TO 102
         IF (J .GE. L) GO TO 102
            N=J
            J=L
            L=N
  102 CONTINUE
      ISH=MAPAO(I)
      JSH=MAPAO(J)
      KSH=MAPAO(K)
      LSH=MAPAO(L)
      IF(KSH.NE.ISH.OR.LSH.LE.JSH) GO TO 105
      NSH=JSH
      JSH=LSH
      LSH=NSH
      N=I
      I=K
      K=N
      N=J
      J=L
      L=N
  105 CONTINUE
      IJSH=IA(ISH)+JSH
      KLSH=IA(KSH)+LSH
      IJKLSH=IA(IJSH)+KLSH
C
      IF(IJKLSH.LT.ILOW.OR.IJKLSH.GT.IHIGH) GO TO 160
C
      IAT=KATOM(ISH)
      JAT=KATOM(JSH)
      KAT=KATOM(KSH)
      LAT=KATOM(LSH)
      IF(IAT.EQ.JAT.AND.IAT.EQ.KAT.AND.IAT.EQ.LAT) GO TO 160
C
      DO 110 IBOX=1,MBOX
      IF(IJKLSH.GE.NSHBXI(IBOX).AND.IJKLSH.LE.NSHBXF(IBOX)) GO TO 120
  110 CONTINUE
  120 CONTINUE
C
      IJKLAD = IADDS(IJSH)
      IF(KLSH.GT.1) IJKLAD = IJKLAD + IJN(IJSH)*IJADD(KLSH-1)
      IJKLAD=IJKLAD-NBXADR(IBOX)
      MINI=KMIN(ISH)
      MINJ=KMIN(JSH)
      MINK=KMIN(KSH)
      MINL=KMIN(LSH)
      NI=(KMAX(ISH)-MINI+1)
      NJ=(KMAX(JSH)-MINJ+1)
      NK=(KMAX(KSH)-MINK+1)
      NL=(KMAX(LSH)-MINL+1)
      NKL =NK*NL
      NJKL=NJ*NKL
      LOCI=I-(KLOC(ISH)-MINI)
      LOCJ=J-(KLOC(JSH)-MINJ)
      LOCK=K-(KLOC(KSH)-MINK)
      LOCL=L-(KLOC(LSH)-MINL)
      IANDJ =(ISH.EQ.JSH).AND.(LOCI.NE.LOCJ)
      KANDL =(KSH.EQ.LSH).AND.(LOCK.NE.LOCL)
      IJNDKL=(ISH.EQ.KSH.AND.JSH.EQ.LSH).AND.
     *       (LOCI.NE.LOCK.OR.LOCJ.NE.LOCL)
C
      IXXX=LOCI
      JXXX=LOCJ
      KXXX=LOCK
      LXXX=LOCL
      NPASS=1
  130 CONTINUE
      LCOUNT=ICOUNT(IBOX)
      LOCB  =LOCBOX(IBOX)
      LOC   =LOCB+LCOUNT
C
      IJKLX = NJKL*(IXXX-MINI)+ NKL*(JXXX-MINJ)+
     *          NL*(KXXX-MINK)+     (LXXX-MINL)+1+IJKLAD
      XIJKL(LOC     ) = VAL
      XIJKL(LOC+LBIN) = IJKLX
      IF(DBUG) WRITE(IW,9995) I,J,K,L,ISH,JSH,KSH,LSH,IBOX,
     *                        IXXX,JXXX,KXXX,LXXX,IJKLX,VAL,IJKLAD
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,IODA20,XIJKL(LOCB+1),LDAF20,NDAF,0)
         ICHAIN(IBOX)=NDAF
         NDAF=NDAF+1
         LCOUNT=1
      END IF
      ICOUNT(IBOX)=LCOUNT
C
  140 CONTINUE
      NPASS=NPASS+1
      GO TO (150,141,142,143,144,145,146,147,150),NPASS
C
  141 IF(.NOT.IANDJ) GO TO 140
      IXXX=LOCJ
      JXXX=LOCI
      KXXX=LOCK
      LXXX=LOCL
      GO TO 130
C
  142 IF(.NOT.KANDL) GO TO 140
      IXXX=LOCI
      JXXX=LOCJ
      KXXX=LOCL
      LXXX=LOCK
      GO TO 130
C
  143 IF(.NOT.IANDJ.OR..NOT.KANDL) GO TO 140
      IXXX=LOCJ
      JXXX=LOCI
      KXXX=LOCL
      LXXX=LOCK
      GO TO 130
C
  144 IF(.NOT.IJNDKL) GO TO 150
      IXXX=LOCK
      JXXX=LOCL
      KXXX=LOCI
      LXXX=LOCJ
      GO TO 130
C
  145 IF(.NOT.KANDL) GO TO 140
      IXXX=LOCL
      JXXX=LOCK
      KXXX=LOCI
      LXXX=LOCJ
      GO TO 130
C
  146 IF(.NOT.IANDJ) GO TO 140
      IXXX=LOCK
      JXXX=LOCL
      KXXX=LOCJ
      LXXX=LOCI
      GO TO 130
C
  147 IF(.NOT.KANDL.OR..NOT.IANDJ) GO TO 150
      IXXX=LOCL
      JXXX=LOCK
      KXXX=LOCJ
      LXXX=LOCI
      GO TO 130
C
  150 CONTINUE
C
  160 CONTINUE
      IF(NX.GT.0) GO TO 100
C
C     ----- DRAIN ALL THE BOXES -----
C
  200 CONTINUE
      DO 210 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,IODA20,XIJKL(LOCB+1),LDAF20,NDAF,0)
         ICHAIN(IBOX)=NDAF
         NDAF=NDAF+1
  210 CONTINUE
      RETURN
C
 9999 FORMAT(' ISH0,JSH0,KSH0,LSH0,II,JJ,KK,LL = ',8I5)
 9998 FORMAT(' MBOX = ',I5)
 9997 FORMAT(' NSHBXI = ',10I10)
 9996 FORMAT(' NSHBXF = ',10I10)
 9995 FORMAT(4I4,4I4,I5,4I3,I10,E20.12,I10)
 9994 FORMAT(' IJN    = ',10I10)
 9993 FORMAT(' IJADD  = ',10I10)
 9992 FORMAT(' NBXADR = ',10I10)
      END
C*MODULE TRFDM2  *DECK GRDDMB
      SUBROUTINE GRDDMB(NFTO,NXO,NRECO,XO,IX,NINTMX,
     *                  IDAF20,IODA20,NDAF20,ICHAIN,NSHBXI,NSHBXF,
     *                  NBXADR,NBOX,IA,IJN,IJADD,IADDS,NSH2,NSH2P1,
     *                  XIJKL,LBOX,XX,LDAF20,MBOX,LBIN,
     *                  ISH0,JSH0,KSH0,LSH0,ISH1,JSH1,KSH1,LSH1,
     *                  CUTOFF,OUT,DBUG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT,DBUG
C
      DIMENSION IA(NSH2),IJN(NSH2),IJADD(NSH2),IADDS(NSH2P1),
     *          ICHAIN(NBOX),NSHBXI(NBOX),NBXADR(NBOX),NSHBXF(NBOX),
     *          XO(NINTMX),IX(NINTMX),IODA20(NDAF20),
     *          XX(LDAF20),XIJKL(LBOX)
      DIMENSION M0(48),M1(48),M2(48),M3(48)
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- WRITE SYMMETRY UNIQUE -DM2- OUT ON -NFTO- -----
C
      IBOX=0
*I64  MASK32=2**32 - 1
*I64  MASKHI = ISHFT(MASK32,32)
  100 CONTINUE
      IBOX=IBOX+1
      IF(IBOX.GT.MBOX) GO TO 700
      CALL VCLR(XIJKL,1,LBOX)
C
C     ----- READ IN BINS FROM -DAF- -----
C
      INTBOX=0
      NDAF=ICHAIN(IBOX)
  120 CONTINUE
      CALL RAREAD(IDAF20,IODA20,XX,LDAF20,NDAF,0)
      NINT= INT(XX(LDAF20-1))
      NDAF= INT(XX(LDAF20  ))
      IF(NINT.EQ.0) GO TO 135
      DO 130 IT=1,NINT
         IVAL= INT(XX(IT+LBIN))
         XIJKL(IVAL)=XX(IT)
  130 CONTINUE
      INTBOX=INTBOX+NINT
C
  135 CONTINUE
      IF(NDAF.GT.0) GO TO 120
      IF(INTBOX.EQ.0) GO TO 100
C
      II0=ISH0
      JJ0=JSH0
      KK0=KSH0
      LL0=LSH0
C
C     ----- I SHELL ----
C
      IST=II0
      DO 640 II=IST,NSHELL
      IISH = II
      IAT=KATOM(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
      DO 210 IT = 1,NT
         ID = MAPSHL(II,IT)
         IF (ID .GT. II) GO TO 640
         M0(IT) = ID
  210 CONTINUE
C
C     ----- J SHELL ----
C
      JST=JJ0
      JJ0=1
      DO 630 JJ=JST,II
      JAT=KATOM(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      NJ=(MAXJ-MINJ+1)
      LOCJ=KLOC(JJ)-MINJ
      DO 240 IT = 1,NT
         ID = M0(IT)
         JD = MAPSHL(JJ,IT)
         IF (JD .GT. II) GO TO 630
         IF (ID .GE. JD) GO TO 230
         ND = ID
         ID = JD
         JD = ND
  230    IF (ID .EQ. II .AND. JD .GT. JJ) GO TO 630
         M1(IT) = ID
         M2(IT) = JD
  240 CONTINUE
C
C     ----- K SHELL ----
C
      KST=KK0
      KK0=1
      DO 620 KK=KST,II
      KAT=KATOM(KK)
      MINK=KMIN(KK)
      MAXK=KMAX(KK)
      NK=(MAXK-MINK+1)
      LOCK=KLOC(KK)-MINK
      DO 260 IT = 1,NT
         KD = MAPSHL(KK,IT)
         IF (KD .GT. II) GO TO 620
         M3(IT) = KD
  260 CONTINUE
C
C     ----- L SHELL ----
C
      LLMAX=KK
      IF(KK.EQ.II) LLMAX=JJ
      LST=LL0
      LL0=1
      DO 610 LL=LST,LLMAX
      LAT=KATOM(LL)
      MINL=KMIN(LL)
      MAXL=KMAX(LL)
      NL=(MAXL-MINL+1)
      LOCL=KLOC(LL)-MINL
      NNN4 = 0
      DO 340 IT = 1,NT
         LD = MAPSHL(LL,IT)
         IF (LD .GT. II) GO TO 610
         KD = M3(IT)
         IF (KD .GE. LD) GO TO 300
         ND = KD
         KD = LD
         LD = ND
  300    CONTINUE
         ID = M1(IT)
         JD = M2(IT)
         IF (ID .NE. II .AND. KD .NE. II) GO TO 340
         IF (KD .LT. ID) GO TO 320
         IF (KD .EQ. ID .AND. LD .LE. JD) GO TO 320
         ND = ID
         ID = KD
         KD = ND
         ND = JD
         JD = LD
         LD = ND
  320    CONTINUE
         IF (JD .LT. JJ) GO TO 340
         IF (JD .GT. JJ) GO TO 610
         IF (KD .LT. KK) GO TO 340
         IF (KD .GT. KK) GO TO 610
         IF (LD .LT. LL) GO TO 340
         IF (LD .GT. LL) GO TO 610
         NNN4 = NNN4+1
  340 CONTINUE
C
      IJSH=IA(II)+JJ
      KLSH=IA(KK)+LL
      IJKLSH=IA(IJSH)+KLSH
C
      IF(IJKLSH.LT.NSHBXI(IBOX)) GO TO 610
      IF(IJKLSH.GT.NSHBXF(IBOX)) GO TO 650
C
      IF(IAT.EQ.JAT.AND.IAT.EQ.KAT.AND.IAT.EQ.LAT) GO TO 610
C
      IJKLAD = IADDS(IJSH)
      IF(KLSH.GT.1) IJKLAD = IJKLAD + IJN(IJSH)*IJADD(KLSH-1)
      IJKLAD=IJKLAD-NBXADR(IBOX)
C
      NKL =NK*NL
      NJKL=NJ*NKL
C
C     ----- CALCULATE Q4 FACTOR FOR THIS GROUP OF SHELLS -----
C
      Q4 = NT
      Q4 = Q4 / NNN4
C
C              BEGIN BASIS FUNCTION LOOPS
C
      DO 540 I=MINI,MAXI
      DO 530 J=MINJ,MAXJ
      DO 520 K=MINK,MAXK
      DO 510 L=MINL,MAXL
C
      IJKLX=NJKL*(I-MINI)+NKL*(J-MINJ)+
     *        NL*(K-MINK)+    (L-MINL)+1+IJKLAD
      VAL=XIJKL(IJKLX) * Q4
      IF(ABS(VAL).LT.CUTOFF) GO TO 510
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
      NXO=NXO+1
      IF(DBUG) WRITE(IW,9999) II,JJ,KK,LL,I,J,K,L,IJKLX,IJKLAD
      IF(OUT) THEN
         N1 = LOCI+I
         N2 = LOCJ+J
         N3 = LOCK+K
         N4 = LOCL+L
         CALL TR2OUT(N1,N2,N3,N4,NXO,VAL,0)
      END IF
      IF(NXO.GT.NINTMX) THEN
         CALL PWRIT(NFTO,XO,IX,NINTMX,NINTMX)
         NRECO=NRECO+1
         NXO=1
      END IF
C
C           END OF BASIS FUNCTION LOOPS
C
  510 CONTINUE
  520 CONTINUE
  530 CONTINUE
  540 CONTINUE
C
      IF(LABSIZ.EQ.2) THEN
*I32     IX( 2*NXO-1 ) = 0
*I32     IX( 2*NXO   ) = 0
*I64     IX(NXO) = 0
      ELSE
*I32     IX(NXO) = 0
*I64     IF(MOD(NXO,2).EQ.0) THEN
*I64        IX(NXO/2) = IAND(IX(NXO/2),MASKHI)
*I64     ELSE
*I64        IX(NXO/2+1) = 0
*I64     END IF
      END IF
C
      XO(NXO)=ZERO
      NXO=NXO+1
      IF(NXO.GT.NINTMX) THEN
         CALL PWRIT(NFTO,XO,IX,NINTMX,NINTMX)
         NRECO=NRECO+1
         NXO=1
      END IF
C
C           END OF SHELL LOOPS
C
  610 CONTINUE
  620 CONTINUE
  630 CONTINUE
  640 CONTINUE
      IISH = NSHELL+1
C
C           END OF THIS BOX
C
  650 CONTINUE
      IF(IISH.LE.NSHELL) GO TO 100
      NINT=-(NXO-1)
      CALL PWRIT(NFTO,XO,IX,NINT,NINTMX)
      NRECO=NRECO+1
      IF(OUT) CALL TR2OUT(0,0,0,0,0,ZERO,1)
C
C           END OF ALL BOXES IN THIS PASS
C
  700 CONTINUE
      ISH0=ISH1
      JSH0=JSH1
      KSH0=KSH1
      LSH0=LSH1
      RETURN
 9999 FORMAT(4I4,4I4,2I10)
      END
C*MODULE TRFDM2  *DECK PASSPQ
      SUBROUTINE PASSPQ(IDAF,IODA,LDAR,V,
     +                  XRSPQ,XIJ,L1,M1,M2,LWIDTH,NSTRIP,MSTRIP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION V(L1,M1)
      DIMENSION XRSPQ(LWIDTH,M2),XIJ(L1,M1)
      DIMENSION IODA(*)
C
      PARAMETER (HALF=0.5D+00)
C
      ISTRIP = 0
      MRSROW = LWIDTH
C
C     ----- TRANSFORM -P- AND -Q- -----
C
      DO 390 MR = 1,M1
         DO 380 MS = 1,MR
            MRSROW = MRSROW + 1
            IF (MRSROW .LE. LWIDTH) GO TO 200
C
C              ----- READ IN A STRIP OF (RS//PQ) INTEGRALS -----
C
            MRSROW = 1
            ISTRIP = ISTRIP + 1
            CALL RDROW1(IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,
     *                  ISTRIP,XRSPQ)
C
C              ----- TRANSFORM TO (RS//IJ) -----
C
  200       CONTINUE
            IF(MR.EQ.MS) CALL DSCAL(M2,HALF,XRSPQ(MRSROW,1),LWIDTH)
            CALL TRNSSM(L1,M1,LWIDTH,XRSPQ(MRSROW,1),V,XIJ)
C
C              ----- WRITE IT OUT AS (RS//IJ) -----
C
            IF(MRSROW.EQ.LWIDTH) CALL WTROW2(IDAF,IODA,LDAR,LWIDTH,
     *                                       NSTRIP,MSTRIP,ISTRIP,XRSPQ)
  380    CONTINUE
  390 CONTINUE
      IF (MRSROW .LT. LWIDTH) CALL WTROW2
     *   (IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,ISTRIP,XRSPQ)
      RETURN
      END
C*MODULE TRFDM2  *DECK TIJKL0
      SUBROUTINE TIJKL0(L1,L2,M1,M2,V,XT4,XT2,XT1)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION V(L1,M1),XT4(L2,L2),XT2(L1,M1),XT1(L1)
C
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00)
C
C     ----- TRANSFORM -P- AND -Q- -----
C
      MRS = 0
      DO 120 MR=1,M1
         DO 110 MS = 1,MR
            MRS = MRS + 1
            IF (MR .EQ. MS) CALL DSCAL(M2,HALF,XT4(1,MRS),1)
            CALL TRNSSM(L1,M1,1,XT4(1,MRS),V,XT2)
  110    CONTINUE
  120 CONTINUE
C
C     ----- TRANSFORM -R- AND -S- -----
C
      MIJ=0
      DO 310 MI=1,L1
         DO 300 MJ=1,MI
            MIJ=MIJ+1
C
            DO 215 MS=1,M1
               DO 210 MK=MI,L1
                  XT2(MK,MS)=ZERO
  210          CONTINUE
  215       CONTINUE
C
            MRS = 0
            DO 240 MR=1,M1
               DO 230 MS=1,MR
                  MRS=MRS+1
                  VAL=XT4(MIJ,MRS)
                  IF(VAL.EQ.ZERO) GO TO 230
                     DO 220 MK=MI,L1
                        XT2(MK,MS)=XT2(MK,MS)+VAL*V(MK,MR)
  220                CONTINUE
                     DO 225 MK=MI,L1
                        XT2(MK,MR)=XT2(MK,MR)+VAL*V(MK,MS)
  225                CONTINUE
  230          CONTINUE
  240       CONTINUE
C
            MKL = MIJ
            LMIN=MJ
            DO 290 MK=MI,L1
               DO 250 ML=LMIN,MK
                  XT1(ML)=ZERO
  250          CONTINUE
               DO 270 MS=1,M1
                  VAL=XT2(MK,MS)
                  IF(VAL.EQ.ZERO) GO TO 270
                     DO 260 ML=LMIN,MK
                        XT1(ML)=XT1(ML)+VAL*V(ML,MS)
  260                CONTINUE
  270          CONTINUE
               DO 280 ML=LMIN,MK
                  XT4(MIJ,MKL)=XT1(ML)
                  MKL = MKL + 1
  280          CONTINUE
               LMIN=1
  290       CONTINUE
C
  300    CONTINUE
  310 CONTINUE
      RETURN
      END
C*MODULE TRFDM2  *DECK TIJKL1
      SUBROUTINE TIJKL1(L1,L2,M1,M2,V,XRSPQ,XT2,XT1,
     *                  NFTO,X,IX,CUTOFF,OUT,SOME)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PACK2E,OUT,SOME
C
      DIMENSION V(L1,M1),XRSPQ(L2,M2),XT2(L1,M1),XT1(L1),
     *          X(NINTMX),IX(NINTMX)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
C
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00)
C
      IF (OUT) CALL TR2OUT(0,0,0,0,0,ZERO,-1)
      NREC = 0
      NX = 1
C
C     ----- TRANSFORM -P- AND -Q- -----
C
C
      MRS = 0
      DO 110 MR=1,M1
         DO 100 MS = 1,MR
            MRS = MRS + 1
            IF (MR .EQ. MS) CALL DSCAL(M2,HALF,XRSPQ(1,MRS),1)
            CALL TRNSSM(L1,M1,1,XRSPQ(1,MRS),V,XT2)
  100    CONTINUE
  110 CONTINUE
C
C     ----- TRANSFORM -R- AND -S- -----
C
      MIJ=0
      DO 210 MI=1,L1
         MIX = MI
         DO 200 MJ=1,MI
            MIJ=MIJ+1
            MJX = MJ
            CALL RSTOKL(M1,L1,L2,MIX,MJX,NFTO,NX,NREC,CUTOFF,.TRUE.,
     *                  OUT,V,XRSPQ(MIJ,1),XT2,XT1,X,IX)
  200    CONTINUE
  210 CONTINUE
C
      IF (OUT) CALL TR2OUT(0,0,0,0,0,ZERO,1)
      NX = NX-1
      NINT = NREC*NINTMX+NX
      NREC = NREC + 1
      NX = -NX
      CALL PWRIT(NFTO,X,IX,NX,NINTMX)
      IF (SOME) WRITE(IW,9008) NINT,NREC,NINTMX,NFTO
      RETURN
C
 9008 FORMAT(1X,'TOTAL NUMBER OF NONZERO -DM2- ELEMENTS IN AO BASIS =',
     *          I10/
     *       1X,I10,' RECORD(S) OF ',I5,' ELEMENTS WRITTEN TO FILE',I5)
      END
C*MODULE TRFDM2  *DECK TRF2DM
      SUBROUTINE TRF2DM
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PACK2E,OUT,DBUG,SOME,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (NNAM=7)
      PARAMETER (MXATM=2000)
C
      DIMENSION QNAM(NNAM),KQNAM(NNAM),TRFDM2(1)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA CHECK/8HCHECK   /, DEBUG/8HDEBUG   /, DBUGME/8HTRFDM2  /
C
C     ----- SET UP NAMELIST SIMULATION -----
C
      DATA TRFDM2 /8HTRFDM2  /
      DATA QNAM /8HNDAR    ,8HLDAR    ,8HNBOXMX  ,
     *           8HNWORD   ,8HCUTOFF  ,8HNOMEM   ,8HNPFLG   /
      DATA KQNAM /1,1,1,1,3,1,1/
C
C     ----- MAIN DRIVER FOR 2 PARTICLE DENSITY BACKTRANSFORM -----
C     THE BACKTRANSFORMATION OF THE DENSITY FROM THE MO BASIS
C     TO THE AO BASIS IS NECESSARY FOR DERIVATIVE CALCULATIONS.
C
C     ----- READ NAMELIST /TRFDM2/ -----
C
      NDAR = 2000
      LDAR = 0
      CALL RASIZE(LDAR)
      NBOXMX = 200
      NWORD = 0
      CUTOFF = 1.0D-09
      NOMEM = 0
      NPFLG = 0
C
      JRET = 0
      CALL NAMEIO(IR,JRET,TRFDM2,NNAM,QNAM,KQNAM,
     *            NDAR,LDAR,NBOXMX,NWORD,CUTOFF,NOMEM,NPFLG,
     *            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,0,0)
      IF(JRET.GE.2) THEN
         IF (MASWRK) WRITE(IW,9000)
         CALL ABRT
      END IF
C
      OUT =NPFLG.GE.1 .AND. MASWRK
      DBUG=NPFLG.GE.2 .AND. MASWRK
      SOME = (NPRINT.NE.-5  .OR. OUT) .AND. MASWRK
      IF (EXETYP .EQ. DEBUG  .OR.  EXETYP .EQ. DBUGME) THEN
         SOME = MASWRK
         DBUG = MASWRK
         OUT  = MASWRK
      END IF
      IF(SOME) WRITE(IW,9010) NWORD,NDAR,NOMEM,LDAR,NPFLG,NBOXMX,CUTOFF
C
      CALL VALFM(LOADFM)
      CALL GOTFM(NGOTMX)
      IF(NWORD.GT.0) NGOTMX=MIN(NGOTMX,NWORD)
      IF(SOME) WRITE(IW,9020) NGOTMX
C
C     ----- READ IN -DRT- DATA TO GET -NORBS- VALUE -----
C
      CALL SEQREW(NFT11)
      CALL RDDRT(NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,NREFS,
     *           IEXCT,NFOCI,INTACT,NCORBS)
      CALL SEQREW(NFT11)
C
      M1= NORBS
      M2=(NORBS*NORBS+NORBS)/2
C
      L1= NUM
      L2=(NUM*NUM+NUM)/2
      L3= NUM*NUM
      L5= L2 * M2
C
C     ----- MEMORY DEMAND FOR INCORE TRANSF AND INCORE SORT -----
C
      LVEC = LOADFM + 1
      LXT4 = LVEC   + L3
      LXT2 = LXT4   + L2*L2
      LXT1 = LXT2   + M1*L1
      LIA  = LXT1   + L1
      LX   = LIA    + L1
      LIX  = LX     + NINTMX
      LAST = LIX    + NINTMX
      NEED=LAST-LOADFM-1
      IF(SOME) WRITE(IW,9100) NEED
      IF(NEED.GT.NGOTMX) GO TO 150
      IF(NOMEM.GE.1) GO TO 150
C
C     ----- DO IN MEMORY TRANSFORMATION AND IN MEMORY SORT -----
C
      IF(SOME) WRITE(IW,9110)
      CALL GETFM(NEED)
      IF (EXETYP.EQ.CHECK) GO TO 140
C
C           LOAD MO VECTORS
C
      CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
C
C           LOAD -DM2- IN MO BASIS FOR TRANSFORMATION TO AO BASIS
C
      CALL RDSQU(NFT15,M1,L2,X(LIA),X(LXT4),X(LX),X(LIX))
C
C           TRANSFORM -DM2- BACK TO AO BASIS
C
      IF(OUT) WRITE(IW,*) 'TRANSFORMED -DM2- ELEMENTS'
      CALL TIJKL0(L1,L2,M1,M2,X(LVEC),X(LXT4),X(LXT2),X(LXT1))
C
C           OUTPUT -DM2- FOR GRADIENT CALCULATION
C
      CALL WT2DM0(NFT16,L1,L2,X(LIA),X(LXT4),X(LX),X(LIX),
     *            CUTOFF,OUT,SOME)
C
  140 CONTINUE
      CALL RETFM(NEED)
      IF(MASWRK) WRITE(IW,9300)
      CALL TIMIT(1)
      GO TO 300
C
C     ----- MEMORY DEMAND FOR INCORE TRANSF, OUT OF CORE SORT -----
C
  150 CONTINUE
      LVEC   = 1      + LOADFM
      LXRSPQ = LVEC   + L3
      LXT2   = LXRSPQ + L5
      LXT1   = LXT2   + M1*L1
      LX     = LXT1   + L1
      LIX    = LX     + NINTMX
      LAST   = LIX    + NINTMX
      NEED=LAST-LVEC-1
      IF(SOME) WRITE(IW,9150) NEED
      IF(NEED.GT.NGOTMX) GO TO 200
      IF(NOMEM.GE.2) GO TO 200
C
C     ----- DO IN MEMORY TRANSFORMATION, BUT OUT OF MEMORY SORT -----
C
      IF(SOME) WRITE(IW,9160)
      CALL GETFM(NEED)
      IF (EXETYP .EQ. CHECK) GO TO 180
C
C           LOAD MO VECTORS
C
      CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
C
C           LOAD -DM2- IN MO BASIS FOR TRANSFORMATION TO AO BASIS
C           NOTE THAT -IA- IS KEPT AT ADDRESS -LXT1-
C
      CALL RDSQU(NFT15,M1,L2,X(LXT1),X(LXRSPQ),X(LX),X(LIX))
      CALL SEQREW(NFT15)
C
C           TRANSFORM -DM2- BACK TO AO BASIS AND STORE ON NFT15
C
      CALL TIJKL1(L1,L2,M1,M2,X(LVEC),X(LXRSPQ),X(LXT2),X(LXT1),
     *            NFT15,X(LX),X(LIX),CUTOFF,OUT,SOME)
C
  180 CONTINUE
      CALL RETFM(NEED)
      IF(MASWRK) WRITE(IW,9300)
      CALL TIMIT(1)
C
C           NOW BRANCH TO OUT OF MEMORY SORT OF AO BASIS DM2
C
      GO TO 250
C
C     ----- MEMORY FOR OUT OF CORE TRANSF AND OUT OF CORE SORT -----
C
  200 CONTINUE
      LVEC  = LOADFM + 1
      LXKL  = LVEC   + L3
      LXIJKS= LXKL   + L1
      LX    = LXIJKS + L1*M1
      LIX   = LX     + NINTMX
      LAST  = LIX    + NINTMX
C
      NTRY = 1
  210 CONTINUE
      NAVAIL=NGOTMX - (LAST-LOADFM-1) - (NDAR/NWDVAR+1)
      IF(NAVAIL.LE.0) GO TO 305
      NSTRIP = (L2*L2 - 1)/NAVAIL + 1
      IF(NSTRIP.EQ.1) NSTRIP=2
      LWIDTH = (L2-1)/NSTRIP + 1
      MSTRIP=(M2-1)/LWIDTH+1
      NSQUAR=NSTRIP*MSTRIP
      LAREA =LWIDTH**2
      NSPACE=NSQUAR*LAREA
      IF(NSPACE.LT.L5) GO TO 320
      IF(NSQUAR.LE.NDAR) GO TO 220
         NDAR = NSQUAR + 50
         NTRY = NTRY + 1
         IF(NTRY.GT.2) THEN
            IF(MASWRK) WRITE(IW,*) 'GIVING UP ON DM2 BKTF MEMORY ALLOC'
            CALL ABRT
         END IF
         GO TO 210
C
  220 CONTINUE
      LXIJRS = LAST
      LIODA  = LXIJRS + LAREA*NSTRIP
      LAST   = LIODA  + (NSQUAR-1)/NWDVAR+1
      NEED=LAST-LOADFM-1
      IF(SOME) WRITE(IW,9200) NEED,NDAR,LDAR,NGOTMX,NSQUAR,LAREA,NEED,
     *                        LWIDTH,NSTRIP,MSTRIP
      IF(NEED.GT.NGOTMX) GO TO 310
C
C     ----- DO OUT OF MEMORY TRANSFORMATION -----
C
      CALL GETFM(NEED)
C---------------------------------PATCH-------------------------------
C     IF(IW.GT.0) THEN
C        IF (MASWRK) WRITE(IW,8234)
C        CALL ABRT
C        STOP
C     END IF
C8234 FORMAT(/1X,'THE OUT OF CORE -DM2- TRANSFORMATION IS BROKEN.'/
C    *       1X,'AT PRESENT, NO FIX IS KNOWN, SO YOUR JOB IS HALTED.'//
C    *       1X,'THE ONLY WAY TO GET A CORRECT CI GRADIENT AT'/
C    *       1X,'PRESENT IS TO INCREASE MEMORY SO THAT THE TRANSFORM'/
C    *       1X,'WILL RUN IN MEMORY.  IT IS NOT NECESSARY TO FIT THE'/
C    *       1X,'DM2 SORT IN MEMORY, AS THE OUT OF CORE SORTING CODE'/
C    *       1X,'DOES WORK CORRECTLY.')
C---------------------------------PATCH-------------------------------
C
C           OPEN DIRECT ACCESS FILE -IDAF20-
C
      LDAR20=LAREA
      CALL RAOPEN(IDAF20,X(LIODA),0,NSQUAR,LDAR20,NPRINT)
      IF(EXETYP.EQ.CHECK) GO TO 240
C
C           OUTPUT -DM2- ON -IDAF20-
C
      CALL SQUCAN(IDAF20,X(LIODA),LDAR20,NFT15,X(LX),X(LIX),
     *            X(LXKL),X(LXIJRS),LWIDTH,NSTRIP,M1)
      CALL SEQREW(NFT15)
C
C           LOAD MO VECTORS
C
      CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
C
C           TRANSFORM -P- AND -Q-
C
      CALL PASSPQ(IDAF20,X(LIODA),LDAR20,X(LVEC),X(LXIJRS),
     *            X(LXIJKS),L1,M1,M2,LWIDTH,NSTRIP,MSTRIP)
C
C           TRANSFORM -R- AND -S-
C
      IF(OUT) WRITE(IW,*) 'TRANSFORMED -DM2- ELEMENTS'
      CALL PASSRS(IDAF20,X(LIODA),LDAR20,X(LVEC),X(LXIJRS),X(LXIJKS),
     *            X(LXKL),L1,LWIDTH,NSTRIP,MSTRIP,M1,NFT15,
     *            X(LX),X(LIX),CUTOFF,.TRUE.,OUT,SOME)
C
C           CLOSE -IDAF20-
C
  240 CONTINUE
      CALL RACLOS(IDAF20,'DELETE')
      CALL RETFM(NEED)
      IF(MASWRK) WRITE(IW,9300)
      CALL TIMIT(1)
C
C     ----- OUT OF MEMORY SORT OF -DM2- -----
C
  250 CONTINUE
      CALL GRDDM2(NDAR,LDAR,NBOXMX,NWORD,CUTOFF,DBUG,OUT,SOME)
C
  300 CONTINUE
      CALL SEQREW(NFT15)
      CALL SEQREW(NFT16)
      RETURN
C
  305 CONTINUE
      DMY = LDAR
      IDMY = INT(SQRT(DMY))
      NEED = IDMY * L2 - NAVAIL
  310 CONTINUE
      MORE = NEED - NGOTMX
      IF (MASWRK) WRITE(IW,9410) MORE
      CALL ABRT
      STOP
C
  320 CONTINUE
      IF (MASWRK) WRITE(IW,9420)
     *   NGOTMX,NDAR,LDAR,LWIDTH,NSTRIP,NSQUAR,LAREA,NSPACE,L5
      CALL ABRT
      STOP
C
 9000 FORMAT(1X,'SYNTAX ERROR IN NAMELIST $TRFDM2 FOUND. STOP.')
 9010 FORMAT(/10X,25(1H-)/10X,'-DM2- BACK TRANSFORMATION',
     *       /10X,25(1H-)//
     *      5X,'PARAMETERS CONTROLLING THE BACK TRANSFORMATION'/
     *      5X,'NWORD =',I12,'  NDAR  =',I6/
     *      5X,'NOMEM =',I12,'  LDAR  =',I6/
     *      5X,'NPFLG =',I12,'  NBOXMX=',I6/
     *      5X,'CUTOFF=',1P,E12.4)
 9020 FORMAT(/I10,' WORDS ARE AVAILABLE.')
 9100 FORMAT( I10,' WORDS NEEDED TO TRANSFORM AND SORT DM2 IN MEMORY')
 9110 FORMAT(1X,'CHOOSING IN MEMORY TRANSFORM AND IN MEMORY SORT...')
 9150 FORMAT( I10,' WORDS NEEDED TO TRANSFORM DM2 IN MEMORY')
 9160 FORMAT(1X,'CHOOSING IN MEMORY TRANSFORM, OUT OF MEMORY SORT...')
 9200 FORMAT( I10,' WORDS NEEDED TO TRANSFORM DM2 OUT OF MEMORY'/
     *       1X,'GIVEN NDAR, LDAR, NWORD   = ',3I10/
     *       1X,'USED  NDAR, LDAR, NWORD   = ',3I10/
     *       1X,' LWIDTH, NSTRIP, MSTRIP   = ',3I10)
 9300 FORMAT(' ...... END OF -DM2- TRANSFORMATION ......')
 9410 FORMAT(' NEED MORE MEMORY. INCREASE BY AT LEAST ',
     1 I10,' WORDS.')
 9420 FORMAT(' NEED MORE DISK SPACE',/,' GIVEN NGOT,NDAR,LDAR = ',3I10,
     1 /,' CALCULATED LWIDTH,NSTRIP,NSQUAR,LAREA = ',4I10,/,
     2   ' -DA- SPACE AVAILABLE = ',I10,' NEEDED = ',I10)
      END
C*MODULE TRFDM2  *DECK TRNSSM
      SUBROUTINE TRNSSM(L1,M1,INC,XSYMP,V,XV)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION V(L1,M1),XSYMP(INC,*),XV(L1,M1)
C
      PARAMETER (ZERO=0.0D+00)
C
      L2 = (L1*L1+L1)/2
      CALL VCLR(XV,1,L1*M1)
      MPQ = 0
      DO 40 MP=1,M1
         DO 30 MQ=1,MP
            MPQ=MPQ+1
            VAL=XSYMP(1,MPQ)
            IF(VAL.EQ.ZERO) GO TO 30
               DO 10 MI=1,L1
                  XV(MI,MQ)=XV(MI,MQ)+VAL*V(MI,MP)
   10          CONTINUE
               IF (MP .EQ. MQ) GO TO 30
                  DO 20 MI=1,L1
                     XV(MI,MP)=XV(MI,MP)+VAL*V(MI,MQ)
   20             CONTINUE
   30    CONTINUE
   40 CONTINUE
C
      CALL VCLR(XSYMP,INC,L2)
      DO 90 MQ=1,M1
         MII = 0
         DO 80 MI=1,L1
            VAL=XV(MI,MQ)
            IF(VAL.EQ.ZERO) GO TO 70
               DO 60 MJ=1,MI
                  XSYMP(1,MII+MJ)=XSYMP(1,MII+MJ)+VAL*V(MJ,MQ)
   60          CONTINUE
   70       CONTINUE
            MII = MII + MI
   80    CONTINUE
   90 CONTINUE
      RETURN
      END
C*MODULE TRFDM2  *DECK WT2DM0
      SUBROUTINE WT2DM0(NFTO,IORB,L2,IA,TX,X,IX,CUTOFF,OUT,SOME)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION TX(L2,L2),X(NINTMX),IX(NINTMX),IA(IORB)
      DIMENSION M0(48),M1(48),M2(48),M3(48)
C
      LOGICAL PACK2E
      LOGICAL OUT,SOME
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- WRITE DM2 TO DISK FOR GRADIENT CALCULATION -----
C
      CALL SEQREW(NFTO)
      NREC=0
      NX=1
*I64  MASK32=2**32 - 1
*I64  MASKHI = ISHFT(MASK32,32)
      IF(OUT) CALL TR2OUT(0,0,0,0,0,ZERO,-1)
C
      DO 50 I=1,IORB
   50 IA(I)=(I*(I-1))/2
C
C     ----- I SHELL -----
C
      DO 740 II=1,NSHELL
      IAT=KATOM(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
      DO 210 IT = 1,NT
         ID = MAPSHL(II,IT)
         IF (ID .GT. II) GO TO 740
         M0(IT) = ID
  210 CONTINUE
C
C     ----- J SHELL -----
C
      DO 730 JJ=1,II
      JAT=KATOM(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      LOCJ=KLOC(JJ)-MINJ
      DO 140 IT = 1,NT
         ID = M0(IT)
         JD = MAPSHL(JJ,IT)
         IF (JD .GT. II) GO TO 730
         IF (ID .GE. JD) GO TO 130
         ND = ID
         ID = JD
         JD = ND
  130    IF (ID .EQ. II .AND. JD .GT. JJ) GO TO 730
         M1(IT) = ID
         M2(IT) = JD
  140 CONTINUE
C
C     ----- K SHELL -----
C
      DO 720 KK=1,II
      KAT=KATOM(KK)
      MINK=KMIN(KK)
      MAXK=KMAX(KK)
      LOCK=KLOC(KK)-MINK
      DO 160 IT = 1,NT
         KD = MAPSHL(KK,IT)
         IF (KD .GT. II) GO TO 720
         M3(IT) = KD
  160 CONTINUE
C
C     ----- L SHELL -----
C
      MAXLL=KK
      IF(KK.EQ.II) MAXLL=JJ
      DO 710 LL=1,MAXLL
      LAT=KATOM(LL)
C
      IF(IAT.EQ.JAT.AND.IAT.EQ.KAT.AND.IAT.EQ.LAT) GO TO 710
C
      MINL=KMIN(LL)
      MAXL=KMAX(LL)
      LOCL=KLOC(LL)-MINL
      NNN4 = 0
      DO 340 IT = 1,NT
         LD = MAPSHL(LL,IT)
         IF (LD .GT. II) GO TO 710
         KD = M3(IT)
         IF (KD .GE. LD) GO TO 300
         ND = KD
         KD = LD
         LD = ND
  300    CONTINUE
         ID = M1(IT)
         JD = M2(IT)
         IF (ID .NE. II .AND. KD .NE. II) GO TO 340
         IF (KD .LT. ID) GO TO 320
         IF (KD .EQ. ID .AND. LD .LE. JD) GO TO 320
         ND = ID
         ID = KD
         KD = ND
         ND = JD
         JD = LD
         LD = ND
  320    CONTINUE
         IF (JD .LT. JJ) GO TO 340
         IF (JD .GT. JJ) GO TO 710
         IF (KD .LT. KK) GO TO 340
         IF (KD .GT. KK) GO TO 710
         IF (LD .LT. LL) GO TO 340
         IF (LD .GT. LL) GO TO 710
         NNN4 = NNN4+1
  340 CONTINUE
C
C     ----- CALCULATE Q4 FACTOR FOR THIS GROUP OF SHELLS -----
C
      Q4 = NT
      Q4 = Q4 / NNN4
C
C     ----- BEGIN PRIMITIVE LOOPS -----
C
      DO 640 I=MINI,MAXI
      DO 630 J=MINJ,MAXJ
      DO 620 K=MINK,MAXK
      DO 610 L=MINL,MAXL
C
      N1=LOCI+I
      N2=LOCJ+J
      N3=LOCK+K
      N4=LOCL+L
C
      IF(N1.GE.N2) GO TO 510
      N =N1
      N1=N2
      N2=N
  510 IF(N3.GE.N4) GO TO 520
      N =N3
      N3=N4
      N4=N
  520 IF(N1-N3) 530,540,550
  530 N =N1
      N1=N3
      N3=N
      N =N2
      N2=N4
      N4=N
      GO TO 550
  540 IF(N2.LT.N4) GO TO 530
C
  550 CONTINUE
      N12=IA(N1)+N2
      N34=IA(N3)+N4
      VAL=TX(N34,N12) * Q4
      IF(N1.NE.N2) VAL=VAL+VAL
      IF(N3.NE.N4) VAL=VAL+VAL
      IF(ABS(VAL).LT.CUTOFF) GO TO 610
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(N1,N2,N3,N4,NX,VAL,0)
      NX=NX+1
      IF(NX.GT.NINTMX) THEN
         CALL PWRIT(NFTO,X,IX,NINTMX,NINTMX)
         NREC=NREC+1
         NX=1
      END IF
C
C        END OF PRIMITIVE LOOPS
C
  610 CONTINUE
  620 CONTINUE
  630 CONTINUE
  640 CONTINUE
C
C           STORE 0 INDEX LABELS AS SIGNAL THIS SHELL SET IS ENDED
C
      IF(LABSIZ.EQ.2) THEN
*I32     IX( 2*NX-1 ) = 0
*I32     IX( 2*NX   ) = 0
*I64     IX(NX) = 0
      ELSE
*I32     IX(NX) = 0
*I64     IF(MOD(NX,2).EQ.0) THEN
*I64        IX(NX/2) = IAND(IX(NX/2),MASKHI)
*I64     ELSE
*I64        IX(NX/2+1) = 0
*I64     END IF
      END IF
C
      X(NX)=ZERO
      NX=NX+1
C
      IF(NX.GT.NINTMX) THEN
         CALL PWRIT(NFTO,X,IX,NINTMX,NINTMX)
         NREC=NREC+1
         NX=1
      END IF
C
C        END OF SHELL LOOPS
C
  710 CONTINUE
  720 CONTINUE
  730 CONTINUE
  740 CONTINUE
C
      IF(OUT) CALL TR2OUT(0,0,0,0,0,ZERO,1)
      NX=NX-1
      NINT=NREC*NINTMX+NX
      NREC=NREC+1
      NX=-NX
      CALL PWRIT(NFTO,X,IX,NX,NINTMX)
C
      IF(SOME) WRITE(IW,9008) NINT,NREC,NINTMX,NFTO
      RETURN
C
 9008 FORMAT(1X,'TOTAL NUMBER OF NONZERO -DM2- ELEMENTS IN AO BASIS =',
     *          I10/
     *       1X,I10,' RECORD(S) OF ',I5,' ELEMENTS WRITTEN TO FILE',I5)
      END
C*MODULE TRFINT  *DECK PASSRS
      SUBROUTINE PASSRS(IDAF,IODA,LDAR,V,XIJRS,XIJKS,XKL,
     *                  M1,LWIDTH,NSTRIP,MSTRIP,L1,
     *                  NFTO,X,IX,CUTOFF,REVRSE,OUT,SOME)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT,SOME,PACK2E,REVRSE
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAFX,NAV,IODAX(950)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
C
      DIMENSION V(M1,L1),XIJRS(LWIDTH,NSTRIP),XIJKS(M1,L1),XKL(M1),
     *          X(NINTMX),IX(NINTMX),IODA(*)
C
      IF (OUT) CALL TR2OUT(0,0,0,0,0,0,-1)
      NREC = 0
      NX = 1
C
C     ----- TRANSFORM -R- AND -S-
C
      ISTRIP = 0
      MIJROW = LWIDTH
      DO 160 MI = 1,M1
         MIX = MI
         DO 140 MJ = 1,MI
            MJX = MJ
            MIJROW = MIJROW + 1
            IF (MIJROW .LE. LWIDTH) GO TO 120
C
C                 ----- READ IN A STRIP OF (IJ//RS)) INTEGRALS -----
C
            MIJROW = 1
            ISTRIP = ISTRIP + 1
            CALL RDROW2(IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,
     *                  ISTRIP,XIJRS)
C
C           ----- TRANSFORM TO (IJ//KL) INTEGRALS -----
C
  120       CONTINUE
            CALL RSTOKL(L1,M1,LWIDTH,MIX,MJX,NFTO,NX,NREC,CUTOFF,
     *                  REVRSE,OUT,V,XIJRS(MIJROW,1),XIJKS,XKL,X,IX)
  140    CONTINUE
  160 CONTINUE
C
      IF (OUT) CALL TR2OUT(0,0,0,0,0,0,1)
      NX = NX-1
      NINT = NREC*NINTMX+NX
      NREC = NREC+1
      NX = -NX
      CALL PWRIT(NFTO,X,IX,NX,NINTMX)
      IF (SOME) WRITE (IW,9008) NINT,NREC,NINTMX,NFTO
      RETURN
C
 9008 FORMAT(1X,'TOTAL NUMBER OF NONZERO -DM2- ELEMENTS IN AO BASIS =',
     *          I10/
     *       1X,I10,' RECORD(S) OF ',I5,' ELEMENTS WRITTEN TO FILE',I5)
      END
C*MODULE TRFINT  *DECK RDROW1
C***********************************************************************
C*       ROUTINE RDROW1(IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,ISTRIP,X)
C*
C*    AUTHOR - S. T. ELBERT (AMES LABORATORY-USDOE) DEC 1985
C*
C*    PURPOSE -
C*       READ A STRIP OF ROWS FROM DISK (PASS 1)
C*
C*    ON ENTRY -
C*       IDAF   - INTEGER
C*                DIRECT ACCESS FILE LOGICAL UNIT NUMBER
C*       IODA   - INTEGER (NDAR)
C*                TABLE OF POINTERS TO ACTUAL DISK RECORDS
C*       LDAR   - INTEGER = LWIDTH**2
C*                LENGHT OF A LOGICAL RECORD TO BE WRITTEN
C*       LWIDTH - INTEGER
C*                NUMBER OF ROWS IN THE STRIP IN MEMORY
C*       NSTRIP - INTEGER
C*                NUMBER OF ROW BLOCKS IN DISK FILE
C*       MSTRIP - INTEGER
C*                NUMBER OF COLUMN BLOCKS IN DISK FILE
C*       ISTRIP - INTEGER
C*                COLUMN NUMBER OF CURRENT STRIP IN RANGE 1:MSTRIP
C*
C*    ON EXIT -
C*       X      - W.P. REAL (LDAR,NSTRIP)
C*                DATA READ INTO MEMORY
C*
C***********************************************************************
      SUBROUTINE RDROW1(IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,ISTRIP,X)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION X(LDAR,NSTRIP), IODA(*)
C
C-----------------------------------------------------------------------
C
      IJBLK = (ISTRIP-1)*NSTRIP + 1
      IF (ISTRIP .EQ. 1) GO TO 130
C
C              GET BLOCKS UP TO BUT NOT INCLUDING DIAGONAL
C
         DO 120 LBLK = 1,ISTRIP-1
            CALL RAREAD(IDAF,IODA,X(1,LBLK),LDAR,IJBLK,0)
            IJBLK = IJBLK + 1
  120    CONTINUE
  130 CONTINUE
      IIBLK = IJBLK
      IF (ISTRIP .EQ. MSTRIP) GO TO 150
C
C              GET BLOCKS AFTER DIAGONAL AND TRANSPOSE THEM
C              USING THE DIAGONAL BLOCK AS WORK SPACE
C
         DO 140 LBLK = ISTRIP+1,MSTRIP
            IJBLK = IJBLK + NSTRIP
            CALL RAREAD(IDAF,IODA,X(1,ISTRIP),LDAR,IJBLK,0)
            CALL TRPOSE(X(1,ISTRIP),X(1,LBLK),LWIDTH,LWIDTH,0)
  140    CONTINUE
  150 CONTINUE
C
C           NOW GET THE DIAGONAL BLOCK
C
      CALL RAREAD(IDAF,IODA,X(1,ISTRIP),LDAR,IIBLK,0)
      RETURN
      END
C*MODULE TRFINT  *DECK RDROW2
C***********************************************************************
C*       ROUTINE RDROW2(IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,ISTRIP,X)
C*
C*    AUTHOR - S. T. ELBERT (AMES LABORATORY-USDOE) DEC 1985
C*
C*    PURPOSE -
C*       READ A STRIP OF ROWS FROM DISK (PASS 2)
C*
C*    ON ENTRY -
C*       IDAF   - INTEGER
C*                DIRECT ACCESS FILE LOGICAL UNIT NUMBER
C*       IODA   - INTEGER (NDAR)
C*                TABLE OF POINTERS TO ACTUAL DISK RECORDS
C*       LDAR   - INTEGER = LWIDTH**2
C*                LENGHT OF A LOGICAL RECORD TO BE WRITTEN
C*       LWIDTH - INTEGER
C*                NUMBER OF ROWS IN THE STRIP IN MEMORY
C*       NSTRIP - INTEGER
C*                NUMBER OF ROW BLOCKS IN DISK FILE
C*       MSTRIP - INTEGER
C*                NUMBER OF COLUMN BLOCKS IN DISK FILE
C*       ISTRIP - INTEGER
C*                ROW NUMBER OF CURRENT STRIP IN RANGE 1:NSTRIP
C*       X      - W.P. REAL (LDAR,NSTRIP)
C*                DATA IN STRIP
C*
C*    ON EXIT -
C*       X      - W.P. REAL (LDAR,NSTRIP)
C*                DATA READ INTO MEMORY
C*
C***********************************************************************
      SUBROUTINE RDROW2(IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,ISTRIP,X)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION X(LDAR,NSTRIP), IODA(*)
C
C-----------------------------------------------------------------------
C
      IJBLK = ISTRIP
      IIBLK = IJBLK
      ITBLK = MIN(ISTRIP,MSTRIP)
      DO 120 NBLK = 1,MSTRIP
         IF (NBLK .NE. ITBLK) THEN
C
C              TRANSPOSE ALL BLOCKS EXCEPT ITBLK
C
            CALL RAREAD(IDAF,IODA,X(1,ITBLK),LDAR,IJBLK,0)
            CALL TRPOSE(X(1,ITBLK),X(1,NBLK),LWIDTH,LWIDTH,0)
         ELSE
C
C              REMEMBER WHICH RECORD IS ITBLK
C
            IIBLK = IJBLK
         END IF
C
         IJBLK = IJBLK + NSTRIP
  120 CONTINUE
C
C        NOW GET ITBLK STRAIGHT
C
      CALL RAREAD(IDAF,IODA,X(1,ITBLK),LDAR,IIBLK,0)
      RETURN
      END
C*MODULE TRFINT  *DECK RDSQU
      SUBROUTINE RDSQU(NFTI,L1,L2,IA,OX,X,IX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PACK2E
C
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /PCKLAB/ LABSIZ
C
      DIMENSION OX(L2,*),X(NINTMX),IX(NINTMX),IA(L1)
C
      L3 = 0
      DO 100 I = 1,L1
         IA(I) = L3
         L3 = L3 + I
  100 CONTINUE
      CALL VCLR(OX,1,L2*L3)
C
C     ----- READ IN INTEGRALS FROM -NFTI- -----
C
      CALL SEQREW(NFTI)
      NX = 0
  140 CONTINUE
         CALL PREAD(NFTI,X,IX,NX,NINTMX)
         IF (NX .EQ. 0) GO TO 180
C
         MX = ABS(NX)
         IF (MX .GT. NINTMX) CALL ABRT
         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
            VAL = X(M)
            OX(IJ,KL) = VAL
            OX(KL,IJ) = VAL
  160    CONTINUE
      IF (NX .GT. 0) GO TO 140
C
  180 CONTINUE
      RETURN
      END
C*MODULE TRFINT  *DECK RSTOKL
      SUBROUTINE RSTOKL(L1,IORB,NIJ,MI,MJ,NFTO,NX,NREC,CUTOFF,REVRSE,
     *                  OUT,V,XIJRS,XIJKS,XKL,X,IX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT,PACK2E,REVRSE
C
      DIMENSION V(IORB,L1)
      DIMENSION X(NINTMX),IX(NINTMX)
      DIMENSION XIJRS(*),XIJKS(IORB,L1),XKL(IORB)
C
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- FOR A GIVEN I AND J TRANSFORM (IJ//RS) TO (IJ//KL) -----
C
      THRSH = CUTOFF/(IORB**2)
C
C     THE TRANSFORMATION CAN YIELD THE NORMAL CANONICAL ORDER
C     FILE, OR STEVE ELBERT'S REVERSE CANONICAL ORDER FILE.
C     THE FORMER IS (29/24)N**5, THE LATTER (25/24)N**5.
C
C        CANONICAL ORDER             REVERSE CANONICAL
C     I.GE.J, K.GE.L, IJ.GE.KL    I.GE.J, K.GE.L, KL.GE.IJ
C     DO I=1,NUM                  DO I=1,NUM
C        DO J=1,I                    DO J=1,I
C           DO K=1,I                    DO K=I,NUM
C              DO L=1,K OR J               DO L=1 OR J,K
C     J IS USED IN THE L LOOPS WHENEVER I=K.  BE CAREFUL,
C     I'S LOOK LIKE 1'S, ESPECIALLY IN THE REVERSE K LOOP.
C
      IF(REVRSE) THEN
         KMIN = MI
         KMAX = IORB
      ELSE
         KMIN = 1
         KMAX = MI
      END IF
C
C     ----- TRANSFORM (IJ//RS) TO (IJ//KS) -----
C
      CALL TRNRK(L1,NIJ,IORB,THRSH,KMIN,KMAX,XIJRS,XIJKS,V)
C
C     ----- TRANSFORM (IJ//KS) TO (IJ//KL) AND OUTPUT TO DISK -----
C
      DO 500 MK = KMIN,KMAX
         IF(REVRSE) THEN
            LMIN = 1
            LMAX = MK
            IF(MK.EQ.MI) LMIN = MJ
         ELSE
            LMIN = 1
            LMAX = MK
            IF(MK.EQ.MI) LMAX = MJ
         END IF
         DO 420 ML = LMIN,LMAX
            XKL(ML) = ZERO
  420    CONTINUE
         DO 460 MS = 1,L1
            VAL = XIJKS(MK,MS)
            IF (ABS(VAL) .LE. THRSH) GO TO 460
               DO 440 ML = LMIN,LMAX
                  XKL(ML) = XKL(ML)+VAL*V(ML,MS)
  440          CONTINUE
  460    CONTINUE
C
C              ----- WRITE OUT RESULTS ON -NFTO- -----
C
         DO 480 ML = LMIN,LMAX
            VAL = XKL(ML)
            IF ( ABS(VAL) .LT. CUTOFF) GO TO 480
C
               NPACK = NX
               IPACK = MI
               JPACK = MJ
               KPACK = MK
               LPACK = ML
               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(MI,MJ,MK,ML,NX,VAL,0)
               NX = NX+1
               IF (NX .LE. NINTMX) GO TO 480
                  CALL PWRIT(NFTO,X,IX,NINTMX,NINTMX)
                  NREC = NREC+1
                  NX = 1
  480    CONTINUE
  500 CONTINUE
      RETURN
      END
C*MODULE TRFINT  *DECK SQUCAN
      SUBROUTINE SQUCAN(IDAF,IODA,LDAR,NFTI,X,IX,IA,OX,
     +                  LWIDTH,NSTRIP,L1)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PACK2E
C
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /PCKLAB/ LABSIZ
C
      DIMENSION X(NINTMX),IX(NINTMX),IA(L1),OX(LWIDTH,*),IODA(*)
C
      II = 0
      DO 100 I = 1,L1
         IA(I) = II
         II = II + I
  100 CONTINUE
      CALL VCLR(OX,1,LDAR)
C
C     ----- READ IN VALUES FROM -NFTI- -----
C     ----- WRITE THEM OUT ON -IDAF-      -----
C
      CALL SEQREW(NFTI)
      ISTRIP = 1
      IROW = 0
      NX = 0
  160 CONTINUE
         CALL PREAD(NFTI,X,IX,NX,NINTMX)
         IF (NX .EQ. 0) GO TO 340
C
         MX = ABS(NX)
         IF (MX .GT. NINTMX) CALL ABRT
         DO 320 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
                       I1 = IPACK
                       I2 = JPACK
                       I3 = KPACK
                       I4 = LPACK
C
            IJ = IA(I1)+I2
            KL = IA(I3)+I4
            IJSTRP = (IJ-1)/LWIDTH+1
            IF (IJSTRP .GT. ISTRIP) THEN
               CALL WTROW1(IDAF,IODA,LDAR,LWIDTH,NSTRIP,IROW,ISTRIP,OX)
               IROW = IROW + LWIDTH
               ISTRIP = ISTRIP + 1
               CALL VCLR(OX,1,(IROW+LWIDTH)*LWIDTH)
            END IF
            IJROW = IJ-IROW
            OX(IJROW,KL) = X(M)
  320    CONTINUE
  340    CONTINUE
      IF (NX .GT. 0) GO TO 160
      CALL WTROW1(IDAF,IODA,LDAR,LWIDTH,NSTRIP,IROW,ISTRIP,OX)
      RETURN
      END
C*MODULE TRFINT  *DECK TRNRK
      SUBROUTINE TRNRK(L1,NIJ,IORB,THRSH,KMIN,KMAX,XIJRS,XIJKS,V)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION XIJRS(*),XIJKS(IORB,L1),V(IORB,L1)
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- TRANSFORM IJRS INTEGRALS TO IJKS INTEGRALS -----
C                 XIJKS = SUM ON R  XIJRS*V(R,K)
C     -V- AND -XIJKS- ARE STORED AS THEIR TRANSPOSES.
C     -XIJRS- IS STORED IN TRIANGULAR ORDER, STRIDE OF -NIJ-,
C     WITH ITS DIAGONAL HALVED IN VALUE.
C
      DO 140 MS = 1,L1
      DO 140 MK = KMIN,KMAX
  140 XIJKS(MK,MS) = ZERO
C
      MIJRS = 1 - NIJ
      DO 400 MR = 1,L1
         DO 380 MS = 1,MR
            MIJRS = MIJRS + NIJ
            VAL = XIJRS(MIJRS)
            IF (ABS(VAL) .LE. THRSH) GO TO 380
               DO 340 MK = KMIN,KMAX
                  XIJKS(MK,MS) = XIJKS(MK,MS) + VAL*V(MK,MR)
  340          CONTINUE
               DO 360 MK = KMIN,KMAX
                  XIJKS(MK,MR) = XIJKS(MK,MR) + VAL*V(MK,MS)
  360          CONTINUE
  380    CONTINUE
  400 CONTINUE
      RETURN
      END
C*MODULE TRFINT  *DECK WTROW1
C***********************************************************************
C*       ROUTINE WTROW1(IDAF,IODA,LDAR,LWIDTH,NSTRIP,IROW,ISTRIP,X)
C*
C*    AUTHOR - S. T. ELBERT (AMES LABORATORY-USDOE) DEC 1985
C*
C*    PURPOSE -
C*       WRITE A STRIP OF ROWS TO DISK (PASS 1)
C*
C*    ON ENTRY -
C*       IDAF   - INTEGER
C*                DIRECT ACCESS FILE LOGICAL UNIT NUMBER
C*       IODA   - INTEGER (NDAR)
C*                TABLE OF POINTERS TO ACTUAL DISK RECORDS
C*       LDAR   - INTEGER = LWIDTH**2
C*                LENGHT OF A LOGICAL RECORD TO BE WRITTEN
C*       LWIDTH - INTEGER
C*                NUMBER OF ROWS IN THE STRIP IN MEMORY
C*       NSTRIP - INTEGER
C*                NUMBER OF ROW BLOCKS IN DISK FILE
C*       IROW   - INTEGER
C*                ZEROETH COLUMN IN ROW MARKING LAST BLOCK
C*       ISTRIP - INTEGER
C*                COLUMN NUMBER OF CURRENT STRIP IN RANGE 1:IROW
C*       X      - W.P. REAL (LDAR,NSTRIP)
C*                DATA IN STRIP
C*
C*    ON EXIT -
C*       X      - W.P. REAL (LDAR,NSTRIP)
C*                LAST BLOCK HAS BEEN FILLED OUT SYMMETRICALLY
C*
C***********************************************************************
      SUBROUTINE WTROW1(IDAF,IODA,LDAR,LWIDTH,NSTRIP,IROW,ISTRIP,X)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION X(LWIDTH,*), IODA(*)
C
C-----------------------------------------------------------------------
C
      IROW1 = IROW+1
C
C        MAKE LAST BLOCK SYMMETRIC
C
      DO 110 I=2,LWIDTH
         CALL DCOPY(I,X(I,IROW1),LWIDTH,X(1,IROW+I),1)
  110 CONTINUE
C
C           PUT EACH BLOCK ON DISK
C
      LBLK = 1
      I0BLK = (ISTRIP-1)*NSTRIP
      DO 120 IJBLK = I0BLK+1, I0BLK+ISTRIP
         CALL RAWRIT(IDAF,IODA,X(1,LBLK),LDAR,IJBLK,0)
         LBLK = LBLK + LWIDTH
  120 CONTINUE
      RETURN
      END
C*MODULE TRFINT  *DECK WTROW2
C***********************************************************************
C*       ROUTINE WTROW2(IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,ISTRIP,X)
C*
C*    AUTHOR - S. T. ELBERT (AMES LABORATORY-USDOE) DEC 1985
C*
C*    PURPOSE -
C*       WRITE A STRIP OF ROWS TO DISK (PASS 2)
C*
C*    ON ENTRY -
C*       IDAF   - INTEGER
C*                DIRECT ACCESS FILE LOGICAL UNIT NUMBER
C*       IODA   - INTEGER (NDAR)
C*                TABLE OF POINTERS TO ACTUAL DISK RECORDS
C*       LDAR   - INTEGER = LWIDTH**2
C*                LENGHT OF A LOGICAL RECORD TO BE WRITTEN
C*       LWIDTH - INTEGER
C*                NUMBER OF ROWS IN THE STRIP IN MEMORY
C*       NSTRIP - INTEGER
C*                NUMBER OF ROW BLOCKS IN DISK FILE
C*       MSTRIP - INTEGER
C*                NUMBER OF COLUMN BLOCKS IN DISK FILE
C*       ISTRIP - INTEGER
C*                COLUMN NUMBER OF CURRENT STRIP IN RANGE 1:MSTRIP
C*       X      - W.P. REAL (LDAR,NSTRIP)
C*                DATA IN STRIP
C*
C*    ON EXIT -
C*       NO CHANGE IN MEMORY
C*
C***********************************************************************
      SUBROUTINE WTROW2(IDAF,IODA,LDAR,LWIDTH,NSTRIP,MSTRIP,ISTRIP,X)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION X(LDAR,NSTRIP), IODA(*)
C
C-----------------------------------------------------------------------
C
      I1BLK = (ISTRIP-1)*NSTRIP + 1
      IJBLK = I1BLK
      ITBLK = ISTRIP
C
C        IF THIS IS NOT THE FIRST STRIP, WRITE THE FIRST BLOCK
C        SO THE SPACE MAY BE USED TO TRANSPOSE BLOCKS BEFORE WRITING
C
C        IF THIS IS THE FIRST STRIP WRITE OTHER BLOCKS FIRST AND
C        USE LAST BLOCK TO TRANSPOSE THE FIRST BLOCK
C
      IF (ISTRIP .NE. 1) CALL RAWRIT(IDAF,IODA,X,LDAR,IJBLK,0)
C
      LBLK = NSTRIP
      DO 120 NBLK = 2,NSTRIP
         IJBLK = IJBLK + 1
         LBLK = NBLK
         IF (NBLK .EQ. ITBLK) THEN
C
C              TRANSPOSE THE DIAGONAL BLOCK AND, FOR LAST STRIP ONLY,
C              ALL BLOCKS BELOW THE DIAGONAL
C
            CALL TRPOSE(X(1,LBLK),X,LWIDTH,LWIDTH,0)
            LBLK = 1
            IF (ISTRIP .EQ. MSTRIP) ITBLK = ITBLK + 1
         END IF
C
         CALL RAWRIT(IDAF,IODA,X(1,LBLK),LDAR,IJBLK,0)
  120 CONTINUE
      IF (ISTRIP .EQ. 1) THEN
C
C           OK TO TRANSPOSE FIRST BLOCK OF FIRST STRIP NOW
C
         CALL TRPOSE(X,X(1,LBLK),LWIDTH,LWIDTH,0)
         CALL RAWRIT(IDAF,IODA,X(1,LBLK),LDAR,I1BLK,0)
      END IF
      RETURN
      END
