C 17 JAN 06 - MWS - CORRECT BYTES PER INTEGRAL RECORD PRINTING
C 19 SEP 05 - GDF - INCLUDE H AND I CODING
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  1 JUN 05 - DGF - EXCHNG: CHANGED FOR FMO RUNS
C  1 JUN 05 - TJP - VECTOR SYSTEMS NO LONGER USE SPECIAL DIRFCKV
C 30 APR 05 - DGF - REMOVE LABSIZ OPTION FROM $INTGRL
C  7 MAR 05 - IA  - INTIN: DYNAMIC POLARIZABILITY MUST NOT USE PK FILE
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL, ROOT, EDCMP
C  5 FEB 05 - DGF - SHELLQUART: KEEP UNCONTRACTED S,P IN S,P CODE
C 10 NOV 04 - KI,MWS - SHELLQUART SELECTS BEST INTEGRAL CODE
C  7 SEP 04 - GDF - NEW AO INTEGRAL PACKAGING TO ACCOMODATE ERIC
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C 16 JAN 04 - MWS - SYNCH COMMON BLOCK DFGRID
C  9 DEC 03 - OQ  - TWOEI: PASS NFLMAT TO DFCKNS ROUTINE
C  4 NOV 03 - TJP - XYZINT: CLEAN UP EXECUTION FLOW
C  3 SEP 03 - SPW - TWOEI: ADDED DIRCIS ARGUMENT AND CALL TO DRFCIS
C  3 JUL 03 - JMM - SUPPRESS PRINTING FOR MONTE CARLO JOBS
C 28 JAN 03 - MWS - SHELLS: ARGUMENT TO SUPPRESS ANGULAR MOMENTUM FLIP
C 12 DEC 02 - MWS - MIN ZETA FOR HONDO INCREASED EVEN FOR PLAIN HF JOBS,
C                   REMOVE HALVING OF CUTOFF IN DEBUT FOR FDIFF JOBS
C 20 JUN 02 - MWS - TWOEI: ANIONS SEND DIFFUSE INTS TO HONDO PACKAGE
C 26 MAR 02 - YA  - TWOEI: IMMEDIATE SCREENING SKIP IF NOT PK FILE
C 16 NOV 01 - JMS - POPLE PACKAGE INITIALIZATIONS CHANGED
C  8 OCT 01 - MWS - RESTORE TIMING CALL
C  6 SEP 01 - CHC - INTIN : ADD QFMM OPTION
C  1 AUG 01 - MWS - MIN ZETA TO FORCE HONDO SMALLER IF VIRTS UNOCCUPIED
C 25 JUN 01 - MWS - ALTER COMMON BLOCK WFNOPT
C 13 JUN 01 - DGF - INTIN: USE OF GRID DFT FORCES NOPK SETTING
C 19 NOV 00 - RMM,HL - INTIN: PAD OUT EDCMP COMMON FOR POLAPP KEYWORD
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER
C 11 JUN 00 - MWS - TWOEI: SEND SMALL EXPONENT SP INTEGRALS TO HONDO
C  1 MAY 00 - MWS - NO SYMMETRY OPTION IN TRFOPT COMMON
C 21 DEC 99 - MWS - MOVE LABSIZ INIT FROM DEBUT TO INTIN
C 13 MAR 99 - KRG - INTIN: USE OF DFT FORCES NOPK SETTING
C  9 JAN 99 - MWS - QOUT: ADD TO SAVE TO WORK AROUND XLF V5 PROBLEM
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C 27 SEP 98 - OS,MWS - JANDK: SET DSKWRK BEFORE DEBUT CALL
C  6 MAY 98 - MWS - DEBUT: HALVE CUTOFF IF FOCK DIFFERENCING,
C                   INTIN: BY DEFAULT EVEN SCF NEVER CREATES SUPERMATRIX
C 27 FEB 98 - MWS - INTIN: AVOID SUPERMATRIX FOR ANY TYPE CI
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 18 DEC 96 - TLW - TWOEI: PASS NFLMAT THROUGH TO DIRECT FOCK BUILDER
C 29 SEP 96 - GDF - DEBUT,PKFILE,ZPKOUT,SHELLS: INDEX BASED ON LMAX
C 13 JUN 96 - VAG - ADD VARIABLE FOR CI TYPE TO SCFOPT COMMON
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C 29 JAN 96 - MWS - JANDK: WRITE ZERO K INTS DURING CHECK RUNS
C  9 JAN 96 - WC  - INTIN,QOUT: GENERATE ONE INTEGRAL FILE FOR MOROKUMA
C 14 SEP 95 - SPW - INTIN: SET NOPK TO 1 FOR ABELIAN POLAR. DECOMP.
C 11 AUG 95 - XL  - INTIN,TWOEI: SCREENED INTEGRAL CHANGES
C 21 APR 95 - MWS - USE CORRECT NAME FOR EXCHANGE INTEGRAL SCREENING
C 28 MAR 95 - MWS - PKFILE,QOUT: SAVE ADDED FOR AIX COMPILER
C  5 MAR 95 - MWS - TWOEI: CHANGE SCHWARZ SCREENING FOR DIRFCK
C  1 FEB 95 - WC  - FINAL,INTIN,QOUT: DUPLICATE J INT FILE FOR MOROKUMA
C 12 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 25 OCT 94 - MWS - INTIN: RAISE NINTMX DEFAULT FROM 1725 TO 15000
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  5 AUG 94 - MWS - USE DOUBLE LABEL PACKING
C 15 JUL 94 - BMB - DEBUT: CHANGE DAREAD TO CALL TO GAMGEN
C  1 JUN 94 - MWS - INTIN: MCSCF/CI RUNS DON'T OPEN ORDINT FILE
C 30 MAR 94 - MWS - DEBUT,TWOEI: DIRECT TRANSFORMATION CHANGES
C  6 JAN 94 - MWS - EXCHNG: STORE EXCHANGE INTEGRALS ON DAF
C 13 DEC 93 - NM  - TWOEI: ADD CALLS FOR DIRECT INTEGRAL TRANSFORMATION
C  5 JUN 92 - TLW - INTIN,JANDK: DISK BASED METHOD PARALLELIZED
C                   EXCHNG: PARALLELIZED
C 18 MAY 92 - MWS - DEBUT: BOMB JOB IF PARALLEL BUT NOT DIRECT SCF
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C 21 FEB 92 - TLW - TWOEI: PARALLELIZE
C 10 FEB 92 - JHJ - JANDK: IF MPC WFN RETURN.
C 11 JAN 92 - TLW - DEBUT: MAKE READS PARALLEL
C 10 JAN 92 - TLW - CHANGE REWIND TO CALL SEQREW
C 10 JAN 92 - MWS,TLW - CHANGE OPENIS AND OPENPK TO SEQOPN
C  7 JAN 92 - TLW - MAKE WRITES PARALLEL; ADD COMMON PAR
C 11 OCT 91 - MWS - DIRECT SCF CHANGES TO DEBUT,FINAL,JANDK,TWOEI,
C                   ADDED ROUTINES BASCHK,INTIN,SCHWDN,ZPKOUT,ZQOUT,
C                   SEVERAL POPLE INTEGRAL ROUTINES MOVED TO INT2B.
C 12 AUG 91 - TLW - PUT IN F AND G FUNCTIONS
C 29 APR 91 - MWS - PKFILE USES FULL 16 BIT PACKING ON 32 BIT MACHINES
C  2 NOV 90 - MWS - RENAME /INDEX/ TO /INTDEX/
C  7 AUG 90 - TLW - ADD CF AND CG TO COMMON NSHEL
C  3 JUN 90 - JAM - CHANGE VAX BYTE PACKING TO FULL 8 BITS
C 29 NOV 89 - MWS - ADD NECP TO /INTOPT/
C 24 OCT 89 - MWS - CHANGE BUFFER ALLOCATION TO DELETE /BUF/,
C                   SOUP UP PKFILE SOMEWHAT
C 18 JAN 89 - MWS - RENAME /IJPAIR/ TO /IJGNRL/
C 17 NOV 88 - MWS - IMPLEMENT MICHEL'S SCHWARZ INEQUALITY SCREENING
C 10 AUG 88 - MWS - MXSH,MXGSH,MXGTOT FROM 120,10,440 TO 1000,30,5000
C 22 MAY 88 - MWS - PASS GOUT TO TQ0111 VIA CALL,
C                   INCREASE ACCURACY OF SP INTEGRALS IN FILMAX
C 17 MAY 88 - MWS - SPD BASES NOW USE POPLE CODE FOR SP INTEGRALS,
C                   QOUT AND QOUT70 COMBINED INTO QOUT,
C                   PKFILE AND PKFI70 COMBINED INTO PKFILE,
C                   HONINT, JKIN70, PKIN70 COMBINED INTO TWOEI,
C                   S0000 AND QOUT CALLED FROM TWOEI,
C                   PARAMETERS USED TO DIMENSION COMMONS,
C                   GENERAL PRETTIFICATION
C  8 MAY 88 - MWS - DEBUT CHECKS 32 BIT MACHINES FOR OVER 255 AO-S
C 14 FEB 88 - MWS - INCREASE RYS ROOTS TO 9 ROOTS
C 15 NOV 87 - STE - USE EXETYP; DON'T PRINT BLOCK TIMES
C  7 AUG 87 - MWS - INCLUDE ETA VERSION
C 19 JUL 87 - MWS - RENAME NOCORE VARIABLE TO NOMEM
C 13 OCT 86 - JAB - REMOVE EXTRANEOUS ARGUMENTS FROM ADVFIL CALLS
C 11 JUL 86 - MWS - PACKING FOR CELERITY AND CRAY VERSIONS
C  7 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS
C  8 NOV 85 - STE - JANDK: RETURN BUFFERS BEFORE ORDRJK
C 22 OCT 85 - STE - FINAL:NSHEL MISSING; LGENR70: CHANGE INT2B CALLS
C                   USE GENERIC ABS,ATAN,EXP,MIN,MAX,SQRT
C 11 JUL 85 - MWS - CHANGE IBM INDEX PACKING
C 20 JAN 84 - STE - MOVE 2-E TIME FROM HONINT,JKIN70,PKIN70 TO JANDK
C  4 JAN 84 - STE - CLEAN UP COMMON BLOCK OCCURENCES
C 19 DEC 83 - STE - MOVE $INTGRL TO START, CHANGE /BUF/
C  2 DEC 83 - STE - INITIALIZE IST,JST...INTLOC IN DEBUT
C 17 NOV 83 - STE - FPS PACKING IN PKFI70,PKFILE,QOUT,QOUT70
C  4 NOV 83 - STE - REMOVE CALLS TO INITPK,INITPN,EXITPK,EXITPN
C 17 AUG 83 - MWS - LESS OUTPUT FROM JKIN70
C 24 MAY 83 - MWS - LESS OUTPUT FROM PKIN70
C 21 OCT 82 - MWS - ADD DMY ARGUMENTS TO NAMEIO CALL
C  8 OCT 82 - MWS - CONVERT TO IBM
C
C*MODULE INT2A   *DECK BASCHK
      SUBROUTINE BASCHK(LMAX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      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
C
C     RETURN THE HIGHEST ANGULAR MOMENTUM PRESENT IN THE BASIS.
C     NOTE THAT KTYPE=1,2,3,4,5 MEANS S, P(L), D, F, G FUNCTION.
C
      KANG = 0
      DO 100 N=1,NSHELL
          IF(KTYPE(N).GT.KANG) KANG = KTYPE(N)
  100 CONTINUE
      LMAX = KANG-1
      RETURN
      END
C*MODULE INT2A   *DECK EXCHNG
      SUBROUTINE EXCHNG(XINTS,GHONDO,DDIJ,NSH2,MAXG,INTTYP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION XINTS(NSH2),GHONDO(MAXG),DDIJ(*)
      DIMENSION IBPOP(4,4)
C
      LOGICAL POPLE,OUT,SOME,IANDJ,GOPARR,DSKWRK,MASWRK,SAVEINT,NXT,
     *        DOESP
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /INTAC2/ EI1,EI2,CUX
      COMMON /FLIPS / IB(4,3)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMORUN/ ESPSCF,IDAFMO,ICURLAY,ICURFG,JCURFG,KCURFG,NCURSH,
     *                NGAU,ICURPOP,IFMOSTP,MONCOR,NAT1E,NEEDR,MODRST,
     *                NORBPROJ
      COMMON /GOUT  / GPOPLE(768),NORGP
      COMMON /INTDEX/ IJGT(784),IJX(784),IJY(784),IJZ(784),IK(784),
     *                KLGT(784),KLX(784),KLY(784),KLZ(784)
      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 /SHLEXC/ NORGSH(3),NORGSP(3),IEXCH,NANGM,NGTH(4)
      COMMON /SHLG70/ ISH,JSH,KSH,LSH,IJKLXX(4)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      DATA IBPOP/0,0,0,0,64,16,4,1,128,32,8,2,192,48,12,3/
C
C     ----- COMPUTE ALL EXCHANGE INTEGRALS [II,JJ/II,JJ] -----
C     THE LARGEST EXCHANGE INTEGRAL FROM EACH INTEGRAL BLOCK
C     IS PICKED OUT AND SAVED, SO THAT THE SCHWARZ INEQUALITY
C     CAN BE USED LATER TO AVOID ENTIRE INTEGRAL BLOCKS.
C
C     ----- INTIALIZE PARALLEL -----
C     DYNAMIC LOAD BALANCING PROVED AN ENTIRE FAILURE, IN BOTH 1ST
C     AND 2ND NESTED SHELL LOOP, PRESUMABLY DUE TO TOO HIGH RATIO
C     OF EXTRA EXPENSES/COMPUTIONS (ON GIGABIT NETWORK).  THE CODE
C     IS KEPT FOR FUTURE AND LOAD BALANCING IS HARDWIRED TO STATIC.
C     NXT = IBTYP.EQ.1
      NXT=.FALSE.
      IPCOUNT = ME - 1
      IF(NXT) IPCOUNT = - 1
      NEXT = -1
      DOESP=NFG.NE.0.AND.NCURSH.NE.0
      IF (GOPARR.OR.DOESP) CALL VCLR(XINTS,1,NSH2)
C
      SOME = NPRINT.NE.-5 .AND. MASWRK
      SAVEINT=NFG.EQ.0.OR.NCURSH.EQ.0.OR.IFMOSTP.EQ.6
C
      IF(SOME) THEN
         TIM = ZERO
         CALL TSECND(TIM)
         TIM0 = TIM
      ENDIF
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      IF(LMAX.EQ.5) NANGM = 21
      IF(LMAX.EQ.6) NANGM = 28
      NGTH(4) = 1
      NGTH(3) = NGTH(4) * NANGM
      NGTH(2) = NGTH(3) * NANGM
      NGTH(1) = NGTH(2) * NANGM
      IF(NOPK.EQ.0) THEN
         NORGSH(1) = 0
         NORGSH(2) = NORGSH(1) + NANGM**4
         NORGSH(3) = NORGSH(2) + NANGM**4
         NORGSP(1) = 0
         NORGSP(2) = 256
         NORGSP(3) = 512
      ELSE
         DO I=1,3
            NORGSH(I) = 0
            NORGSP(I) = 0
         ENDDO
      END IF
C
C        THE IDEA IS TO DO EVEN SMALL INTEGRALS, BELOW THE USUAL
C        CUTOFF THRESHHOLDS, BY RESETTING TOLERANCES TIGHTLY.
C
      TOLSV = TOL
      TOL = 75.0D+00
C
      EI1SV = EI1
      EI2SV = EI2
      CUXSV = CUX
      EI1 = 1.0D-17
      EI2 = 1.0D-17
      CUX = 50.0D+00
C
      IEXCH = 1
      NORGP = 0
      QQ4   = ONE
      NINT  = 0
C
C     ----- LOOP OVER ALL SHELL BLOCKS -----
C
      IJIJ = 0
      DO 600 ISH = 1,NSHELL
         IF (GOPARR.AND.NXT) THEN
            IPCOUNT = IPCOUNT + 1
            IF (IPCOUNT.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
            IF (NEXT.NE.IPCOUNT) THEN
               IJIJ = IJIJ+ISH
               GO TO 600
            ENDIF
         END IF
         DO 500 JSH = 1,ISH
            IJIJ = IJIJ+1
C
C           SKIP UNNEEDED OFF-DIAGONAL BLOCKS FOR FMO ESP SCREENING.
C
            IF(DOESP.AND.ISH.GT.NCURSH.AND.JSH.LE.NCURSH) GO TO 500
C
C           ----- GO PARALLEL! -----
C
            IF (GOPARR.AND..NOT.NXT) THEN
               IPCOUNT = IPCOUNT + 1
               IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 500
            END IF
C
C     USE POPLE CODE FOR ANY PURE SP INTEGRAL BLOCKS,
C     USE HONDO RYS POLYNOMIAL CODE FOR OTHER BLOCKS
C
            POPLE=.TRUE.
            IF(INTTYP.GE.2)     POPLE=.FALSE.
            IF(KTYPE(ISH).GT.2) POPLE=.FALSE.
            IF(KTYPE(JSH).GT.2) POPLE=.FALSE.
C
            IF(POPLE) THEN
               KSH=ISH
               LSH=JSH
               CALL GENR70(IEXCH,.FALSE.)
            ELSE
               CALL SHELLS(1,ISH,JSH,ISH,JSH,.TRUE.)
            CALL IJPRIM(DDIJ)
            CALL SHELLS(2,ISH,JSH,ISH,JSH,.TRUE.)
            CALL ZQOUT(GHONDO)
            IF(IJKL.EQ.1) CALL S0000(GHONDO,DDIJ)
            IF(IJKL.GT.1) CALL GENRAL(GHONDO,DDIJ)
         END IF
C
C     ----- PICK OUT LARGEST EXCHANGE INTEGRAL FOR THIS BLOCK -----
C
         VMAX = ZERO
         MINI = KMIN(ISH)
         MINJ = KMIN(JSH)
         MAXI = KMAX(ISH)
         JMAX = KMAX(JSH)
         IANDJ=ISH.EQ.JSH
         IBB = IB(1,IEXCH)
         JBB = IB(2,IEXCH)
         KBB = IB(3,IEXCH)
         LBB = IB(4,IEXCH)
         IJN = 0
         DO 300 I=MINI,MAXI
            IF(IANDJ) JMAX = I
            DO 200 J=MINJ,JMAX
               IF(POPLE) THEN
                  NN = IBPOP(IBB,I) + IBPOP(JBB,J)
     *               + IBPOP(KBB,I) + IBPOP(LBB,J) + 1
                  VAL = GPOPLE(NN)
               ELSE
                  IJN = IJN+1
                  NN = IJGT(IJN) + KLGT(IJN)
                  VAL = GHONDO(NN)
               END IF
               IF(VAL.GT.ZERO) NINT=NINT+1
               IF(VAL.GT.VMAX) VMAX=VAL
  200       CONTINUE
  300    CONTINUE
         XINTS(IJIJ)=SQRT(VMAX)
  500    CONTINUE
  600 CONTINUE
C
C     ----- SUM UP PARTIAL CONTRIBUTIONS IF PARALLEL -----
C
      IF (GOPARR) THEN
         CALL DDI_GSUMF(1050,XINTS,NSH2)
         CALL DDI_GSUMI(1051,NINT ,1)
         IF(NXT) CALL DDI_DLBRESET
      END IF
C
      IF(OUT) THEN
         WRITE(IW,*) 'MAX EXCHANGE INTEGRAL IN SHELL'
         CALL PRTRI(XINTS,NSHELL)
      END IF
C
      IF(SOME) THEN
         CALL TSECND(TIM)
         TEXCH = TIM-TIM0
         WRITE(IW,9000) NINT,TEXCH
      ENDIF
C
      TOL = TOLSV
      EI1 = EI1SV
      EI2 = EI2SV
      CUX = CUXSV
C
C     DURING FMO ESP RUNS, EXCHANGE INTEGRALS HAVE DIFFERENT SIZE SO
C     ONE CANNOT WRITE THEM TO THE SAME RECORD. THE ONLY EXCEPTION IS
C     THE SEPARATED DIMER ENERGIES WHERE THERE IS JUST ONE SET OF 2E
C     INTEGRALS.
C
      IF(SAVEINT) CALL DAWRIT(IDAF,IODA,XINTS,NSH2,54,0)
      RETURN
 9000 FORMAT(1X,'SCHWARZ INEQUALITY OVERHEAD:',I10,' INTEGRALS, T=',
     *       F12.2)
      END
C*MODULE INT2A   *DECK DEBUT
      SUBROUTINE DEBUT(DIRSCF,BUFP,BUFK,IX,NINTMX,NEED,DIRTRF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DIRSCF,DIRTRF
      LOGICAL DIR,GOPARR,DSKWRK,MASWRK,PK,PANDK,BLOCK,OUT
C
      DIMENSION BUFP(NINTMX),BUFK(NINTMX),IX(*)
C
      PARAMETER (MXSH=5000, MXGTOT=20000,  MXATM=2000, MXAO=8192)
C
      COMMON /B     / CO(MXSH,3)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTPR / QINT(2),VALINT(2),JCINT(11)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     2                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     3                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     4                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 /PCKLAB/ LABSIZ
      COMMON /PKFIL / PK,PANDK,BLOCK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      PARAMETER (ONE=1.0D+00, TEN=10.0D+00, RLN10=2.30258D+00)
C
      DATA CHECK/8HCHECK   /
C
C     ----- INITIALIZE TWO ELECTRON INTEGRAL CALCULATION -----
C
      TOL= ITOL*RLN10
      CUTOFF= ONE/(TEN**ICUT)
      DIR= DIRSCF .OR. DIRTRF
C
      DO 100 I=1,NUM
         IA(I)=(I*I-I)/2
  100 CONTINUE
C
C     ----- ERIC (AND OTHER INTEGRAL PACKAGE) INITIALIZATIONS -----
C
      CALL ERIPRE
C
      IF((NPRINT.NE.-5) .AND. MASWRK) THEN
         IF(DIR) THEN
            IF(DIRSCF) WRITE(IW,9000)
            IF(DIRSCF) WRITE(IW,9040)
            IF(DIRTRF) WRITE(IW,9045)
         ELSE
            WRITE(IW,9000)
            IF(PK) THEN
               IF(     PANDK .AND. NPRINT.NE.-5) WRITE(IW,9010)
               IF(.NOT.PANDK) WRITE(IW,9020)
            ELSE
               WRITE(IW,9030)
            END IF
C  J (OR P) INTEGRAL, 4 LABELS OF 1 OR 2 BYTES, PLUS MAYBE A K INTEGRAL
            NBYTES = 8 + 4*LABSIZ
            IF(PANDK) NBYTES = NBYTES+8
            IF(NINTIC.NE.0) WRITE(IW,9055) NINTIC
            WRITE(IW,9050) NINTMX,NBYTES
            WRITE(IW,9060) NEED
         END IF
      END IF
C
      OUT = NPRINT.EQ.4 .AND. MASWRK
      JCINT(1) = 0
C
      DO 200 I=1,NSHELL
         ICC = KATOM(I)
         CO(I,1)= C(1,ICC)
         CO(I,2)= C(2,ICC)
         CO(I,3)= C(3,ICC)
  200 CONTINUE
C
      IF(DIRSCF .OR. DIRTRF .OR. EXETYP.EQ.CHECK) GO TO 400
C
      CALL SEQREW(IS)
C
      IF(IREST.LT.1 .OR. NREC.LE.1 .OR. INTLOC.LE.1) GO TO 400
  300 CONTINUE
C
C     ----- POSITION THE INTEGRAL FILE FOR A RESTART JOB -----
C
      ICOUNT = INTLOC
      N = NREC-1
      IF(MASWRK) THEN
         DO 310 I=1,N
            READ(IS)
  310    CONTINUE
      END IF
      IF(NINTIC.NE.0) CALL ABRT
C     NO RESTART SUPPORT YET.
      IF(.NOT.PANDK) CALL PREAD (IS,BUFP,IX,NXX,NINTMX)
      IF(     PANDK) CALL PKREAD(IS,BUFP,BUFK,IX,NXX,NINTMX)
      CALL SEQREW(IS)
      IF(MASWRK) THEN
         DO 320 I=1,N
            READ(IS)
  320    CONTINUE
      END IF
      GO TO 999
  400 CONTINUE
C
C     ----- NORMAL START -----
C
      IF(IST.LT.1) IST = 1
      IF(JST.LT.1) JST = 1
      IF(KST.LT.1) KST = 1
      IF(LST.LT.1) LST = 1
      IF(IST.GT.NSHELL) GO TO 999
      IF(IST.NE.1 .OR. JST.NE.1 .OR. KST.NE.1 .OR. LST.NE.1) GO TO 300
      NREC   = 1
      INTLOC = 1
      ICOUNT = 1
  999 CONTINUE
      RETURN
 9000 FORMAT(/10X,20(1H-)/10X,'2 ELECTRON INTEGRALS'/10X,20(1H-)/)
 9010 FORMAT(' THE -PK- OPTION IS ON, CREATING -P- AND -K-',
     *       ' SUPERMATRICES.')
 9020 FORMAT(' THE -PK- OPTION IS ON, CREATING A -P- SUPERMATRIX.')
 9030 FORMAT(' THE -PK- OPTION IS OFF, THE INTEGRALS ARE NOT IN',
     *       ' SUPERMATRIX FORM.')
 9040 FORMAT(' DIRECT SCF METHOD SKIPS INTEGRAL STORAGE ON DISK.')
 9045 FORMAT(' DIRECT TRANSFORMATION SKIPS AO INTEGRAL STORAGE',
     *       ' ON DISK.')
 9050 FORMAT(' STORING',I8,' INTEGRALS/RECORD ON DISK, USING',I3,
     *       ' BYTES/INTEGRAL.')
 9055 FORMAT(' STORING',I9,' INTEGRALS IN MEMORY,')
 9060 FORMAT(' TWO ELECTRON INTEGRAL EVALUATION REQUIRES',I8,
     *       ' WORDS OF MEMORY.')
      END
C*MODULE INT2A   *DECK FINAL
      SUBROUTINE FINAL(INDEX,II,JJ,KK,LL,PANDK,BUFP,BUFK,IX,NINTMX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PANDK,OUT,GOPARR,DSKWRK,MASWRK
C
      DIMENSION BUFP(NINTMX),BUFK(NINTMX),IX(*)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /INTPR / Q(2),V(2),JC,N1(2),J1(2),J2(2),J3(2),J4(2)
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
C
      IF(OUT .AND. JC.GT.0)
     * WRITE(IW,9088) (J1(M),J2(M),J3(M),J4(M),Q(M),V(M),M=1,JC)
C
      IF (INDEX.EQ.1) GO TO 140
C
C         RAN OUT OF TIME, FLUSH PARTIAL BUFFER, PRINT RESTART DATA
C
      IREST = 1
      IST = II
      JST = JJ
      KST = KK
      LST = LL+1
      IF(LST.LE.KK) GO TO 120
      LST = 1
      KST = KK+1
      IF(KST.LE.JJ) GO TO 120
      KST = 1
      JST = JJ+1
      IF(JST.LE.II) GO TO 120
      JST = 1
      IST = II+1
      IF(IST.GT.NSHELL) GO TO 140
C
  120 CONTINUE
CNB   DO SOMETHING FOR IN CORE
      NXX = ICOUNT-1
      IF(.NOT.PANDK) CALL PWRIT (IS,BUFP,IX,NXX,NINTMX)
      IF(     PANDK) CALL PKWRIT(IS,BUFP,BUFK,IX,NXX,NINTMX)
      NINT = NINTMX*(NREC-1)+ICOUNT-1
      IF (MASWRK) THEN
         WRITE(IW,9010) NINT,NREC,IS
         WRITE(IW,9020) NREC,ICOUNT,IST,JST,KST,LST
      END IF
      RETURN
C
C        DONE WITH INTEGRALS, WRITE LAST BUFFER, PRINT STATISTICS
C
  140 CONTINUE
      IREST = 0
      IST = 1
      JST = 1
      KST = 1
      LST = 1
      NXX = ICOUNT-1
      IF(NXX.GE.NINTIC) THEN
C
C     GE INSTEAD OF GT ENFORCES WRITING A RECORD WITH 0 INTEGRALS
C     (IF NINTIC IS EQUAL TO NXX) TO COMPLY WITH THE INTEGRAL FILE
C     STRUCTURE
C
         NXX=NXX-NINTIC
         NXX = -NXX
C        WRITE(6,*) 'SAVING',NXX
         IF(.NOT.PANDK) CALL PWRIT (IS,BUFP(NINTIC+1),IX(ININTIC+1),
     *                              NXX,NINTMX)
         IF(     PANDK) CALL PKWRIT(IS,BUFP,BUFK,IX,NXX,NINTMX)
         NINT = NINTMX*(NREC-1)+ICOUNT-1
C        NOTE THAT ICOUNT-1 INCLUDES NINTIC
      ELSE
         NINT = NXX
      ENDIF
C     THE # OF INTEGRALS MUST BE STORED ON EACH NODE BEFORE GSUMI.
      IF(NINTIC.NE.0) NXXIC=MIN(NINT,NINTIC)
      NINTMY=NINT
      IF (GOPARR) THEN
         CALL DDI_GSUMI(1056,NINT,1)
         CALL DDI_GSUMI(1057,NREC,1)
      END IF
      IF (MASWRK.AND.(NFG.EQ.0.OR.NPRINT.NE.-5)) THEN
         IF(NINTIC.EQ.0) THEN
            WRITE(IW,9010) NINT,NREC,IS
         ELSE IF(NINTMY.LE.NINTIC) THEN
            WRITE(IW,9015) NINT,(NINTMY*1.0D+02)/NINTIC
         ELSE
            WRITE(IW,9017) NINT,NINTIC,(NINTIC*1.0D+02)/NINTMY,
     *                     NREC,IS
         ENDIF
      ENDIF
      RETURN
C
 9010 FORMAT(1X,'TOTAL NUMBER OF NONZERO TWO-ELECTRON INTEGRALS =',I20/
     *       1X,I10,' INTEGRAL RECORDS WERE STORED ON DISK FILE',I3,'.')
 9015 FORMAT(1X,'TOTAL NUMBER OF NONZERO TWO-ELECTRON INTEGRALS =',I20/
     *       1X,'ALL INTEGRALS FITTED INTO MEMORY (',F5.1,
     *          '% OF BUFFER USED)!')
 9017 FORMAT(1X,'TOTAL NUMBER OF NONZERO TWO-ELECTRON INTEGRALS =',I20
     *      /1X,'ON NODE 0',I13,' INTEGRALS STORED IN MEMORY(',F4.1,'%)'
     *     ,/I10,' INTEGRAL RECORDS WERE STORED ON DISK FILE',I3,'.')
 9020 FORMAT(/1X,'...... WARNING   .......   WARNING   .......'/
     *        1X,'TIME LIMIT HAS EXPIRED.  THIS JOB MUST BE RESTARTED.'/
     *        1X,'IF YOU SAVED THE INTEGRALS, RESTART WITH IREST=1,'/
     *        1X,'NREC=',I8,' INTLOC=',I6,' IST,JST,KST,LST=',4I6)
 9088 FORMAT(2(4I4,F5.1,F17.9,1X))
      END
C*MODULE INT2A   *DECK FORMS
      SUBROUTINE FORMS(GHONDO)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION GHONDO(*)
C
      COMMON /DENS  / DKL(784),DIJ(784)
      COMMON /INTDEX/ IJGT(784),IJX(784),IJY(784),IJZ(784),IK(784),
     *                KLGT(784),KLX(784),KLY(784),KLZ(784)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /XYZ   / XIN(31213),YIN(31213),ZIN(31213)
C
C     ----- FORM INTEGRALS OVER FUNCTIONS -----
C     DIMENSIONING XIN(81,5), AND ROLLING UP THE COMPUTATION
C     OF GHONDO IN A LOOP OF LENGTH NROOTS ADDS 33 SECONDS TO
C     A 240 SECOND INTEGRAL COMPUTATION JOB.  LEAVE IT UNROLLED.
C
      GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130),NROOTS
C
C          CODE FOR NROOTS=1
C
   10 CONTINUE
      DO 12 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 11 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      ))
   11 CONTINUE
   12 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=2
C
   20 CONTINUE
      DO 22 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 21 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401))
   21 CONTINUE
   22 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=3
C
   30 CONTINUE
      DO 32 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 31 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802))
   31 CONTINUE
   32 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=4
C
   40 CONTINUE
      DO 42 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 41 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203))
   41 CONTINUE
   42 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=5
C
   50 CONTINUE
      DO 52 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 51 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604))
   51 CONTINUE
   52 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=6
C
   60 CONTINUE
      DO 62 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 61 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604)
     *          +   XIN(MX+12005)*YIN(MY+12005)*ZIN(MZ+12005))
   61 CONTINUE
   62 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=7
C
   70 CONTINUE
      DO 72 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 71 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604)
     *          +   XIN(MX+12005)*YIN(MY+12005)*ZIN(MZ+12005)
     *          +   XIN(MX+14406)*YIN(MY+14406)*ZIN(MZ+14406))
   71 CONTINUE
   72 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=8
C
   80 CONTINUE
      DO 82 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 81 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604)
     *          +   XIN(MX+12005)*YIN(MY+12005)*ZIN(MZ+12005)
     *          +   XIN(MX+14406)*YIN(MY+14406)*ZIN(MZ+14406)
     *          +   XIN(MX+16807)*YIN(MY+16807)*ZIN(MZ+16807))
   81 CONTINUE
   82 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=9
C
   90 CONTINUE
      DO 92 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 91 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604)
     *          +   XIN(MX+12005)*YIN(MY+12005)*ZIN(MZ+12005)
     *          +   XIN(MX+14406)*YIN(MY+14406)*ZIN(MZ+14406)
     *          +   XIN(MX+16807)*YIN(MY+16807)*ZIN(MZ+16807)
     *          +   XIN(MX+19208)*YIN(MY+19208)*ZIN(MZ+19208))
   91 CONTINUE
   92 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=10
C
  100 CONTINUE
      DO 102 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 101 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604)
     *          +   XIN(MX+12005)*YIN(MY+12005)*ZIN(MZ+12005)
     *          +   XIN(MX+14406)*YIN(MY+14406)*ZIN(MZ+14406)
     *          +   XIN(MX+16807)*YIN(MY+16807)*ZIN(MZ+16807)
     *          +   XIN(MX+19208)*YIN(MY+19208)*ZIN(MZ+19208)
     *          +   XIN(MX+21609)*YIN(MY+21609)*ZIN(MZ+21609))
  101 CONTINUE
  102 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=11
C
  110 CONTINUE
      DO 112 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 111 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604)
     *          +   XIN(MX+12005)*YIN(MY+12005)*ZIN(MZ+12005)
     *          +   XIN(MX+14406)*YIN(MY+14406)*ZIN(MZ+14406)
     *          +   XIN(MX+16807)*YIN(MY+16807)*ZIN(MZ+16807)
     *          +   XIN(MX+19208)*YIN(MY+19208)*ZIN(MZ+19208)
     *          +   XIN(MX+21609)*YIN(MY+21609)*ZIN(MZ+21609)
     *          +   XIN(MX+24010)*YIN(MY+24010)*ZIN(MZ+24010))
     *          *D1*DKL(K)+GHONDO(N)
  111 CONTINUE
  112 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=12
C
  120 CONTINUE
      DO 122 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 121 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604)
     *          +   XIN(MX+12005)*YIN(MY+12005)*ZIN(MZ+12005)
     *          +   XIN(MX+14406)*YIN(MY+14406)*ZIN(MZ+14406)
     *          +   XIN(MX+16807)*YIN(MY+16807)*ZIN(MZ+16807)
     *          +   XIN(MX+19208)*YIN(MY+19208)*ZIN(MZ+19208)
     *          +   XIN(MX+21609)*YIN(MY+21609)*ZIN(MZ+21609)
     *          +   XIN(MX+24010)*YIN(MY+24010)*ZIN(MZ+24010)
     *          +   XIN(MX+26411)*YIN(MY+26411)*ZIN(MZ+26411))
     *          *D1*DKL(K)+GHONDO(N)
  121 CONTINUE
  122 CONTINUE
      RETURN
C
C          CODE FOR NROOTS=13
C
  130 DO 132 I = 1,IJ
      D1 = DIJ(I)
      NX = IJX(I)
      NY = IJY(I)
      NZ = IJZ(I)
      N1 = IJGT(I)
      MAX = IK(I)
      DO 131 K = 1,MAX
      MX = NX+KLX(K)
      MY = NY+KLY(K)
      MZ = NZ+KLZ(K)
      N = N1+KLGT(K)
      GHONDO(N) = GHONDO(N) + D1*DKL(K)*
     *            ( XIN(MX      )*YIN(MY      )*ZIN(MZ      )
     *          +   XIN(MX+ 2401)*YIN(MY+ 2401)*ZIN(MZ+ 2401)
     *          +   XIN(MX+ 4802)*YIN(MY+ 4802)*ZIN(MZ+ 4802)
     *          +   XIN(MX+ 7203)*YIN(MY+ 7203)*ZIN(MZ+ 7203)
     *          +   XIN(MX+ 9604)*YIN(MY+ 9604)*ZIN(MZ+ 9604)
     *          +   XIN(MX+12005)*YIN(MY+12005)*ZIN(MZ+12005)
     *          +   XIN(MX+14406)*YIN(MY+14406)*ZIN(MZ+14406)
     *          +   XIN(MX+16807)*YIN(MY+16807)*ZIN(MZ+16807)
     *          +   XIN(MX+19208)*YIN(MY+19208)*ZIN(MZ+19208)
     *          +   XIN(MX+21609)*YIN(MY+21609)*ZIN(MZ+21609)
     *          +   XIN(MX+24010)*YIN(MY+24010)*ZIN(MZ+24010)
     *          +   XIN(MX+26411)*YIN(MY+26411)*ZIN(MZ+26411)
     *          +   XIN(MX+28812)*YIN(MY+28812)*ZIN(MZ+28812))
  131 CONTINUE
  132 CONTINUE
      RETURN
      END
C*MODULE INT2A   *DECK GENRAL
      SUBROUTINE GENRAL(GHONDO,DDIJ)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION GHONDO(*),DDIJ(*)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,NORM,DOUBLE
C
      PARAMETER (MXGSH=30, MXG2=MXGSH*MXGSH)
C
      COMMON /DENS  / DKL(784),DIJ(784)
      COMMON /IJGNRL/ AA(MXG2),R(MXG2),X1(MXG2),Y1(MXG2),Z1(MXG2),
     *                IJD(784)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /SETINT/ IN(13),KN(13),NI,NJ,NK,NL,NMAX,MMAX,
     +                BP01,B00,B10,XCP00,XC00,YCP00,YC00,ZCP00,ZC00,F00,
     +                DXIJ,DYIJ,DZIJ,DXKL,DYKL,DZKL
      COMMON /SHLINF/  AG(MXGSH),CSA(MXGSH),CPA(MXGSH),CDA(MXGSH),
     *                CFA(MXGSH),CGA(MXGSH),CHA(MXGSH),CIA(MXGSH),
     *                 BG(MXGSH),CSB(MXGSH),CPB(MXGSH),CDB(MXGSH),
     *                CFB(MXGSH),CGB(MXGSH),CHB(MXGSH),CIB(MXGSH),
     *                 CG(MXGSH),CSC(MXGSH),CPC(MXGSH),CDC(MXGSH),
     *                CFC(MXGSH),CGC(MXGSH),CHC(MXGSH),CIC(MXGSH),
     *                 DG(MXGSH),CSD(MXGSH),CPD(MXGSH),CDD(MXGSH),
     *                CFD(MXGSH),CGD(MXGSH),CHD(MXGSH),CID(MXGSH),
     *                XI,YI,ZI,XJ,YJ,ZJ,RRI,XK,YK,ZK,XL,YL,ZL,RRK,
     *                NGA,NGB,NGC,NGD
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     +                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     +                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      DIMENSION IN1(13)
C
      PARAMETER (SQRT3=1.73205080756888D+00, SQRT5=2.23606797749979D+00,
     *           SQRT7=2.64575131106459D+00, PI252=34.986836655250D+00,
     *           SQRT9=3.0D+00,SQRT11=3.3166247903553998D+00,
     *           ZERO=0.0D+00, HALF=0.5D+00, ONE=1.0D+00)
C
C     GENERAL INTEGRAL ROUTINE FOR SPDFGHI AND L FUNCTIONS
C
      FACTOR = PI252*QQ4
      NORM = NORMF .NE. 1 .OR. NORMP .NE. 1
      NI = LIT-1
      NJ = LJT-1
      NK = LKT-1
      NL = LLT-1
      DXIJ = XI-XJ
      DYIJ = YI-YJ
      DZIJ = ZI-ZJ
      DXKL = XK-XL
      DYKL = YK-YL
      DZKL = ZK-ZL
      NMAX = NI+NJ
      MMAX = NK+NL
      MAX = NMAX+1
      DO 100 I = 1,MAX
         N = I-1
         IF (N .LE. NI) IN1(I) = 343*N+1
         IF (N .GT. NI) IN1(I) = 343*NI+49*(N-NI)+1
  100 CONTINUE
      MAX = MMAX+1
      DO 120 K = 1,MAX
         N = K-1
         IF (N .LE. NK) KN(K) = 7*N
         IF (N .GT. NK) KN(K) = 7*NK+N-NK
  120 CONTINUE
C
C     ----- K PRIMITIVE
C
      LGMAX = NGD
      DO 480 KG = 1,NGC
         AK = CG(KG)
         BRRK = AK*RRK
         AKXK = AK*XK
         AKYK = AK*YK
         AKZK = AK*ZK
         CSK = CSC(KG)*FACTOR
         CPK = CPC(KG)*FACTOR
         CDK = CDC(KG)*FACTOR
         CFK = CFC(KG)*FACTOR
         CGK = CGC(KG)*FACTOR
         CHK = CHC(KG)*FACTOR
         CIK = CIC(KG)*FACTOR
C
C        ----- L PRIMITIVE
C
         IF (KANDL) LGMAX = KG
         DO 460 LG = 1,LGMAX
            AL = DG(LG)
            B = AK+AL
            BINV = ONE/B
            BBRRK = AL*BRRK*BINV
            IF (BBRRK .GT. TOL) GO TO 460
            CSL = CSD(LG)
            CPL = CPD(LG)
            CDL = CDD(LG)
            CFL = CFD(LG)
            CGL = CGD(LG)
            CHL = CHD(LG)
            CIL = CID(LG)
            XB = (AKXK+AL*XL)*BINV
            YB = (AKYK+AL*YL)*BINV
            ZB = (AKZK+AL*ZL)*BINV
            BXBK = B*(XB-XK)
            BYBK = B*(YB-YK)
            BZBK = B*(ZB-ZK)
            BXBI = B*(XB-XI)
            BYBI = B*(YB-YI)
            BZBI = B*(ZB-ZI)
C
C           ----- DENSITY FACTOR
C
            DOUBLE=KANDL.AND.KG.NE.LG
            N = 0
            MAX = MAXL
            DUM1 = ZERO
            DUM2 = ZERO
            DO 370 K = MINK,MAXK
               GO TO (140,160,220,220,180,220,220,200,220,220,
     1                201,220,220,202,220,220,220,220,220,203,
     1                204,220,220,205,220,220,220,220,220,206,
     1                220,220,207,220,220,
     1                208,220,220,209,220,220,220,220,220,210,
     1                220,220,220,220,220,211,220,220,212,220,
     1                220,
     1                213,220,220,214,220,220,220,220,220,215,
     1                220,220,220,220,220,216,220,220,217,220,
     1                220,218,220,220,220,220,220,219),K
  140          DUM1 = CSK*BINV
               GO TO 220
  160          DUM1 = CPK*BINV
               GO TO 220
  180          DUM1 = CDK*BINV
               GO TO 220
  200          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 220
  201          DUM1 = CFK*BINV
               GO TO 220
  202          IF (NORM) DUM1 = DUM1*SQRT5
               GO TO 220
  203          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 220
  204          DUM1 = CGK*BINV
               GO TO 220
  205          IF (NORM) DUM1 = DUM1*SQRT7
               GO TO 220
  206          IF (NORM) DUM1 = DUM1*SQRT5/SQRT3
               GO TO 220
  207          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 220
  208          DUM1 = CHK*BINV
               GO TO 220
  209          IF (NORM) DUM1 = DUM1*SQRT9
               GO TO 220
  210          IF (NORM) DUM1 = DUM1*SQRT7/SQRT3
               GO TO 220
  211          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 220
  212          IF (NORM) DUM1 = DUM1*SQRT5/SQRT3
               GO TO 220
  213          DUM1 = CIK*BINV
               GO TO 220
  214          IF (NORM) DUM1 = DUM1*SQRT11
               GO TO 220
  215          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 220
  216          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 220
  217          IF (NORM) DUM1 = DUM1*SQRT7/(SQRT5*SQRT3)
               GO TO 220
  218          IF (NORM) DUM1 = DUM1*SQRT5
               GO TO 220
  219          IF (NORM) DUM1 = DUM1*SQRT5/SQRT3
C
  220          IF (KANDL) MAX = K
               DO 360 L = MINL,MAX
                  GO TO (240,280,340,340,300,340,340,320,340,340,
     1                   321,340,340,322,340,340,340,340,340,323,
     1                   324,340,340,325,340,340,340,340,340,326,
     1                   340,340,327,340,340,
     1                   328,340,340,329,340,340,340,340,340,330,
     1                   340,340,340,340,340,331,340,340,332,340,
     1                   340,
     1                   333,340,340,334,340,340,340,340,340,335,
     1                   340,340,340,340,340,336,340,340,337,340,
     1                   340,338,340,340,340,340,340,339),L
  240             DUM2 = DUM1*CSL
                  IF ( .NOT. DOUBLE) GO TO 340
                  IF (K .GT. 1) GO TO 260
                  DUM2 = DUM2+DUM2
                  GO TO 340
  260             DUM2 = DUM2+CSK*CPL*BINV
                  GO TO 340
  280             DUM2 = DUM1*CPL
                  IF (DOUBLE) DUM2 = DUM2+DUM2
                  GO TO 340
  300             DUM2 = DUM1*CDL
                  IF (DOUBLE) DUM2 = DUM2+DUM2
                  GO TO 340
  320             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 340
  321             DUM2 = DUM1*CFL
                  IF (DOUBLE) DUM2 = DUM2+DUM2
                  GO TO 340
  322             IF (NORM) DUM2 = DUM2*SQRT5
                  GO TO 340
  323             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 340
  324             DUM2 = DUM1*CGL
                  IF (DOUBLE) DUM2 = DUM2+DUM2
                  GO TO 340
  325             IF (NORM) DUM2 = DUM2*SQRT7
                  GO TO 340
  326             IF (NORM) DUM2 = DUM2*SQRT5/SQRT3
                  GO TO 340
  327             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 340
  328             DUM2 = DUM1*CHL
                  IF (DOUBLE) DUM2 = DUM2+DUM2
                  GO TO 340
  329             IF (NORM) DUM2 = DUM2*SQRT9
                  GO TO 340
  330             IF (NORM) DUM2 = DUM2*SQRT7/SQRT3
                  GO TO 340
  331             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 340
  332             IF (NORM) DUM2 = DUM2*SQRT5/SQRT3
                  GO TO 340
  333             DUM2 = DUM1*CIL
                  IF (DOUBLE) DUM2 = DUM2+DUM2
                  GO TO 340
  334             IF (NORM) DUM2 = DUM2*SQRT11
                  GO TO 340
  335             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 340
  336             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 340
  337             IF (NORM) DUM2 = DUM2*SQRT7/(SQRT5*SQRT3)
                  GO TO 340
  338             IF (NORM) DUM2 = DUM2*SQRT5
                  GO TO 340
  339             IF (NORM) DUM2 = DUM2*SQRT5/SQRT3
C
  340             N = N+1
                  DKL(N) = DUM2
  360          CONTINUE
  370       CONTINUE
C
C           ----- PAIR OF I,J PRIMITIVES
C
            NN = 0
            DO 440 N = 1,NIJ
               DUM = BBRRK+R(N)
               IF (DUM .GT. TOL) GO TO 440
               DO 380 I = 1,IJ
                  DIJ(I) = DDIJ(IJD(I)+NN)
  380          CONTINUE
               A = AA(N)
               AB = A*B
               AANDB = A+B
               EXPE = EXP(-DUM)/SQRT(AANDB)
               RHO = AB/AANDB
               XA = X1(N)
               YA = Y1(N)
               ZA = Z1(N)
               XX = RHO*((XA-XB)*(XA-XB) + (YA-YB)*(YA-YB)
     *                                   + (ZA-ZB)*(ZA-ZB))
               AXAK = A*(XA-XK)
               AYAK = A*(YA-YK)
               AZAK = A*(ZA-ZK)
               AXAI = A*(XA-XI)
               AYAI = A*(YA-YI)
               AZAI = A*(ZA-ZI)
               C1X = BXBK+AXAK
               C2X = A*BXBK
               C3X = BXBI+AXAI
               C4X = B*AXAI
               C1Y = BYBK+AYAK
               C2Y = A*BYBK
               C3Y = BYBI+AYAI
               C4Y = B*AYAI
               C1Z = BZBK+AZAK
               C2Z = A*BZBK
               C3Z = BZBI+AZAI
               C4Z = B*AZAI
C
C              ----- ROOTS AND WEIGHTS FOR QUADRATURE
C
               IF (NROOTS .LE. 3) CALL RT123
               IF (NROOTS .EQ. 4) CALL ROOT4
               IF (NROOTS .EQ. 5) CALL ROOT5
               IF (NROOTS .GE. 6) CALL ROOT6
               MM = 0
               MAX = NMAX+1
C
C              COMPUTE TWO-ELECTRON INTEGRALS FOR EACH ROOT
C
               DO 420 M = 1,NROOTS
                  U2 = U(M)*RHO
                  F00 = EXPE*W(M)
                  DO 400 I = 1,MAX
                     IN(I) = IN1(I)+MM
  400             CONTINUE
                  DUMINV = ONE/(AB+U2*AANDB)
                  DM2INV = HALF*DUMINV
                  BP01 = (A+U2)*DM2INV
                  B00 = U2*DM2INV
                  B10 = (B+U2)*DM2INV
                  XCP00 = (U2*C1X+C2X)*DUMINV
                  XC00 = (U2*C3X+C4X)*DUMINV
                  YCP00 = (U2*C1Y+C2Y)*DUMINV
                  YC00 = (U2*C3Y+C4Y)*DUMINV
                  ZCP00 = (U2*C1Z+C2Z)*DUMINV
                  ZC00 = (U2*C3Z+C4Z)*DUMINV
                  CALL XYZINT
                  MM = MM+2401
  420          CONTINUE
C
C              ----- FORM (I,J//K,L) INTEGRALS OVER FUNCTIONS
C
               CALL FORMS(GHONDO)
  440       NN = NN+49
  460    CONTINUE
  480 CONTINUE
C
      RETURN
      END
C*MODULE INT2A   *DECK IJPRIM
      SUBROUTINE IJPRIM(DDIJ)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,NORM
C
      PARAMETER (MXGSH=30, MXG2=MXGSH*MXGSH)
C
      DIMENSION DDIJ(49*MXG2)
C
      COMMON /IJGNRL/ A(MXG2),R(MXG2),X1(MXG2),Y1(MXG2),Z1(MXG2),
     *                IJD(784)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /SHLINF/  AG(MXGSH),CSA(MXGSH),CPA(MXGSH),CDA(MXGSH),
     *                CFA(MXGSH),CGA(MXGSH),CHA(MXGSH),CIA(MXGSH),
     *                 BG(MXGSH),CSB(MXGSH),CPB(MXGSH),CDB(MXGSH),
     *                CFB(MXGSH),CGB(MXGSH),CHB(MXGSH),CIB(MXGSH),
     *                 CG(MXGSH),CSC(MXGSH),CPC(MXGSH),CDC(MXGSH),
     *                CFC(MXGSH),CGC(MXGSH),CHC(MXGSH),CIC(MXGSH),
     *                 DG(MXGSH),CSD(MXGSH),CPD(MXGSH),CDD(MXGSH),
     *                CFD(MXGSH),CGD(MXGSH),CHD(MXGSH),CID(MXGSH),
     *                XI,YI,ZI,XJ,YJ,ZJ,RRI,XK,YK,ZK,XL,YL,ZL,RRK,
     *                NGA,NGB,NGC,NGD
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      PARAMETER (SQRT3=1.73205080756888D+00,
     *           SQRT5=2.23606797749979D+00,
     *           SQRT7=2.64575131106459D+00,
     *           SQRT9=3.0D+00,
     *           SQRT11=3.3166247903553998D+00,
     *           ZERO=0.0D+00, ONE=1.0D+00)
C
      NORM = NORMF .NE. 1 .OR. NORMP .NE. 1
      MAX = MAXJ
      N = 0
      NN = 0
      NM = -2**20
      DO 180 I = MINI,MAXI
         GO TO (100,100,120,120,100,120,120,100,120,120,
     1          100,120,120,100,120,120,120,120,120,100,
     1          100,120,120,100,120,120,120,120,120,100,
     1          120,120,100,120,120,
     1          100,120,120,100,120,120,120,120,120,100,
     1          120,120,120,120,120,100,120,120,100,120,
     1          120,
     1          100,120,120,100,120,120,120,120,120,100,
     1          120,120,120,120,120,100,120,120,100,120,
     1          120,100,120,120,120,120,120,100),I
  100    NM = NN
  120    NN = NM
         IF (IANDJ) MAX = I
         DO 170 J = MINJ,MAX
            GO TO (140,140,160,160,140,160,160,140,160,160,
     1             140,160,160,140,160,160,160,160,160,140,
     1             140,160,160,140,160,160,160,160,160,140,
     1             160,160,140,160,160,
     1             140,160,160,140,160,160,160,160,160,140,
     1             160,160,160,160,160,140,160,160,140,160,
     1             160,
     1             140,160,160,140,160,160,160,160,160,140,
     1             160,160,160,160,160,140,160,160,140,160,
     1             160,140,160,160,160,160,160,140),J
  140       NN = NN+1
  160       N = N+1
            IJD(N) = NN
  170    CONTINUE
  180 CONTINUE
C
C     ----- I PRIMITIVE
C
      NIJ = 0
      JBMAX = NGB
      DO 540 IA = 1,NGA
         AI = AG(IA)
         ARRI = AI*RRI
         AXI = AI*XI
         AYI = AI*YI
         AZI = AI*ZI
         CSI = CSA(IA)
         CPI = CPA(IA)
         CDI = CDA(IA)
         CFI = CFA(IA)
         CGI = CGA(IA)
         CHI = CHA(IA)
         CII = CIA(IA)
C
C        ----- J PRIMITIVE
C
         IF (IANDJ) JBMAX = IA
         DO 520 JB = 1,JBMAX
            AJ = BG(JB)
            AA = AI+AJ
            AAINV = ONE/AA
            DUM = AJ*ARRI*AAINV
            IF (DUM .GT. TOL) GO TO 520
            CSJ = CSB(JB)
            CPJ = CPB(JB)
            CDJ = CDB(JB)
            CFJ = CFB(JB)
            CGJ = CGB(JB)
            CHJ = CHB(JB)
            CIJ = CIB(JB)
            NM = 49*NIJ
            NN = NM
            NIJ = NIJ+1
            R(NIJ) = DUM
            A(NIJ) = AA
            X1(NIJ) = (AXI+AJ*XJ)*AAINV
            Y1(NIJ) = (AYI+AJ*YJ)*AAINV
            Z1(NIJ) = (AZI+AJ*ZJ)*AAINV
C
C           ----- DENSITY FACTOR
C
            DUM1 = ZERO
            DUM2 = ZERO
            DO 420 I = MINI,MAXI
               GO TO (200,220,420,420,240,420,420,260,420,420,
     1                261,420,420,262,420,420,420,420,420,263,
     1                264,420,420,265,420,420,420,420,420,266,
     1                420,420,267,420,420,
     1                268,420,420,269,420,420,420,420,420,270,
     1                420,420,420,420,420,271,420,420,272,420,
     1                420,
     1                273,420,420,274,420,420,420,420,420,275,
     1                420,420,420,420,420,276,420,420,277,420,
     1                420,278,420,420,420,420,420,279),I
  200          DUM1 = CSI*AAINV
               GO TO 280
  220          DUM1 = CPI*AAINV
               GO TO 280
  240          DUM1 = CDI*AAINV
               GO TO 280
  260          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 280
  261          DUM1 = CFI*AAINV
               GO TO 280
  262          IF (NORM) DUM1 = DUM1*SQRT5
               GO TO 280
  263          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 280
  264          DUM1 = CGI*AAINV
               GO TO 280
  265          IF (NORM) DUM1 = DUM1*SQRT7
               GO TO 280
  266          IF (NORM) DUM1 = DUM1*SQRT5/SQRT3
               GO TO 280
  267          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 280
  268          DUM1 = CHI*AAINV
               GO TO 280
  269          IF (NORM) DUM1 = DUM1*SQRT9
               GO TO 280
  270          IF (NORM) DUM1 = DUM1*SQRT7/SQRT3
               GO TO 280
  271          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 280
  272          IF (NORM) DUM1 = DUM1*SQRT5/SQRT3
               GO TO 280
  273          DUM1 = CII*AAINV
               GO TO 280
  274          IF (NORM) DUM1 = DUM1*SQRT11
               GO TO 280
  275          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 280
  276          IF (NORM) DUM1 = DUM1*SQRT3
               GO TO 280
  277          IF (NORM) DUM1 = DUM1*SQRT7/(SQRT5*SQRT3)
               GO TO 280
  278          IF (NORM) DUM1 = DUM1*SQRT5
               GO TO 280
  279          IF (NORM) DUM1 = DUM1*SQRT5/SQRT3
C
  280          IF (IANDJ) MAX = I
               DO 400 J = MINJ,MAX
                  GO TO (300,320,400,400,340,400,400,360,400,400,
     1                   361,400,400,362,400,400,400,400,400,363,
     1                   364,400,400,365,400,400,400,400,400,366,
     1                   400,400,367,400,400,
     1                   368,400,400,369,400,400,400,400,400,370,
     1                   400,400,400,400,400,371,400,400,372,400,
     1                   400,
     1                   373,400,400,374,400,400,400,400,400,375,
     1                   400,400,400,400,400,376,400,400,377,400,
     1                   400,378,400,400,400,400,400,379),J
  300             DUM2 = DUM1*CSJ
                  GO TO 380
  320             DUM2 = DUM1*CPJ
                  GO TO 380
  340             DUM2 = DUM1*CDJ
                  GO TO 380
  360             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 380
  361             DUM2 = DUM1*CFJ
                  GO TO 380
  362             IF (NORM) DUM2 = DUM2*SQRT5
                  GO TO 380
  363             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 380
  364             DUM2 = DUM1*CGJ
                  GO TO 380
  365             IF (NORM) DUM2 = DUM2*SQRT7
                  GO TO 380
  366             IF (NORM) DUM2 = DUM2*SQRT5/SQRT3
                  GO TO 380
  367             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 380
  368             DUM2 = DUM1*CHJ
                  GO TO 380
  369             IF (NORM) DUM2 = DUM2*SQRT9
                  GO TO 380
  370             IF (NORM) DUM2 = DUM2*SQRT7/SQRT3
                  GO TO 380
  371             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 380
  372             IF (NORM) DUM2 = DUM2*SQRT5/SQRT3
                  GO TO 380
  373             DUM2 = DUM1*CIJ
                  GO TO 380
  374             IF (NORM) DUM2 = DUM2*SQRT11
                  GO TO 380
  375             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 380
  376             IF (NORM) DUM2 = DUM2*SQRT3
                  GO TO 380
  377             IF (NORM) DUM2 = DUM2*SQRT7/(SQRT5*SQRT3)
                  GO TO 380
  378             IF (NORM) DUM2 = DUM2*SQRT5
                  GO TO 380
  379             IF (NORM) DUM2 = DUM2*SQRT5/SQRT3
C
  380             NN = NN+1
                  DDIJ(NN) = DUM2
  400          CONTINUE
  420       CONTINUE
            IF ( .NOT. IANDJ) GO TO 520
            IF (IA .EQ. JB) GO TO 520
            GO TO (500,440,460,455,450,445,444),LIT
  440       IF (MINI .EQ. 2) GO TO 500
            DDIJ(NM+2) = DDIJ(NM+2)+CSI*CPJ*AAINV
            GO TO 480
  444       DDIJ(NM+28) = DDIJ(NM+28)+DDIJ(NM+28)
            DDIJ(NM+27) = DDIJ(NM+27)+DDIJ(NM+27)
            DDIJ(NM+26) = DDIJ(NM+26)+DDIJ(NM+26)
            DDIJ(NM+25) = DDIJ(NM+25)+DDIJ(NM+25)
            DDIJ(NM+24) = DDIJ(NM+24)+DDIJ(NM+24)
            DDIJ(NM+23) = DDIJ(NM+23)+DDIJ(NM+23)
            DDIJ(NM+22) = DDIJ(NM+22)+DDIJ(NM+22)
            DDIJ(NM+21) = DDIJ(NM+21)+DDIJ(NM+21)
            DDIJ(NM+20) = DDIJ(NM+20)+DDIJ(NM+20)
            DDIJ(NM+19) = DDIJ(NM+19)+DDIJ(NM+19)
            DDIJ(NM+18) = DDIJ(NM+18)+DDIJ(NM+18)
            DDIJ(NM+17) = DDIJ(NM+17)+DDIJ(NM+17)
            DDIJ(NM+16) = DDIJ(NM+16)+DDIJ(NM+16)
  445       DDIJ(NM+15) = DDIJ(NM+15)+DDIJ(NM+15)
            DDIJ(NM+14) = DDIJ(NM+14)+DDIJ(NM+14)
            DDIJ(NM+13) = DDIJ(NM+13)+DDIJ(NM+13)
            DDIJ(NM+12) = DDIJ(NM+12)+DDIJ(NM+12)
            DDIJ(NM+11) = DDIJ(NM+11)+DDIJ(NM+11)
  450       DDIJ(NM+10) = DDIJ(NM+10)+DDIJ(NM+10)
            DDIJ(NM+9) = DDIJ(NM+9)+DDIJ(NM+9)
            DDIJ(NM+8) = DDIJ(NM+8)+DDIJ(NM+8)
            DDIJ(NM+7) = DDIJ(NM+7)+DDIJ(NM+7)
  455       DDIJ(NM+6) = DDIJ(NM+6)+DDIJ(NM+6)
            DDIJ(NM+5) = DDIJ(NM+5)+DDIJ(NM+5)
            DDIJ(NM+4) = DDIJ(NM+4)+DDIJ(NM+4)
  460       DDIJ(NM+2) = DDIJ(NM+2)+DDIJ(NM+2)
  480       DDIJ(NM+3) = DDIJ(NM+3)+DDIJ(NM+3)
  500       DDIJ(NM+1) = DDIJ(NM+1)+DDIJ(NM+1)
  520    CONTINUE
  540 CONTINUE
      RETURN
      END
C*MODULE INT2A   *DECK INTIN
      SUBROUTINE INTIN
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DOUBLE PRECISION INTGRL,MCSCF,MOROKM
      LOGICAL PK,PANDK,BLOCK,PACK2E,SCHWRZ,DIRSCF,FDIFF,
     *        GOPARR,DSKWRK,MASWRK,SVDSKW,DIRTRF,SCREEN,
     *        MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,
     *        POLDCM,POLANG,POLAPP,KMIDPT,POLDYN
      LOGICAL QOPS,QFMM,OK
C
      PARAMETER (NNAM=20)
      PARAMETER (MXATM=2000,NMO=500)
C
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
C
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /EDCMP / ZIJ(NMO),ZMO(5,NMO),OCCUP(NMO),DPFREQ(50),
     *                MOIDNO(5,NMO),IJMO(2,NMO),MOIJ(NMO),NMOIJ(NMO),
     *                NMOAT(NMO),NDPFREQ,IPROT(5),NPROT,
     *                MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,
     *                POLANG,POLAPP,KMIDPT,POLDYN
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      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 /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /ORDOPT/ NORDER,NDAR  ,LDAR  ,NBOXMX,NWORD,NOMEM,NSQUAR
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /PKFIL / PK,PANDK,BLOCK
      COMMON /PRPOPT/ ILOCAL
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCINP / VLAMB,SCREEN
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      DATA IJKO/24/
      DATA RHF,UHF,ROHF,GVB,MCSCF
     *    /8HRHF     ,8HUHF     ,8HROHF    ,8HGVB     ,8HMCSCF   /
      DATA RNONE/8HNONE    /
      DATA MOROKM/8HMOROKUMA/
C
      DATA INTGRL/8HINTGRL  /
      DATA QNAM/8HNORDER  ,8HNDAR    ,8HLDAR    ,8HNBOXMX  ,
     *          8HNWORD   ,8HNINTMX  ,8HNOMEM   ,8HNSQUAR  ,
     *          8HNOPK    ,
     *          8HIST     ,8HJST     ,8HKST     ,8HLST     ,
     *          8HNREC    ,8HINTLOC  ,8HSCHWRZ  ,
     *          8HSCREEN  ,8HVLAMB   ,8HQFMM    ,8HNINTIC  /
      DATA KQNAM/1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,3,0,1/
C
C     ----- INITIALIZE VARIABLES FOR NAMELIST $INTGRL -----
C
      NORDER = 0
      NDAR   = 2000
      CALL RASIZE(LDAR)
      NBOXMX = 200
      NWORD  = 0
      NINTMX = 0
      NOMEM  = 0
      NSQUAR = 0
      QFMM  =.FALSE.
      NINTIC = 0
      ININTIC= 0
C                    INITIAL VALUE OF NOPK IS ILLEGAL
      NOPK   = -27
      IST    = 1
      JST    = 1
      KST    = 1
      LST    = 1
      NREC   = 1
      INTLOC = 1
      SCHWRZ =.FALSE.
      SCREEN=.FALSE.
      VLAMB=0.0D+00
      IF(NAT.GT.5.OR.NFG.NE.0) SCHWRZ=.TRUE.
C     SETTING SCHWRZ TO .FALSE. FOR FMO FRANKENSTEINIZES A BIZARRE BUG
C     OF THE FOLLOWING MOST MACABRE NATURE:
C     SCHWRZ IS SET HERE FOR THE FAKE $DATA (THAT USUALLY HAS 2-4 ATOMS,
C     WHEREAS REAL FRAGMENTS HAVE OFTEN MORE).
C
      IF(DIRSCF) SCHWRZ=.TRUE.
C
C    ----- READ NAMELIST $INTGRL -----
C
      CALL NAMEIO(IR,JRET,INTGRL,NNAM,QNAM,KQNAM,
     *            NORDER,NDAR,LDAR,NBOXMX,NWORD,NINTMX,NOMEM,NSQUAR,
     *            NOPK,IST,JST,KST,LST,NREC,INTLOC,SCHWRZ,SCREEN,VLAMB,
     *            QFMM,NINTIC,
     *            0,0,0,0,
     *    0,0,0,0,0,  0,0,0,0,0,    0,0,0,0,0,  0,0,0,0,0,
     *    0,0,0,0,0,  0,0,0,0,0,    0,0,0,0,0,  0,0,0,0,0)
      IF(JRET.EQ.2) THEN
         IF (MASWRK) WRITE(IW,9000)
         CALL ABRT
      END IF
C
      IF (QFMM) CALL QFMMIN
C
C     IF SCREEN THEN SCHWARZ INEQUALITIES ARE SKIPPED
C
      IF (SCREEN) SCHWRZ=.FALSE.
C
      ISCHWZ = 0
      IF(SCHWRZ) ISCHWZ = 1
C
      IF(QFMM) THEN
          OK = .TRUE.
          CALL DERCHK(NDER)
          IF(SCFTYP.EQ.UHF    .AND.  NDER.GT.1)     OK=.FALSE.
          IF(SCFTYP.EQ.ROHF   .AND.  NDER.GT.1)     OK=.FALSE.
          IF(SCFTYP.EQ.GVB)                         OK=.FALSE.
          IF(SCFTYP.EQ.MCSCF)                       OK=.FALSE.
          IF(DFTYPE.NE.RNONE  .AND.  SCFTYP.NE.RHF) OK=.FALSE.
          IF(.NOT.OK) THEN
             IF(MASWRK) WRITE(IW,9030)
             CALL ABRT
          END IF
      END IF
C
C     ----- DETERMINE WHICH 2E- INTEGRAL SCHEME TO USE -----
C     NOPK=0 MEANS A -P- SUPERMATRIX, AND POSSIBLY -K- SUPERMATRIX.
C     NOPK=1 MEANS A CONVENTIONAL -J- INTEGRAL LIST WILL BE USED.
C     SUPERMATRIX IS INCORRECT FOR MOROKUMA ANALYSIS.
C     ANYTHING THAT DOES AN INTEGRAL TRANSFORMATION (E.G. MCSCF,
C     CI, MP2, RUEDENBERG LOCALIZATION, ANALYTIC HESSIAN, LOCALIZED
C     ORBITAL POLARIZABILITIES) MAY NOT USE A SUPERMATRIX.
C     IN CORE RUNS ARE NOT YET TAUGHT TO USE NOPK (THEY COULD BE).
C
C     IN CASE OF FMO PK OPTION IS DOOMED IN MANY PLACES. THE HARD
C     ONES TO FIND ARE ZPKOUT AND PKFILE, WHERE THE FIRST ROUTINE
C     IS SET FOR THE FIRST FRAGMENT ONLY (SEE SHELLS FOR A SOLUTION).
C     OTHER PLACES ARE PROBABLY WRONG TOO (NEVER CHECKED).
C
      CALL DERCHK(NDER)
      IF(NDFTFG.NE.0)              NOPK = 1
      IF(DFTTYP(1) .NE. 0.0D+00)   NOPK = 1
      IF(RUNTYP.EQ.MOROKM)         NOPK = 1
      IF(SCFTYP.EQ.MCSCF)          NOPK = 1
      IF(CITYP.NE.RNONE)           NOPK = 1
      IF(ILOCAL.EQ.2)              NOPK = 1
      IF(POLDCM)                   NOPK = 1
      IF(POLDYN)                   NOPK = 1
      IF(NDER.EQ.2)                NOPK = 1
      IF(NINTIC.NE.0)              NOPK = 1
      IF(NFG.NE.0)                 NOPK = 1
C
C         SINCE J FILE IS MUCH SHORTER THAN P OR PK FILE,
C         AND I/O IS STILL QUITE BAD EVEN IF STRIPING,
C         WE MAKE ALL INTEGRAL FILES NON-SUPERMATRIX,
C         UNLESS THE USER HAS SPECIFICALLY ASKED FOR ONE.
C
      IF(NOPK.EQ.-27)              NOPK = 1
      IF(NOPK.NE.1)                NOPK = 0
C
      PK = NOPK.EQ.0
      PANDK = (PK .AND. SCFTYP.EQ. UHF) .OR.
     *        (PK .AND. SCFTYP.EQ.ROHF) .OR.
     *        (PK .AND. SCFTYP.EQ. GVB)
C
      IF(      PANDK .AND. NINTMX.EQ.0) NINTMX=10000
      IF(.NOT. PANDK .AND. NINTMX.EQ.0) NINTMX=15000
C
C     ----- OPEN INTEGRAL FILES -----
C
      IF(DIRSCF  .OR.  DIRTRF) THEN
         PK    = .FALSE.
         PANDK = .FALSE.
         NOPK  = 1
      ELSE
         SVDSKW = DSKWRK
         DSKWRK = .TRUE.
         CALL SEQOPN(IS,'AOINTS','UNKNOWN',.FALSE.,'UNFORMATTED')
C
C     EXCHANGE -IJKO- AND -IS- SO WE DON'T GET TWO COPIES OF 2E-INTS
C
         IF (RUNTYP.EQ.MOROKM) THEN
            CALL SEQOPN(IJKO,'ORDINT','UNKNOWN',.FALSE.,'UNFORMATTED')
            ISK = IJKO
            IJKO = IS
            IS = ISK
         END IF
         DSKWRK = SVDSKW
      END IF
C
C     ARRAY DIMENSIONS THROUGH OUT THE PROGRAM ALLOW -MXAO- AO-S,
C     EXCEPT IN THE CI CODE WHERE THE LIMIT IS -MXAOCI-.
C     THESE LIMITS ARE TESTED NEAR WHERE THE MOLECULE IS READ IN,
C     AND NEED NOT CONCERN US FURTHER.
C     FOR CONVENTIONAL SCF, WITH A P OR PK SUPERMATRIX, THE 16
C     BIT PACKING LIMITS THE AOS TO 361.  ELSEWHERE WE USE 8
C     BITS TO HANDLE CASES SMALLER THAN 256, 16 BITS OTHERWISE.
C
      MAXAO=255
      IF(PK) MAXAO=361
      LABSIZ = 1
      IF(NUM.GT.MAXAO.OR.NFG.NE.0) LABSIZ = 2
C
C     DURING IN-CORE FMO RUNS LABSIZ SHOULD NOT BE SET BASED
C     ON THE LIBRARY $DATA (THAT DELIBERATELY RESULTS IN LABSIZ=1).
C     THE SOLUTION IS TO SET LABSIZ TO 2 ALWAYS AND RECOMPUTE FOR
C     EACH FRAGMENT LATER. POSITIVE INPUT VALUES OF NINTIC MAY
C     RESULT IN NOT FULLY USING AVAILABLE MEMORY AND SHOULD BE
C     AVOIDED (USE NEGATIVE VALUES IN $INTGRL NINTIC INSTEAD).
C
      IF(PK  .AND.  NUM.GT.MAXAO) THEN
         IF(MASWRK) WRITE(IW,*) 'TOO MANY AOS TO USE PK SUPERMATRIX.'
         IF(MASWRK) WRITE(IW,*) 'USE J INTEGRAL LIST, OR DIRECT SCF'
         CALL ABRT
      END IF
C
      IF (MASWRK) WRITE(IW,9010) NOPK,NORDER,SCHWRZ
C
C     CHECK IF IT IS AN SCREEN CALCULATION. IF SO, TELL IT ,
C     MAKE SCHWZ FALSE AND
C     CALL TO THE INITFCTS SUBROUTINE TO GENERATE THE VALUES
C     FOR COMMON /FCTS/
C
      IF (SCREEN) THEN
          WRITE(IW,9011) SCREEN,VLAMB
          CALL INITFCTS
      END IF
C
      RETURN
C
 9000 FORMAT(1X,'ERROR IN $INTGRL INPUT')
 9010 FORMAT(/10X,22(1H-)/10X,'INTEGRAL INPUT OPTIONS'/10X,22(1H-)/
     *       1X,'NOPK  =',I8,' NORDER=',I8,' SCHWRZ=',L8)
 9011 FORMAT(/,'SCREENED INTEGRALS',10X,
     *       ' SCREEN=',L8,' VLAMB= ',F6.3,/)
 9030 FORMAT(1X,'*** ERROR ***'/
     *       1X,'THE QFMM=.TRUE. OPTION IS AVAILABLE ONLY FOR'/
     *       1X,'CLOSED SHELL RHF OR DFT ENERGIES AND GRADIENTS,'/
     *       1X,'OR FOR UHF AND ROHF NON-DFT ENERGIES.')
      END
C*MODULE INT2A   *DECK INTOUT
      SUBROUTINE INTOUT(I1,I2,I3,I4,Q4,NN,VAL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /INTPR / Q(2),V(2),JC,N1(2),J1(2),J2(2),J3(2),J4(2)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      JC = JC+1
      J1(JC) = I1
      J2(JC) = I2
      J3(JC) = I3
      J4(JC) = I4
      Q(JC) = Q4
      N1(JC) = NN
      V(JC) = VAL
      IF (JC.LT.2) GO TO 100
      JC = 0
      IF (MASWRK) WRITE (IW,9088)
     *   (J1(M),J2(M),J3(M),J4(M),Q(M),V(M),M = 1,2)
  100 CONTINUE
      RETURN
C
 9088 FORMAT(2(4I4,F5.1,F17.9,1X))
      END
C*MODULE INT2A   *DECK JANDK
      SUBROUTINE JANDK
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SCHWRZ,PACK2E,PK,PANDK,BLOCK,DIRTRF,FDIFF
      LOGICAL GOPARR,DSKWRK,MASWRK,TDSKWRK,DIRSCF
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXGSH=30, MXG2=MXGSH*MXGSH)
C
      COMMON /FMCOM / XX(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMOOPT/ ESPSCA(9),RESPAP(2),RESPPC(2),RESDIM,RESTRI(4),
     *                RCORSD,CONVFG,CNVDMP,COROFF,IXESP,MXITFG,NGUESS,
     *                NBSSE,MODORB,MODPAR,IRSTSTP,IRSTLAY,NPRFMO,
     *                NFMOPAL,MODPRP,MAXL1C
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      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),MIN(MXSH),MAX(MXSH),NSHELL
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /ORDOPT/ NORDER,NDAR,LDAR,NBOXMX,NWORD,NOMEM,NSQUAR
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /PKFIL / PK,PANDK,BLOCK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      DATA CHECK/8HCHECK   /
      DATA NONE/4HNONE/
C
C     ----- MAIN DRIVER FOR CALCULATION OF 2E- INTEGRALS -----
C
C     ----- MOPAC 2-ELECTRON INTEGRALS ALREADY CALCULATED -----
C
      IF(MPCTYP.NE.NONE) RETURN
C
C     HONDO INTEGRAL PACKAGE REQUIRES A BUFFER DIMENSIONED FOR
C     THE MAXIMUM ANGULAR MOMENTUM OCCURING IN THE BASIS SET.
C     A PURE SP BASIS USING THE POPLE INTEGRALS DOESN'T NEED THIS.
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      IF(LMAX.EQ.5) NANGM = 21
      IF(LMAX.EQ.6) NANGM = 28
                 MAXG = NANGM**4
      IF(PK)     MAXG = MAXG*3
      IF(DIRSCF) MAXG = 1
C
      NSH2 = (NSHELL*NSHELL+NSHELL)/2
      MINTMX=NINTMX
      IF(NINTIC.NE.0) MINTMX=0
C     THE MEMORY IS ALLOCATED ELSEWHERE
C
      CALL VALFM(LOADFM)
      LBUFP  = LOADFM + 1
      LBUFK  = LBUFP  + MINTMX
      LIX    = LBUFK  + MINTMX
      LXINTS = LIX    + MINTMX
      LGHOND = LXINTS + NSH2
      LDDIJ  = LGHOND + MAXG
      LAST   = LDDIJ  + 49*MXG2
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
      IF(NINTIC.NE.0) THEN
         LBUFP=LBUFPIC
         LIX=LIXIC
      ENDIF
C
      IF(EXETYP.EQ.CHECK) THEN
         IF(ISCHWZ.GT.0) THEN
            CALL VCLR(XX(LXINTS),1,NSH2)
            CALL DAWRIT(IDAF,IODA,XX(LXINTS),NSH2,54,0)
         END IF
      END IF
C
C           INITIALIZE THE CALCULATION
C
      TDSKWRK = DSKWRK
      DSKWRK  = .TRUE.
      CALL DEBUT(DIRSCF,XX(LBUFP),XX(LBUFK),XX(LIX),NINTMX,NEED,DIRTRF)
      IF(EXETYP.EQ.CHECK)  GO TO 200
      IF(DIRSCF.OR.DIRTRF) GO TO 200
C
C     ----- PACKING PARAMETERS: THIS IS AN INACTIVE OPTION.
C           NHEX = DESIRED HEXADECIMAL ACCURACY.
C           NTUPL= # OF BYTES PER INTEGER WORD TO BE PACKED.
C                  THE NEGATIVE VALUE OF -NTUPL- MEANS THAT THE
C                  INTEGER LABELS ARE NOT TO BE PACKED.
C
      PACK2E = ICUT .LT. 0
      NTUPL = -4
      IF (PACK2E .AND. MASWRK) WRITE (IW,9088) NHEX,NTUPL
 9088 FORMAT(41H THE INTEGRALS ARE PACKED WITH A.D.MCLEAN,
     *     26H PACKING UTILITIES (1977).,8H NHEX = ,I5,9H NTUPL = ,I5/)
C
C           GENERATE ALL EXCHANGE INTEGRALS
C
      SCHWRZ = ISCHWZ.GT.0
      IF(SCHWRZ) CALL EXCHNG(XX(LXINTS),XX(LGHOND),XX(LDDIJ),
     *                       NSH2,MAXG,INTTYP)
C
C           CRUNCH OUT THE INTEGRALS
C
      IDUMMY=0
      DUMMY=0.0D+00
      CALL TWOEI(SCFTYP,.FALSE.,.FALSE.,.FALSE.,.FALSE.,
     *           INTTYP,SCHWRZ,NINT,NSCHWZ,1,1,
     *           XX(LBUFP),XX(LBUFK),XX(LIX),NINTMX,
     *           XX(LXINTS),NSH2,XX(LGHOND),MAXG,XX(LDDIJ),
     *           IDUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,1)
C
  200 CONTINUE
      DSKWRK  = TDSKWRK
      CALL RETFM(NEED)
      IF (MASWRK.AND.NPRTGO.NE.2.AND.(NFG.EQ.0.OR.IAND(NPRFMO,3).EQ.0))
     *   WRITE(IW,*) ' ...... END OF TWO-ELECTRON INTEGRALS .....'
      IF (MASWRK.AND.(NFG.EQ.0.OR.IAND(NPRFMO,3).EQ.0)) CALL TEXIT(1,1)
C
C     ----- INTEGRAL ORDERING -----
C
      IF (NORDER.EQ.1) CALL ORDRJK
      RETURN
      END
C*MODULE INT2A   *DECK PKFILE
      SUBROUTINE PKFILE(II,JJ,KK,LL,SKIPA,SKIPB,SKIPC,NPSYM,
     *                  BUFP,BUFK,IX,NINTMX,GHONDO)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION BUFP(NINTMX),BUFK(NINTMX),IX(NINTMX),GHONDO(*)
      DIMENSION IB(15),JB(15),KB(15),LB(15)
C
      LOGICAL SKIPA,SKIPB,SKIPC,NPSYM
      LOGICAL PKFL,PANDK,BLOCK,IANDJ,KANDL,SAME,OUT,FIRST
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXAO=8192)
C
      COMMON /IJPAIR/ IJADD(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MISC  / IANDJ,KANDL,SAME
      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),MIN(MXSH),MAX(MXSH),NSHELL
      COMMON /PCKLAB/ LABSIZ
      COMMON /PKFIL / PKFL,PANDK,BLOCK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /SHLEXC/ NORGSH(3),NORGSP(3),IEXCH,NANGM,NGTH(4)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00)
C
      SAVE FIRST,IB,JB,KB,LB
      DATA FIRST/.TRUE./
C
C     ----- WRITE THIS SHELL'S P OR PK INTEGRAL FILE -----
C
      IF(FIRST) THEN
         FIRST=.FALSE.
         DO 50 I=1,NANGM
            LB(I) = I-1
            KB(I) = LB(I) * NANGM
            JB(I) = KB(I) * NANGM
            IB(I) = JB(I) * NANGM
  50     CONTINUE
      END IF
C
      IND = 1
      IF (SKIPA .AND. NPSYM) IND = 2
      IF (SKIPB .AND. NPSYM) IND = 3
      IF (SKIPC .AND. NPSYM) IND = 3
      IF (SKIPA .AND. SKIPB .AND. NPSYM) IND = 4
C
      NORG1 = NORGSH(1)+1
      NORG2 = NORGSH(2)+1
      NORG3 = NORGSH(3)+1
C
      LIT = KTYPE(II)
      LKT = KTYPE(KK)
      MINI = MIN(II)
      MINJ = MIN(JJ)
      MINK = MIN(KK)
      MINL = MIN(LL)
      MAXI = MAX(II)
      MAXJ = MAX(JJ)
      MAXK = MAX(KK)
      MAXL = MAX(LL)
      LOCI = KLOC(II)-MINI
      LOCJ = KLOC(JJ)-MINJ
      LOCK = KLOC(KK)-MINK
      LOCL = KLOC(LL)-MINL
C
      IANDJ = II .EQ. JJ
      KANDL = KK .EQ. LL
      SAME = (II .EQ. KK) .AND. (JJ .EQ. LL)
C
C     TYPE = 1 FOR (II II II II)
C            2     (II JJ JJ JJ)
C            3     (II II KK KK) AND  LIT.GE.LKT
C            4     (II II KK KK) AND  LIT.LT.LKT
C            5     (II II II LL)
C            6     (II JJ KK KK)
C            7     (II JJ JJ LL)
C            8     (II II KK LL)
C            9     (II JJ KK LL)
C
      NTYP = 0
      IF (II.EQ.JJ .AND. JJ.EQ.KK .AND. KK.EQ.LL) NTYP = 1
      IF (II.GT.JJ .AND. JJ.EQ.KK .AND. KK.EQ.LL) NTYP = 2
      IF (II.EQ.JJ .AND. JJ.GT.KK .AND. KK.EQ.LL
     *                          .AND. LIT.GE.LKT) NTYP = 3
      IF (II.EQ.JJ .AND. JJ.GT.KK .AND. KK.EQ.LL
     *                          .AND. LIT.LT.LKT) NTYP = 4
      IF (II.EQ.JJ .AND. JJ.EQ.KK .AND. KK.GT.LL) NTYP = 5
      IF (II.GT.JJ .AND. JJ.GT.KK .AND. KK.EQ.LL) NTYP = 6
      IF (II.GT.JJ .AND. JJ.EQ.KK .AND. KK.GT.LL) NTYP = 7
      IF (II.EQ.JJ .AND. JJ.GT.KK .AND. KK.GT.LL) NTYP = 8
      IF (II.GT.JJ .AND. JJ.GT.KK .AND. KK.GT.LL) NTYP = 9
      IF (SKIPA .AND. .NOT. NPSYM) NORG2 = 1
      IF (SKIPC .AND. .NOT. NPSYM) NORG3 = NORGSH(2)+1
      IF (SKIPB .AND. .NOT. NPSYM) NORG3 = 1
C
C     ----- BEGIN LOOPS OVER PRIMITIVES IN THIS SHELL -----
C
C     INTEGRAL TYPES N1,G1 FOR (I,J//K,L)
C                    N2,G2 FOR (I,K//J,L)
C                    N3,G3 FOR (I,L//J,K)
C
C        N1 = IB(IA)+JB(JA)+KB(KA)+LB(LA)+NORG1
C        N2 = IB(IA)+JB(KA)+KB(JA)+LB(LA)+NORG2
C        N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
C
      JMAX = MAXJ
      KMAX = MAXK
      LMAX = MAXL
      DO 860 I = MINI,MAXI
      IAO = LOCI + I
      IA = I-MINI+1
      N1I = NORG1 + IB(IA)
      N2I = NORG2 + IB(IA)
C
      IF (IANDJ) JMAX = I
      DO 840 J = MINJ,JMAX
      IF (JJ .EQ. KK) KMAX = J
      JAO = LOCJ + J
      JA = J-MINJ+1
      N1IJ = N1I + JB(JA)
      N2IJ = N2I + KB(JA)
C
      DO 820 K = MINK,KMAX
      KAO = LOCK + K
      KA = K-MINK+1
      N1IJK = N1IJ + KB(KA)
      N2IJK = N2IJ + JB(KA)
C
      IF (KANDL) LMAX = K
      DO 800 L = MINL,LMAX
         LAO = LOCL + L
         LA = L-MINL+1
         N1 = N1IJK + LB(LA)
         N2 = N2IJK + LB(LA)
C
         GO TO (200,220,230,250,270,280,290,300,310),NTYP
  200    IF (IA .EQ. JA) GO TO 210
         N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
         GO TO 400
  210    N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
         GO TO 400
  220    N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
         GO TO 400
  230    IF (IA .EQ. JA) GO TO 240
         N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
         GO TO 400
  240    N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
         GO TO 400
  250    IF (KA .EQ. LA) GO TO 260
         N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
         GO TO 400
  260    N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
         GO TO 400
  270    N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
         GO TO 400
  280    N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
         GO TO 400
  290    N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
         GO TO 400
  300    N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
         GO TO 400
  310    N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
C
C     ----- FORM FIRST LINEAR COMBINATION -----
C
  400 CONTINUE
      G1 = GHONDO(N1)
      G2 = GHONDO(N2)
      G3 = GHONDO(N3)
C
      JUMP = 1
      I1 = IAO
      I2 = JAO
      I3 = KAO
      I4 = LAO
      IF (I2 .EQ. I3) JUMP = 2
      IF ((I2 .EQ. I4) .OR. (I1 .EQ. I3)) JUMP = 3
C
      GO TO (410,420,430,440),IND
  410 VALK = G2+G3
      VALP = (G1+G1)+(G1+G1)-VALK
      GO TO 460
  420 VALK = G3
      VALP = (G1+G1)+(G1+G1)-VALK
      GO TO 460
  430 VALK = G2
      VALP = (G1+G1)+(G1+G1)-VALK
      GO TO 460
  440 VALK = ZERO
      VALP = (G1+G1)+(G1+G1)
  460 CONTINUE
      NN = N1
      GO TO 700
C
C     ----- FORM SECOND LINEAR COMBINATION -----
C
  500 CONTINUE
      GO TO (510,520,530,540),IND
  510 VALK = G3+G1
      VALP = (G2+G2)+(G2+G2)-VALK
      GO TO 560
  520 VALK = G1+G3
      VALP = -VALK
      GO TO 560
  530 VALK = G1
      VALP = (G2+G2)+(G2+G2)-VALK
      GO TO 560
  540 VALK = G1
      VALP = -VALK
  560 CONTINUE
      NN = N2
      JUMP = 2
      IF ((I1 .EQ. I2) .OR. (I3 .EQ. I4)) JUMP = 3
      I2 = KAO
      I3 = JAO
      GO TO 700
C
C     ----- FORM THIRD LINEAR COMBINATION -----
C
  600 CONTINUE
      GO TO (610,620,630,640),IND
  610 VALK = G1+G2
      VALP = (G3+G3)+(G3+G3)-VALK
      GO TO 660
  620 VALK = G1
      VALP = (G3+G3)+(G3+G3)-VALK
      GO TO 660
  630 VALK = G1+G2
      VALP = -VALK
      GO TO 660
  640 VALK = G1
      VALP = -VALK
  660 CONTINUE
      NN = N3
      I2 = LAO
      I3 = JAO
      I4 = KAO
      JUMP = 3
C
C     ----- STORE INTEGRAL AND INDICES -----
C
  700 CONTINUE
      IF (PANDK) GO TO 740
C
C     ----- -P- SUPERMATRIX ONLY -----
C
      IF (ABS(VALP) .LT. CUTOFF) GO TO 780
      IF (OUT) CALL INTOUT(I1,I2,I3,I4,QQ4,NN,VALP)
      IF (I1.EQ.I3 .AND. I2.EQ.I4) VALP = VALP*HALF
      I1I2 = IJADD(I1) + I2
      I3I4 = IJADD(I3) + I4
C
                 NPACK = ICOUNT
                 IPACK = I1I2
                 JPACK = I3I4
                 IF (LABSIZ .EQ. 2) THEN
*I32               IX( 2*NPACK-1 ) = IPACK
*I32               IX( 2*NPACK   ) = JPACK
*I64               LABEL = ISHFT( IPACK, 32 ) + JPACK
*I64               IX(NPACK) = LABEL
                 ELSE IF (LABSIZ .EQ. 1) THEN
*I32               LABEL = ISHFT( IPACK, 16 ) + JPACK
*I32               IX(NPACK) = LABEL
*I64               IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                 LABEL = ISHFT( IPACK, 16 ) + JPACK
*I64                 IX( NPACK/2 ) = IX( NPACK/2 ) + LABEL
*I64               ELSE
*I64                 LABEL = ISHFT( IPACK, 48 ) + ISHFT( JPACK, 32 )
*I64                 IX( (NPACK/2)+1 ) = LABEL
*I64               END IF
                 END IF
C
      BUFP(ICOUNT) = VALP
      ICOUNT = ICOUNT+1
      IF (ICOUNT .GT. NINTMX) THEN
         NXX = NINTMX
         CALL PWRIT(IS,BUFP,IX,NXX,NINTMX)
         ICOUNT = 1
         NREC = NREC+1
      END IF
      GO TO 780
C
C     ----- -P- AND -K- SUPERMATRICES -----
C
  740 CONTINUE
      IF (ABS(VALP) .LT. CUTOFF .AND. ABS(VALK) .LT. CUTOFF) GO TO 780
      IF(OUT) THEN
         CALL INTOUT(I1,I2,I3,I4,QQ4,NN,VALP)
         CALL INTOUT(I1,I2,I3,I4,QQ4,NN,VALK)
      END IF
      IF (I1.EQ.I3 .AND. I2.EQ.I4) THEN
         VALP = VALP*HALF
         VALK = VALK*HALF
      END IF
      I1I2 = IJADD(I1) + I2
      I3I4 = IJADD(I3) + I4
C
                 NPACK = ICOUNT
                 IPACK = I1I2
                 JPACK = I3I4
                 IF (LABSIZ .EQ. 2) THEN
*I32               IX( 2*NPACK-1 ) = IPACK
*I32               IX( 2*NPACK   ) = JPACK
*I64               LABEL = ISHFT( IPACK, 32 ) + JPACK
*I64               IX(NPACK) = LABEL
                 ELSE IF (LABSIZ .EQ. 1) THEN
*I32               LABEL = ISHFT( IPACK, 16 ) + JPACK
*I32               IX(NPACK) = LABEL
*I64               IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                 LABEL = ISHFT( IPACK, 16 ) + JPACK
*I64                 IX( NPACK/2 ) = IX( NPACK/2 ) + LABEL
*I64               ELSE
*I64                 LABEL = ISHFT( IPACK, 48 ) + ISHFT( JPACK, 32 )
*I64                 IX( (NPACK/2)+1 ) = LABEL
*I64               END IF
                 END IF
C
      BUFP(ICOUNT) = VALP
      BUFK(ICOUNT) = VALK
      ICOUNT = ICOUNT+1
      IF (ICOUNT .GT. NINTMX) THEN
         NXX = NINTMX
         CALL PKWRIT(IS,BUFP,BUFK,IX,NXX,NINTMX)
         ICOUNT = 1
         NREC = NREC+1
      END IF
  780 CONTINUE
      GO TO (500,600,800),JUMP
  800 CONTINUE
  820 CONTINUE
  840 CONTINUE
  860 CONTINUE
      RETURN
      END
C*MODULE INT2A   *DECK QOUT
      SUBROUTINE QOUT(BUFP,IX,NINTMX,GHONDO)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT
C
      DIMENSION BUFP(NINTMX),IX(*),GHONDO(*)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /ERIOUT/ ISH,JSH,KSH,LSH,LSTRI,LSTRJ,LSTRK,LSTRL
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /NSHEL / EXX(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
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
C
C-NEXT STATEMENT IS FOR VARIOUS IBM XLF 3.X AND 5.X COMPILERS-
C
      SAVE IJN,KLN
C
      DATA HALF /0.5D+00/
C
C     ----- PACK THE 4 INDICES OF INTEGRAL INTO ONE WORD
C     ----- WRITE LABEL + INTEGRAL ON TAPE (IS)
C
      SAME  = ISH .EQ. KSH .AND. JSH .EQ. LSH
      IANDJ = ISH .EQ. JSH
      KANDL = KSH .EQ. LSH
C
      MINI = KMIN(ISH)
      MINJ = KMIN(JSH)
      MINK = KMIN(KSH)
      MINL = KMIN(LSH)
      MAXI = KMAX(ISH)
      MAXJ = KMAX(JSH)
      MAXK = KMAX(KSH)
      MAXL = KMAX(LSH)
      LOCI = KLOC(ISH)-MINI
      LOCJ = KLOC(JSH)-MINJ
      LOCK = KLOC(KSH)-MINK
      LOCL = KLOC(LSH)-MINL
C
      IJN = 0
      JMAX = MAXJ
      DO 260 I = MINI,MAXI
         I_INDEX = (I-MINI)*LSTRI + 1
         IF (IANDJ) JMAX = I
         DO 240 J = MINJ,JMAX
            IJ_INDEX = (J-MINJ)*LSTRJ + I_INDEX
            IJN = IJN+1
            LMAX = MAXL
            KLN = 0
            DO 220 K =  MINK,MAXK
               IJK_INDEX = (K-MINK)*LSTRK + IJ_INDEX
               IF (KANDL) LMAX = K
               DO 200 L = MINL,LMAX
                  KLN = KLN+1
                  IF(SAME  .AND.  KLN.GT.IJN) GO TO 240
                  IJKL_INDEX = (L-MINL)*LSTRL + IJK_INDEX
C
                  VAL = GHONDO( IJKL_INDEX )
                  IF(ABS(VAL).LT.CUTOFF) GO TO 200
C
                  I1 = LOCI+I
                  I2 = LOCJ+J
                  I3 = LOCK+K
                  I4 = LOCL+L
                  IF (I1 .GE. I2) GO TO 100
                  N = I1
                  I1 = I2
                  I2 = N
  100             IF (I3 .GE. I4) GO TO 120
                  N = I3
                  I3 = I4
                  I4 = N
  120             IF (I1-I3) 140,160,180
  140             N = I1
                  I1 = I3
                  I3 = N
                  N = I2
                  I2 = I4
                  I4 = N
                  GO TO 180
  160             IF (I2 .LT. I4) GO TO 140
  180             CONTINUE
C
                  IF (OUT) CALL INTOUT(I1,I2,I3,I4,QQ4,IJKL_INDEX,VAL)
                  IF (I1 .EQ. I2) VAL = VAL*HALF
                  IF (I3 .EQ. I4) VAL = VAL*HALF
                  IF (I1 .EQ. I3 .AND. I2 .EQ. I4) VAL = VAL*HALF
C
                  NPACK = ICOUNT
                  IPACK = I1
                  JPACK = I2
                  KPACK = I3
                  LPACK = I4
                  IF(LABSIZ .EQ. 2) THEN
*I32                 LABEL1 = ISHFT( IPACK, 16 ) + JPACK
*I32                 LABEL2 = ISHFT( KPACK, 16 ) + LPACK
*I32                 IX( 2*NPACK-1 ) = LABEL1
*I32                 IX( 2*NPACK   ) = LABEL2
*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
                  BUFP(ICOUNT) = VAL
                  ICOUNT = ICOUNT+1
                  IF(ICOUNT .GT. NINTIC) THEN
                     JCOUNT=ICOUNT-NINTIC
                     IF(JCOUNT .GT. NINTMX) THEN
                        NXX = NINTMX
                        CALL PWRIT(IS,BUFP(NINTIC+1),IX(ININTIC+1),
     *                             NXX,NINTMX)
                        ICOUNT = NINTIC+1
                        NREC = NREC+1
                     END IF
                  END IF
  200          CONTINUE
  220       CONTINUE
  240    CONTINUE
  260 CONTINUE
      RETURN
      END
C*MODULE INT2A   *DECK S0000
      SUBROUTINE S0000(GHONDO,DDIJ)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT
C
      PARAMETER (MXGSH=30, MXG2=MXGSH*MXGSH)
C
      DIMENSION GHONDO(*),DDIJ(49*MXG2)
C
      COMMON /IJGNRL/ A(MXG2),R(MXG2),X1(MXG2),Y1(MXG2),Z1(MXG2),
     *                IJD(784)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /SHLINF/  AG(MXGSH),CSA(MXGSH),CPA(MXGSH),CDA(MXGSH),
     *                CFA(MXGSH),CGA(MXGSH),CHA(MXGSH),CIA(MXGSH),
     *                 BG(MXGSH),CSB(MXGSH),CPB(MXGSH),CDB(MXGSH),
     *                CFB(MXGSH),CGB(MXGSH),CHB(MXGSH),CIB(MXGSH),
     *                 CG(MXGSH),CSC(MXGSH),CPC(MXGSH),CDC(MXGSH),
     *                CFC(MXGSH),CGC(MXGSH),CHC(MXGSH),CIC(MXGSH),
     *                 DG(MXGSH),CSD(MXGSH),CPD(MXGSH),CDD(MXGSH),
     *                CFD(MXGSH),CGD(MXGSH),CHD(MXGSH),CID(MXGSH),
     *                XI,YI,ZI,XJ,YJ,ZJ,RRI,XK,YK,ZK,XL,YL,ZL,RRK,
     *                NGA,NGB,NGC,NGD
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      PARAMETER (PI252=34.986836655250D+00, PIE4=7.85398163397448D-01,
     *           ZERO=0.0D+00, ONE=1.0D+00)
C
C     SPECIAL SSSS INTEGRAL ROUTINE WHEN USING HONDO INTEGRALS
C
      GGOUT = ZERO
      LGMAX = NGD
      DO 300 KG = 1,NGC
      BK = CG(KG)
      BRRK = BK*RRK
      BXK = BK*XK
      BYK = BK*YK
      BZK = BK*ZK
      CSK = CSC(KG)
      IF (KANDL) LGMAX = KG
      DO 280 LG = 1,LGMAX
      BL = DG(LG)
      BB = BK+BL
      BBINV = ONE/BB
      DUM = BL*BRRK*BBINV
      IF (DUM .GT. TOL) GO TO 280
      BBRRK = DUM
      D2 = CSD(LG)*CSK*BBINV
      IF (KANDL .AND. LG .NE. KG) D2 = D2+D2
      BBX = (BXK+BL*XL)*BBINV
      BBY = (BYK+BL*YL)*BBINV
      BBZ = (BZK+BL*ZL)*BBINV
      SUM = ZERO
      NN = 1
      DO 260 N = 1,NIJ
      DUM = BBRRK+R(N)
      IF (DUM .GT. TOL) GO TO 260
      EXPE = EXP(-DUM)
      AA = A(N)
      AB = AA+BB
      DUM = X1(N)-BBX
      XX = DUM*DUM
      DUM = Y1(N)-BBY
      XX = DUM*DUM+XX
      DUM = Z1(N)-BBZ
      XX = DUM*DUM+XX
      X = XX*AA*BB/AB
C
      IF (X .GT. 5.0D+00) GO TO 160
      IF (X .GT. 1.0D+00) GO TO 120
      IF (X .GT. 3.0D-07) GO TO 100
      WW1 = 1.0D+00-X/3.0D+00
      GO TO 240
C
  100 CONTINUE
      F1 = ((((((((-8.36313918003957D-08*X+1.21222603512827D-06 )*X-
     +     1.15662609053481D-05 )*X+9.25197374512647D-05 )*X-
     +     6.40994113129432D-04 )*X+3.78787044215009D-03 )*X-
     +     1.85185172458485D-02 )*X+7.14285713298222D-02 )*X-
     +     1.99999999997023D-01 )*X+3.33333333333318D-01
      WW1 = (X+X)*F1+EXP(-X)
      GO TO 240
C
  120 CONTINUE
      IF (X .GT. 3.0D+00) GO TO 140
      Y = X-2.0D+00
      F1 = ((((((((((-1.61702782425558D-10*Y+1.96215250865776D-09 )*Y-
     +     2.14234468198419D-08 )*Y+2.17216556336318D-07 )*Y-
     +     1.98850171329371D-06 )*Y+1.62429321438911D-05 )*Y-
     +     1.16740298039895D-04 )*Y+7.24888732052332D-04 )*Y-
     +     3.79490003707156D-03 )*Y+1.61723488664661D-02 )*Y-
     +     5.29428148329736D-02 )*Y+1.15702180856167D-01
      WW1 = (X+X)*F1+EXP(-X)
      GO TO 240
C
  140 CONTINUE
      Y = X-4.0D+00
      F1 = ((((((((((-2.62453564772299D-11*Y+3.24031041623823D-10 )*Y-
     +     3.614965656163D-09)*Y+3.760256799971D-08)*Y-
     +     3.553558319675D-07)*Y+3.022556449731D-06)*Y-
     +     2.290098979647D-05)*Y+1.526537461148D-04)*Y-
     +     8.81947375894379D-04 )*Y+4.33207949514611D-03 )*Y-
     +     1.75257821619926D-02 )*Y+5.28406320615584D-02
      WW1 = (X+X)*F1+EXP(-X)
      GO TO 240
C
  160 CONTINUE
      IF (X .GT. 15.0D+00) GO TO 200
      E = EXP(-X)
      IF (X .GT. 10.0D+00) GO TO 180
      XINV = ONE/X
      WW1 = (((((( 4.6897511375022D-01*XINV-6.9955602298985D-01)*XINV +
     +     5.3689283271887D-01)*XINV-3.2883030418398D-01)*XINV +
     +     2.4645596956002D-01)*XINV-4.9984072848436D-01)*XINV -
     +     3.1501078774085D-06)*E + SQRT(PIE4*XINV)
      GO TO 240
C
  180 CONTINUE
      XINV = ONE/X
      WW1 = (((-1.8784686463512D-01*XINV+2.2991849164985D-01)*XINV
     +         -4.9893752514047D-01)*XINV-2.1916512131607D-05)*E
     +         + SQRT(PIE4*XINV)
      GO TO 240
C
  200 CONTINUE
      IF (X .GT. 33.0D+00) GO TO 220
      XINV = ONE/X
      E = EXP(-X)
      WW1 = (( 1.9623264149430D-01*XINV-4.9695241464490D-01)*XINV -
     +     6.0156581186481D-05)*E + SQRT(PIE4*XINV)
      GO TO 240
C
  220 WW1 = SQRT(PIE4/X)
C
  240 SUM = SUM+DDIJ(NN)*WW1*EXPE/SQRT(AB)
  260 NN = NN+49
      GGOUT = GGOUT+D2*SUM
  280 CONTINUE
  300 CONTINUE
      GHONDO(1) = GGOUT*PI252*QQ4
      RETURN
      END
C*MODULE INT2A   *DECK SCHWDN
      DOUBLE PRECISION FUNCTION SCHWDN(DSH,ISH,JSH,KSH,LSH,IA)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION DSH(*),IA(*)
C
      PARAMETER (FOUR=4.0D+00)
C
C     ----- FIND MAXIMUM DENSITY CONTRIBUTION TO THIS SHELL SET -----
C     -DSH- IS THE DENSITY MATRIX ALREADY COMPRESSED TO SHELLS
C
      IJ = IA(ISH)+JSH
      IK = IA(ISH)+KSH
      IL = IA(ISH)+LSH
      KL = IA(KSH)+LSH
      JK = IA(JSH)+KSH
      JL = IA(JSH)+LSH
      IF(JSH.LT.KSH) JK=IA(KSH)+JSH
      IF(JSH.LT.LSH) JL=IA(LSH)+JSH
      SCHWDN=MAX(FOUR*DSH(IJ),FOUR*DSH(KL),
     *           DSH(JL),DSH(JK),DSH(IL),DSH(IK))
      RETURN
      END
C*MODULE INT2A   *DECK SHELLS
      SUBROUTINE SHELLS(NELEC,ISH,JSH,KSH,LSH,FLIP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL FLIP
      LOGICAL IANDJ,KANDL,SAME
C
      DIMENSION IX(84),IY(84),IZ(84),
     *          JX(84),JY(84),JZ(84),
     *          KX(84),KY(84),KZ(84),
     *          LX(84),LY(84),LZ(84)
C
      PARAMETER (MXSH=5000, MXGSH=30, MXGTOT=20000, MXATM=2000)
C
      COMMON /ERIOUT/ INU,JNU,KNU,LNU,NGTI,NGTJ,NGTK,NGTL
      COMMON /INTDEX/ IJGT(784),IJX(784),IJY(784),IJZ(784),IK(784),
     *                KLGT(784),KLX(784),KLY(784),KLZ(784)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /MISC  / IANDJ,KANDL,SAME
      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 /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /SHLEXC/ NORGSH(3),NORGSP(3),IEXCH,NANGM,NGTH(4)
      COMMON /SHLINF/  GA(MXGSH),CSA(MXGSH),CPA(MXGSH),CDA(MXGSH),
     *                CFA(MXGSH),CGA(MXGSH),CHA(MXGSH),CIA(MXGSH),
     *                 GB(MXGSH),CSB(MXGSH),CPB(MXGSH),CDB(MXGSH),
     *                CFB(MXGSH),CGB(MXGSH),CHB(MXGSH),CIB(MXGSH),
     *                 GC(MXGSH),CSC(MXGSH),CPC(MXGSH),CDC(MXGSH),
     *                CFC(MXGSH),CGC(MXGSH),CHC(MXGSH),CIC(MXGSH),
     *                 GD(MXGSH),CSD(MXGSH),CPD(MXGSH),CDD(MXGSH),
     *                CFD(MXGSH),CGD(MXGSH),CHD(MXGSH),CID(MXGSH),
     *                AX,AY,AZ,BX,BY,BZ,RAB,CX,CY,CZ,DX,DY,DZ,RCD,
     *                NGA,NGB,NGC,NGD
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     +                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     +                NIJ,IJ,KL,IJKL
C
      DATA LX /   0,   1,   0,   0,   2,   0,   0,   1,   1,   0,
     *            3,   0,   0,   2,   2,   1,   0,   1,   0,   1,
     *            4,   0,   0,   3,   3,   1,   0,   1,   0,   2,
     *            2,   0,   2,   1,   1,
     *            5,   0,   0,   4,   4,   1,   0,   1,   0,   3,
     *            3,   2,   0,   2,   0,   3,   1,   1,   2,   2,
     *            1,
     *            6,   0,   0,   5,   5,   1,   0,   1,   0,   4,
     *            4,   2,   0,   2,   0,   4,   1,   1,   3,   3,
     *            0,   3,   3,   2,   1,   2,   1,   2/
      DATA KX /   0,   7,   0,   0,  14,   0,   0,   7,   7,   0,
     *           21,   0,   0,  14,  14,   7,   0,   7,   0,   7,
     *           28,   0,   0,  21,  21,   7,   0,   7,   0,  14,
     *           14,   0,  14,   7,   7,
     *           35,   0,   0,  28,  28,   7,   0,   7,   0,  21,
     *           21,  14,   0,  14,   0,  21,   7,   7,  14,  14,
     *            7,
     *           42,   0,   0,  35,  35,   7,   0,   7,   0,  28,
     *           28,  14,   0,  14,   0,  28,   7,   7,  21,  21,
     *            0,  21,  21,  14,   7,  14,   7,  14/
      DATA JX /   0,  49,   0,   0,  98,   0,   0,  49,  49,   0,
     *          147,   0,   0,  98,  98,  49,   0,  49,   0,  49,
     *          196,   0,   0, 147, 147,  49,   0,  49,   0,  98,
     *           98,   0,  98,  49,  49,
     *          245,   0,   0, 196, 196,  49,   0,  49,   0, 147,
     *          147,  98,   0,  98,   0, 147,  49,  49,  98,  98,
     *           49,
     *          294,   0,   0, 245, 245,  49,   0,  49,   0, 196,
     *          196,  98,   0,  98,   0, 196,  49,  49, 147, 147,
     *            0, 147, 147,  98,  49,  98,  49,  98/
      DATA IX /   1, 344,   1,   1, 687,   1,   1, 344, 344,   1,
     *         1030,   1,   1, 687, 687, 344,   1, 344,   1, 344,
     *         1373,   1,   1,1030,1030, 344,   1, 344,   1, 687,
     *          687,   1, 687, 344, 344,
     *         1716,   1,   1,1373,1373, 344,   1, 344,   1,1030,
     *         1030, 687,   1, 687,   1,1030, 344, 344, 687, 687,
     *          344,
     *         2059,   1,   1,1716,1716, 344,   1, 344,   1,1373,
     *         1373, 687,   1, 687,   1,1373, 344, 344,1030,1030,
     *            1,1030,1030, 687, 344, 687, 344, 687/
      DATA LY /   0,   0,   1,   0,   0,   2,   0,   1,   0,   1,
     *            0,   3,   0,   1,   0,   2,   2,   0,   1,   1,
     *            0,   4,   0,   1,   0,   3,   3,   0,   1,   2,
     *            0,   2,   1,   2,   1,
     *            0,   5,   0,   1,   0,   4,   4,   0,   1,   2,
     *            0,   3,   3,   0,   2,   1,   3,   1,   2,   1,
     *            2,
     *            0,   6,   0,   1,   0,   5,   5,   0,   1,   2,
     *            0,   4,   4,   0,   2,   1,   4,   1,   3,   0,
     *            3,   2,   1,   3,   3,   1,   2,   2/
      DATA KY /   0,   0,   7,   0,   0,  14,   0,   7,   0,   7,
     *            0,  21,   0,   7,   0,  14,  14,   0,   7,   7,
     *            0,  28,   0,   7,   0,  21,  21,   0,   7,  14,
     *            0,  14,   7,  14,   7,
     *            0,  35,   0,   7,   0,  28,  28,   0,   7,  14,
     *            0,  21,  21,   0,  14,   7,  21,   7,  14,   7,
     *           14,
     *            0,  42,   0,   7,   0,  35,  35,   0,   7,  14,
     *            0,  28,  28,   0,  14,   7,  28,   7,  21,   0,
     *           21,  14,   7,  21,  21,   7,  14,  14/
      DATA JY /   0,   0,  49,   0,   0,  98,   0,  49,   0,  49,
     *            0, 147,   0,  49,   0,  98,  98,   0,  49,  49,
     *            0, 196,   0,  49,   0, 147, 147,   0,  49,  98,
     *            0,  98,  49,  98,  49,
     *            0, 245,   0,  49,   0, 196, 196,   0,  49,  98,
     *            0, 147, 147,   0,  98,  49, 147,  49,  98,  49,
     *           98,
     *            0, 294,   0,  49,   0, 245, 245,   0,  49,  98,
     *            0, 196, 196,   0,  98,  49, 196,  49, 147,   0,
     *          147,  98,  49, 147, 147,  49,  98,  98/
      DATA IY /   1,   1, 344,   1,   1, 687,   1, 344,   1, 344,
     *            1,1030,   1, 344,   1, 687, 687,   1, 344, 344,
     *            1,1373,   1, 344,   1,1030,1030,   1, 344, 687,
     *            1, 687, 344, 687, 344,
     *            1,1716,   1, 344,   1,1373,1373,   1, 344, 687,
     *            1,1030,1030,   1, 687, 344,1030, 344, 687, 344,
     *          687,
     *            1,2059,   1, 344,   1,1716,1716,   1, 344, 687,
     *            1,1373,1373,   1, 687, 344,1373, 344,1030,   1,
     *         1030, 687, 344,1030,1030, 344, 687, 687/
      DATA LZ /   0,   0,   0,   1,   0,   0,   2,   0,   1,   1,
     *            0,   0,   3,   0,   1,   0,   1,   2,   2,   1,
     *            0,   0,   4,   0,   1,   0,   1,   3,   3,   0,
     *            2,   2,   1,   1,   2,
     *            0,   0,   5,   0,   1,   0,   1,   4,   4,   0,
     *            2,   0,   2,   3,   3,   1,   1,   3,   1,   2,
     *            2,
     *            0,   0,   6,   0,   1,   0,   1,   5,   5,   0,
     *            2,   0,   2,   4,   4,   1,   1,   4,   0,   3,
     *            3,   1,   2,   1,   2,   3,   3,   2/
      DATA KZ /   0,   0,   0,   7,   0,   0,  14,   0,   7,   7,
     *            0,   0,  21,   0,   7,   0,   7,  14,  14,   7,
     *            0,   0,  28,   0,   7,   0,   7,  21,  21,   0,
     *           14,  14,   7,   7,  14,
     *            0,   0,  35,   0,   7,   0,   7,  28,  28,   0,
     *           14,   0,  14,  21,  21,   7,   7,  21,   7,  14,
     *           14,
     *            0,   0,  42,   0,   7,   0,   7,  35,  35,   0,
     *           14,   0,  14,  28,  28,   7,   7,  28,   0,  21,
     *           21,   7,  14,   7,  14,  21,  21,  14/
      DATA JZ /   0,   0,   0,  49,   0,   0,  98,   0,  49,  49,
     *            0,   0, 147,   0,  49,   0,  49,  98,  98,  49,
     *            0,   0, 196,   0,  49,   0,  49, 147, 147,   0,
     *           98,  98,  49,  49,  98,
     *            0,   0, 245,   0,  49,   0,  49, 196, 196,   0,
     *           98,   0,  98, 147, 147,  49,  49, 147,  49,  98,
     *           98,
     *            0,   0, 294,   0,  49,   0,  49, 245, 245,   0,
     *           98,   0,  98, 196, 196,  49,  49, 196,   0, 147,
     *          147,  49,  98,  49,  98, 147, 147,  98/
      DATA IZ /   1,   1,   1, 344,   1,   1, 687,   1, 344, 344,
     *            1,   1,1030,   1, 344,   1, 344, 687, 687, 344,
     *            1,   1,1373,   1, 344,   1, 344,1030,1030,   1,
     *          687, 687, 344, 344, 687,
     *            1,   1,1716,   1, 344,   1, 344,1373,1373,   1,
     *          687,   1, 687,1030,1030, 344, 344,1030, 344, 687,
     *          687,
     *            1,   1,2059,   1, 344,   1, 344,1716,1716,   1,
     *          687,   1, 687,1373,1373, 344, 344,1373,   1,1030,
     *         1030, 344, 687, 344, 687,1030,1030, 687/
C
C     PREPARE SHELL INFORMATION/FOR HONDO INTEGRATION
C
      IF(NELEC.EQ.2) GO TO 200
C
C     ----- PERMUTE ISH AND JSH SHELLS, FOR THEIR TYPE
C     THIS IS DONE FOR SPEED REASONS.  THE CODE GETS THE RIGHT ANSWER
C     WITHOUT THE ANGULAR MOMENTUM FLIPPING, AND THEREFORE A CALLING
C     ARGUMENT ALLOWS ONE DO EXACTLY THE INTEGRAL BLOCK AS SPECIFIED,
C     SHOULD THAT BE DESIRED.
C
      IANDJ = ISH .EQ. JSH
      IF (KTYPE(ISH) .LT. KTYPE(JSH)  .AND.  FLIP) THEN
         INU = JSH
         JNU = ISH
         NGTI = NGTH(2)
         NGTJ = NGTH(1)
      ELSE
         INU = ISH
         JNU = JSH
         NGTI = NGTH(1)
         NGTJ = NGTH(2)
      END IF
C
C     ----- ISHELL
C
      I = KATOM(INU)
      AX = C(1,I)
      AY = C(2,I)
      AZ = C(3,I)
      I1 = KSTART(INU)
      I2 = I1+KNG(INU)-1
      LIT = KTYPE(INU)
      MINI = KMIN(INU)
      MAXI = KMAX(INU)
      LOCI = KLOC(INU)-MINI
      NGA = 0
      DO 140 I = I1,I2
         NGA = NGA+1
         GA(NGA) = EX(I)
         CSA(NGA) = CS(I)
         CPA(NGA) = CP(I)
         CDA(NGA) = CD(I)
         CFA(NGA) = CF(I)
         CGA(NGA) = CG(I)
         CHA(NGA) = CH(I)
         CIA(NGA) = CI(I)
  140 CONTINUE
C
C     ----- JSHELL
C
      J = KATOM(JNU)
      BX = C(1,J)
      BY = C(2,J)
      BZ = C(3,J)
      J1 = KSTART(JNU)
      J2 = J1+KNG(JNU)-1
      LJT = KTYPE(JNU)
      MINJ = KMIN(JNU)
      MAXJ = KMAX(JNU)
      LOCJ = KLOC(JNU)-MINJ
      NGB = 0
      DO 160 J = J1,J2
         NGB = NGB+1
         GB(NGB) = EX(J)
         CSB(NGB) = CS(J)
         CPB(NGB) = CP(J)
         CDB(NGB) = CD(J)
         CFB(NGB) = CF(J)
         CGB(NGB) = CG(J)
         CHB(NGB) = CH(J)
         CIB(NGB) = CI(J)
  160 CONTINUE
      RAB = ((AX-BX)*(AX-BX) + (AY-BY)*(AY-BY) + (AZ-BZ)*(AZ-BZ))
C
C     ----- PREPARE INDICES FOR PAIRS OF (I,J) FUNCTIONS
C
      IJ = 0
      JMAX = MAXJ
      DO 190 I = MINI,MAXI
         NX = IX(I)
         NY = IY(I)
         NZ = IZ(I)
         IF (IANDJ) JMAX = I
         DO 180 J = MINJ,JMAX
            IJ = IJ+1
            IJX(IJ) = NX+JX(J)
            IJY(IJ) = NY+JY(J)
            IJZ(IJ) = NZ+JZ(J)
            IJGT(IJ) = NGTI*(I-MINI)+NGTJ*(J-MINJ)+1
  180    CONTINUE
  190 CONTINUE
      RETURN
C     ******
C
C        K AND L SHELL
C
  200 CONTINUE
      KANDL = KSH .EQ. LSH
      SAME = ISH .EQ. KSH .AND. JSH .EQ. LSH
C
C     ----- PERMUTE KSH AND LSH SHELLS, FOR THEIR TYPE
C
      IF (KTYPE(KSH) .LT. KTYPE(LSH)  .AND.  FLIP) THEN
         KNU = LSH
         LNU = KSH
         NGTK = NGTH(4)
         NGTL = NGTH(3)
      ELSE
         KNU = KSH
         LNU = LSH
         NGTK = NGTH(3)
         NGTL = NGTH(4)
      END IF
C
C     ----- K SHELL
C
      K = KATOM(KNU)
      CX = C(1,K)
      CY = C(2,K)
      CZ = C(3,K)
      K1 = KSTART(KNU)
      K2 = K1+KNG(KNU)-1
      LKT = KTYPE(KNU)
      MINK = KMIN(KNU)
      MAXK = KMAX(KNU)
      LOCK = KLOC(KNU)-MINK
      NGC = 0
      DO 260 K = K1,K2
         NGC = NGC+1
         GC(NGC) = EX(K)
         CSC(NGC) = CS(K)
         CPC(NGC) = CP(K)
         CDC(NGC) = CD(K)
         CFC(NGC) = CF(K)
         CGC(NGC) = CG(K)
         CHC(NGC) = CH(K)
         CIC(NGC) = CI(K)
  260 CONTINUE
C
C     ----- LSHELL
C
      L = KATOM(LNU)
      DX = C(1,L)
      DY = C(2,L)
      DZ = C(3,L)
      L1 = KSTART(LNU)
      L2 = L1+KNG(LNU)-1
      LLT = KTYPE(LNU)
      MINL = KMIN(LNU)
      MAXL = KMAX(LNU)
      LOCL = KLOC(LNU)-MINL
      NGD = 0
      DO 280 L = L1,L2
         NGD = NGD+1
         GD(NGD) = EX(L)
         CSD(NGD) = CS(L)
         CPD(NGD) = CP(L)
         CDD(NGD) = CD(L)
         CFD(NGD) = CF(L)
         CGD(NGD) = CG(L)
         CHD(NGD) = CH(L)
         CID(NGD) = CI(L)
  280 CONTINUE
      NROOTS = (LIT+LJT+LKT+LLT-2)/2
      RCD = ((CX-DX)*(CX-DX) + (CY-DY)*(CY-DY) + (CZ-DZ)*(CZ-DZ))
C
C     ----- PREPARE INDICES FOR PAIRS OF (K,L) FUNCTIONS
C
      KL = 0
      LMAX = MAXL
      DO 310 K = MINK,MAXK
         NX = KX(K)
         NY = KY(K)
         NZ = KZ(K)
         IF (KANDL) LMAX = K
         DO 300 L = MINL,LMAX
            KL = KL+1
            KLX(KL) = NX+LX(L)
            KLY(KL) = NY+LY(L)
            KLZ(KL) = NZ+LZ(L)
            KLGT(KL) = NGTK*(K-MINK)+NGTL*(L-MINL)
  300    CONTINUE
  310 CONTINUE
      MAX = KL
      DO 320 I = 1,IJ
      IF (SAME) MAX = I
  320 IK(I) = MAX
      IJKL = IJ*KL
      IF (SAME) IJKL = IJ*(IJ+1)/2
      RETURN
      END
C*MODULE INT2C   *DECK SHELLQUART
      SUBROUTINE SHELLQUART(ISH,JSH,KSH,LSH,GHONDO)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION GHONDO(*)
      DIMENSION GROTSPD(1296)
C
      LOGICAL PACK2E,IANDJ,KANDL,SAME
C
      PARAMETER (MXGSH=30, MXG2=MXGSH*MXGSH, MXSH=5000, MXGTOT=20000)
C
      COMMON /FLIPS / IB(4,3)
      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 /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /SHLEXC/ NORGSH(3),NORGSP(3),IEXCH,NANGM,NGTH(4)
C
C  FOR RYS QUADRATURE CODE
C
      LOGICAL LSHEL
      COMMON /FMCOM /XX(1)
C
C  FOR ERIC CODE, BUT ALL CODES MUST SET ERIOUT FOR OUTPUT ROUTINES
C
      LOGICAL ERICQT
      COMMON /ERIDAT/ LEN1,LEN2,LEN3,LEN4
      COMMON /ERIOUT/ INW,JNW,KNW,LNW,LSTRI,LSTRJ,LSTRK,LSTRL
C
C  FOR THE TWO ROTATED AXIS CODES
C
      INTEGER IDPOP(4,10)
      LOGICAL SP,SPD,ROTSP,ROTSPD,SPDFG
      COMMON /GOUT  / GPOPLE(768),NORGP
      COMMON /POPOUT/ LPOPI,LPOPJ,LPOPK,LPOPL
      COMMON /SHLG70/ IPL,JPL,KPL,LPL,INEW,JNEW,KNEW,LNEW
      DATA IDPOP/0,0,0,0,216,36,6,1,432,72,12,2,648,108,18,3,
     *           0,0,0,0,216,36,6,1,432,72,12,2,648,108,18,3,
     *           864,144,24,4,1080,180,30,5/
C
C     ----- SELECT THE INTEGRAL CODE FOR THIS SHELL QUARTET -----
C     THE USER INPUT SELECTION -INTTYP- HAS THE FOLLOWING MEANING:
C      INTTYP=0    BEST TIMING:
C                  USE ROTATED AXIS CODES FOR ANY S,P,D,L SHELLS,
C                  OTHERWISE PICK ERIC CODE WHENEVER POSSIBLE, BUT
C                  USE RYS CODE FOR L SHELL OR IF TOO MUCH ANG.MOM.
C      INTTYP=1    USE THE S,P,L OR S,P,D,L ROTATED AXIS CODE WHENEVER
C                  POSSIBLE, OTHERWISE RYS QUADRATURE (NO ERIC).
C      INTTYP=2    USE ERIC CODE AS MUCH AS POSSIBLE, OTHERWISE
C                  USE THE RYS QUADRATURE (NO ROTATED AXIS).
C      INTTYP=3    USE RYS POLYNOMIAL QUADRATURE FOR EVERYTHING.
C
      SP    = KTYPE(ISH).LE.2.AND.
     *        KTYPE(JSH).LE.2.AND.
     *        KTYPE(KSH).LE.2.AND.
     *        KTYPE(LSH).LE.2
      SPD   = KTYPE(ISH).LE.3.AND.
     *        KTYPE(JSH).LE.3.AND.
     *        KTYPE(KSH).LE.3.AND.
     *        KTYPE(LSH).LE.3
      IF(SP) SPD=.FALSE.
      LSHEL = (KMAX(ISH)-KMIN(ISH)+1).EQ.4.OR.
     *        (KMAX(JSH)-KMIN(JSH)+1).EQ.4.OR.
     *        (KMAX(KSH)-KMIN(KSH)+1).EQ.4.OR.
     *        (KMAX(LSH)-KMIN(LSH)+1).EQ.4
      LQSUM = KTYPE(ISH) + KTYPE(JSH) + KTYPE(KSH) + KTYPE(LSH) - 4
C
      ROTSP  = SP
      ROTSPD = SPD
      SPDFG = KTYPE(ISH).LE.5.AND.
     *        KTYPE(JSH).LE.5.AND.
     *        KTYPE(KSH).LE.5.AND.
     *        KTYPE(LSH).LE.5
      ERICQT = .NOT.LSHEL .AND. LQSUM.LE.5 .AND. SPDFG
C
C        RYS QUADRATURE IS A BIT FASTER AT UNCONTRACTED QUARTETS
C
      KQCON = KNG(ISH) * KNG(JSH) * KNG(KSH) * KNG(LSH) + INTTYP
      IF(KQCON.EQ.1  .AND.  .NOT.SP) THEN
         ROTSP  = .FALSE.
         ROTSPD = .FALSE.
         ERICQT = .FALSE.
      END IF
C
C        INPUT OVERRIDES
C
      IF(INTTYP.EQ.1) ERICQT = .FALSE.
      IF(INTTYP.GE.2) ROTSP  = .FALSE.
      IF(INTTYP.GE.2) ROTSPD = .FALSE.
      IF(INTTYP.EQ.3) ERICQT = .FALSE.
C
C        THE VARIOUS PACKAGES ARE CALLED BELOW IN THE ORDER OF
C        FIRST ROTATED AXIS, THEN ERIC, FINALLY RYS QUADRATURE.
C        SINCE EACH CODE RETURNS, A QUARTET IS NEVER DONE TWICE.
C
C  ROTATED AXIS CODE FOR PURE SP SHELL QUARTET
C
      IF (ROTSP) THEN
        IPL = ISH
        JPL = JSH
        KPL = KSH
        LPL = LSH
        INW = ISH
        JNW = JSH
        KNW = KSH
        LNW = LSH
        NORGP = NORGSP(IEXCH)
        NORGH = NORGSH(IEXCH)
C
        CALL GENR70(1,.FALSE.)
C
C  SAVE TO OUTPUT ARRAY WITH HONDO INDEXING
C
        MINI = KMIN(INW)
        MAXI = KMAX(INW)
        MINJ = KMIN(JNW)
        MAXJ = KMAX(JNW)
        MINK = KMIN(KNW)
        MAXK = KMAX(KNW)
        MINL = KMIN(LNW)
        MAXL = KMAX(LNW)
C
        II = 1
        DO I = MINI, MAXI
          IP = (I-1)*LPOPI + 1
          IJ  = II
          DO J = MINJ, MAXJ
            IJP = (J-1)*LPOPJ + IP
            IJK  = IJ
            DO K = MINK, MAXK
              IJKP = (K-1)*LPOPK + IJP
              IJKL  = IJK
              DO L = MINL, MAXL
                IJKLP = (L-1)*LPOPL + IJKP
                GHONDO(IJKL+NORGH) = GPOPLE(IJKLP+NORGP)
                IJKL = IJKL  + LEN1
              END DO
              IJK  = IJK  + LEN2
            END DO
            IJ  = IJ  + LEN3
          END DO
          II = II + LEN4
        END DO
        LSTRI = LEN4
        LSTRJ = LEN3
        LSTRK = LEN2
        LSTRL = LEN1
        RETURN
C       ******
C
C  ROTATED AXIS CODE FOR QUARTET CONTAINING AT LEAST ONE D FUNCTION
C
      ELSE IF (ROTSPD) THEN
        INW = ISH
        JNW = JSH
        KNW = KSH
        LNW = LSH
C
        CALL GENR03(GROTSPD)
C
C  SAVE TO OUTPUT ARRAY WITH HONDO INDEXING
C
        NORGH = NORGSH(IEXCH)
        IANDJ = ISH.EQ.JSH
        KANDL = KSH.EQ.LSH
        SAME  = ISH.EQ.KSH  .AND.  JSH.EQ.LSH
        IF(NOPK.EQ.0) SAME=.FALSE.
C
        IEX=1
        IBB = IB(1,IEX)
        JBB = IB(2,IEX)
        KBB = IB(3,IEX)
        LBB = IB(4,IEX)
C
        MINI = KMIN(INW)
        MAXI = KMAX(INW)
        MINJ = KMIN(JNW)
        MAXJ = KMAX(JNW)
        MINK = KMIN(KNW)
        MAXK = KMAX(KNW)
        MINL = KMIN(LNW)
        MAXL = KMAX(LNW)
C
        IJN = 0
        JMAX = MAXJ
        DO I = MINI, MAXI
          IHONDO = (I-MINI)*LEN4 + 1
          IROTAX = IDPOP(IBB,I)  + 1
          IF(IANDJ) JMAX=I
          DO 340 J = MINJ, JMAX
            IJHONDO = (J-MINJ)*LEN3 + IHONDO
            IJROTAX = IDPOP(JBB,J)  + IROTAX
            IJN = IJN+1
            LMAX=MAXL
            KLN=0
            DO K = MINK, MAXK
              IJKHONDO = (K-MINK)*LEN2 + IJHONDO
              IJKROTAX = IDPOP(KBB,K)  + IJROTAX
              IF(KANDL) LMAX=K
              DO L = MINL, LMAX
                KLN = KLN+1
                IF(SAME .AND. KLN.GT.IJN) GO TO 340
                IJKLHONDO = (L-MINL)*LEN1 + IJKHONDO
                IJKLROTAX = IDPOP(LBB,L)  + IJKROTAX
                GHONDO(IJKLHONDO+NORGH) = GROTSPD(IJKLROTAX)
              END DO
            END DO
  340     CONTINUE
        END DO
        LSTRI = LEN4
        LSTRJ = LEN3
        LSTRK = LEN2
        LSTRL = LEN1
        RETURN
C       ******
C
C  USE ERIC FAST CODES, REQUIRES THAT LQSYM.LE.5 AND NO L-SHELLS
C  NOTE THAT THERE IS CODE COPYING ERIC BUFFERS INTO THE HONDO
C  FORMAT BUFFER AT THE END OF THE -ERIC- ROUTINE.
C
      ELSE IF (ERICQT) THEN
        NORGH = NORGSH(IEXCH)
        CALL ERIC(ISH,JSH,KSH,LSH,GHONDO(1+NORGH))
        RETURN
C       ******
C
C  GENERAL CASE = HONDO/RYS QUADRATURE: ANY S,P,D,F,G, OR L SHELLS
C
      ELSE
        CALL VALFM(LOADFM)
        IDDIJ = LOADFM + 1
        NEED  = 49*MXG2
        CALL GETFM(NEED)
        CALL SHELLS(1,ISH,JSH,KSH,LSH,.TRUE.)
        CALL SHELLS(2,ISH,JSH,KSH,LSH,.TRUE.)
        CALL IJPRIM(XX(IDDIJ))
        NORGH = NORGSH(IEXCH)
        IF(NOPK.NE.0) CALL ZQOUT(GHONDO)
        IF(LQSUM.EQ.0) THEN
           CALL S0000(GHONDO(1+NORGH),XX(IDDIJ))
        ELSE
           CALL GENRAL(GHONDO(1+NORGH),XX(IDDIJ))
        END IF
        CALL RETFM(NEED)
        RETURN
C       ******
C
      END IF
      END
C*MODULE INT2A   *DECK TWOEI
      SUBROUTINE TWOEI(TYPSCF,DIRSCF,DIRNLO,DIRTRF,DIRCIS,
     *                 INTTYP,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                 BUFP,BUFK,IX,NINTMX,
     *                 XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                 IA,DA,FA,DB,FB,DSH,DNLO,FNLO,NFLMAT)
C
C       MANY ARGUMENTS ARE OPTIONAL, YOU MUST ALLOCATE STORAGE FOR
C              ALL CALLS: GHONDO, DDIJ, XINTS
C           CONVENTIONAL: BUFP, IX, AND POSSIBLY BUFK
C             DIRECT SCF: IA, DSH, DA, FA, AND POSSIBLY DB, FB
C             DIRECT CIS: IA, DSH, DA, FA, AND POSSIBLY DB, FB
C             DIRECT NLO: DNLO, FNLO, NFLMAT
C  DIRECT TRANSFORMATION: BUFP, IX
C     RESPONSE EQUATIONS: MUST DEFINE NFLMAT.NE.1
C  NOTE THAT THE TYPE OF FOCK MATRIX BUILT (TYPSCF) DOES NOT
C  NECESSARILY HAVE TO MATCH THIS RUNS SCFTYP VALUE.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,DIRNLO,DIRTRF,DIRCIS,CMBDIR
      LOGICAL OUT,SCHWRZ,SCHSKP,GOPARR,DSKWRK,MASWRK,DLB,SLB,C1GRP
      LOGICAL SKIPA,SKIPB,SKIPC,NPSYM
      LOGICAL PK,PANDK,NOTPK,BLOCK,GPSAVE,SCREEN
C
      DIMENSION BUFP(NINTMX),BUFK(NINTMX),IX(*),XINTS(NSH2),
     *          GHONDO(MAXG),IA(L1),DA(L2),FA(L2),DB(L2),FB(L2),
     *          DSH(NSH2),DDIJ(*),DNLO(L1,L1),FNLO(L1,L1)
      DIMENSION MI(48),MJ(48),MK(48),M0(48)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000)
C
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      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 /PKFIL / PK,PANDK,BLOCK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /SCINP / VLAMB,SCREEN
      COMMON /SHLEXC/ NORGSH(3),NORGSP(3),IEXCH,NANGM,NGTH(4)
      COMMON /SHLG70/ ISH,JSH,KSH,LSH,IJKLXX(4)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
      PARAMETER (ZERO=0.0D+00)
C
C          ----- TWO-ELECTRON INTEGRALS -----
C     THIS VERSION CAN HANDLE S,P,D,F,G AND L SHELLS
C
      TIM = ZERO
      CALL TSECND(TIM)
C
C           PERHAPS CALL XABI LOPEZ/JOSE UGALDE'S SCREENED INTEGRAL CODE
C
      IF (SCREEN) THEN
         WRITE(IW,36)
  36     FORMAT (/,'#########',/,'SCREEN TWO-ELECTRON INTEGRAL',/)
         CALL STWOEI(TYPSCF,DIRSCF,DIRNLO,DIRTRF,
     *               INTTYP,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *               BUFP,BUFK,IX,NINTMX,
     *               XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *               IA,DA,FA,DB,FB,DSH,DNLO,FNLO)
         RETURN
      END IF
C
      CMBDIR= DIRSCF .OR. DIRNLO .OR. DIRTRF .OR. DIRCIS
C
C        THE OLD FASHIONED PARALLEL INTEGRAL TRANSFORMATIONS DO NOT
C        ALLOW THE AO INTEGRAL WORK TO BE RUN IN PARALLEL.  THE MODERN
C        DISTRIBUTED MEMORY TRANSFORMATIONS DO NOT PASS THROUGH HERE.
C
      ICONT=  0
      GPSAVE = GOPARR
      IF(DIRTRF) GOPARR=.FALSE.
C
C     ----- INITIALIZATION FOR PARALLEL WORK -----
C     BOTH STATIC AND DYNAMIC LOAD BALANCING ARE IMPLEMENTED BELOW
C
      SLB = GOPARR  .AND.  IBTYP.EQ.0
      DLB = GOPARR  .AND.  IBTYP.EQ.1
      NEXT = -1
      MINE = -1
      IPCOUNT = ME - 1
C
      C1GRP = NT.EQ.1
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      IF(LMAX.EQ.5) NANGM = 21
      IF(LMAX.EQ.6) NANGM = 28
      NGTH(4) = 1
      NGTH(3) = NGTH(4) * NANGM
      NGTH(2) = NGTH(3) * NANGM
      NGTH(1) = NGTH(2) * NANGM
      IF(NOPK.EQ.0) THEN
         NORGSH(1) = 0
         NORGSH(2) = NORGSH(1) + NANGM**4
         NORGSH(3) = NORGSH(2) + NANGM**4
         NORGSP(1) = 0
         NORGSP(2) = 256
         NORGSP(3) = 512
      ELSE
         DO I=1,3
            NORGSH(I) = 0
            NORGSP(I) = 0
         ENDDO
      END IF
C
      NOTPK = .NOT.PK
      NINT  = 0
      NSCHWZ= 0
      SCHSKP=.FALSE.
      DENMAX = ZERO
C
C        NOW WE ARE READY TO LOOP OVER ALL NSHELL**4 SHELL QUARTETS
C
C     ----- I SHELL -----
C
      DO 920 II = IST,NSHELL
C
C     ----- CHECK CPU TIME -----
C
      CALL TSECND(TIM)
      IF(TIM.GE.TIMLIM) THEN
C        NOTHING CAN BE DONE FOR IN-CORE INTEGRALS: JUST FORGET THEM
         IF(.NOT.CMBDIR)
     *      CALL FINAL(0,II,1,1,1,PANDK,BUFP,BUFK,IX,NINTMX)
         IF(MASWRK) WRITE(IW,9030)
         CALL ABRT
      END IF
C
C     ----- PRINT INTERMEDIATE RESTART DATA -----
C
      IF(NPRINT.NE.-5  .AND.  .NOT.CMBDIR .AND. MASWRK) THEN
         IF(ICOUNT.LE.NINTIC) THEN
            WRITE(IW,9015) II,JST,KST,LST,ICOUNT
         ELSE
            WRITE(IW,9010) II,JST,KST,LST,NREC,ICOUNT-NINTIC
         ENDIF
      ENDIF
C
C     ----- SKIP I SHELL IF NOT SYMMETRY UNIQUE -----
C     THIS, AND THE SIMILAR BRANCHINGS FOR THE J, K, AND L LOOPS IS
C     WHAT GENERATES THE "PETITE" RATHER THAN "GRANDE" INTEGRAL LIST.
C
      IF(C1GRP) THEN
         MI(1)=II
      ELSE
         DO 120 IT = 1,NT
            ID = MAPSHL(II,IT)
            IF (ID .GT. II) GO TO 920
            MI(IT) = ID
  120    CONTINUE
      END IF
C
C     ----- J SHELL -----
C
      J0 = JST
      DO 900 JJ = J0,II
      JST = 1
C
      IF(C1GRP) THEN
         MJ(1)=JJ
      ELSE
         DO 200 IT = 1,NT
            ID = MI(IT)
            JD = MAPSHL(JJ,IT)
            MJ(IT) = JD
            IF (ID .GE. JD) GO TO 160
            ND = ID
            ID = JD
            JD = ND
  160       IF (ID-II) 200,180,900
  180       IF (JD-JJ) 200,200,900
  200    CONTINUE
      END IF
C
C     ----- GO PARALLEL! -----
C
      IF (DLB) THEN
         MINE = MINE + 1
         IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
         IF (NEXT.NE.MINE) GO TO 900
      END IF
C
C     ----- K SHELL -----
C
      K0 = KST
      DO 880 KK = K0,JJ
      KST = 1
C
      IF(C1GRP) THEN
         MK(1)=KK
      ELSE
         DO 340 IT = 1,NT
            ID = MI(IT)
            JD = MJ(IT)
            KD = MAPSHL(KK,IT)
            MK(IT) = KD
  240       IF (ID .GE. JD) GO TO 260
            ND = ID
            ID = JD
            JD = ND
  260       IF (JD .GE. KD) GO TO 280
            ND = JD
            JD = KD
            KD = ND
            GO TO 240
  280       IF (ID-II) 340,300,880
  300       IF (JD-JJ) 340,320,880
  320       IF (KD-KK) 340,340,880
  340    CONTINUE
      END IF
C
C     ----- GO PARALLEL! -----
C
      IF(SLB) THEN
         IPCOUNT = IPCOUNT + 1
         IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 880
      END IF
C
C     ----- L SHELL ----
C
      L0 = LST
      DO 860 LL = L0,KK
      LST = 1
C
      IF(C1GRP) THEN
         M0(1)=1
         N4=1
      ELSE
         N4 = 0
         DO 540 IT = 1,NT
            ID = MI(IT)
            JD = MJ(IT)
            KD = MK(IT)
            LD = MAPSHL(LL,IT)
  380       IF (ID .GE. JD) GO TO 400
            ND = ID
            ID = JD
            JD = ND
  400       IF (JD .GE. KD) GO TO 420
            ND = JD
            JD = KD
            KD = ND
            GO TO 380
  420       IF (KD .GE. LD) GO TO 440
            ND = KD
            KD = LD
            LD = ND
            GO TO 400
  440       IF (ID-II) 540,460,860
  460       IF (JD-JJ) 540,480,860
  480       IF (KD-KK) 540,500,860
  500       IF (LD-LL) 540,520,860
  520       N4 = N4+1
            M0(N4) = IT
  540    CONTINUE
      END IF
C
C         THE LOOP STRUCTURE IN THIS ROUTINE IS DESIGNED TO FACILITATE
C         SUPERMATRIX CONSTRUCTION BY HAVING UP TO THREE "EXCHANGED"
C         QUARTETS AVAILABLE AT ONCE.  THE LOOP STRUCTURE TO GENERATE
C         A MORE NORMAL CANONICAL ORDERING OF THE QUARTETS HITS THE
C         SAME QUARTETS IN A SLIGHTLY DIFFERENT ORDER, BUT BOTH LOOPS
C         WILL DO EXACTLY THE SAME QUARTETS.
C
C             CANONICAL                      SUPERMATRIX
C         DO ISH=1,NSHELL                 DO II=1,NSHELL
C           DO JSH=1,ISH                    DO JJ=1,II
C             IJSH = IA(ISH)+JSH
C             DO KSH=1,ISH                    DO KK=1,JJ
C               DO LSH=1,KSH                    DO LL=1,KK
C                 KLSH=IA(KSH)+LSH
C                 IF(IJSH.LT.KLSH),               [II JJ|KK LL],
C                    CYCLE KSH LOOP               [II KK|JJ LL],
C                 [ISH JSH|KSH LSH]               [II LL|JJ KK]
C               ENDDO                           ENDDO
C             ENDDO                           ENDDO
C           ENDDO                           ENDDO
C         ENDDO                           ENDDO
C
C     ----- CHECK FOR REDUNDANIES BETWEEN THE 3 COMBINATIONS -----
C            (II,JJ//KK,LL), (II,KK//JJ,LL), (II,LL//JJ,KK)
C
      SKIPA =  JJ.EQ.KK
      SKIPB = (II.EQ.KK) .OR. (JJ.EQ.LL)
      SKIPC = (II.EQ.JJ) .OR. (KK.EQ.LL)
      NPSYM = .FALSE.
      IF (SKIPA .OR. SKIPB .OR. SKIPC) GO TO 720
      NPSYM = .TRUE.
      DO 640 M = 1,N4
         IT = M0(M)
         IH = MI(IT)
         JH = MJ(IT)
         IF(JH.LE.IH) THEN
            ID = IH
            JD = JH
         ELSE
            ID = JH
            JD = IH
         END IF
         IF(.NOT.SKIPA) SKIPA = (ID.EQ.II .AND. JD.EQ.KK) .OR.
     *                          (ID.EQ.JJ .AND. JD.EQ.LL)
         IF(.NOT.SKIPB) SKIPB = (ID.EQ.II .AND. JD.EQ.LL) .OR.
     *                          (ID.EQ.JJ .AND. JD.EQ.KK)
         IF (SKIPA .AND. SKIPB) GO TO 660
         KH = MK(IT)
         IF(KH.LE.IH) THEN
            ID = IH
            KD = KH
         ELSE
            ID = KH
            KD = IH
         END IF
         IF(.NOT.SKIPC) SKIPC = (ID.EQ.II .AND. KD.EQ.LL) .OR.
     *                          (ID.EQ.JJ .AND. KD.EQ.KK)
         IF(SKIPA .AND. SKIPC) GO TO 680
         IF(SKIPB .AND. SKIPC) GO TO 700
  640 CONTINUE
      GO TO 720
C
  660 SKIPC = .TRUE.
      GO TO 720
  680 SKIPB = .TRUE.
      GO TO 720
  700 SKIPA = .TRUE.
C
C        GENERATE SYMMETRY FACTOR -Q4- FOR THIS QUARTET IN PETITE LIST
C
  720 CONTINUE
      Q4 = NT
      Q4 = Q4 / N4
C
C     ----- (II,JJ//KK,LL) -----
C
      IEXCH = 1
      ISH = II
      JSH = JJ
      KSH = KK
      LSH = LL
      QQ4 = Q4
      IF(SKIPA .AND. NPSYM) QQ4 = QQ4+Q4
      IF(SKIPB .AND. NPSYM) QQ4 = QQ4+Q4
      GO TO 780
C
C     ----- (II,KK//JJ,LL) -----
C
  740 IF (SKIPA) GO TO 760
      IEXCH = 2
      ISH = II
      JSH = KK
      KSH = JJ
      LSH = LL
      QQ4 = Q4
      IF (SKIPC .AND. NPSYM) QQ4 = QQ4+Q4
      GO TO 780
C
C     ----- (II,LL//JJ,KK) -----
C
  760 IF (SKIPB .OR. SKIPC) GO TO 840
      IEXCH = 3
      ISH = II
      JSH = LL
      KSH = JJ
      LSH = KK
      QQ4 = Q4
C
C        ----- COMPUTE TWO-ELECTRON INTEGRALS ----
C
  780 CONTINUE
      IF(PK .AND. IEXCH.EQ.1) CALL ZPKOUT(ISH,JSH,KSH,LSH,GHONDO,
     *                                    SKIPA,SKIPB,SKIPC,NPSYM)
C
C     APPLY THE SCHWARZ INEQUALITY TO SCREEN OUT SMALL INTEGRALS,
C      (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C     SEE, FOR EXAMPLE, J.L.WHITTEN, J.CHEM.PHYS. 58,4496-4501(1973)
C
      IF(SCHWRZ) THEN
         IJIJ = (ISH*ISH-ISH)/2 + JSH
         KLKL = (KSH*KSH-KSH)/2 + LSH
         TEST = QQ4*XINTS(IJIJ)*XINTS(KLKL)
         IF(DIRSCF) THEN
            DENMAX = SCHWDN(DSH,ISH,JSH,KSH,LSH,IA)
            TEST = TEST*DENMAX
         END IF
         SCHSKP = TEST.LT.CUTOFF
         IF(SCHSKP) NSCHWZ = NSCHWZ + 1
      END IF
      IF(SCHSKP) GO TO 820
C
C        ----- ELECTRON REPULSION INTEGRAL CALCULATION -----
C     THIS MAY USE ROTATED AXIS, ERIC, OR RYS QUADRATURE METHODS
C
      CALL SHELLQUART(ISH,JSH,KSH,LSH,GHONDO)
C
C        USE THE INTEGRALS JUST FORMED.  AT MOST, 1 OF THESE IS CALLED
C
           IF(DIRSCF) THEN
         CALL DIRFCK(TYPSCF,IA,DA,FA,DB,FB,GHONDO,L2,NINT,NFLMAT)
      ELSE IF(DIRCIS) THEN
         CALL DRFCIS(DA,FA,DB,FB,GHONDO,L1,NINT,NFLMAT)
      ELSE IF(DIRNLO) THEN
         CALL DFCKNS(DNLO,FNLO,GHONDO,L1,NINT,NFLMAT)
      ELSE IF(DIRTRF) THEN
         CALL DIRTRN(BUFP,IX,NINTMX,GHONDO,ICONT,NINT)
      ELSE
         IF(NOTPK) CALL QOUT(BUFP,IX,NINTMX,GHONDO)
      END IF
C
  820 CONTINUE
      GO TO (740,760,840),IEXCH
C
C     ----- WRITE THE P (OR PK) SUPERMATRIX TO DISK FILE -----
C
  840 CONTINUE
      IF(PK) CALL PKFILE(II,JJ,KK,LL,SKIPA,SKIPB,SKIPC,NPSYM,
     *                   BUFP,BUFK,IX,NINTMX,GHONDO)
C
C     ----- END OF SHELL LOOPS -----
C
  860 CONTINUE
  880 CONTINUE
  900 CONTINUE
  920 CONTINUE
C
      IF(DLB) CALL DDI_DLBRESET
C
C     ----- OUTPUT THE LAST BITS OF INTEGRALS -----
C
      IF(DIRTRF) CALL ONEIDX(BUFP,IX,ICONT)
      IF(.NOT.CMBDIR) THEN
         IF(SCHWRZ) THEN
            IF(GOPARR) CALL DDI_GSUMI(1055,NSCHWZ,1)
            IF(NPRINT.NE.-5 .AND. MASWRK) WRITE(IW,9020) NSCHWZ
         END IF
         CALL FINAL(1,II,II,II,II,PANDK,BUFP,BUFK,IX,NINTMX)
      END IF
C
      GOPARR = GPSAVE
      RETURN
C
 9010 FORMAT(1X,'II,JST,KST,LST =',4I3,' NREC =',I10,' INTLOC =',I5)
 9015 FORMAT(1X,'II,JST,KST,LST =',4I3,' IN CORE, INTLOC =',I12)
 9020 FORMAT(1X,'SCHWARZ INEQUALITY TEST SKIPPED',I10,
     *        ' INTEGRAL BLOCKS.')
 9030 FORMAT(//1X,'*** THIS JOB HAS EXHAUSTED ITS CPU TIME ***'/
     *         1X,'     (WHILE COMPUTING 2E- INTEGRALS)'///)
      END
C*MODULE INT2A   *DECK XYZINT
      SUBROUTINE XYZINT
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL N0,N1,M0,M1,FIRST1,FIRST2,FIRST3,FIRST4
C
      COMMON /SETINT/ I(13),K(13),NIMAX,NJMAX,NKMAX,NLMAX,NMAX,MMAX
     +               ,BP01,B00,B10,XCP00,XC00,YCP00,YC00,ZCP00,ZC00,F00
     +               ,DXIJ,DYIJ,DZIJ,DXKL,DYKL,DZKL
      COMMON /XYZ   / XINT(31213),YINT(31213),ZINT(31213)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      N0 = NMAX .EQ. 0
      N1 = NMAX .LE. 1
      M0 = MMAX .EQ. 0
      M1 = MMAX .LE. 1
C
C     ----- I(0,0) -----
C
      I1 = I(1)
      XINT(I1) = ONE
      YINT(I1) = ONE
      ZINT(I1) = F00
      IF (N0 .AND. M0) RETURN
      I2 = I(2)
      K2 = K(2)
      CP10 = B00
C
C     ----- I(1,0) -----
C
      IF (.NOT. N0) THEN
        XINT(I2) = XC00
        YINT(I2) = YC00
        ZINT(I2) = ZC00*F00
        IF (M0) GO TO 120
      END IF
C
C     ----- I(0,1) -----
C
      I3 = I1+K2
      XINT(I3) = XCP00
      YINT(I3) = YCP00
      ZINT(I3) = ZCP00*F00
C
C     ----- I(1,1) -----
C
      IF (.NOT. N0) THEN
        I3 = I2+K2
        XINT(I3) = XCP00*XINT(I2)+CP10
        YINT(I3) = YCP00*YINT(I2)+CP10
        ZINT(I3) = ZCP00*ZINT(I2)+CP10*F00
      END IF
C
  120 CONTINUE
      IF (.NOT. N1) THEN
        C10 = ZERO
        I3 = I1
        I4 = I2
        DO 160 N = 2,NMAX
          C10 = C10+B10
C
C     ----- I(N,0) -----
C
          I5 = I(N+1)
          XINT(I5) = C10*XINT(I3)+XC00*XINT(I4)
          YINT(I5) = C10*YINT(I3)+YC00*YINT(I4)
          ZINT(I5) = C10*ZINT(I3)+ZC00*ZINT(I4)
          IF ( .NOT. M0) THEN
            CP10 = CP10+B00
C
C     ----- I(N,1) -----
C
            I3 = I5+K2
            XINT(I3) = XCP00*XINT(I5)+CP10*XINT(I4)
            YINT(I3) = YCP00*YINT(I5)+CP10*YINT(I4)
            ZINT(I3) = ZCP00*ZINT(I5)+CP10*ZINT(I4)
          END IF
          I3 = I4
          I4 = I5
  160     CONTINUE
      END IF
      IF ( .NOT. M1) THEN
        CP01 = ZERO
        C01 = B00
        I3 = I1
        I4 = I1+K2
        DO 220 M = 2,MMAX
          CP01 = CP01+BP01
C
C     ----- I(0,M) -----
C
          I5 = I1+K(M+1)
          XINT(I5) = CP01*XINT(I3)+XCP00*XINT(I4)
          YINT(I5) = CP01*YINT(I3)+YCP00*YINT(I4)
          ZINT(I5) = CP01*ZINT(I3)+ZCP00*ZINT(I4)
C
C     ----- I(1,M) -----
C
          IF (.NOT. N0) THEN
            C01 = C01+B00
            I3 = I2+K(M+1)
            XINT(I3) = XC00*XINT(I5)+C01*XINT(I4)
            YINT(I3) = YC00*YINT(I5)+C01*YINT(I4)
            ZINT(I3) = ZC00*ZINT(I5)+C01*ZINT(I4)
          END IF
          I3 = I4
          I4 = I5
  220   CONTINUE
      END IF
C
C     ----- I(N,M) -----
C
      IF (.NOT. N1 .AND. .NOT. M1) THEN
        C01 = B00
        K3 = K2
        DO 280 M = 2,MMAX
          K4 = K(M+1)
          C01 = C01+B00
          I3 = I1
          I4 = I2
          C10 = B10
          DO 260 N = 2,NMAX
            I5 = I(N+1)
            XINT(I5+K4) = C10*XINT(I3+K4)+XC00*XINT(I4+K4)
     *                    +C01*XINT(I4+K3)
            YINT(I5+K4) = C10*YINT(I3+K4)+YC00*YINT(I4+K4)
     *                    +C01*YINT(I4+K3)
            ZINT(I5+K4) = C10*ZINT(I3+K4)+ZC00*ZINT(I4+K4)
     *                    +C01*ZINT(I4+K3)
            C10 = C10+B10
            I3 = I4
            I4 = I5
  260     CONTINUE
          K3 = K4
  280   CONTINUE
      END IF
C
C     ----- I(NI,NJ,M) -----
C
      IF (NJMAX .GT. 0) THEN
        M = 0
        I5 = I(NMAX+1)
        FIRST1 = .TRUE.
        DO 430 WHILE (FIRST1 .OR. M .LE. MMAX)
          MIN = NIMAX
          KM = K(M+1)
          FIRST2 = .TRUE.
          DO 360 WHILE (FIRST2 .OR. MIN .LT. NMAX)
            N = NMAX
            I3 = I5+KM
            FIRST3 = .TRUE.
            DO 340 WHILE (FIRST3 .OR. N .GT. MIN)
              I4 = I(N)+KM
              XINT(I3) = XINT(I3)+DXIJ*XINT(I4)
              YINT(I3) = YINT(I3)+DYIJ*YINT(I4)
              ZINT(I3) = ZINT(I3)+DZIJ*ZINT(I4)
              I3 = I4
              N = N-1
              FIRST3 = .FALSE.
  340       END DO
            MIN = MIN+1
            FIRST2 = .FALSE.
  360     END DO
          IF (NIMAX .GT. 0) THEN
            I3 = 49+KM+I1
            DO 400 NJ = 1,NJMAX
              I4 = I3
              DO 380 NI = 1,NIMAX
                XINT(I4) = XINT(I4+294)+DXIJ*XINT(I4-49)
                YINT(I4) = YINT(I4+294)+DYIJ*YINT(I4-49)
                ZINT(I4) = ZINT(I4+294)+DZIJ*ZINT(I4-49)
                I4 = I4+343
  380         CONTINUE
              I3 = I3+49
  400       CONTINUE
          END IF
          M = M+1
          FIRST1 = .FALSE.
  430   END DO
      END IF
C
C     ----- I(NI,NJ,NK,NL) -----
C
      IF (NLMAX .GT. 0) THEN
        I5 = K(MMAX+1)
        IA = I1
        NI = 0
        FIRST4 = .TRUE.
        DO 580 WHILE (FIRST4 .OR. NI .LE. NIMAX)
          NJ = 0
          IB = IA
          FIRST1 = .TRUE.
          DO 570 WHILE (FIRST1 .OR. NJ .LE. NJMAX)
            MIN = NKMAX
            FIRST2 = .TRUE.
            DO 530 WHILE (FIRST2 .OR. MIN .LT. MMAX)
              M = MMAX
              I3 = IB+I5
              FIRST3 = .TRUE.
              DO 520 WHILE (FIRST3 .OR. M .GT. MIN)
                I4 = IB+K(M)
                XINT(I3) = XINT(I3)+DXKL*XINT(I4)
                YINT(I3) = YINT(I3)+DYKL*YINT(I4)
                ZINT(I3) = ZINT(I3)+DZKL*ZINT(I4)
                I3 = I4
                M = M-1
                FIRST3 = .FALSE.
  520         END DO
              MIN = MIN+1
              FIRST2 = .FALSE.
  530       END DO
            IF (NKMAX .GT. 0) THEN
              I3 = IB+1
              DO 560 NL = 1,NLMAX
                I4 = I3
                DO 540 NK = 1,NKMAX
                  XINT(I4) = XINT(I4+6)+DXKL*XINT(I4-1)
                  YINT(I4) = YINT(I4+6)+DYKL*YINT(I4-1)
                  ZINT(I4) = ZINT(I4+6)+DZKL*ZINT(I4-1)
                  I4 = I4+7
  540           END DO
              I3 = I3+1
  560         END DO
            END IF
            NJ = NJ+1
            IB = IB+49
            FIRST1 = .FALSE.
  570     END DO
          NI = NI+1
          IA = IA+343
          FIRST4 = .FALSE.
  580   END DO
      END IF
C
      RETURN
      END
C*MODULE INT2A   *DECK ZPKOUT
      SUBROUTINE ZPKOUT(II,JJ,KK,LL,GHONDO,SKIPA,SKIPB,SKIPC,NPSYM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION GHONDO(*)
      DIMENSION IB(28),JB(28),KB(28),LB(28)
C
      LOGICAL SKIPA,SKIPB,SKIPC,NPSYM,IANDJ,KANDL,FIRST
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      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),MIN(MXSH),MAX(MXSH),NSHELL
      COMMON /SHLEXC/ NORGSH(3),NORGSP(3),IEXCH,NANGM,NGTH(4)
C
      PARAMETER (ZERO=0.0D+00)
C
      SAVE FIRST,IB,JB,KB,LB
      DATA FIRST/.TRUE./
C
C     ----- ZERO HONDO PK INTEGRAL FORMATION REGION -----
C
      IF(FIRST) THEN
         FIRST=.FALSE.
         DO 100 I=1,NANGM
            LB(I) = I-1
            KB(I) = LB(I) * NANGM
            JB(I) = KB(I) * NANGM
            IB(I) = JB(I) * NANGM
 100     CONTINUE
      END IF
C
      NORG1 = NORGSH(1)+1
      NORG2 = NORGSH(2)+1
      NORG3 = NORGSH(3)+1
C
      LIT = KTYPE(II)
      MINI = MIN(II)
      MAXI = MAX(II)
      MINJ = MIN(JJ)
      MAXJ = MAX(JJ)
      LKT = KTYPE(KK)
      MINK = MIN(KK)
      MAXK = MAX(KK)
      MINL = MIN(LL)
      MAXL = MAX(LL)
      IANDJ = II .EQ. JJ
      KANDL = KK .EQ. LL
C
C     TYPE = 1 FOR (II II II II)
C            2     (II JJ JJ JJ)
C            3     (II II KK KK) AND  LIT.GE.LKT
C            4     (II II KK KK) AND  LIT.LT.LKT
C            5     (II II II LL)
C            6     (II JJ KK KK)
C            7     (II JJ JJ LL)
C            8     (II II KK LL)
C            9     (II JJ KK LL)
C
      NTYP = 0
      IF(II.EQ.JJ .AND. JJ.EQ.KK .AND. KK.EQ.LL) NTYP = 1
      IF(II.GT.JJ .AND. JJ.EQ.KK .AND. KK.EQ.LL) NTYP = 2
      IF(II.EQ.JJ .AND. JJ.GT.KK .AND. KK.EQ.LL
     *                         .AND. LIT.GE.LKT) NTYP = 3
      IF(II.EQ.JJ .AND. JJ.GT.KK .AND. KK.EQ.LL
     *                         .AND. LIT.LT.LKT) NTYP = 4
      IF(II.EQ.JJ .AND. JJ.EQ.KK .AND. KK.GT.LL) NTYP = 5
      IF(II.GT.JJ .AND. JJ.GT.KK .AND. KK.EQ.LL) NTYP = 6
      IF(II.GT.JJ .AND. JJ.EQ.KK .AND. KK.GT.LL) NTYP = 7
      IF(II.EQ.JJ .AND. JJ.GT.KK .AND. KK.GT.LL) NTYP = 8
      IF(II.GT.JJ .AND. JJ.GT.KK .AND. KK.GT.LL) NTYP = 9
C
      IF(SKIPA .AND. .NOT.NPSYM) NORG2 = 1
      IF(SKIPC .AND. .NOT.NPSYM) NORG3 = NORGSH(2)+1
      IF(SKIPB .AND. .NOT.NPSYM) NORG3 = 1
C
C     ----- BEGIN LOOPS OVER PRIMITIVES IN THIS SHELL -----
C
C     INTEGRAL TYPES N1,G1 FOR (I,J//K,L)
C                    N2,G2 FOR (I,K//J,L)
C                    N3,G3 FOR (I,L//J,K)
C
C                      HONDO INTEGRALS
C        N1 = IB(IA)+JB(JA)+KB(KA)+LB(LA)+NORG1
C        N2 = IB(IA)+JB(KA)+KB(JA)+LB(LA)+NORG2
C
      JMAX = MAXJ
      KMAX = MAXK
      LMAX = MAXL
      DO 860 I = MINI,MAXI
      IA = I-MINI+1
      N1I = NORG1 + IB(IA)
      N2I = NORG2 + IB(IA)
C
      IF (IANDJ) JMAX = I
      DO 840 J = MINJ,JMAX
      IF (JJ .EQ. KK) KMAX = J
      JA = J-MINJ+1
      N1IJ = N1I + JB(JA)
      N2IJ = N2I + KB(JA)
C
      DO 820 K = MINK,KMAX
      KA = K-MINK+1
      N1IJK = N1IJ + KB(KA)
      N2IJK = N2IJ + JB(KA)
C
      IF (KANDL) LMAX = K
      DO 800 L = MINL,LMAX
      LA = L-MINL+1
      N1 = N1IJK + LB(LA)
      N2 = N2IJK + LB(LA)
C
      GO TO (200,220,230,250,270,280,290,300,310),NTYP
  200 IF (IA .EQ. JA) GO TO 210
      N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
      GO TO 400
  210 N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
      GO TO 400
  220 N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
      GO TO 400
  230 IF (IA .EQ. JA) GO TO 240
      N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
      GO TO 400
  240 N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
      GO TO 400
  250 IF (KA .EQ. LA) GO TO 260
      N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
      GO TO 400
  260 N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
      GO TO 400
  270 N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
      GO TO 400
  280 N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
      GO TO 400
  290 N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
      GO TO 400
  300 N3 = IB(JA)+JB(KA)+KB(IA)+LB(LA)+NORG3
      GO TO 400
  310 N3 = IB(IA)+JB(LA)+KB(JA)+LB(KA)+NORG3
C
  400 CONTINUE
      GHONDO(N1) = ZERO
      GHONDO(N2) = ZERO
      GHONDO(N3) = ZERO
  800 CONTINUE
  820 CONTINUE
  840 CONTINUE
  860 CONTINUE
      RETURN
      END
C*MODULE INT2A   *DECK ZQOUT
      SUBROUTINE ZQOUT(GHONDO)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION GHONDO(*)
C
      LOGICAL IANDJ,KANDL,SAME
C
      COMMON /INTDEX/ IJGT(784),IJX(784),IJY(784),IJZ(784),IK(784),
     *                KLGT(784),KLX(784),KLY(784),KLZ(784)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJX,IJ,KL,IJKL
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- ZERO HONDO CONVENTIONAL INTEGRAL OUTPUT REGION -----
C
      IJN = 0
      JMAX = MAXJ
      DO 260 I = MINI,MAXI
         IF (IANDJ) JMAX = I
         DO 240 J = MINJ,JMAX
            IJN = IJN+1
            N1 = IJGT(IJN)
            LMAX = MAXL
            KLN = 0
            DO 220 K =  MINK,MAXK
               IF (KANDL) LMAX = K
               DO 200 L = MINL,LMAX
                  KLN = KLN+1
                  IF (SAME .AND. KLN .GT. IJN) GO TO 240
                  NN = N1+KLGT(KLN)
                  GHONDO(NN) = ZERO
  200          CONTINUE
  220       CONTINUE
  240    CONTINUE
  260 CONTINUE
      RETURN
      END
C*MODULE INT2A   *DECK INT2EIC
      SUBROUTINE INT2EIC(IMODE)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL PACK2E
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PCKLAB/ LABSIZ
      SAVE NEED
C
C     INITIALISE(IMODE=0)/FINALISE(IMODE=1) IN CORE 2E INTEGRALS
C     IF NINTIC IS NEGATIVE,
C         IT IS ASSUMED TO BE THE MEMORY AMOUNT TO BE USED
C     IF NINTIC IS POSITIVE,
C         IT IS THE NUMBER OF INTEGRALS TO BE STORED IN CORE
C     IF NINTIC IS 0,
C         NONE OF THE INTEGRALS WILL BE STORED IN CORE.
C
C     GAMESS SEEMS TO PAY NO ATTENTION ALLOCATING INTEGRAL INDEX
C     BUFFER IGNORING LABSIZ. BELOW WE DO STRICTLY CORRECT USAGE
C     ALLOCATING MINIMUM POSSIBLE SIZE. IT MAY NOT WORK IF WHEREVER
C     IN-CORE INTEGRALS ARE USED THE BUFFERS ARE REUSED FOR SOMETHING
C     ELSE WITH INCORRECT ASSUMPTION ABOUT THE SIZE SINCE THE BUFFERS
C     ALLOCATED BELOW WILL BE USED INSTEAD OF WHATEVER IS ALLOCATED
C     IN THE MAIN BODY.
C     SEE ALSO OPTFMOX IF MEMORY ALLOCATION IN THIS SUBROUTINE CHANGES.
C
      IF(NINTIC.EQ.0) RETURN
      LABSIZ2=2/LABSIZ
      IF(LABSIZ.NE.1.AND.LABSIZ.NE.2) CALL ABRT
C     THIS WILL WORK FOR LABSIZ=1 AND 2 (ONLY).
C
      IF(NINTIC.LT.0) NINTIC=(-NINTIC*LABSIZ2)/(LABSIZ2+1)
C
C     ININTIC IS USED TO ADDRESS INTEGER ARRAYS TO PROPERLY SHIFT
C     INDICES, HAVING THEM POINTING WHERE DISK DRIVEN INTEGRALS START
C
      ININTIC=NINTIC
      IF(LABSIZ.EQ.2.AND.NWDVAR.EQ.2) ININTIC=NINTIC*2
      IF(LABSIZ.EQ.1.AND.NWDVAR.EQ.1) THEN
        IF(MOD(NINTIC,2).EQ.1) THEN
C         IT IS NOT THAT DIFFICULT TO IMPLEMENT THIS
C         (ADD SHIFTING 4 BYTES IN ADDRESSING 8-BYTE INTEGERS INDICES),
C         BUT WHY BOTHER?
          NINTIC=NINTIC-1
C         IF(MASWRK) WRITE(IW,9020)
C         CALL ABRT
C       ELSE
        ENDIF
        ININTIC=NINTIC/2
      ENDIF
      IF(IMODE.EQ.0) THEN
        CALL VALFM(LOADFM)
        LBUFPIC= LOADFM + 1
        LIXIC=   LBUFPIC+ NINTMX+NINTIC
        LAST=    LIXIC  + (NINTMX+NINTIC-1)/LABSIZ2+1
        NEED=    LAST - LOADFM - 1
        CALL GETFM(NEED)
        IF(MASWRK) WRITE(IW,9000) NEED
      ELSE
        CALL RETFM(NEED)
        IF(MASWRK) WRITE(IW,9010)
      ENDIF
 9000 FORMAT(/1X,'ALLOCATED ',I12,' WORDS FOR IN CORE 2E INTEGRALS.',/)
 9010 FORMAT(1X,'RETURNED IN CORE 2E INTEGRAL BUFFER.',/)
C9020 FORMAT(/1X,'PLEASE SELECT AN EVEN NINTIC IF ',
C    *          'LABSIZ.EQ.1.AND.NWDVAR.EQ.1',/)
      RETURN
      END
