C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C 19 SEP 01 - MWS - CONVERT MXAOCI PARAMTER TO MXAO
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 26 NOV 96 - VAG - INCREASE CI AO'S TO 768
C 29 SEP 96 - KRG - ADDED SOME ERROR MESSAGES BEFORE ABRT CALLS
C 13 JUN 96 - MWS - REMOVE A FTNCHEK WARNING
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C 13 DEC 93 - TLW - LOOPY: MATRIX ELEMENT OUTPUT DIVIDED OVER NODES
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C 11 JAN 92 - TLW - DRTTAP,GUGDAEM: 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 17 DEC 91 - MWS - COSMETIC CHANGES, WHILE DEBUGGING SOMETHING ELSE
C  7 JAN 90 - MWS - SUPPRESS PRINTOUT OF DRT FILE TITLE
C 11 DEC 89 - MWS - DRTTAP,GUGAEM,LOOPY: /ORBSYM/ REPLACED /DRTBUF/
C 26 SEP 89 - MWS - ADD NFT13,NFT14 TO /CIFILS/
C  3 APR 89 - STE - INTEGRALS NOW ON NFT14
C 20 FEB 89 - STE - DELETE EXTERN, AND ITS CALL FROM LOOPY (DEAD CODE)
C 31 JAN 89 - MWS - RENAME PUTEXT,PUTOUT,NXTGRP,FINOUT TO PUTEX1,...
C  7 OCT 88 - MWS - INCREASE AO NUMBER FROM 128 TO 256
C 14 JAN 88 - MWS - CHANGE EXTERNAL IN LOOPY FOR CRAY-2
C 17 NOV 87 - STE - INTEGRALS NOW ON NFT12; USE EXETYP
C  6 AUG 87 - MWS - INCLUDE ETA VERSION
C  3 NOV 86 - STE - EXTERN/EXTSAV/, LOOPY/LPYSAV/, SETEM/SEMSAV/,
C                   SETMXE/SMXESV (SAVE FOOLS FPS COMPILER)
C  5 AUG 86 - MWS - SINGLY SUBSCRIPT /FMCOM/ IN SETMXE
C 21 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS,
C                   PACKING FOR CELERITY AND CRAY VERSIONS,
C                   SAVE STATEMENT REPLACES /SEMSAV/ AND /SMXESV/
C 15 OCT 85 - STE - USE GENERIC SQRT,ABS; /CIFILE/ BECOMES /CIFILS/
C                   SETEM:/SEMSAV/;SETMXE:/SMXESV/ INSTEAD OF SAVE
C 12 JUL 84 - STE - ADD PRINT OPTION TO SETMXE
C  5 MAY 84 - STE - CHANGE SO GUGDM2 CAN USE LOOPY,EXTERN(DEF SQRT2,1)
C 21 FEB 84 - STE - MAKE OUTPUT BUFFERS DYNAMIC WITH 32 BIT INDEXES
C 11 JAN 84 - STE - SAVE VARIABLES IN SETEM AND SETMXE
C 28 DEC 83 - STE - DELETE GUGARD,GUGWTD
C 18 NOV 83 - STE - FPS PACKING IN SETMXE
C  7 NOV 83 - STE - DELETE SETEXT,THREEX; MAKE EXTERN MAIN ROUTINE
C 21 OCT 82 - MWS - ADD DMY ARGUMENTS TO NAMEIO CALL
C  1 OCT 82 - MWS - CONVERT TO IBM
C
C*MODULE GUGEM   *DECK DRTTAP
      SUBROUTINE DRTTAP(NFT11,NROWS,NROWS4,NKL,NIJ,NABCA,NABCB,NABCS,
     +                  IARC,NLWKS,NUWKS,PUWK,INDX,IWGHT,IJADD,IJGRP,
     *                  KADD,LADD,INEXT,JMNNXT,JMXNXT,NWKS,
     *                  NEXT,NGRPS,NINTMX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER   PUWK
C
      PARAMETER (MXAO=8192)
C
      DIMENSION NABCA(NROWS),NABCB(NROWS),NABCS(NROWS)
      DIMENSION IARC(NROWS4),NLWKS(NROWS),NUWKS(NROWS),PUWK(NROWS)
      DIMENSION INDX(NWKS),IWGHT(NROWS4),IJADD(NIJ),IJGRP(NIJ)
      DIMENSION KADD(NKL),LADD(NKL),INEXT(200),JMNNXT(200),JMXNXT(200)
C
      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
C
      READ (NFT11) IOUT
      READ (NFT11) ISYM
      READ (NFT11) LEVNR
      READ (NFT11) LEVPT
      READ (NFT11) NABCA
      READ (NFT11) NABCB
      READ (NFT11) NABCS
      READ (NFT11) NLWKS
      READ (NFT11) NUWKS
      READ (NFT11) PUWK
      READ (NFT11) INDX
      READ (NFT11) IARC
      READ (NFT11) IWGHT
      READ (NFT11) NGRPS,NEXT,NINTMX
      READ (NFT11) IJADD
      READ (NFT11) IJGRP
      READ (NFT11) KADD
      READ (NFT11) LADD
      READ (NFT11) INEXT
      READ (NFT11) JMNNXT
      READ (NFT11) JMXNXT
      RETURN
      END
C*MODULE GUGEM   *DECK GUGAEM
      SUBROUTINE GUGAEM(NPRINT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      EXTERNAL PUTEX1,PUTOU1,NXGRP1,FINOU1
C
      LOGICAL SOME,OUT,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (TENPM8=1.0D-08, NNAM=2)
      PARAMETER (MXATM=2000, MXAO=8192)
C
      DIMENSION TITLE1(10)
      DIMENSION QNAM(NNAM),KQNAM(NNAM),GUGEM(1)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /EMPRT / ILEVEL,JLEVEL,KLEVEL,LLEVEL,OUT,SOME
      COMMON /FMCOM / XX(1)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /LOOPS / X(4),THRSEM,IX(12),INTSAD,NINTMX,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 /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA DEBUG/8HDEBUG   /
C
C     ----- SET UP NAMELIST SIMULATION -----
C
      DATA GUGEM/8HGUGEM   /
      DATA QNAM/8HCUTOFF  ,8HNWORD    /
      DATA KQNAM/3,1/
C
      SOME = NPRINT .NE. -5 .AND. MASWRK
      OUT = NPRINT .GT. 0 .AND. MASWRK
      IF (RUNTYP .EQ. DEBUG) THEN
         SOME = .TRUE. .AND. MASWRK
         OUT  = .TRUE. .AND. MASWRK
      END IF
      IF (SOME) WRITE (IW,9008)
C
C     ----- READ NAMELIST -$GUGEM- -----
C
      CUTOFF=TENPM8
      NWORD=0
      JRET=0
      CALL NAMEIO(IR,JRET,GUGEM,NNAM,QNAM,KQNAM,
     *            CUTOFF,NWORD,   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,  0,0,0,0,0)
      IF (JRET .GT. 1) THEN
         IF (MASWRK) WRITE (IW,9128)
         CALL ABRT
      END IF
      THRSEM = CUTOFF
C
C     ----- GET FAST MEMORY -----
C
      LOADFM = 0
      CALL VALFM(LOADFM)
C
C     ----- READ IN -DRT- DATA         -----
C     ----- READ IN INTEGRAL TAPE DATA -----
C
      IF (OUT) WRITE (IW,9068)
      CALL SEQREW(NFT11)
      NORBMX=0
      NROWS=0
      NWKS=0
      READ (NFT11) NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX
      READ (NFT11) TITLE1
      IF (SOME) WRITE (IW,9028) NWKS
      CALL SEQREW(NFT15)
      CALL SEQREW(NFT16)
      ITAP = 1
      WRITE (NFT15) ITAP,NWKS,NEMEMX,CUTOFF,TITLE,TITLE1
      ITAP = 2
      WRITE (NFT16) ITAP,NWKS,NEMEMX,CUTOFF,TITLE,TITLE1
C
      NROWS4 = NROWS*4
      NKL = NSYM*NORBS
      NIJ = (NORBS*(NORBS+1))/2
      NLNG = LEVFRM*NSYM
      IH1  = 1 + LOADFM
      IH2  = IH1 + (NROWS4-1)/NWDVAR + 1
      IH3  = IH2 + (NROWS -1)/NWDVAR + 1
      IH4  = IH3 + (NROWS -1)/NWDVAR + 1
      IH6  = IH4 + (NROWS -1)/NWDVAR + 1
      IH7  = IH6 + (NROWS -1)/NWDVAR + 1
      IH8  = IH7 + (NROWS -1)/NWDVAR + 1
      IH9  = IH8 + (NROWS -1)/NWDVAR + 1
      IH11 = IH9 + (NWKS  -1)/NWDVAR + 1
      IH12 = IH11+ (NROWS4-1)/NWDVAR + 1
      IH13 = IH12+ (NIJ   -1)/NWDVAR + 1
      IH14 = IH13+ (NIJ   -1)/NWDVAR + 1
      IH15 = IH14+ (NKL   -1)/NWDVAR + 1
      IH16 = IH15+ (NKL   -1)/NWDVAR + 1
      IH17 = IH16+ (200   -1)/NWDVAR + 1
      IH18 = IH17+ (200   -1)/NWDVAR + 1
      IH19 = IH18+ (200   -1)/NWDVAR + 1
      IH20 = IH19+ (NLNG  -1)/NWDVAR + 1
      IH21 = IH20+ (NLNG  -1)/NWDVAR + 1
      IH22 = IH21+ (NLNG  -1)/NWDVAR + 1
      IH23 = IH22+ (NLNG  -1)/NWDVAR + 1
      LAST = IH23+ (NLNG  -1)/NWDVAR
      NEED = LAST-LOADFM
      CALL GETFM(NEED)
C
      NEXT = 0
      CALL DRTTAP(NFT11,NROWS,NROWS4,NKL,NIJ,XX(IH2),XX(IH3),
     *            XX(IH4),XX(IH1),XX(IH6),XX(IH7),XX(IH8),
     *            XX(IH9),XX(IH11),XX(IH12),XX(IH13),XX(IH14),
     *            XX(IH15),XX(IH16),XX(IH17),XX(IH18),
     *            NWKS,NEXT,NGRPS,NINTMX)
      CALL SEQREW(NFT11)
      CALL SEQREW(NFT14)
      CALL SQWRIT(NFT15,XX(IH9),(NWKS-1)/NWDVAR+1)
C
C           GET SPACE FOR OUTPUT BUFFERS
C
      CALL VALFM(LOADFM)
      IBUFFR = LOADFM + 1
      IBFFOI = IBUFFR + NEMEMX
      LBUFOV = IBFFOI + NEMEMX
      IBFFDI = LBUFOV + NEMEMX
      LBUFDV = IBFFDI + NEMEMX
      LAST   = LBUFDV + NEMEMX
      NEED2  = LAST   - LOADFM
      CALL GETFM(NEED2)
C
      CALL SETMXE
      CALL SETEM
C
C     ----- CALCULATE -CI- ENERGY MATRIX -----
C
      IF (OUT) WRITE (IW,9088)
      CALL LOOPY(NROWS,XX(IH3),XX(IH6),XX(IH7),XX(IH8),XX(IH11),
     *     XX(IH2),XX(IH12),XX(IH13),XX(IH14),XX(IH15),XX(IH16),
     *     XX(IH17),XX(IH18),XX(IH1),NEXT,NROWS4,NIJ,NKL,PUTEX1,
     *     PUTOU1,NXGRP1,FINOU1,XX(IBUFFR),XX(IBFFOI),XX(LBUFOV),
     *     XX(IBFFDI),XX(LBUFDV))
C
C     ----- RESET FAST MEMORY -----
C
      CALL RETFM(NEED2)
      CALL RETFM(NEED)
      IF (SOME) WRITE (IW,9048)
      IF (SOME) CALL TEXIT(2,2)
      RETURN
C
 9008 FORMAT(/1X,25(1H-),5X,39(1H-)/
     +        1X,'ENERGY MATRIX CALCULATION',5X,
     +        'WRITTEN BY B.R.BROOKS,W.D.LAIDIG,P.SAXE'/
     +        1X,25(1H-),5X,39(1H-))
 9028 FORMAT(/1X,'COMPUTING THE HAMILTONIAN FOR THE',I10,' CSF-S...')
 9048 FORMAT(48H ...... END OF ENERGY MATRIX CALCULATION ...... )
 9068 FORMAT(17H READ -DRT- DATA )
 9088 FORMAT(25H CALCULATE ENERGY MATRIX )
 9128 FORMAT(33H NO NAMELIST $GUGEM FOUND. STOP. )
      END
C*MODULE GUGEM   *DECK LOOPY
      SUBROUTINE LOOPY(NROWS,NABC,NLWKS,NUWKS,PUWK,IWGHT,NELEC,
     *                 IJADD,IJGRP,KADD,LADD,INEXT,JMNNXT,JMXNXT,
     *                 IARC,NEXT,NROWS4,NIJ,NKL,
     *                 PUTEXT,PUTOUT,NXTGRP,FINOUT,
     *                 IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C          LOOPY IS CALLED FROM BOTH GUGAEM AND GUGDM2.
C          THE FORMAL ARGUMENTS PUTEXT,... WILL BE EITHER
C          PUTEX1,... OR PUTEX2,....
C
      EXTERNAL PUTEXT,PUTOUT,NXTGRP,FINOUT
C
      INTEGER PUWK
C
      LOGICAL SOME,OUT,GOPARR,DSKWRK,MASWRK,NXT
C
      PARAMETER (MXAO=8192)
C
      DIMENSION NABC(NROWS),NLWKS(NROWS),NUWKS(NROWS),IARC(NROWS4),
     *          PUWK(NROWS),IWGHT(NROWS4),IJADD(NIJ),IJGRP(NIJ),
     *          KADD(NKL),LADD(NKL),NELEC(NROWS),
     *          INEXT(NEXT),JMNNXT(NEXT),JMXNXT(NEXT)
      DIMENSION ISEGM(MXAO),JSEGM(MXAO),IMAIN(MXAO),
     *          ISUB(MXAO),IUWKMN(MXAO),
     *          IUWKSB(MXAO),ITRACK(MXAO),ACOEF(MXAO),
     *          BCOEF(MXAO),LMIN(MXAO)
      DIMENSION NLCSMN(22),JSEGNR(22),JSEGPT(22)
      DIMENSION IARCMN(228),IARCSB(228),ITRK(228),JCOND(228),KCOND(228),
     *          NXTSEG(228)
      DIMENSION JSEGPX(3),ISHIFT(4)
      DIMENSION MULTS(8),ISMOFF(8),LCOND(8),LKUPSM(64)
      DIMENSION COEFFS(20,21),CFS(420)
      DIMENSION IBUFFR(*),IBFFOI(*),BUFFOV(*),IBFFDI(*),BUFFDV(*)
C
      COMMON /EMPRT / ILEVEL,JLEVEL,KLEVEL,LLEVEL,OUT,SOME
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /LOOPS / ACF,CCF,D,VAL,CUTOFF,LAD,NUWK,NLWK,
     *                IUWK,JUWK,ITRAK,LEVI,JMIN,JMAX,IAD,IISYMT,
     *                KSBT,INTSAD,NINTMX,NGRPS
      COMMON /LPYSAV/ IJKSYM,IJSYM,JAD,KAD,KSMPTX,LSMPTX
      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 /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      EQUIVALENCE (COEFFS(1,1),CFS(1))
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, HALF=0.5D+00)
      PARAMETER (CRITE=1.0D-05)
C                CRITE=1.0D-10 IN HONDO
C
      DATA CHECK/8HCHECK   /
      DATA MULTS/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/
      DATA JSEGNR/16,34,52,63,75,92,102,118,128,137,148,155,162,172,
     + 179,186,193,200,207,214,221,228/
      DATA JCOND/12*1,4*-1,13*1,5*-1,13*1,5*-1,176*0/
      DATA KCOND/7*1,9*0,5*1,13*0,5*1,13*0,7*1,4*0,7*1,5*0,11*1,6*0,
     + 5*1,5*0,10*1,6*0,5*1,5*0,5*1,4*0,5*1,6*0,1,1,5*0,1,1,5*0,4*1,
     + 62*0/
      DATA ITRK/10,2,2,3,7,3,7,1,3*9,5*1,0,2*10,2,10,4*11,2*9,3,3,6*0,
     +  10,10,2,10,4*11,2*9,2*3,27*0,1,3*0,4*12,8*0,2*3,1,2*0,2*1,5*0,
     +  2*1,4*0,4*1,6*0,1,0,0,1,1,14*0,1,35*0,8,6*0,8,6*0,13,6*0,13,33*0
     + /
      DATA NXTSEG/3*0,17,15,18,16,10,5,5,4,7,2,2,3,3,20,3*21,22,11,11,
     + 12,12,6,6,7,7,4*2,3,19,3*22,21,11,11,13,13,6,6,9,9,4*3,2,3*0,
     + 21,21,22,22,4*4,3*0,21,21,22,22,4*5,7,3*0,21,21,22,22,19,19,20,
     + 20,4*6,7,9,0,21,21,20,20,4*7,8,0,0,21,21,22,22,19,19,20,20,4*8,
     + 7,9,0,22,22,19,19,4*9,8,0,21,21,22,22,4*10,0,21,21,22,22,4*11,
     + 12,13,21,21,3*12,12,14,22,22,4*13,14,21,21,22,22,4*14,12,13,
     + 0,0,4*15,16,0,0,4*16,15,0,0,4*17     ,18,0,0,4*18,17,0,0,4*19,
     + 20,0,0,20,3*20,19,0,0,4*21,22,0,0,4*22,21/
      DATA IARCMN/4,3,2,3,4,2,4,4,2,3,4,3,3,4,2,4,1,3,4,3*2,4,3,4,1,2,1,
     + 3,1,2,3,4,2,1,2,4,3*3,4,2,4,1,3,1,2,1,2,3,4,3,2,3,4,3,4,2,4,
     + 1,2,3,4,2,3,4,3,4,2,4,1,2,3,4,3,2,3,4,3,4,2,4,1,2,1,3,1,2,3,4,
     + 3,2,2,2,4,1,2,1,2,3,4,2,2,3,3,4,2,4,1,2,1,3,1,2,3,4,3,2,3,3,4,
     + 1,3,1,2,3,4,3,1,1,3,1,2,1,2,3,4,1,1,3,1,2,1,2,3,4,3,2,1,2,1,2,
     + 3,4,2,1,3,1,2,3,4,3,1,3,1,2,1,2,3,4,3,2,1,2,1,2,3,4,2,1,3,1,2,
     + 3,4,3,1,2,1,2,3,4,2,1,3,1,2,3,4,3,3,4,1,2,3,4,3,2,4,1,2,3,4,2,
     + 1,2,1,2,3,4,2,1,3,1,2,3,4,3/
      DATA IARCSB/4,3,2,1,2,1,3,1,2,3,4,2,1,2,1,3,4,3,4,2,3,1,3,1,2,3,4,
     + 2,4,1,2,3,4,3,4,2,4,3,2,1,2,1,3,2,4,3,4,1,2,3,4,2,2,3,4,1,2,1,3,
     + 1,2,3,4,2,3,4,1,2,1,3,1,2,3,4,2,2,3,4,1,2,1,3,3,4,2,4,1,2,3,4,
     + 2,3,3,1,3,3,4,1,2,3,4,3,2,3,1,2,1,3,3,4,2,4,1,2,3,4,2,3,2,1,2,
     + 2,4,1,2,3,4,2,4,2,4,3,4,1,2,3,4,4,2,4,3,4,1,2,3,4,2,3,3,4,1,2,
     + 3,4,3,2,4,1,2,3,4,2,2,4,3,4,1,2,3,4,2,3,3,4,1,2,3,4,3,2,4,1,2,
     + 3,4,2,3,4,1,2,3,4,3,2,4,1,2,3,4,2,1,2,1,2,3,4,2,1,3,1,2,3,4,3,
     + 3,4,1,2,3,4,3,2,4,1,2,3,4,2/
      DATA JSEGPX/12,29,47/
      DATA NLCSMN/6*1,0,1,14*0/
C
      IF (EXETYP .EQ. CHECK) GO TO 2540
C
      NXT = IBTYP.EQ.1
      IPCOUNT = ME -1
      NEXTP = -1
      LCNT = -1
      ROOT2 = SQRT(TWO)
      ROOTN2 = -ROOT2
      TOOR2 = ONE / ROOT2
      TOORN2 = -TOOR2
      JSEGPT(1) = 0
      DO 100 I = 1,21
  100 JSEGPT(I+1) = JSEGNR(I)
      DO 120 I = 1,2
      DO 120 J = 1,21
  120 COEFFS(I,J) = ZERO
      DO 140 I = 1,NIJ
  140 IJADD(I) = IJADD(I)+(INTSAD-1)
C
      DO 160 I = 3,20
      A = I - 2
      COEFFS(I, 1) = SQRT(A/(A+ONE))
      COEFFS(I, 2) = -COEFFS(I,1)
      COEFFS(I, 3) = COEFFS(I,1)/SQRT(TWO)
      COEFFS(I, 4) = -COEFFS(I,3)
      COEFFS(I, 5) = SQRT((A+ONE)/A)
      COEFFS(I, 6) = -COEFFS(I,5)
      COEFFS(I, 7) = COEFFS(I,5)/SQRT(TWO)
      COEFFS(I, 8) = -COEFFS(I,7)
      COEFFS(I, 9) = SQRT((A+TWO)/(A*TWO))
      COEFFS(I,10) = -COEFFS(I,9)
      COEFFS(I,11) = SQRT(A/(TWO*(A+TWO)))
      COEFFS(I,12) = -COEFFS(I,11)
      COEFFS(I,13) = SQRT(TWO/(A*(A+ONE)))
      COEFFS(I,14) = SQRT(A*(A+TWO))/(A+ONE)
      COEFFS(I,15) = -COEFFS(I,14)
      COEFFS(I,16) = SQRT((A-ONE)*(A+TWO)/(A*(A+ONE)))
      COEFFS(I,17) = -COEFFS(I,16)
      COEFFS(I,18) = -SQRT(TWO/(A*(A+TWO)))
      COEFFS(I,19) = ONE/A
      COEFFS(I,20) = -COEFFS(I,19)
      COEFFS(I,21) = -SQRT(TWO)/A
  160 CONTINUE
      DO 180 K = 1,4
         ISHIFT(K) = (K-1)*NROWS
  180 CONTINUE
      DO 200 I = 1,NROWS
         NELEC(I) = NELEC(I)+NELEC(I)+NABC(I)
  200 CONTINUE
C
      DO 220 I = 1,NSYM
         ISMOFF(I) = (I-1)*NORBS
         LCOND(I) = 0
  220 CONTINUE
      I = ISYM(1)
      LCOND(I) = 1
      LCOND(1) = 1
      NSM = 0
      DO 260 IORB = 2,NORBS
         DO 240 I = 1,NSYM
            IF (LCOND(I) .EQ. 0) GO TO 240
            LKUP = MULTS(I)+ISYM(IORB)
            J = LKUPSM(LKUP)
            IF (LCOND(J) .GT. 0) GO TO 240
            LCOND(J) = IORB
            NSM = NSM+1
            IF (NSM .EQ. NSYM) GO TO 280
  240    CONTINUE
  260 CONTINUE
C
  280 CONTINUE
      DO 300 I = 1,NSYM
         IF (LCOND(I) .EQ. 0) LCOND(I) = NORBS+1
  300 CONTINUE
C
C     ----- LOOP OVER GROUPS OF INTEGRALS -----
C
      INXT = 1
      DO 2520 LGRP = 1,NGRPS
      IF (OUT) WRITE (IW,9008) LGRP
  320 CONTINUE
      I = INEXT(INXT)
      LEVI = I+1
      JMAX = JMXNXT(INXT)
      JMIN = JMNNXT(INXT)
      ILEVEL = I
      IAD = (I*(I-1))/2
      IJ = IAD+JMAX
      IF (LGRP .NE. IJGRP(IJ)) GO TO 2500
      IISYM = ISYM(I)
      LEV = LEVI
      LEVM = LEV-1
      NR = LEVNR(LEV)
      NPT = LEVPT(LEV)
C
      DO 2460 IROW = 1,NR
      NPT = NPT+1
      ISEGM(LEV) = 1
      ISEG = 1
      IMN = NPT
      ISB = NPT
      KSEG = 0
      KSEGMX = JSEGNR(ISEG)
      LMIN(LEV) = LCOND(IISYM)
      IUWKMN(LEV) = PUWK(NPT)
      IUWKSB(LEV) = PUWK(NPT)
      IMAIN(LEV) = NPT
      ISUB(LEV) = NPT
      NUWK = NUWKS(NPT)
      ACOEF(LEV) = ONE
C
C     ----- TEST NEXT SEGMENT OF GROUP -----
C
  360 CONTINUE
      KSEG = KSEG+1
      IF (KSEG .GT. KSEGMX) GO TO 2420
      KMN = IARCMN(KSEG)
      IARPT = IMN+ISHIFT(KMN)
      KMN = IARC(IARPT)
      IF (KMN .EQ. 0) GO TO 360
      KSB = IARCSB(KSEG)
      JARPT = ISB+ISHIFT(KSB)
      KSB = IARC(JARPT)
      IF (KSB .EQ. 0) GO TO 360
      JSEGM(LEV) = KSEG
      IUWKMN(LEVM) = IUWKMN(LEV)+IWGHT(IARPT)
      IUWKSB(LEVM) = IUWKSB(LEV)+IWGHT(JARPT)
      LMIN(LEVM) = LMIN(LEV)
      IF (JCOND(KSEG)) 380,420,400
  380 CONTINUE
      IF (LEVM .LE. JMIN) GO TO 2420
      GO TO 420
C
  400 CONTINUE
      IF (LEVM .GT. JMAX) GO TO 2400
      JLEVEL = LEVM
      IJ = IAD+LEVM
      JAD = IJADD(IJ)
      IJKUP = MULTS(IISYM)+ISYM(LEVM)
      IJSYM = LKUPSM(IJKUP)
      LMIN(LEVM) = LCOND(IJSYM)
      KSMPTX = ISMOFF(IJSYM)
  420 CONTINUE
      IF (KCOND(KSEG) .EQ. 0) GO TO 440
      KLEVEL = LEVM
      KSMPT = LEVM+KSMPTX
      KAD = JAD+KADD(KSMPT)
      IJKKUP = MULTS(IJSYM)+ISYM(LEVM)
      IJKSYM = LKUPSM(IJKKUP)
      LMIN(LEVM) = LCOND(IJKSYM)
      LSMPTX = ISMOFF(IJKSYM)
  440 CONTINUE
      IF (ITRK(KSEG)) 480,480,460
  460 ITRACK(LEVM) = ITRK(KSEG)
      GO TO 500
  480 ITRACK(LEVM) = ITRACK(LEV)
C
C          KSEG HAS 228 POSSIBLE VALUES
C
  500 CONTINUE
      GO TO (1420,520,520,520,560,520,580,520,1300,1320,1440,520,520,
     +     560,520,580,600,1460,1480,620,1500,1220,1240,520,640,1340,
     +     1360,520,660,520,620,540,540,680,700,1460,1480,720,1520,1260,
     +     1280,520,740,1380,1400,520,760,520,540,720,540,1140,1960,
     +     1960,1980,1960,2000,1960,2020,520,520,520,520,2160,1780,2060,
     +     1780,1800,1760,1820,1840,1920,1940,1840,2080,2160,1780,2060,
     +     1780,1800,1760,1820,1780,1800,1760,1820,1840,1920,1940,1840,
     +     2080,2080,620,620,1900,620,660,520,780,780,520,800,820,840,
     +     840,860,820,880,840,860,820,880,520,900,920,520,940,940,720,
     +     720,2040,720,760,520,960,960,520,980,520,560,540,580,540,520,
     +     540,540,520,1000,1680,1700,1720,1740,1840,1860,1880,1840,
     +     2100,2120,1540,1560,520,1020,520,520,2140,1540,1580,520,520,
     +     1040,520,1060,1600,1620,1640,1660,520,1080,2170,520,1100,
     +     1120,520,600,520,620,540,540,680,520,700,520,540,720,540,
     +     1140,520,600,520,620,540,540,680,520,700,520,540,720,540,
     +     1140,520,580,520,1160,540,540,1180,520,560,520,540,1160,540,
     +     1200,520,600,520,620,540,540,680,520,700,520,540,720,540,
     +     1140),KSEG
  520 ACOEF(LEVM) = ACOEF(LEV)
      GO TO 2220
C
  540 ACOEF(LEVM) = -ACOEF(LEV)
      GO TO 2220
C
  560 IA = NABC(IMN) + 2
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  580 IA = NABC(IMN) + 83
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  600 IA = NABC(IMN) + 82
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  620 IA = NABC(IMN) + 261
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  640 IA = NABC(IMN) + 1
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  660 IA = NABC(IMN) + 102
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  680 IA = NABC(IMN) + 362
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  700 IA = NABC(IMN) + 3
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  720 IA = NABC(IMN) + 263
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  740 IA = NABC(IMN) + 84
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  760 IA = NABC(IMN) + 23
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  780 IA = NABC(IMN) + 281
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  800 IA = NABC(IMN) + 402
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  820 IA = NABC(IMN) + 162
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  840 IA = NABC(IMN) + 222
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  860 IA = NABC(IMN) + 143
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  880 IA = NABC(IMN) + 42
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  900 IA = NABC(IMN) + 302
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  920 IA = NABC(IMN) + 303
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  940 IA = NABC(IMN) + 342
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  960 IA = NABC(IMN) + 283
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
  980 IA = NABC(IMN)+404
      ACOEF(LEVM) = ACOEF(LEV)*CFS(IA)
      GO TO 2220
C
 1000 ACOEF(LEVM) = ACOEF(LEV) * ROOT2
      GO TO 2220
C
 1020 IA = NABC(IMN) + 301
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1040 IA = NABC(IMN) + 304
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1060 IA = NABC(IMN) + 244
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1080 IA = NABC(IMN) + 322
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1100 IA = NABC(IMN) + 243
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1120 IA = NABC(IMN) + 242
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1140 IA = NABC(IMN) + 384
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1160 IA = NABC(IMN) + 262
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1180 IA = NABC(IMN) + 363
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1200 IA = NABC(IMN) + 383
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1220 IA = NABC(IMN) + 122
      IB = IA - 61
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1240 IB = NABC(IMN) + 162
      ACOEF(LEVM) = ACOEF(LEV) * TOORN2
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1260 IA = NABC(IMN) + 43
      IB = IA + 81
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1280 IB = NABC(IMN) + 222
      ACOEF(LEVM) = ACOEF(LEV) * TOORN2
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1300 IB = NABC(IMN)+221
      ACOEF(LEVM) = ACOEF(LEV) * TOOR2
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1320 IB = NABC(IMN) + 163
      ACOEF(LEVM) = ACOEF(LEV) * TOOR2
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1340 IB = NABC(IMN) + 162
      ACOEF(LEVM) = ACOEF(LEV) * TOOR2
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1360 IA = NABC(IMN) + 122
      IB = IA - 81
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1380 IB = NABC(IMN) + 222
      ACOEF(LEVM) = ACOEF(LEV) * TOOR2
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1400 IA = NABC(IMN) + 43
      IB = IA + 101
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      BCOEF(LEVM) = ACOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1420 ACOEF(LEVM) = ACOEF(LEV) + ACOEF(LEV)
      D = HALF
      GO TO 2220
C
 1440 ACOEF(LEVM) = ACOEF(LEV)*ROOT2
      GO TO 2220
C
 1460 ACOEF(LEVM) = -ACOEF(LEV)
      D = -ONE
      GO TO 2220
C
 1480 ACOEF(LEVM) = -ACOEF(LEV) - ACOEF(LEV)
      D =-HALF
      GO TO 2220
C
 1500 IA = NABC(IMN)+362
      D = ONE/CFS(IA)
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1520 IA = NABC(IMN) + 384
      D = ONE/CFS(IA)
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 1540 ACOEF(LEVM) = ACOEF(LEV)
      D = -ONE
      GO TO 2220
C
 1560 IA = NABC(IMN) + 82
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      D = -ONE
      GO TO 2220
C
 1580 IA = NABC(IMN) + 3
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      D = -ONE
      GO TO 2220
C
 1600 IA = NABC(IMN) + 123
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      D = -ONE
      GO TO 2220
C
 1620 IA = NABC(IMN) + 222
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      D = -ONE
      GO TO 2220
C
 1640 IA = NABC(IMN) + 62
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      D = -ONE
      GO TO 2220
C
 1660 IA = NABC(IMN) + 162
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      D = -ONE
      GO TO 2220
C
 1680 IA = NABC(IMN) + 42
      IB = IA + 81
      ACOF = ACOEF(LEV) * CFS(IA)
      BCOF = BCOEF(LEV) * CFS(IB)
      D = ACOF + BCOF
      IF (ABS(D) .LT. CRITE) GO TO 2180
      ACOEF(LEVM) = D
      D = (ACOF - BCOF) / D
      GO TO 2220
C
 1700 IB = NABC(IMN) + 222
      ACOF = ACOEF(LEV) * TOORN2
      BCOF = BCOEF(LEV) * CFS(IB)
      D = ACOF + BCOF
      IF (ABS(D) .LT. CRITE) GO TO 2180
      ACOEF(LEVM) = D
      D = (ACOF - BCOF) / D
      GO TO 2220
C
 1720 IA = NABC(IMN) + 123
      IB = IA - 61
      ACOF = ACOEF(LEV) * CFS(IA)
      BCOF = BCOEF(LEV) * CFS(IB)
      D = ACOF + BCOF
      IF (ABS(D) .LT. CRITE) GO TO 2180
      ACOEF(LEVM) = D
      D = (ACOF - BCOF) / D
      GO TO 2220
C
 1740 IB = NABC(IMN) + 162
      ACOF = ACOEF(LEV) * TOORN2
      BCOF = BCOEF(LEV) * CFS(IB)
      D = ACOF + BCOF
      IF (ABS(D) .LT. CRITE) GO TO 2180
      ACOEF(LEVM) = D
      D = (ACOF - BCOF) / D
      GO TO 2220
C
 1760 IB = NABC(IMN) + 162
      DX = ACOEF(LEV)*TOORN2
      D = DX+BCOEF(LEV)*CFS(IB)
      IF (ABS(D) .LT. CRITE) GO TO 2200
      ACOEF(LEVM) = D
      D = -(DX+DX)/D
      GO TO 2220
C
 1780 IB = NABC(IMN) + 222
      DX = ACOEF(LEV)*TOORN2
      D = DX+BCOEF(LEV)*CFS(IB)
      IF (ABS(D) .LT. CRITE) GO TO 2200
      ACOEF(LEVM) = D
      D = -(DX+DX)/D
      GO TO 2220
C
 1800 IA = NABC(IMN) + 62
      IB = IA + 81
      DX = ACOEF(LEV)*CFS(IA)
      D = DX+BCOEF(LEV)*CFS(IB)
      IF (ABS(D) .LT. CRITE) GO TO 2200
      ACOEF(LEVM) = D
      D = -(DX+DX)/D
      GO TO 2220
C
 1820 IA = NABC(IMN) + 143
      IB = IA - 101
      DX = ACOEF(LEV)*CFS(IA)
      D = DX+BCOEF(LEV)*CFS(IB)
      IF (ABS(D) .LT. CRITE) GO TO 2200
      ACOEF(LEVM) = D
      D = -(DX+DX)/D
      GO TO 2220
C
 1840 ACOEF(LEVM) = ACOEF(LEV)
      BCOEF(LEVM) = BCOEF(LEV)
      GO TO 2220
C
 1860 IB = NABC(IMN) + 322
      ACOEF(LEVM) = -ACOEF(LEV)
      BCOEF(LEVM) = BCOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1880 IB = NABC(IMN) + 323
      ACOEF(LEVM) = -ACOEF(LEV)
      BCOEF(LEVM) = BCOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1900 IA = NABC(IMN)+21
      ACOEF(LEVM) = ACOEF(LEV)*CFS(IA)
      GO TO 2220
C
 1920 IB = NABC(IMN) + 302
      ACOEF(LEVM) = ACOEF(LEV)
      BCOEF(LEVM) = BCOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1940 IB = NABC(IMN) + 303
      ACOEF(LEVM) = ACOEF(LEV)
      BCOEF(LEVM) = BCOEF(LEV) * CFS(IB)
      GO TO 2220
C
 1960 ACOEF(LEVM) = ACOEF(LEV)*TOORN2
      D = -TWO
      GO TO 2220
C
 1980 ACOEF(LEVM) = ACOEF(LEV)*ROOTN2
      D = -TWO
      GO TO 2220
C
 2000 IA = NABC(IMN)+62
      ACOEF(LEVM) = ACOEF(LEV)*CFS(IA)
      D = -TWO
      GO TO 2220
C
 2020 IA = NABC(IMN)+143
      ACOEF(LEVM) = ACOEF(LEV)*CFS(IA)
      D = -TWO
      GO TO 2220
C
 2040 IA = NABC(IMN)+104
      ACOEF(LEVM) = ACOEF(LEV)*CFS(IA)
      GO TO 2220
C
 2060 ACOEF(LEVM) = ACOEF(LEV) * ROOTN2
      D = -TWO
      GO TO 2220
C
 2080 IA = NABC(IMN) + 342
      ACOEF(LEVM) = BCOEF(LEV) * CFS(IA)
      GO TO 2220
C
 2100 IA = NABC(IMN) + 243
      ACOEF(LEVM) = BCOEF(LEV) * CFS(IA)
      GO TO 2220
C
 2120 IA = NABC(IMN) + 242
      ACOEF(LEVM) = BCOEF(LEV) * CFS(IA)
      GO TO 2220
C
 2140 IA = NABC(IMN) + 241
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 2160 IB = NABC(IMN) + 162
      DX = ACOEF(LEV)*TOORN2
      D = DX+BCOEF(LEV)*CFS(IB)
      IF (ABS(D) .LT. CRITE) GO TO 2200
      ACOEF(LEVM) = D
      D = -(DX+DX)/D
      GO TO 2220
C
 2170 IA = NABC(IMN) + 323
      ACOEF(LEVM) = ACOEF(LEV) * CFS(IA)
      GO TO 2220
C
 2180 ITRACK(LEVM) = 3
      ACOEF(LEVM) = ACOF-BCOF
      GO TO 2220
C
 2200 ITRACK(LEVM) = 2
      ACOEF(LEVM) = -(DX+DX)
C
 2220 CONTINUE
      IF (NXTSEG(KSEG) .GT. 0) GO TO 2380
      IF (ISYM(LEVM) .NE. IJKSYM) GO TO 360
      LLEVEL = LEVM
      LSMPT = LEVM+LSMPTX
      LAD = KAD+LADD(LSMPT)
      IF (KMN-KSB) 2240,2360,2240
 2240 LEVL = LEVM
      KSEGMX = 4
 2260 CONTINUE
      LEV = LEVM
      LEVM = LEV-1
      IF (LEVM .GT. 0) GO TO 2280
      IF (MASWRK) WRITE (IW,9028)
      CALL ABRT
C
 2280 CONTINUE
      KSEG = 0
      IMAIN(LEV) = KMN
      IMN = KMN
      ISUB(LEV) = KSB
      ISB = KSB
 2300 KSEG = KSEG+1
      IF (KSEG .GT. KSEGMX) GO TO 2340
      IARPT = IMN+ISHIFT(KSEG)
      KMN = IARC(IARPT)
      IF (KMN .LE. 0) GO TO 2300
      JARPT = ISB+ISHIFT(KSEG)
      KSB = IARC(JARPT)
      IF (KSB .LE. 0) GO TO 2300
      JSEGM(LEV) = KSEG
      IUWKMN(LEVM) = IUWKMN(LEV)+IWGHT(IARPT)
      IUWKSB(LEVM) = IUWKSB(LEV)+IWGHT(JARPT)
      IF (KMN-KSB) 2260,2320,2260
 2320 NLWK = NLWKS(KMN)
      IUWK = IUWKMN(LEVM)
      JUWK = IUWKSB(LEVM)
      ITRAK = ITRACK(LEVL)
      ACF = ACOEF(LEVL)
      IF (GOPARR) THEN
        IF (NXT) THEN
          LCNT = LCNT + 1
          IF (LCNT.GT.NEXTP) CALL DDI_DLBNEXT(NEXTP)
          IF (NEXTP.EQ.LCNT)
     *    CALL PUTOUT(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
        ELSE
          IPCOUNT = IPCOUNT + 1
          IF (MOD(IPCOUNT,NPROC).EQ.0)
     *    CALL PUTOUT(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
        END IF
      ELSE
        CALL PUTOUT(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
      END IF
      GO TO 2300
C
 2340 IF (LEV .EQ. LEVL) GO TO 2420
      LEVM = LEV
      LEV = LEVM+1
      IMN = IMAIN(LEV)
      ISB = ISUB(LEV)
      KSEG = JSEGM(LEV)
      GO TO 2300
C
 2360 NLWK = NLWKS(KMN)
      IUWK = IUWKMN(LEVM)
      JUWK = IUWKSB(LEVM)
      ITRAK = ITRACK(LEVM)
      ACF = ACOEF(LEVM)
      IF (GOPARR) THEN
         IPCOUNT = IPCOUNT + 1
         IF (MOD(IPCOUNT,NPROC).EQ.0)
     *    CALL PUTOUT(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
      ELSE
        CALL PUTOUT(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
      END IF
      GO TO 360
C
 2380 CONTINUE
      IF (LEVM .LE. LMIN(LEVM)) GO TO 360
      ISEG = NXTSEG(KSEG)
      IF (NLCSMN(ISEG) .GT. 0 .AND. NELEC(KMN) .EQ. 0) GO TO 360
C----  IF(LVFRM.EQ.LEVM.AND.ISEG.LT.4) GO TO 460
      LEV = LEVM
      LEVM = LEV-1
      ISEGM(LEV) = ISEG
      KSEG = JSEGPT(ISEG)
      IMN = KMN
      IMAIN(LEV) = KMN
      ISB = KSB
      ISUB(LEV) = KSB
      KSEGMX = JSEGNR(ISEG)
      GO TO 360
C
 2400 CONTINUE
      KSEG = JSEGPX(ISEG)
      GO TO 360
C
 2420 CONTINUE
      IF (LEV .EQ. LEVI) GO TO 2460
      LEVM = LEV
      LEV = LEVM+1
      ISEG = ISEGM(LEV)
      IMN = IMAIN(LEV)
      ISB = ISUB(LEV)
      KSEG = JSEGM(LEV)
      KSEGMX = JSEGNR(ISEG)
      GO TO 360
C
C           END OF LOOP OVER ROWS OF -LEVI-
C
 2460 CONTINUE
      INXT = INXT+1
      IF (INXT .LE. NEXT) GO TO 320
      GO TO 2520
C
 2500 CONTINUE
C
C              READ IN NEW GROUP OF INTEGRALS
C
      CALL NXTGRP
 2520 CONTINUE
C
C           END OF LOOP OVER GROUPS OF INTEGRALS
C
 2540 CONTINUE
      CALL FINOUT(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
      IF (GOPARR.AND.NXT) CALL DDI_DLBRESET
      RETURN
C
 9008 FORMAT(29H PROCESS INTEGRALS FROM GROUP,I4)
 9028 FORMAT(28H PROBLEMS WITH PARTIAL SPACE)
      END
C
C*MODULE GUGEM   *DECK SETEM
      SUBROUTINE SETEM
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /EMPRT / ILEVEL,JLEVEL,KLEVEL,LLEVEL,OUT,SOME
      COMMON /FMCOM / XX(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,NINTMX,NGRPS
      COMMON /SEMSAV/ SQRT2,LGRP,NLEXT,NLINT
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (TWO=2.0D+00)
C
      SQRT2 = SQRT(TWO)
      LGRP = 1
      NLEXT = 0
      NLINT = 0
C
C           GET INTEGRAL BUFFER SPACE
C
      LOADFM = 0
      CALL VALFM(LOADFM)
      INTSAD=LOADFM+1
      CALL GETFM(NINTMX)
      GO TO 100
C
C     ------------
      ENTRY NXGRP1
C     ------------
      IF (LGRP .GT. NGRPS)THEN
          IF(MASWRK)WRITE(IW,*)' LGRP .GT. NGRPS IN ENTRY NXGRP1'
          CALL ABRT
      ENDIF
      LGRP = LGRP+1
  100 CONTINUE
      INTMX = NINTMX
      CALL SQREAD(NFT14,XX(INTSAD),INTMX)
C
C     ----- NOW ALL INTEGRALS OF LGRP ARE IN FAST MEMORY -----
C
      RETURN
C
C     ------------
      ENTRY PUTEX1
C     ------------
      NLEXT = NLEXT+1
      IF (NUWK .EQ. 0) RETURN
      GO TO 120
C
C     ------------
      ENTRY PUTOU1(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
C     ------------
      NLINT = NLINT+1
  120 CONTINUE
      GO TO (140,160,180,200,220,240,260,280,300,320,340,360,380,400,
     +     420,440,460,480),ITRACK
C
  140 VAL = A * XX(LAD+1)
      GO TO 500
C
  160 VAL = A * XX(LAD+2)
      GO TO 500
C
  180 VAL = A * XX(LAD+3)
      GO TO 500
C
  200 VAL = XX(LAD+1) + XX(LAD+2)
      GO TO 500
C
  220 VAL = XX(LAD+2) + XX(LAD+2) + XX(LAD+1)
      GO TO 500
C
  240 VAL = XX(LAD+3) + XX(LAD+2)
      GO TO 500
C
  260 VAL = A * (XX(LAD+3) + XX(LAD+1))
      GO TO 500
C
  280 VAL = A * (XX(LAD+3) + XX(LAD+2) + XX(LAD+1))
      GO TO 500
C
  300 VAL = A * (XX(LAD+1) + D * XX(LAD+2))
      GO TO 500
C
  320 VAL = A * (XX(LAD+2) + D * XX(LAD+1))
      GO TO 500
C
  340 VAL = A * (XX(LAD+1) + D * XX(LAD+3))
      GO TO 500
C
  360 VAL = A * (XX(LAD+3) + D * XX(LAD+2))
      GO TO 500
C
  380 VAL = A * (XX(LAD+3) + XX(LAD+2))
      GO TO 500
C
  400 VAL = XX(LAD+1) + XX(LAD+3)
      GO TO 500
C
C
  420 VAL = XX(LAD+2) - XX(LAD+3)
      GO TO 500
C
  440 VAL = XX(LAD+1)*SQRT2
      GO TO 500
C
  460 VAL = A * (XX(LAD+1) + XX(LAD+2))
      GO TO 500
C
  480 VAL = A * (XX(LAD+2) - XX(LAD+3))
C
  500 CONTINUE
      NAD = LAD-(INTSAD-1)
      IF(OUT) THEN
         WRITE (IW,9068) NLINT,NLEXT,ILEVEL,JLEVEL,KLEVEL,LLEVEL,
     +     NAD,NUWK,NLWK,IUWK,JUWK,ITRACK,A,D,VAL,XX(LAD+1),
     +     XX(LAD+2),XX(LAD+3)
      END IF
      IF(ABS(VAL).GT.CUTOFF)
     *   CALL OUTMXE(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
      RETURN
C
C     ------------
      ENTRY FINOU1(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
C     ------------
      NLTOT = NLINT+NLEXT
      CALL DDI_GSUMI(1850,NLTOT,1)
      CALL DDI_GSUMI(1851,NLINT,1)
      CALL DDI_GSUMI(1852,NLEXT,1)
      IF (SOME) WRITE (IW,9008) NLTOT
      IF (SOME) WRITE (IW,9028) NLINT
      IF (SOME) WRITE (IW,9048) NLEXT
      CALL RETFM(NINTMX)
      CALL FINMXE(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
      RETURN
C
 9008 FORMAT(/,I12,39H IS THE TOTAL NUMBER OF GENERATED LOOPS)
 9028 FORMAT(I12,42H WERE CREATED BY THE LOOP-DRIVEN ALGORITHM)
 9048 FORMAT(I12,24H WERE CREATED IMPLICITLY)
 9068 FORMAT(1X,2I10,' I,J,K,LLEV=',4I4/
     *         ' NAD,NUWK,NLWK,IUWK,JUWK=',5I6,I3/
     *       1X,'A,D=',2F12.6,'  VAL=',E16.8/
     *       1X,'XINTS=',3E16.8)
      END
C*MODULE GUGEM   *DECK SETMXE
      SUBROUTINE SETMXE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /MXE   / NUWKD,NUWKO,NELD,NELO,NBUFD,NBUFO,NELIND,
     *                NELINO,NUWKFX
      NUWKD  = 0
      NUWKO  = 0
      NELD   = 0
      NELO   = 0
      NBUFD  = 0
      NBUFO  = 0
      NELIND = 0
      NELINO = 0
      NUWKFX = 0
      RETURN
      END
C*MODULE GUGEM   *DECK OUTMXE
      SUBROUTINE OUTMXE(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT
C
      DIMENSION IBUFFR(*),IBFFOI(*),BUFFOV(*),IBFFDI(*),BUFFDV(*)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /EMPRT / ILEVEL,JLEVEL,KLEVEL,LLEVEL,OUT,SOME
      COMMON /LOOPS / X(3),VAL,CUTOFF,LAD,NUWK,NLWK,IUWK,JUWK,IX(10)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MXE   / NUWKD,NUWKO,NELD,NELO,NBUFD,NBUFO,NELIND,
     *                NELINO,NUWKFX
C
      IF (IUWK .EQ. JUWK) GO TO 160
C
C     ----- STORE OFF-DIAGONAL ELEMENTS -----
C
      NELO = NELO+1
  100 NELINO = NELINO+1
      IF (NUWK .EQ. NUWKO) GO TO 120
C
*I32  IBUFFR(   NELINO   ) = 0
*I32  IBFFOI( 2*NELINO-1 ) = 0
*I32  IBFFOI( 2*NELINO   ) = 0
*I64  IF (MOD(NELINO,2).EQ.1) IBUFFR( NELINO/2 + 1 ) = 0
*I64  IBFFOI(   NELINO   ) = 0
C
      BUFFOV(NELINO) = NUWK
      NUWKO = NUWK
      NUWKFX = 1
      IF (NELINO .EQ. NEMEMX) GO TO 140
      NUWKFX = 0
      NELINO = NELINO+1
  120 CONTINUE
C
*I32  IBUFFR(   NELINO   ) = NLWK
*I32  IBFFOI( 2*NELINO-1 ) = IUWK
*I32  IBFFOI( 2*NELINO   ) = JUWK
*I64  IF (MOD(NELINO,2) .EQ. 0) THEN
*I64    IBUFFR( NELINO/2 ) = IBUFFR( NELINO/2 ) + ISHFT(NLWK,32)
*I64  ELSE
*I64    IBUFFR( NELINO/2 + 1 ) = NLWK
*I64  END IF
*I64  IBFFOI(   NELINO   ) = ISHFT(IUWK,32) + JUWK
C
      BUFFOV(NELINO) = VAL
      IF (NELINO .LT. NEMEMX) RETURN
  140 CONTINUE
      CALL PKWRIT(NFT16,BUFFOV,IBFFOI,IBUFFR,NELINO,NEMEMX)
      NELINO = 0
      NBUFO = NBUFO+1
      IF (NUWKFX .EQ. 0) RETURN
      NUWKFX = 0
      GO TO 100
C
C     ----- STORE DIAGONAL ELEMENTS -----
C
  160 CONTINUE
      NELIND = NELIND+1
      IF (NUWK .EQ. NUWKD) GO TO 180
C
*I32  IBFFDI( 2*NELIND-1 ) = 0
*I32  IBFFDI( 2*NELIND   ) = 0
*I64  IBFFDI(   NELIND   ) = 0
C
      BUFFDV(NELIND) = NUWK
      NUWKD = NUWK
      NUWKFX = 1
      IF (NELIND .EQ. NEMEMX) GO TO 200
      NUWKFX = 0
      NELIND = NELIND+1
  180 CONTINUE
C
*I32  IBFFDI( 2*NELIND-1 ) = IUWK
*I32  IBFFDI( 2*NELIND   ) = NLWK
*I64  IBFFDI(   NELIND   ) = ISHFT(IUWK,32) + NLWK
C
      BUFFDV(NELIND) = VAL
      NELD = NELD+1
      IF (OUT) WRITE(IW,9068) NELD,NUWK,NLWK,IUWK,NELIND,VAL
      IF (NELIND .LT. NEMEMX) RETURN
  200 CONTINUE
      CALL PXWRIT(NFT15,BUFFDV,IBFFDI,NELIND,NEMEMX)
      NELIND = 0
      NBUFD = NBUFD+1
      IF (NUWKFX .EQ. 0) RETURN
      NUWKFX = 0
      GO TO 160
C
 9068 FORMAT(' OUTMXE:NELD,NUWK,NLWK,IUWK,NELIND,VAL',5I10,1P,E20.12)
      END
C*MODULE GUGEM   *DECK FINMXE
      SUBROUTINE FINMXE(IBUFFR,IBFFOI,BUFFOV,IBFFDI,BUFFDV)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT
C
      DIMENSION IBUFFR(*),IBFFOI(*),BUFFOV(*),IBFFDI(*),BUFFDV(*)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /EMPRT / ILEVEL,JLEVEL,KLEVEL,LLEVEL,OUT,SOME
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MXE   / NUWKD,NUWKO,NELD,NELO,NBUFD,NBUFO,NELIND,
     *                NELINO,NUWKFX
C
      NELIND = -NELIND
      CALL PXWRIT(NFT15,BUFFDV,IBFFDI,NELIND,NEMEMX)
      NBUFD = NBUFD+1
      NELINO = -NELINO
      CALL PKWRIT(NFT16,BUFFOV,IBFFOI,IBUFFR,NELINO,NEMEMX)
      NBUFO = NBUFO+1
      NELTOT = NELD+NELO
      CALL DDI_GSUMI(1875,NELTOT,1)
      CALL DDI_GSUMI(1876,NELD,1)
      CALL DDI_GSUMI(1877,NELO,1)
      IF (SOME) WRITE (IW,9008) NELTOT
      IF (SOME) WRITE (IW,9028) NELD,NBUFD,NEMEMX
      IF (SOME) WRITE (IW,9048) NELO,NBUFO,NEMEMX
      RETURN
C
 9008  FORMAT(/,I12,39H IS THE TOTAL NUMBER OF PROCESSED LOOPS)
 9028  FORMAT(I12,43H     DIAGONAL LOOPS ARE STORED ON WORK15 IN,I6,
     +     12H BUFFERS OF ,I6,10H ELEMENTS.)
 9048  FORMAT(I12,43H OFF DIAGONAL LOOPS ARE STORED ON WORK16 IN,I6,
     +     12H BUFFERS OF ,I6,10H ELEMENTS.)
      END
