C 22 FEB 06 - MWS - FIX ALL THE BOOKKEEPING TO MATCH H,I CHANGES
C 19 SEP 05 - GDF - ADJUST COMMON BLOCKS FOR H AND I FUNCTIONS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL, ROOT
C 10 NOV 04 - MWS - LEX: USE SHLEXC COMMON
C  7 SEP 04 - CHC - LINEAR SCALING EXCHANGE GRADIENT FOR HF AND HYBRID
C                   DFT, LEX: MODIFY TEST VALUES
C                   SYMMETRY ADAPTED LINEAR SCALING COULOMB
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C 28 JUL 03 - CHC - LINEAR SCALING COULOMB GRADIENT OPTION
C                   NEW MULTIPOLE GENERATION CODE THAT DOES NOT USE HDD
C                   NEW Y*Z ROUTINES
C  3 JUN 03 - CHC - NEARJ: RESET LOAD BALANCE COUNTER AT END
C 15 MAY 03 - CHC - ENABLE DFT QFMM JOBS TO PROCEED
C 28 JAN 03 - MWS - KEEP ARGS FOR SHELLS ROUTINE CONSISTENT
C  7 AUG 02 - CHC - NEARJ: FIX TO ALLOW FOR DFT
C 25 OCT 01 - MWS - QFMMIN: USE D.P. INSTEAD OF C*8 DECLARATIONS
C  6 SEP 01 - CHC - NEW MODULE FOR QFMM (QUANTUM FAST MULTIPOLE
C                   METHOD). THIS IS THE MAIN DRIVER FOR QUANTUM PART.
C                   DUE TO THE MULTIPOLE APPROXIMATION, THE STANDARD
C                   INTEGRAL ROUTINES NEEDED TO BE MODIFIED.
C
C*MODULE QMFM    *DECK QFMMUP
      SUBROUTINE QFMMUP(LL2,LS,NSHL2,LSLIST,NSHELL,LSLN,LTS,
     *     NCXYZ,LCXYZ,LIYP,LIBS,LISP,LIPP,LIDXWS,LINDX,MAXWS,
     *     MAXNYP,NSH2,LIDXSHL,LPNTR,NBOX,NTBOX,LCLM,LFLM,
     *     LAST,LIDXBOX,LMBOX,LEBOX,LNBR,LNUMWS,LYZPNT,LTMPGPS,
     *     LTMPGPL,NEED1,NEED,LAST1,LINDX2,LINDX3,
     *     LIDXIJK,LPTBL,LYZTBL,NSBOX,NTMPL,
     *     MTIJ,MIJKL,LYP,LZP,LITSP,LITPP,LITSP2,
     *     LITPP2,IJTPP,KLTPP,IJSPP,KLSPP,IJTBLP,IJTBL,LAST2,NEED2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL QFMM,QOPS
C
      COMMON /FMCOM / X(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /QMFM  / SIZE,EPSLN,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /QFMLEX/ MAXGP
C
C     GET TABLE FOR 1-ELECTRON INTEGRAL
      CALL GXYZLM
C
      CALL INITQFMM(LL2,X(LS),NSHL2,X(LSLIST),NSHELL,X(LSLN),X(LTS),
     *     NCXYZ,X(LCXYZ),X(LIYP),X(LIBS),X(LISP),X(LIPP),X(LIDXWS),
     *     X(LINDX),MAXWS,MAXNYP,NSH2,X(LIDXSHL),X(LPNTR),NBOX,NTBOX,
     *     X(LCLM),X(LFLM))
C
C     ON THE BASIS OF NTBOX, RESERVE FAST MEMORY FOR FMM PART OF QFMM
C
      LIDXBOX = 1        + LAST
      LMBOX   = LIDXBOX + 3*(NTBOX+1)/NWDVAR+1
      LEBOX   = LMBOX   + (NTBOX+1)/NWDVAR+1
      LNBR    = LEBOX   + (NTBOX+1)/NWDVAR+1
      LNUMWS  = LNBR    + (MAXWS*2+1)**3/NWDVAR+1
      LYZPNT  = LNUMWS  + MAXWS/2*(NTBOX+1)/NWDVAR+1
      LTMPGPS = LYZPNT  + MAXWS/2*(NTBOX+1)/NWDVAR+1
      LTMPGPL = LTMPGPS + MAXNYP*(NP+1)*(NP+2)
      LAST1   = LTMPGPL + MAXNYP*(NP+1)*(NP+2)
      NEED1   = LAST1   - LAST
      CALL GETFM(NEED1)
      NEED=NEED+NEED1
C
      CALL INITFMM(NCXYZ,X(LCXYZ),X(LINDX),X(LINDX2),X(LINDX3),
     *     MAXWS,X(LIDXWS),X(LIDXIJK),X(LPNTR),
     *     X(LPTBL),X(LYZTBL),NTBOX,X(LIDXBOX),X(LMBOX),
     *     X(LEBOX),X(LNUMWS),X(LYZPNT),NSBOX,NTMPL)
C
      CALL MAXJK(NTBOX,X(LIDXBOX),X(LMBOX),X(LEBOX),NSBOX,X(LYZTBL),
     *           X(LNBR),MAXWS,X(LNUMWS),X(LYZPNT),MTIJ,MIJKL)
C
      LYP    = 1      + LAST1
      LZP    = LYP    + (NP+1)*(NP+2)*NTMPL
      LITSP  = LZP    + (NP+1)*(NP+2)*NTMPL
      LITPP  = LITSP  + MIJKL*2/NWDVAR
      LITSP2 = LITPP  + MIJKL*2/NWDVAR
      LITPP2 = LITSP2 + MIJKL*2/NWDVAR
      IJTPP  = LITPP2 + MIJKL*2/NWDVAR
      KLTPP  = IJTPP  + 2*MAXGP/NWDVAR
      IJSPP  = KLTPP  + 2*MAXGP/NWDVAR
      KLSPP  = IJSPP  + 2*MAXGP/NWDVAR
      IJTBLP= KLSPP  + 2*MAXGP/NWDVAR
      IJTBL = IJTBLP+ (MAXGP+1)/NWDVAR+1
      LAST2  = IJTBL + (MAXGP*NSHL2)/NWDVAR+1
      NEED2  = LAST2  - LAST1
C
      RETURN
      END
C*MODULE QMFM    *DECK INITPRMT
      SUBROUTINE INITPRMT(NCXYZ,MQOPS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION INTCT
      LOGICAL QFMM,OUT,QOPS,GOPARR,DSKWRK,MASWRK
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TEN=1.0D+01)
      PARAMETER (E=2.30258D+00,TWO=2.0D+00)
      PARAMETER (SLOPE=-0.962780401D+00,INTCT=3.105952915D+00)
      PARAMETER (MXATM=2000)
      PARAMETER (MAXQATM=100)
      PARAMETER (MAXNP=45)
C
      LOGICAL SLQFMM
C
      COMMON /SLFM  / SLQFMM,IQMATM(MAXQATM),NSLQMATM,SLQMCTR(3),SLRDS,
     *                SLTRNS(3)
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /IQMFM / SCLF,ITGERR,IEPS,IDPGD
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      DIMENSION VMAX(3)
C
      CALL QDIAMTR(SIZE,NAT,C,VMAX)
      DIMTR=SIZE
C
C     IF QOPS=.TRUE., ICUT, ITOL, IEPS,IDPGD, D ARE DETERMINED, WHERE D
C     IS THE DIMENSION OF THE SYSTEM.
C     IF MQOPS=0, THE ROUTINE FURTHER DETERMINES, SCLF AND NS.
C     IF MQOPS=1, USER SHOULD PROVIDE SCLF AND NS.
C
      IF (QOPS) THEN
         ICUT=INT(INTCT-SLOPE*ITGERR+1)
         IF (ICUT.LT.ZERO) ICUT=0
         ITOL=ICUT+4
C
C        TOL : GAUSSIAN DISTRIBUTION CUTOFF
C        CUTOFF : INTEGRAL CUTOFF OF DIRECT SCF
C
         TOL = E*ITOL
         CUTOFF = ONE/(TEN**ICUT)/TWO
C
         CALL NZXYZ(NCXYZ,NYP)
C
         IEPS=ICUT
         IDPGD=ITGERR+1
         DPGD=ONE/(TEN**IDPGD)
         EPS=ONE/(TEN**IEPS)
         ID=INT(VMAX(1)+VMAX(2)+VMAX(3))
         IF (ID.EQ.0) ID=1
         IF (MQOPS.EQ.1) THEN
            SIZE=SIZE*SCLF
         ENDIF
            BOXSIZE=SIZE/2**NS
            TR=IWS+1.0D+00
            NP=IGETNP(EPS,TR,BOXSIZE)
         IF (MQOPS.EQ.0) THEN
            CALL SQOPS(NYP,EPS,ID,SCLF,NCXYZ)
         ENDIF
      ELSE
         DPGD=ONE/(TEN**IDPGD)
         EPS=ONE/(TEN**IEPS)
         CALL NZXYZ(NCXYZ,NYP)
      ENDIF
C
C   SLQFMM OPTION
C
      IF (SLQFMM) THEN
         IF (SIZE.LE.(DIMTR+2*SIZE/2**NS)) THEN
            S_OLD=SIZE
  500       S_NEW=(DIMTR+2*S_OLD/2**NS)*1.01D+00
            IF (S_NEW.GT.(DIMTR+2*S_NEW/2**NS)) GOTO 1000
            S_OLD=S_NEW
            GOTO 500
 1000       SIZE=S_NEW
         ENDIF
         CALL SLDISP
      ENDIF
C
      IF (MASWRK) WRITE(IW,9000) QOPS,ID,SIZE,NP,NS,
     *   IWS,IDPGD,IEPS,ISCUT,ITOL,ICUT,ITGERR,SCLF,MQOPS,
     *   NCXYZ,NYP,SLQFMM,MPMTHD
C
C     CHECK IF THE PARAMETERS ARE OK.
C
      IF ((NP.GT.MAXNP).AND.MASWRK) THEN
         WRITE(IW,9100) NP,MAXNP
         CALL ABRT
      ENDIF
C
      RETURN
 9000 FORMAT(/5X,'$FMM OPTIONS'/5X,12(1H-)/
     *  5X,7HQOPS  =,L8,5X,7HD     =,I8,5X,7HCUBE  =,F8.2/
     *  5X,7HNP    =,I8,5X,7HNS    =,I8,5X,7HMINWS =,I8/
     *  5X,7HIDPGD =,I8,5X,7HIEPS  =,I8,5X,7HISCUT =,I8/
     *  5X,7HITOL  =,I8,5X,7HICUT  =,I8,5X,7HITGERR=,I8/
     *  5X,7HSCLF  =,F8.2,5X,7HMQOPS =,I8,5X,7HNCXYZ =,I8/
     *  5X,7HNTP   =,I8,5X,7HSLQFMM=,L8,5X,7HMODE  =,I8/)
 9100 FORMAT(/5X,'$FMM ERROR'/5X,12(1H-)/
     *  5X,'NP=',I4,' EXCEEDS THE MAXIMUM NP=',I4/
     *  5X,'THERE IS A PROBLEM IN FMM PARAMETER SETTINGS'/)
      END
C*MODULE QMFM    *DECK INITQFMM
      SUBROUTINE INITQFMM(L2,S,NSHL2,LDST,ISHELL,LSHL,TS,NCXYZ,CXYZ,
     *     IYP,IBS,ISP,IPP,IDXWS,INDX,MAXWS,MAXNYP,NSH2,IDXSHL,IPNTR,
     *     NBOX,NTBOX,CLM,FLM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL QFMM,QOPS,GOPARR,DSKWRK,MASWRK
      PARAMETER (MAXQATM=100)
C
      LOGICAL SLQFMM
C
      COMMON /SLFM  / SLQFMM,IQMATM(MAXQATM),NSLQMATM,SLQMCTR(3),SLRDS,
     *                SLTRNS(3)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
C
      DIMENSION S(L2),TS(ISHELL),LDST(NSHL2),LSHL(ISHELL+1)
      DIMENSION CXYZ(NCXYZ,3),IYP(NCXYZ),
     *          INDX(NCXYZ),IBS(NCXYZ,4),ISP(NCXYZ,2),
     *          IPP(NCXYZ,2),IDXWS(NCXYZ)
      DIMENSION IDXSHL(NSH2+1)
      DIMENSION IPNTR(2**NS,3),FLM(-NP:NP),CLM(-NP:NP)
C
C     SORTS RETURNS THE SIGNIFICANT SHELL PAIRS(LDST) THAT ARE PRESECTED
C     BY USING OVERLAP INTERGRAL(S) AND PREORDERED BY THE SIZE OF THE
C     INTEGRAL ESTIMATE. THE SIZE OF LDST IS NSHELL*NSHELL.
C     LDST IS USED IN THE LINEAR EXCHANGE ROUTINE LEX TO ACHIEVE LINEAR
C     SCALING CONSTRUCTIONS OF EXCHANGE MATRIX(K).
C
      CALL SORTS(S,L2,LDST,NSHL2,LSHL,TS,ISHELL)
      CALL QMPM(NCXYZ,CXYZ,IYP,IBS,ISP,IPP,IDXWS,MAXWS,MAXNYP,
     *      IDXSHL,NSH2,NYP)
      IFLG=2**NS
      IF ( MAXWS.GT.IFLG ) THEN
         IF(MASWRK) WRITE(IW,*) 'NS MUST BE GREATER THAN',NS,'!!'
         IF(MASWRK) WRITE(IW,*) 'THIS MEANS THE PROBLEM AT HAND IS NOT'
         IF(MASWRK) WRITE(IW,*) 'BIG ENOUGH TO USE QFMM EFFECTIVELY.'
         CALL ABRT
      ENDIF
C
C     SLQFMM OPTION ---- SHIFTING ENTIRE SYSTEM FOR FMM
C
      IF (SLQFMM) THEN
         DO I=1,NCXYZ
            CXYZ(I,1)=CXYZ(I,1)+SLTRNS(1)
            CXYZ(I,2)=CXYZ(I,2)+SLTRNS(2)
            CXYZ(I,3)=CXYZ(I,3)+SLTRNS(3)
         ENDDO
      ENDIF
C
      CALL GETCLM(CLM)
      CALL GETFLM(FLM)
      CALL INITIDX(NCXYZ,INDX)
C
C     GET THE NUMBER OF NON-EMPTY BOX (NBOX) IN THE LOWEST
C     SUBDIVISION LEVEL.
C
      CALL GETNBOX(NCXYZ,CXYZ,INDX,IDXWS,IPNTR,NBOX)
      CALL UPPBOX(NBOX,NTBOX)
C
      RETURN
C9500 FORMAT(/10X,40(1H-)/10X,
C    *40HQUANTUM FAST MULTIPOLE (QFMM) STATISTICS/10X,40(1H-))
C9510 FORMAT(/10X,
C    *'THE HIGEST MULTIPOLE MOMENT IN QFMM  : ',9X,I6,
C    */10X,'THE LEVEL OF MAXIMUM SUB-DIVISION    : ',9X,I6)
      END
C*MODULE QMFM    *DECK QFMMBOX
      SUBROUTINE QFMMBOX(NCXYZ,NMAXBOX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL QFMM,QOPS
C
      COMMON /FMCOM / X(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
C
C        RETURNS MAXIMUM NUMBER OF BOXES -NMAXBOX-
C
      CALL VALFM(LOADFM)
      LCXYZ  = LOADFM + 1
      LINDX  = LCXYZ  + NCXYZ*3
      LIDXWS = LINDX  + NCXYZ/NWDVAR+1
      LPNTR  = LIDXWS + NCXYZ/NWDVAR+1
      LAST   = LPNTR  + 3*2**NS/NWDVAR+1
      NEED  = LAST -LOADFM -1
      CALL GETFM(NEED)
      CALL GENCRD(NCXYZ,X(LCXYZ))
      CALL GETNBOX(NCXYZ,X(LCXYZ),X(LINDX),X(LIDXWS),X(LPNTR),NBOX)
      CALL RETFM(NEED)
      NMAXBOX=NBOX
C
      RETURN
      END
C*MODULE QMFM    *DECK INITFMM
      SUBROUTINE INITFMM(NCXYZ,CXYZ,INDX,INDX2,INDX3,
     *                   MAXWS,IDXWS,IDXIJK,IPNTR,ITBL,IYZTBL,
     *                   NTBOX,IDXBOX,MBOX,LEBOX,NUMWS,IYZPNT,NSBOX,
     *                   NTMPL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL QFMM,QOPS,GOPARR,DSKWRK,MASWRK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DIMENSION CXYZ(NCXYZ,3),INDX(NCXYZ),INDX2(NCXYZ),INDX3(NCXYZ),
     *          IDXWS(NCXYZ),IDXIJK(NCXYZ,3),
     *          IPNTR(2**NS,3),
     *          ITBL(2**(NS+1)-1,2**(NS+1)-1,2**(NS+1)-1),
     *          IYZTBL(2**(NS+1)-1,2**(NS+1)-1,2**(NS+1)-1)
      DIMENSION IDXBOX(3,NTBOX),MBOX(NTBOX),LEBOX(0:NTBOX),
     *          IYZPNT(NTBOX,MAXWS/2),NUMWS(NTBOX,MAXWS/2),NSBOX(20)
C
      DATA CHECK/8HCHECK   /
C
      CALL DIVIDE(NCXYZ,CXYZ,INDX,IPNTR,ITBL,
     *     NTBOX,IDXBOX,MBOX,LEBOX,
     *     NSBOX,IDXWS,MAXNB,IDXIJK)
      CALL SORTWS(NCXYZ,INDX,INDX2,INDX3,IDXWS,
     *     CXYZ,NTBOX,MBOX,NSBOX,MAXWS,NUMWS,NTMPL)
      CALL CMPTBL(ITBL,IYZTBL,NTBOX,IDXBOX,MBOX,
     *     NSBOX,MAXWS,NUMWS,IYZPNT,NTMPL)
C
      IF(EXETYP.EQ.CHECK) GO TO 800
C
  800 CONTINUE
      IF(MASWRK) WRITE(IW,9530)
      CALL TIMIT(1)
      RETURN
C
 9530 FORMAT(1X,'.... DONE INITIALIZING QFMM COMPUTATION ....')
      END
C*MODULE QMFM    *DECK IMAXJ
      INTEGER FUNCTION IMAXJ(I,J)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      IMAXJ=I
      IF (J.GT.I) IMAXJ=J
C
      RETURN
      END
C*MODULE QMFM    *DECK DERFINV
      DOUBLE PRECISION FUNCTION DERFINV(Y)
C
C     DERFINV : THIS ROUTINE RETURNS THE INVERSE ERROR FUNCTION OF Y.
C     THE DOMAIN IS -1 <= Y <= 1
C     HOWEVER Y SHOULD NOT BE -1 AND 1, SINCE THEY CORRESPOND POSITIVE
C     AND NEGATIVE INFINITIES.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (A1= 0.886226899D+00,A2=-1.645349621D+00,
     *           A3= 0.914624893D+00,A4=-0.140543331D+00)
      PARAMETER (B1=-2.118377725D+00,B2= 1.442710462D+00,
     *           B3=-0.329097515D+00,B4= 0.012229801D+00)
      PARAMETER (C1=-1.970840454D+00,C2=-1.624906493D+00,
     *           C3= 3.429567803D+00,C4= 1.641345311D+00)
      PARAMETER (D1= 3.543889200D+00,D2= 1.637067800D+00)
      PARAMETER (ONE=1.0D+00,TWO=2.0D+00)
C
      Y0=0.7D+00
      IF (ABS(Y).LE.Y0) THEN
         Z=Y*Y
         DERFINV=((A4*Z+A3)*Z+A2)*Z+A1
         DERFINV=Y*DERFINV/((((B4*Z+B3)*Z+B2)*Z+B1)*Z+ONE)
      ELSEIF ( (Y0.LT.Y).AND.(Y.LT.ONE) ) THEN
         Z=SQRT(-LOG((ONE-Y)/TWO))
         DERFINV=((C4*Z+C3)*Z+C2)*Z+C1
         DERFINV=DERFINV/((D2*Z+D1)*Z+ONE)
      ELSEIF ( (-Y0.GT.Y).AND.(Y.GT.-ONE) ) THEN
         Z=SQRT(-LOG((ONE+Y)/TWO))
         DERFINV=((C4*Z+C3)*Z+C2)*Z+C1
         DERFINV=-DERFINV/((D2*Z+D1)*Z+1)
      ENDIF
C
C     ONE CAN FURTHER INCREASE THE ACCURACY OF THIS ROUTINE BY
C     USING NEWTON-RAPHSON CORRECTION.
C     HOWEVER THAT WOULD MAKE THIS ROUTINE 3 TIMES SLOWER.
C     THE ACCURACY WITHOUT THE CORRECTION IS ABOUT 6 DIGITS.
C
      RETURN
      END
C*MODULE QMFM    *DECK NZXYZ
      SUBROUTINE NZXYZ(NCXYZ,NYP)
C
C     NCXYZ: NUMBER OF NUN-ZERO PRODUCT OF PRIMITIVE GAUSSIANS.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000,MXGTOT=20000,MXATM=2000)
      PARAMETER (RLN10=2.30258D+00)
C
      LOGICAL IANDJ
C
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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
      TOL=RLN10*ITOL
C
      NCXYZ=0
      NYP=0
C
C     FIRST SHELL LOOP.
C
      DO II=1,NSHELL
         I=KATOM(II)
         XI=C(1,I)
         YI=C(2,I)
         ZI=C(3,I)
         I1=KSTART(II)
         I2=I1+KNG(II)-1
         MINI=KMIN(II)
         MAXI=KMAX(II)
C
C
C    SECOND SHELL LOOP.
C
         DO JJ=1,II
            J=KATOM(JJ)
            XJ=C(1,J)
            YJ=C(2,J)
            ZJ=C(3,J)
            J1=KSTART(JJ)
            J2=J1+KNG(JJ)-1
            MINJ=KMIN(JJ)
            MAXJ=KMAX(JJ)
            RR=(XI-XJ)*(XI-XJ)+(YI-YJ)*(YI-YJ)+(ZI-ZJ)*(ZI-ZJ)
            IANDJ=II.EQ.JJ
C
C
C           I PRIMITIVE.
C
            JGMAX=J2
            DO IG=I1,I2
               AI=EX(IG)
               ARRI=AI*RR
C           J PRIMITIVE.
               IF(IANDJ) JGMAX=IG
               DO JG=J1,JGMAX
                  AJ=EX(JG)
                  AA=AI+AJ
                  DUM=AJ*ARRI/AA
                  IF(DUM.GT.TOL) GO TO 6000
C
                  NCXYZ=NCXYZ+1
                  MAX=MAXJ
                  DO I=MINI,MAXI
                     IF(IANDJ)MAX=I
                     DO J=MINJ,MAX
                        NYP=NYP+1
                     ENDDO
                  ENDDO
C
6000           ENDDO
            ENDDO
         ENDDO
      ENDDO
C
      RETURN
      END
C*MODULE QMFM    *DECK GENCRD
      SUBROUTINE GENCRD(NXYZ,CXYZ)
C
C     NCXYZ: NUMBER OF NUN-ZERO PRODUCT OF PRIMITIVE GAUSSIANS.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000,MXGTOT=20000,MXATM=2000)
      PARAMETER (RLN10=2.30258D+00)
C
      LOGICAL IANDJ
C
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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
      DIMENSION CXYZ(NXYZ,3)
C
      TOL=RLN10*ITOL
C
      NCXYZ=0
C
C     FIRST SHELL LOOP.
C
      DO II=1,NSHELL
         I=KATOM(II)
         XI=C(1,I)
         YI=C(2,I)
         ZI=C(3,I)
         I1=KSTART(II)
         I2=I1+KNG(II)-1
C
C
C    SECOND SHELL LOOP.
C
         DO JJ=1,II
            J=KATOM(JJ)
            XJ=C(1,J)
            YJ=C(2,J)
            ZJ=C(3,J)
            J1=KSTART(JJ)
            J2=J1+KNG(JJ)-1
            RR=(XI-XJ)*(XI-XJ)+(YI-YJ)*(YI-YJ)+(ZI-ZJ)*(ZI-ZJ)
            IANDJ=II.EQ.JJ
C
C
C           I PRIMITIVE.
C
            JGMAX=J2
            DO IG=I1,I2
               AI=EX(IG)
               ARRI=AI*RR
               AXI=AI*XI
               AYI=AI*YI
               AZI=AI*ZI
C           J PRIMITIVE.
               IF(IANDJ) JGMAX=IG
               DO JG=J1,JGMAX
                  AJ=EX(JG)
                  AA=AI+AJ
                  DUM=AJ*ARRI/AA
                  IF(DUM.GT.TOL) GO TO 6000
                  AX=(AXI+AJ*XJ)/AA
                  AY=(AYI+AJ*YJ)/AA
                  AZ=(AZI+AJ*ZJ)/AA
C
                  NCXYZ=NCXYZ+1
                  CXYZ(NCXYZ,1)=AX
                  CXYZ(NCXYZ,2)=AY
                  CXYZ(NCXYZ,3)=AZ
C
6000           ENDDO
            ENDDO
         ENDDO
      ENDDO
C
      RETURN
      END
C*MODULE QMFM    *DECK QMPM
      SUBROUTINE QMPM(NCXYZ,CXYZ,IYP,IBS,
     *                ISP,IPP,IDXWS,MAXWS,MAXNYP,IDXSHL,NSH2,NYP)
C
C     THIS ROUTINE SETS THE WS INDEX FOR EACH PAIR OF PRIMIVITE
C     GAUSSIANS AND COMPLETES THE LOOK-UP TABLES FOR LATER CALCULATIONS.
C
C     ICXYZ: TWO-DIMENSIONAL ARRAY OF PRIMITIVE GAUSSIAN PAIR INDEX
C           MATRIX.
C     CXYZ: THE CENTER OF PRODUCT OF PRIMITIVE GAUSSIANS.
C     YP  : MULTIPOLE REPRESENTATIONS OF PRODUCT OF PRIMITIVE GAUSSIANS.
C           NOTE IT IS COMPLEX.
C     NCXYZ: NUMBER OF NUN-ZERO PRODUCT OF PRIMITIVE GAUSSIANS. THIS
C            WILL BE REPLACED WITH A NEW ONE IN THIS ROUTINE.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000,MXGTOT=20000,MXATM=2000)
      PARAMETER (RLN10=2.30258D+00)
      PARAMETER (ONE=1.0D+00)
C
      LOGICAL IANDJ,GOPARR,DSKWRK,MASWRK,QFMM,QOPS
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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 /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /QFMLEX/ MAXGP
C
      DIMENSION CXYZ(NCXYZ,3),IYP(NCXYZ),IDXSHL(NSH2+1),
     *          IBS(NCXYZ,4),ISP(NCXYZ,2),
     *          IPP(NCXYZ,2),IDXWS(NCXYZ)
C
      TOL=RLN10*ITOL
C
      MAXWS=IWS
C
C     ZEROING OUT
C
      NKP=0
      NYP=0
      MAXNYP=0
      DO ILKP=1,NCXYZ
         IYP(ILKP)=0
      ENDDO
      NNCXYZ=NCXYZ
      NCXYZ=0
C
C     COMPUTE BASE EXTENT AND PRINT OUT THE RESULTS.
C     THE FOLLOWING LINE REQUIRES INVERSE ERROR FUNCTION, DERFINV.
C
      BEX=SQRT(2.0D+00)*DERFINV(ONE-DPGD)
      BOXSIZE=SIZE/2**NS
C
      IDXSHL(1)=0
      IPSHL=0
      ICSHL=1
C
C     FIRST SHELL LOOP.
C
      DO II=1,NSHELL
         I=KATOM(II)
         XI=C(1,I)
         YI=C(2,I)
         ZI=C(3,I)
         I1=KSTART(II)
         I2=I1+KNG(II)-1
         MINI=KMIN(II)
         MAXI=KMAX(II)
C
C        SECOND SHELL LOOP.
C
         DO JJ=1,II
            J=KATOM(JJ)
            XJ=C(1,J)
            YJ=C(2,J)
            ZJ=C(3,J)
            J1=KSTART(JJ)
            J2=J1+KNG(JJ)-1
            MINJ=KMIN(JJ)
            MAXJ=KMAX(JJ)
            RR=(XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
            IANDJ=II.EQ.JJ
            ICSHL=ICSHL+1
            IF ( (KNG(II)*KNG(JJ)).GT.MAXGP ) MAXGP=KNG(II)*KNG(JJ)
C
C           PREPARE INDICES FOR PAIRS OF (I,J) FUNCTIONS.
C
            MAX=MAXJ
C
C           I PRIMITIVE.
C
C    IJP : INDEX OF PRIMITIVE PAIR
C
            IJP=0
            JGMAX=J2
            DO IG=I1,I2
               IGP=IG-I1+1
               AI=EX(IG)
               ARRI=AI*RR
               AXI=AI*XI
               AYI=AI*YI
               AZI=AI*ZI
C              J PRIMITIVE.
               IF(IANDJ) JGMAX=IG
               DO JG=J1,JGMAX
                  JGP=JG-J1+1
                  AJ=EX(JG)
                  AA=AI+AJ
                  DUM=AJ*ARRI/AA
                  NKP=NKP+1
                  IF(DUM.GT.TOL) GO TO 6000
                  IJP=IJP+1
                  AX=(AXI+AJ*XJ)/AA
                  AY=(AYI+AJ*YJ)/AA
                  AZ=(AZI+AJ*ZJ)/AA
                  NCXYZ=NCXYZ+1
                  IF(NCXYZ.GT.NNCXYZ) THEN
                     IF(MASWRK) WRITE(IW,*) 'QMPM: PROBLEM WITH NCXYZ'
                     CALL ABRT
                  END IF
                  CXYZ(NCXYZ,1)=AX
                  CXYZ(NCXYZ,2)=AY
                  CXYZ(NCXYZ,3)=AZ
                  IREXT=2*(INT(BEX/(SQRT(AA)*BOXSIZE)))
                  IDXWS(NCXYZ)=IMAXJ(IREXT,IWS)
                  IF (IDXWS(NCXYZ).GT.MAXWS) MAXWS=IDXWS(NCXYZ)
C
                  MAX=MAXJ
                  NN=0
                  DO I=MINI,MAXI
                     IF(IANDJ)MAX=I
                     DO J=MINJ,MAX
                        NN=NN+1
C
                        NYP=NYP+1
                     ENDDO
                  ENDDO
C
C
C     THE FOLLOWING ARRAYS ARE NEEDED, SINCE QUANTUM CALCULATION
C     REQUIRES SPECIFIC INDICES OF BASIS SETS AND SHELL PAIRS.
C     NCXYZ        : THE NUMBER OF TOTAL MULTIPOLE.
C     IBS(NCXYZ,4) : CONTAINS THE RANGE OF BASIS SET INDICES OF A GIVEN
C                    MULTIPOLE.
C     IPP(NCXYZ,2) : CONTAINS PRIMITIVE INDICES OF A GIVEN MULTIPOLE.
C     ISP(NCXYZ,2) : CONTAINS THE SHELL INDICES OF A GIVEN MULTIPOLE.
C     IYP(NCXYZ)   : CONTAINS THE POINTER OF A GIVEN MULTIPOLE.
C
C                 BASIS INFO
                  IF (NN.GT.MAXNYP) MAXNYP=NN
                  IBS(NCXYZ,1)=KLOC(II)
                  IBS(NCXYZ,2)=KLOC(II)+MAXI-MINI
                  IBS(NCXYZ,3)=KLOC(JJ)
                  IBS(NCXYZ,4)=KLOC(JJ)+MAXJ-MINJ
C                 PRIMITIVE INFO
                  IPP(NCXYZ,1)=IGP
                  IPP(NCXYZ,2)=JGP
C                 SHELL INFO
                  ISP(NCXYZ,1)=II
                  ISP(NCXYZ,2)=JJ
                  IYP(NCXYZ)=NYP
6000           ENDDO
            ENDDO
C           END OF PRIMITIVE GAUSSIAN PAIR
            IPSHL=IPSHL+IJP
            IDXSHL(ICSHL)=IPSHL
         ENDDO
      ENDDO
C
      RETURN
C9000 FORMAT(
C    *10X,'THE LENGTH OF THE CUBE               : ',F15.10,
C    */10X,'THE LENGTH OF THE SMALLEST CUBE      : ',F15.10)
C9100 FORMAT(10X,
C    *'NUMBER OF PRIMITIVE GAUSSIAN PRODUCT :      ',I10,
C    */10X,'NUMBER OF POINTS                     :      ',I10,
C    */10X,'THE MAXIUM IWS                       :      ',I10)
      END
C*MODULE QMFM    *DECK FORMJK
      SUBROUTINE FORMJK(SCFTYP,IA,DA,FA,DB,FB,GHONDO,L2,NINT,NXYZ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,UROHF
C
      DIMENSION IA(*),DA(*),FA(*),DB(*),FB(*),GHONDO(*)
C
      PARAMETER (MXAO=8192)
      LOGICAL QFMM,QOPS
      COMMON /QMFM  /SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *       ITERMS,QOPS,ISCUT
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NORB,NCONF(MXAO),NHAM
      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 /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
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      DATA HALF /0.5D+00/
      DATA RHF,UHF,ROHF/8HRHF     ,8HUHF     ,8HROHF     /
      DATA GVB/8HGVB     /
C
C-NEXT STATEMENT IS FOR VARIOUS IBM XLF 3.X AND 5.X COMPILERS-
C
      SAVE IJN,KLN
C
C     ----- FORM FOCK OPERATOR DIRECTLY FROM INTEGRALS -----
C     THIS ROUTINE WAS PIECED TOGETHER FROM QOUT AND HSTAR
C     BY FRANK JENSEN AT ODENSE UNIVERSITY IN MARCH 1990.
C     SCF FUNCTIONS BESIDES RHF ADDED BY MWS IN AUGUST 1991.
C
C     NOTE THAT OFF-DIAGONAL ELEMENTS WILL NEED TO BE HALVED LATER.
C
      HFSCAL=DFTTYP(3)
      UROHF = SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF
      CUTINT = CUTOFF/ISCUT
C
      IF(SCFTYP.EQ.GVB) THEN
         NSHL = NHAM
         IF(NCO.GT.0) NSHL=NSHL-1
      END IF
C
      IJN = 0
      JMAX = MAXJ
      DO 360 I = MINI,MAXI
         IF (IANDJ) JMAX = I
         DO 340 J = MINJ,JMAX
            IJN = IJN+1
            N1 = IJGT(IJN)
            LMAX = MAXL
            KLN = 0
            DO 320 K =  MINK,MAXK
               IF (KANDL) LMAX = K
               DO 300 L = MINL,LMAX
                  KLN = KLN+1
                  IF(SAME .AND. KLN.GT.IJN) GO TO 340
                  NN = N1+KLGT(KLN)
                  VAL = GHONDO(NN)
C
                  IF(ABS(VAL).LT.CUTINT) GO TO 300
                  NINT = NINT + 1
C
                  II = LOCI+I
                  JJ = LOCJ+J
                  KK = LOCK+K
                  LL = LOCL+L
                  IF (II .GE. JJ) GO TO 100
                  N = II
                  II = JJ
                  JJ = N
  100             IF (KK .GE. LL) GO TO 120
                  N = KK
                  KK = LL
                  LL = N
  120             IF (II-KK) 140,160,180
  140             N = II
                  II = KK
                  KK = N
                  N = JJ
                  JJ = LL
                  LL = N
                  GO TO 180
  160             IF (JJ .LT. LL) GO TO 140
  180             CONTINUE
C
                  IF(II.EQ.JJ) VAL = VAL*HALF
                  IF(KK.EQ.LL) VAL = VAL*HALF
                  IF(II.EQ.KK  .AND.  JJ.EQ.LL) VAL = VAL*HALF
C
C      WE NOW HAVE EVERYTHING READY, PUT INTEGRALS INTO FOCK MATRIX
C
                  NIJ = IA(II)+JJ
                  NKL = IA(KK)+LL
                  NIK = IA(II)+KK
                  NIL = IA(II)+LL
                  NJK = IA(JJ)+KK
                  NJL = IA(JJ)+LL
                  IF(JJ.LT.KK) NJK = IA(KK)+JJ
                  IF(JJ.LT.LL) NJL = IA(LL)+JJ
C
                  VAL2 = VAL+VAL
                  VAL4 = (VAL2+VAL2)*QQ4
C
C       NXYZ DISTINGUISHES CODE FOR RHF OR RHF RESPONSE EQUATIONS
C
C       HFSCAL DISTINGUISHES CODE FOR HF OR DFT
C
                  IF(HFSCAL .EQ. 1.0D+00) THEN
                  IF(SCFTYP.EQ.RHF) THEN
                     IF(NXYZ.EQ.1) THEN
                        FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                        FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        FA(NIK) = FA(NIK)- VAL*DA(NJL)
                        FA(NIL) = FA(NIL)- VAL*DA(NJK)
                        FA(NJK) = FA(NJK)- VAL*DA(NIL)
                        FA(NJL) = FA(NJL)- VAL*DA(NIK)
                     ELSE
                        NIJ = (NIJ-1)*NXYZ+1
                        NKL = (NKL-1)*NXYZ+1
                        NIK = (NIK-1)*NXYZ+1
                        NIL = (NIL-1)*NXYZ+1
                        NJK = (NJK-1)*NXYZ+1
                        NJL = (NJL-1)*NXYZ+1
                        DO 210 IXYZ=0,NXYZ-1
                          FA(NIJ+IXYZ) = FA(NIJ+IXYZ)+VAL4*DA(NKL+IXYZ)
                          FA(NKL+IXYZ) = FA(NKL+IXYZ)+VAL4*DA(NIJ+IXYZ)
                          FA(NIK+IXYZ) = FA(NIK+IXYZ)- VAL*DA(NJL+IXYZ)
                          FA(NIL+IXYZ) = FA(NIL+IXYZ)- VAL*DA(NJK+IXYZ)
                          FA(NJK+IXYZ) = FA(NJK+IXYZ)- VAL*DA(NIL+IXYZ)
                          FA(NJL+IXYZ) = FA(NJL+IXYZ)- VAL*DA(NIK+IXYZ)
  210                   CONTINUE
                     END IF
                  END IF
C
                  IF(UROHF) THEN
                     DUM = VAL4*(DA(NKL)+DB(NKL))
                     FA(NIJ) = FA(NIJ)+DUM
                     FB(NIJ) = FB(NIJ)+DUM
                     DUM = VAL4*(DA(NIJ)+DB(NIJ))
                     FA(NKL) = FA(NKL)+DUM
                     FB(NKL) = FB(NKL)+DUM
                     FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                     FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                     FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                     FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                     FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                     FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                     FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                     FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                  END IF
C
                  IF(SCFTYP.EQ.GVB) THEN
                     IF(NCO.GT.0) THEN
                        FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                        FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        FA(NIK) = FA(NIK)-VAL *DA(NJL)
                        FA(NIL) = FA(NIL)-VAL *DA(NJK)
                        FA(NJK) = FA(NJK)-VAL *DA(NIL)
                        FA(NJL) = FA(NJL)-VAL *DA(NIK)
                        IOFF1 = L2
                        IOFF2 = L2
                     ELSE
                        IOFF1 = 0
                        IOFF2 = 0
                     END IF
                     DO 220 IFO = 1,NSHL
                        FA(NIJ+IOFF1)    = FA(NIJ+IOFF1)
     *                              + VAL4*DA(NKL+IOFF2)
                        FA(NKL+IOFF1)    = FA(NKL+IOFF1)
     *                              + VAL4*DA(NIJ+IOFF2)
                        FA(NIK+IOFF1+L2) = FA(NIK+IOFF1+L2)
     *                              + VAL *DA(NJL+IOFF2)
                        FA(NIL+IOFF1+L2) = FA(NIL+IOFF1+L2)
     *                              + VAL *DA(NJK+IOFF2)
                        FA(NJK+IOFF1+L2) = FA(NJK+IOFF1+L2)
     *                              + VAL *DA(NIL+IOFF2)
                        FA(NJL+IOFF1+L2) = FA(NJL+IOFF1+L2)
     *                              + VAL *DA(NIK+IOFF2)
                        IOFF1 = IOFF1+L2+L2
                        IOFF2 = IOFF2+L2
  220                CONTINUE
                  END IF
                  ELSE
C
C                 DFT CASE
C
                  IF(SCFTYP.EQ.RHF) THEN
                     IF(NXYZ.EQ.1) THEN
                        FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                        FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        FA(NIK) = FA(NIK)- VAL*DA(NJL)*HFSCAL
                        FA(NIL) = FA(NIL)- VAL*DA(NJK)*HFSCAL
                        FA(NJK) = FA(NJK)- VAL*DA(NIL)*HFSCAL
                        FA(NJL) = FA(NJL)- VAL*DA(NIK)*HFSCAL
                     ELSE
                        NIJ = (NIJ-1)*NXYZ+1
                        NKL = (NKL-1)*NXYZ+1
                        NIK = (NIK-1)*NXYZ+1
                        NIL = (NIL-1)*NXYZ+1
                        NJK = (NJK-1)*NXYZ+1
                        NJL = (NJL-1)*NXYZ+1
                        DO 310 IXYZ=0,NXYZ-1
                          FA(NIJ+IXYZ) = FA(NIJ+IXYZ)+VAL4*DA(NKL+IXYZ)
                          FA(NKL+IXYZ) = FA(NKL+IXYZ)+VAL4*DA(NIJ+IXYZ)
                          FA(NIK+IXYZ) = FA(NIK+IXYZ)- VAL*DA(NJL+IXYZ)
     *                                                          *HFSCAL
                          FA(NIL+IXYZ) = FA(NIL+IXYZ)- VAL*DA(NJK+IXYZ)
     *                                                          *HFSCAL
                          FA(NJK+IXYZ) = FA(NJK+IXYZ)- VAL*DA(NIL+IXYZ)
     *                                                          *HFSCAL
                          FA(NJL+IXYZ) = FA(NJL+IXYZ)- VAL*DA(NIK+IXYZ)
     *                                                          *HFSCAL
  310                   CONTINUE
                     END IF
                  END IF
C
                  IF(UROHF) THEN
                     DUM = VAL4*(DA(NKL)+DB(NKL))
                     FA(NIJ) = FA(NIJ)+DUM
                     FB(NIJ) = FB(NIJ)+DUM
                     DUM = VAL4*(DA(NIJ)+DB(NIJ))
                     FA(NKL) = FA(NKL)+DUM
                     FB(NKL) = FB(NKL)+DUM
                     FA(NIK) = FA(NIK)-VAL2*DA(NJL)*HFSCAL
                     FB(NIK) = FB(NIK)-VAL2*DB(NJL)*HFSCAL
                     FA(NIL) = FA(NIL)-VAL2*DA(NJK)*HFSCAL
                     FB(NIL) = FB(NIL)-VAL2*DB(NJK)*HFSCAL
                     FA(NJK) = FA(NJK)-VAL2*DA(NIL)*HFSCAL
                     FB(NJK) = FB(NJK)-VAL2*DB(NIL)*HFSCAL
                     FA(NJL) = FA(NJL)-VAL2*DA(NIK)*HFSCAL
                     FB(NJL) = FB(NJL)-VAL2*DB(NIK)*HFSCAL
                  END IF
C
                  IF(SCFTYP.EQ.GVB) THEN
                    WRITE(IW,*)'DIRECT GVB DFT NOT IMPLEMENTED'
                    CALL ABRT()
C                   I COULDN'T FIGURE OUT THE DO 220 LOOP  :-)
                  END IF
                  END IF
C
  300          CONTINUE
  320       CONTINUE
  340    CONTINUE
  360 CONTINUE
      RETURN
      END
C*MODULE QMFM    *DECK FORMJ
      SUBROUTINE FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                  L2,NINT,NXYZ,IFLAG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,UROHF
C
      DIMENSION IA(*),DA(*),FA(*),DB(*),FB(*),GHONDO(*)
C
      PARAMETER (MXAO=8192)
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NORB,NCONF(MXAO),NHAM
      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 /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
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      DATA HALF /0.5D+00/
      DATA RHF,UHF,ROHF/8HRHF     ,8HUHF     ,8HROHF     /
      DATA GVB/8HGVB     /
C
C-NEXT STATEMENT IS FOR VARIOUS IBM XLF 3.X AND 5.X COMPILERS-
C
      SAVE IJN,KLN
C
C     ----- FORM FOCK OPERATOR DIRECTLY FROM INTEGRALS -----
C     THIS ROUTINE WAS PIECED TOGETHER FROM QOUT AND HSTAR
C     BY FRANK JENSEN AT ODENSE UNIVERSITY IN MARCH 1990.
C     SCF FUNCTIONS BESIDES RHF ADDED BY MWS IN AUGUST 1991.
C
C     NOTE THAT OFF-DIAGONAL ELEMENTS WILL NEED TO BE HALVED LATER.
C
      HFSCAL=DFTTYP(3)
      UROHF = SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF
      CUTINT = CUTOFF
C
      IF(SCFTYP.EQ.GVB) THEN
         NSHL = NHAM
         IF(NCO.GT.0) NSHL=NSHL-1
      END IF
C
      IJN = 0
      ITFLAG=IFLAG
      JMAX = MAXJ
      DO 360 I = MINI,MAXI
         IF (IANDJ) JMAX = I
         DO 340 J = MINJ,JMAX
            IJN = IJN+1
            N1 = IJGT(IJN)
            LMAX = MAXL
            KLN = 0
            DO 320 K =  MINK,MAXK
               IF (KANDL) LMAX = K
               DO 300 L = MINL,LMAX
                  IFLAG=ITFLAG
                  KLN = KLN+1
                  IF(SAME .AND. KLN.GT.IJN) GO TO 340
                  NN = N1+KLGT(KLN)
                  VAL = GHONDO(NN)
C
                  IF(ABS(VAL).LT.CUTINT) GO TO 300
                  NINT = NINT + 1
C
                  II = LOCI+I
                  JJ = LOCJ+J
                  KK = LOCK+K
                  LL = LOCL+L
                  IF (II .GE. JJ) GO TO 100
                  N = II
                  II = JJ
                  JJ = N
  100             IF (KK .GE. LL) GO TO 120
                 N = KK
                  KK = LL
                  LL = N
  120         IF (II-KK) 140,160,180
  140             N = II
                  II = KK
                  KK = N
                  N = JJ
                  JJ = LL
                  LL = N
                    IF (IFLAG.EQ.2) THEN
                       IFLAG=3
                    ELSEIF (IFLAG.EQ.3) THEN
                       IFLAG=2
                    ENDIF
                  GO TO 180
  160             IF (JJ .LT. LL) GOTO 140
  180             CONTINUE
C
                  IF(II.EQ.JJ) VAL = VAL*HALF
                  IF(KK.EQ.LL) VAL = VAL*HALF
                  IF(II.EQ.KK  .AND.  JJ.EQ.LL) VAL = VAL*HALF
C
C      WE NOW HAVE EVERYTHING READY, PUT INTEGRALS INTO FOCK MATRIX
C
                  NIJ = IA(II)+JJ
                  NKL = IA(KK)+LL
C
                  VAL2 = VAL+VAL
                  VAL4 = (VAL2+VAL2)*QQ4
C
C       NXYZ DISTINGUISHES CODE FOR RHF OR RHF RESPONSE EQUATIONS
C
C       HFSCAL DISTINGUISHES CODE FOR HF OR DFT
C
                  IF(HFSCAL .EQ. 1.0D+00) THEN
                  IF(SCFTYP.EQ.RHF) THEN
                     IF(NXYZ.EQ.1) THEN
                        IF (IFLAG.EQ.1) THEN
                           FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                           FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        ELSEIF (IFLAG.EQ.2) THEN
                           FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                        ELSEIF (IFLAG.EQ.3) THEN
                           FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        ENDIF
                        IFLAG=ITFLAG
                     ELSE
                        NIJ = (NIJ-1)*NXYZ+1
                        NKL = (NKL-1)*NXYZ+1
                        DO 210 IXYZ=0,NXYZ-1
                        IF (IFLAG.EQ.1) THEN
                          FA(NIJ+IXYZ) = FA(NIJ+IXYZ)+VAL4*DA(NKL+IXYZ)
                          FA(NKL+IXYZ) = FA(NKL+IXYZ)+VAL4*DA(NIJ+IXYZ)
                        ELSEIF (IFLAG.EQ.2) THEN
                          FA(NIJ+IXYZ) = FA(NIJ+IXYZ)+VAL4*DA(NKL+IXYZ)
                        ELSEIF (IFLAG.EQ.3) THEN
                          FA(NKL+IXYZ) = FA(NKL+IXYZ)+VAL4*DA(NIJ+IXYZ)
                        ENDIF
                        IFLAG=ITFLAG
  210                   CONTINUE
                     END IF
                  END IF
C
                  IF(UROHF) THEN
                     IF (IFLAG.EQ.1) THEN
                        DUM = VAL4*(DA(NKL)+DB(NKL))
                        FA(NIJ) = FA(NIJ)+DUM
                        FB(NIJ) = FB(NIJ)+DUM
                        DUM = VAL4*(DA(NIJ)+DB(NIJ))
                        FA(NKL) = FA(NKL)+DUM
                        FB(NKL) = FB(NKL)+DUM
                     ELSEIF (IFLAG.EQ.2) THEN
                        DUM = VAL4*(DA(NKL)+DB(NKL))
                        FA(NIJ) = FA(NIJ)+DUM
                        FB(NIJ) = FB(NIJ)+DUM
                     ELSEIF (IFLAG.EQ.3) THEN
                        DUM = VAL4*(DA(NIJ)+DB(NIJ))
                        FA(NKL) = FA(NKL)+DUM
                        FB(NKL) = FB(NKL)+DUM
                     ENDIF
                     IFLAG=ITFLAG
                  END IF
C
                  IF(SCFTYP.EQ.GVB) THEN
                     IF(NCO.GT.0) THEN
                        IF (IFLAG.EQ.1) THEN
                           FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                           FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        ELSEIF (IFLAG.EQ.2) THEN
                           FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                        ELSEIF (IFLAG.EQ.3) THEN
                           FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        ENDIF
                        IFLAG=ITFLAG
                        IOFF1 = L2
                        IOFF2 = L2
                     ELSE
                        IOFF1 = 0
                        IOFF2 = 0
                        IFLAG=ITFLAG
                     END IF
                     DO 220 IFO = 1,NSHL
                        IF (IFLAG.EQ.1) THEN
                           FA(NIJ+IOFF1)    = FA(NIJ+IOFF1)
     *                              + VAL4*DA(NKL+IOFF2)
                           FA(NKL+IOFF1)    = FA(NKL+IOFF1)
     *                              + VAL4*DA(NIJ+IOFF2)
                        ELSEIF (IFLAG.EQ.2) THEN
                           FA(NIJ+IOFF1)    = FA(NIJ+IOFF1)
     *                              + VAL4*DA(NKL+IOFF2)
                        ELSEIF (IFLAG.EQ.3) THEN
                           FA(NKL+IOFF1)    = FA(NKL+IOFF1)
     *                              + VAL4*DA(NIJ+IOFF2)
                        ENDIF
                        IFLAG=ITFLAG
                        IOFF1 = IOFF1+L2+L2
                        IOFF2 = IOFF2+L2
  220                CONTINUE
                  END IF
                  ELSE
C
C                 DFT CASE
C
                  IF(SCFTYP.EQ.RHF) THEN
                     IF(NXYZ.EQ.1) THEN
                        IF (IFLAG.EQ.1) THEN
                           FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                           FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        ELSEIF (IFLAG.EQ.2) THEN
                           FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                        ELSEIF (IFLAG.EQ.3) THEN
                           FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                        ENDIF
                        IFLAG=ITFLAG
                     ELSE
                        NIJ = (NIJ-1)*NXYZ+1
                        NKL = (NKL-1)*NXYZ+1
                        DO 310 IXYZ=0,NXYZ-1
                           IF (IFLAG.EQ.1) THEN
                           FA(NIJ+IXYZ) = FA(NIJ+IXYZ)+VAL4*DA(NKL+IXYZ)
                           FA(NKL+IXYZ) = FA(NKL+IXYZ)+VAL4*DA(NIJ+IXYZ)
                           ELSEIF (IFLAG.EQ.2) THEN
                           FA(NIJ+IXYZ) = FA(NIJ+IXYZ)+VAL4*DA(NKL+IXYZ)
                           ELSEIF (IFLAG.EQ.3) THEN
                           FA(NKL+IXYZ) = FA(NKL+IXYZ)+VAL4*DA(NIJ+IXYZ)
                           ENDIF
                           IFLAG=ITFLAG
  310                   CONTINUE
                     END IF
                  END IF
C
                  IF(UROHF) THEN
                     IF (IFLAG.EQ.1) THEN
                        DUM = VAL4*(DA(NKL)+DB(NKL))
                        FA(NIJ) = FA(NIJ)+DUM
                        FB(NIJ) = FB(NIJ)+DUM
                        DUM = VAL4*(DA(NIJ)+DB(NIJ))
                        FA(NKL) = FA(NKL)+DUM
                        FB(NKL) = FB(NKL)+DUM
                     ELSEIF (IFLAG.EQ.2) THEN
                        DUM = VAL4*(DA(NKL)+DB(NKL))
                        FA(NIJ) = FA(NIJ)+DUM
                        FB(NIJ) = FB(NIJ)+DUM
                     ELSEIF (IFLAG.EQ.3) THEN
                        DUM = VAL4*(DA(NIJ)+DB(NIJ))
                        FA(NKL) = FA(NKL)+DUM
                        FB(NKL) = FB(NKL)+DUM
                     ENDIF
                     IFLAG=ITFLAG
                  END IF
C
                  IF(SCFTYP.EQ.GVB) THEN
                    WRITE(IW,*) 'DIRECT GVB DFT NOT IMPLEMENTED'
                    CALL ABRT()
C                   I COULDN'T FIGURE OUT THE DO 220 LOOP  :-)
                  END IF
                  END IF
C
  300          CONTINUE
  320       CONTINUE
  340    CONTINUE
  360 CONTINUE
      RETURN
      END
C*MODULE QMFM    *DECK FORMK
      SUBROUTINE FORMK(SCFTYP,IEXCH,POPLE,IA,DA,FA,DB,FB,GHONDO,
     *                  L2,NINT,NXYZ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,POPLE,UROHF
C
      DIMENSION IA(*),DA(*),FA(*),DB(*),FB(*),GHONDO(*)
      DIMENSION IBPOP(4,4)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXAO=8192)
C
      LOGICAL QFMM,QOPS
      COMMON /QMFM  /SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *       ITERMS,QOPS,ISCUT
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /FLIPS / IB(4,3)
      COMMON /GOUT  / GPOPLE(768),NORGP
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NORB,NCONF(MXAO),NHAM
      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 /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 /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,
     *                NIJX,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      DATA IBPOP/0,0,0,0,64,16,4,1,128,32,8,2,192,48,12,3/
      DATA HALF /0.5D+00/
      DATA RHF,UHF,ROHF/8HRHF     ,8HUHF     ,8HROHF     /
      DATA GVB/8HGVB     /
C
C-NEXT STATEMENT IS FOR VARIOUS IBM XLF 3.X AND 5.X COMPILERS-
C
      SAVE IJN,KLN,IBB,JBB,KBB,LBB
C
C     ----- FORM FOCK OPERATOR DIRECTLY FROM INTEGRALS -----
C     THIS ROUTINE WAS PIECED TOGETHER FROM QOUT AND HSTAR
C     BY FRANK JENSEN AT ODENSE UNIVERSITY IN MARCH 1990.
C     SCF FUNCTIONS BESIDES RHF ADDED BY MWS IN AUGUST 1991.
C
C     NOTE THAT OFF-DIAGONAL ELEMENTS WILL NEED TO BE HALVED LATER.
C
      HFSCAL=DFTTYP(3)
      UROHF = SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF
      CUTINT = CUTOFF/ISCUT
C
      IF(SCFTYP.EQ.GVB) THEN
         NSHL = NHAM
         IF(NCO.GT.0) NSHL=NSHL-1
      END IF
C
      IF(POPLE) THEN
         SAME = ISH .EQ. KSH .AND. JSH .EQ. LSH
         IBB  = IB(1,IEXCH)
         JBB  = IB(2,IEXCH)
         KBB  = IB(3,IEXCH)
         LBB  = IB(4,IEXCH)
         MINI = KMIN(ISH)
         MINJ = KMIN(JSH)
         MINK = KMIN(KSH)
         MINL = KMIN(LSH)
         MAXI = KMAX(ISH)
         MAXJ = KMAX(JSH)
         MAXK = KMAX(KSH)
         MAXL = KMAX(LSH)
         IANDJ = ISH .EQ. JSH
         KANDL = KSH .EQ. LSH
         LOCI = KLOC(ISH)-MINI
         LOCJ = KLOC(JSH)-MINJ
         LOCK = KLOC(KSH)-MINK
         LOCL = KLOC(LSH)-MINL
      END IF
C
      IJN = 0
      JMAX = MAXJ
      DO 360 I = MINI,MAXI
         IF (IANDJ) JMAX = I
         DO 340 J = MINJ,JMAX
            IJN = IJN+1
            IF(POPLE) THEN
               N1 = IBPOP(IBB,I)+IBPOP(JBB,J)+1
            ELSE
               N1 = IJGT(IJN)
            END IF
            LMAX = MAXL
            KLN = 0
            DO 320 K =  MINK,MAXK
               IF (KANDL) LMAX = K
               DO 300 L = MINL,LMAX
                  KLN = KLN+1
                  IF(SAME .AND. KLN.GT.IJN) GO TO 340
                  IF(POPLE) THEN
                     NN = N1+IBPOP(KBB,K)+IBPOP(LBB,L)
                     VAL = GPOPLE(NN)
                  ELSE
                     NN = N1+KLGT(KLN)
                     VAL = GHONDO(NN)
                  END IF
C
                  IF(ABS(VAL).LT.CUTINT) GO TO 300
                  NINT = NINT + 1
C
                  II = LOCI+I
                  JJ = LOCJ+J
                  KK = LOCK+K
                  LL = LOCL+L
                  IF (II .GE. JJ) GO TO 100
                  N = II
                  II = JJ
                  JJ = N
  100             IF (KK .GE. LL) GO TO 120
                  N = KK
                  KK = LL
                  LL = N
  120             IF (II-KK) 140,160,180
  140             N = II
                  II = KK
                  KK = N
                  N = JJ
                  JJ = LL
                  LL = N
                  GO TO 180
  160             IF (JJ .LT. LL) GO TO 140
  180             CONTINUE
C
                  IF(II.EQ.JJ) VAL = VAL*HALF
                  IF(KK.EQ.LL) VAL = VAL*HALF
                  IF(II.EQ.KK  .AND.  JJ.EQ.LL) VAL = VAL*HALF
C
C      WE NOW HAVE EVERYTHING READY, PUT INTEGRALS INTO FOCK MATRIX
C
                  NIK = IA(II)+KK
                  NIL = IA(II)+LL
                  NJK = IA(JJ)+KK
                  NJL = IA(JJ)+LL
                  IF(JJ.LT.KK) NJK = IA(KK)+JJ
                  IF(JJ.LT.LL) NJL = IA(LL)+JJ
C
                  VAL2 = VAL+VAL
C
C       NXYZ DISTINGUISHES CODE FOR RHF OR RHF RESPONSE EQUATIONS
C
C       HFSCAL DISTINGUISHES CODE FOR HF OR DFT
C
                  IF(HFSCAL .EQ. 1.0D+00) THEN
                  IF(SCFTYP.EQ.RHF) THEN
                     IF(NXYZ.EQ.1) THEN
                        FA(NIK) = FA(NIK)- VAL*DA(NJL)
                        FA(NIL) = FA(NIL)- VAL*DA(NJK)
                        FA(NJK) = FA(NJK)- VAL*DA(NIL)
                        FA(NJL) = FA(NJL)- VAL*DA(NIK)
                    ELSE
                        NIK = (NIK-1)*NXYZ+1
                        NIL = (NIL-1)*NXYZ+1
                        NJK = (NJK-1)*NXYZ+1
                        NJL = (NJL-1)*NXYZ+1
                        DO 210 IXYZ=0,NXYZ-1
                          FA(NIK+IXYZ) = FA(NIK+IXYZ)- VAL*DA(NJL+IXYZ)
                          FA(NIL+IXYZ) = FA(NIL+IXYZ)- VAL*DA(NJK+IXYZ)
                          FA(NJK+IXYZ) = FA(NJK+IXYZ)- VAL*DA(NIL+IXYZ)
                          FA(NJL+IXYZ) = FA(NJL+IXYZ)- VAL*DA(NIK+IXYZ)
  210                   CONTINUE
                     END IF
                  END IF
C
                  IF(UROHF) THEN
                     FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                     FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                     FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                     FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                     FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                     FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                     FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                     FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                  END IF
C
                  IF(SCFTYP.EQ.GVB) THEN
                     IF(NCO.GT.0) THEN
                        FA(NIK) = FA(NIK)-VAL *DA(NJL)
                        FA(NIL) = FA(NIL)-VAL *DA(NJK)
                        FA(NJK) = FA(NJK)-VAL *DA(NIL)
                        FA(NJL) = FA(NJL)-VAL *DA(NIK)
                        IOFF1 = L2
                        IOFF2 = L2
                     ELSE
                        IOFF1 = 0
                        IOFF2 = 0
                     END IF
                     DO 220 IFO = 1,NSHL
                        FA(NIK+IOFF1+L2) = FA(NIK+IOFF1+L2)
     *                              + VAL *DA(NJL+IOFF2)
                        FA(NIL+IOFF1+L2) = FA(NIL+IOFF1+L2)
     *                              + VAL *DA(NJK+IOFF2)
                        FA(NJK+IOFF1+L2) = FA(NJK+IOFF1+L2)
     *                              + VAL *DA(NIL+IOFF2)
                        FA(NJL+IOFF1+L2) = FA(NJL+IOFF1+L2)
     *                              + VAL *DA(NIK+IOFF2)
                        IOFF1 = IOFF1+L2+L2
                        IOFF2 = IOFF2+L2
  220                CONTINUE
                  END IF
                  ELSE
C
C                 DFT CASE
C
                  IF(SCFTYP.EQ.RHF) THEN
                     IF(NXYZ.EQ.1) THEN
                        FA(NIK) = FA(NIK)- VAL*DA(NJL)*HFSCAL
                        FA(NIL) = FA(NIL)- VAL*DA(NJK)*HFSCAL
                        FA(NJK) = FA(NJK)- VAL*DA(NIL)*HFSCAL
                        FA(NJL) = FA(NJL)- VAL*DA(NIK)*HFSCAL
                     ELSE
                        NIK = (NIK-1)*NXYZ+1
                        NIL = (NIL-1)*NXYZ+1
                        NJK = (NJK-1)*NXYZ+1
                        NJL = (NJL-1)*NXYZ+1
                        DO 310 IXYZ=0,NXYZ-1
                          FA(NIK+IXYZ) = FA(NIK+IXYZ)- VAL*DA(NJL+IXYZ)
     *                                                          *HFSCAL
                          FA(NIL+IXYZ) = FA(NIL+IXYZ)- VAL*DA(NJK+IXYZ)
     *                                                          *HFSCAL
                          FA(NJK+IXYZ) = FA(NJK+IXYZ)- VAL*DA(NIL+IXYZ)
     *                                                          *HFSCAL
                          FA(NJL+IXYZ) = FA(NJL+IXYZ)- VAL*DA(NIK+IXYZ)
     *                                                          *HFSCAL
  310                   CONTINUE
                     END IF
                  END IF
C
                  IF(UROHF) THEN
                     FA(NIK) = FA(NIK)-VAL2*DA(NJL)*HFSCAL
                     FB(NIK) = FB(NIK)-VAL2*DB(NJL)*HFSCAL
                     FA(NIL) = FA(NIL)-VAL2*DA(NJK)*HFSCAL
                     FB(NIL) = FB(NIL)-VAL2*DB(NJK)*HFSCAL
                     FA(NJK) = FA(NJK)-VAL2*DA(NIL)*HFSCAL
                     FB(NJK) = FB(NJK)-VAL2*DB(NIL)*HFSCAL
                     FA(NJL) = FA(NJL)-VAL2*DA(NIK)*HFSCAL
                     FB(NJL) = FB(NJL)-VAL2*DB(NIK)*HFSCAL
                  END IF
C
                  IF(SCFTYP.EQ.GVB) THEN
                    WRITE(IW,*)'DIRECT GVB DFT NOT IMPLEMENTED'
                    CALL ABRT()
C                   I COULDN'T FIGURE OUT THE DO 220 LOOP  :-)
                  END IF
                  END IF
C
  300          CONTINUE
  320       CONTINUE
  340    CONTINUE
  360 CONTINUE
      RETURN
      END
C*MODULE QMFM    *DECK QFMMIN
      SUBROUTINE QFMMIN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (ONE=1.0D+00)
      PARAMETER (MAXQATM=100)
C
      LOGICAL DIRSCF,FDIFF,GOPARR,DSKWRK,MASWRK,OK,QFMM,QOPS
      LOGICAL SLQFMM
C
      DOUBLE PRECISION METHOD,DISK,TERMS,JMTX,KMTX,JADK
      CHARACTER*1 TAG(7)
C
      COMMON /SLFM  / SLQFMM,IQMATM(MAXQATM),NSLQMATM,SLQMCTR(3),SLRDS,
     *                SLTRNS(3)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /IQMFM / SCLF,ITGERR,IEPS,IDPGD
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      PARAMETER (NNAM=15)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA FMM  /8HFMM     /
      DATA QNAM /8HNP      ,8HNS      ,8HIWS     ,8HIDPGD   ,8HIEPS    ,
     *8HMETHOD  ,8HNUMRD   ,8HTERMS   ,8HQOPS    ,8HISCUT   ,8HITGERR  ,
     *8HSCLF    ,8HMQOPS   ,8HSLQFMM  ,8HIQMATM  /
      DATA KQNAM/1,1,1,1,1,5,1,5,0,1,1,3,1,0,1/
C
      DATA DISK/8HDISK    /
      DATA JMTX,KMTX,JADK /8HCOULOMB ,8HEXCHANGE,8HJANDK   /
      DATA RHF,UHF,ROHF/8HRHF     ,8HUHF     ,8HROHF    /
      DATA RNONE,NONE/8HNONE    ,4HNONE/
      DATA TAG/'S','P','D','F','G','H','I'/
C
      KQNAM(15) = 10*7*MAXQATM + 1
      DO I=1,MAXQATM
         IQMATM(I)=0
      ENDDO
C
C     DEFAULT VALUES
C
C     ITGERR : TARGET ERROR OF 10**(-ITGERR) IN HF ENERGY.
C     NP     : THE HIGHEST ORDER OF MULTIPOLE EXPANSION
C     NS     : THE SUBDIVISION LEVEL OF QFMM
C     IWS    : DEFAULT WELL-SEPARATENESS
C     IEPS   : TARGET ERROR IN FMM ENERGY
C     IDPGD  : TARGET ERROR IN GAUSSIAN DISTRIBUTION DUE TO POINT
C              CHARGE APPROX.
C     ISCUT  : DIVISION FACTOR DUE TO QFMM
C     METHOD : MULTIPOLE SAVE OPTION
C     TERMS  : COULOMB ONLY, EXCHANGE ONLY OR BOTH
C     NUMRD  : WHEN METHOD <=1, DETERMINES CACHE OF READING DISK FILE.
C     SLQFMM : SPATIAL LOCALIZATION OPTION
C
      ITGERR=7
      NP=15
      NS=2
      IWS=2
      IEPS=9
      IDPGD=9
      ISCUT=5
      METHOD=DISK
      MPMTHD=0
      TERMS=JADK
      NUMRD=1
      SCLF=ONE
      QOPS=.TRUE.
      MQOPS=0
      SLQFMM=.FALSE.
      NSLQMATM=0
C
C     ----- READ NAMELIST -$FMM -----
C
      JRET = 0
      CALL NAMEIO(IR,JRET,FMM,NNAM,QNAM,KQNAM,
     *            NP,NS,IWS,IDPGD,IEPS,METHOD,NUMRD,TERMS,QOPS,ISCUT,
     *            ITGERR,SCLF,MQOPS,SLQFMM,
     *     IQMATM,0,0,0,0,   0,0,0,0,0,
     *     0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0,
     *     0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0)
C
C     DOES NOT SUPPORT THESE OPTIONS
      NUMRD=1
C
C     ----- SLQFMM OPTIONS -----
C
C      IF (ITGERR.LE.4) IWS=1
      IF (SLQFMM) THEN
         DO I=1,MAXQATM
            IF (IQMATM(I).NE.0) NSLQMATM=NSLQMATM+1
         ENDDO
         CALL SLCTR
      ENDIF
C
C     ----- DETERMINE MULTIPOLE SAVE OPTION -----
C
C      IF (METHOD.EQ.DISK) MPMTHD=0
C      IF (METHOD.EQ.SEMI) MPMTHD=1
C      IF (METHOD.EQ.FULL) MPMTHD=2
C
C     CURRENTLY ONLY SUPPORT METHOD 2
C
       MPMTHD=2
C
C     ----- DETERMINE THE TERMS TO BE COMPUTED -----
C
C      ITERMS=0
      IF (TERMS.EQ.JADK) ITERMS=0
      IF (TERMS.EQ.JMTX) ITERMS=1
      IF (TERMS.EQ.KMTX) ITERMS=2
C
C          ERROR CHECKING
C
      NERR=0
      IF (.NOT.DIRSCF) THEN
         IF (MASWRK) WRITE(IW,9100)
         NERR=NERR+1
      ENDIF
C
C     NPGP RETURN THE HIGHEST ANGULAR MOMENTUM PRESENT IN THE BASIS.
C     NOTE KTYPE=1,2,3,4,5,6,7 MEANS S, P(L), D, F, G, H, I FUNCTION.
C     CURRENTLY QFMM SUPPORTS ONLY UP TO D.
C     NOTE THAT BASCHK RETURNS MAXIMUM KTYPE-1, WHICH IS THE TRUE
C     ANGLUAR MOMENTUM
C
      CALL BASCHK(NPGP)
      IF (NPGP.GE.4) THEN
         IF (MASWRK) WRITE(IW,9200) TAG(NPGP)
         NERR=NERR+1
      ENDIF
      NPGP=NPGP*2
C
C     AND THIS MUST BE AN ORDINARY SCF OR DFT, BUT NOT GVB OR MCSCF
C
      OK = SCFTYP.EQ.RHF  .OR.  SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF
      OK = OK .AND. (CITYP.EQ.RNONE  .AND.   CCTYP.EQ.RNONE  .AND.
     *               MPLEVL.EQ.0  .AND.  MPCTYP.EQ.NONE)
      IF(.NOT.OK) THEN
         IF(MASWRK) WRITE(IW,9400)
         NERR=NERR+1
      END IF
      IF(NERR.GT.0) CALL ABRT
C
      CALL INITPRMT(NCXYZ,MQOPS)
      RETURN
C
 9100 FORMAT(1X,'*** ERROR *** IN -QFMMIN-'/,
     *  1X,'QFMM ONLY RUNS IN DIRECT SCF MODE. '/,
     *  1X,'INCLUDE DIRSCF=.T. IN $SCF GROUP.'/)
 9200 FORMAT(/1X,'THE HIGHEST ANGULAR MOMENTUM IS ',A1/,
     *  1X,'QFMM WILL NOT RUN WITH ANGULAR MOMENTUM HIGHER THAN D'/
     *  1X,'FUTURE VERSION WILL REMOVE THIS RESTRICTION'/)
 9400 FORMAT(/1X,'THE SCFTYP FOR QFMM MUST BE RHF, UHF, OR ROHF,'/
     *        1X,'CORRELATION METHODS MPLEVL, CITYP, CCTYP CANNOT',
     *           ' BE USED,'/
     *        1X,'NOR ANY SEMI-EMPIRICAL HAMILTONIAN.')
      END
C*MODULE QMFM    *DECK NEARJ
      SUBROUTINE NEARJ(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                 XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                 IA,DA,FA,DB,FB,DSH,NXYZ,
     *                 NCXYZ,INDX,IPP,ISP,
     *                 ITSP,ITPP,ITSP2,ITPP2,
     *                 NTBOX,IDXBOX,MBOX,LEBOX,NSBOX,IYZTBL,NBR,
     *                 MAXWS,NUMWS,IYZPNT,MIJKL)
C
C
C     THIS ROUTINE FORMS NEAR FIELD J MATRIX (COULOMB POTENTIAL).
C     ALTHOUGH IT SAYS J, IT ALSO CALCULATES EXCHANGE TERMS IF
C     ITERMS.EQ.0.
C
C     FA : ALPHA FOCK MATRIX.
C
C     YP : COMPLEX[(NP+1)*(NP+2)/2 X NZ]
C
C     C. H. CHOI DEC 1999
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DIRSCF
      LOGICAL SCHWRZ,GOPARR,DSKWRK,MASWRK
      LOGICAL JANDK,QFMM,QOPS,OK
      PARAMETER (MXSH=5000, MXATM=2000)
C
      DIMENSION IDXBOX(3,NTBOX),MBOX(NTBOX),LEBOX(0:NTBOX),NSBOX(20),
     *          NUMWS(NTBOX,MAXWS/2),IYZPNT(NTBOX,MAXWS/2)
      DIMENSION XINTS(NSH2),GHONDO(MAXG),IA(L1),DA(L2),FA(L2),
     *          DB(*),FB(*),DSH(NSH2),DDIJ(*)
      DIMENSION INDX(NCXYZ),
     *          IPP(NCXYZ,2),ISP(NCXYZ,2),
     *          ITPP(MIJKL,2),ITSP(MIJKL,2),
     *          ITPP2(MIJKL,2),ITSP2(MIJKL,2),
     *          IYZTBL(2**(NS+1)-1,2**(NS+1)-1,2**(NS+1)-1),
     *          NBR((MAXWS*2+1)**3)
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 /FMCOM / X(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
C     PARALLEL INITIALIZATION
C
      NEXT = -1
      MINE = -1
C
C     CHECK FOR DFT
      OK =  NDFTFG.EQ.1 .OR. DFTTYP(1).NE.1.0D+00
      JANDK=.NOT.(OK.AND.(DFTTYP(3).EQ.0.0D+00))
C     CHECK FOR SYMMETRY
      JANDK=(NT.EQ.1).AND.(ITERMS.EQ.0)
C
      CALL VALFM(LOADFM)
      LPTR     = 1     + LOADFM
      LTBL     = LPTR  + MIJKL*2/NWDVAR
      LPTR2    = LTBL  + MIJKL/NWDVAR+2
      LTBL2    = LPTR2 + MIJKL*2/NWDVAR
      LPPIJ    = LTBL2 + MIJKL/NWDVAR+2
      LPPKL    = LPPIJ + MIJKL*2/NWDVAR
      LXIJKL   = LPPKL + MIJKL*2/NWDVAR
      LAST     = LXIJKL + MIJKL*2/NWDVAR
      NEED = LAST - LOADFM
      CALL GETFM(NEED)
C
C     ----- LOOP OVER NON-EMPTY BOXES IN THE LOWEST LEVEL -----
C
      DO NON=1,NSBOX(1)
         IF (GOPARR) THEN
            MINE=MINE+1
            IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
            IF (NEXT.NE.MINE)  GOTO 50
         ENDIF
C
         I=IDXBOX(1,NON)
         J=IDXBOX(2,NON)
         K=IDXBOX(3,NON)
C
         IXYZ=LEBOX(IYZTBL(I,J,K))-MBOX(IYZTBL(I,J,K))
C
C        DO LOOP OVER DISTRIBUTIONS IN A GIVEN BOX.
C
         DO M=1,MBOX(NON)
            IXYZ=IXYZ+1
            IEND=INDX(IXYZ)
C
C           PUT THE SHELL PAIR AND PRIMITIVE GAUSSIAN PRODUCT
C           INDICES IN THE TEMPORARY SPACE.
C
            ITSP(M,1)=ISP(IEND,1)
            ITSP(M,2)=ISP(IEND,2)
            ITPP(M,1)=IPP(IEND,1)
            ITPP(M,2)=IPP(IEND,2)
         ENDDO
C
C        SORTING OUT ITSP AND ITPP IN ORDER TO OPTIMIZE INTEGRAL.
C
         CALL SORTSP(MIJKL,M-1,ITSP,ITPP,X(LPTR),
     *        X(LTBL),IXTBL)
         IF (JANDK) THEN
         CALL COREJK(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *               XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *               IA,DA,FA,DB,FB,DSH,NXYZ,MIJKL,
     *               ITSP,ITPP,IXTBL,X(LTBL),X(LPPIJ),
     *               X(LPPKL))
         ELSE
         CALL COREJ(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *              XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *              IA,DA,FA,DB,FB,DSH,NXYZ,MIJKL,
     *              ITSP,ITPP,IXTBL,X(LTBL),
     *              X(LPPIJ),X(LPPKL),X(LXIJKL))
         ENDIF
 50   ENDDO
C
C     ----- INTEGRALS BETWEEN BOXES -----
C
C     NSBOX(1) CONTAINS THE NUMBER OF NON-EMPTY BOXES IN THE LOWEST
C     LEVEL, NS. REMOVE BLANK SPACE.
C
      IBOXS=1
      IBOXE=NSBOX(1)
      MAXSIZE=2**NS
      MINX=MAXSIZE
      MAXX=1
      MINY=MAXSIZE
      MAXY=1
      MINZ=MAXSIZE
      MAXZ=1
C
      DO I=IBOXS,IBOXE
         MX=IDXBOX(1,I)
         MY=IDXBOX(2,I)
         MZ=IDXBOX(3,I)
         IF (MX.LT.MINX) MINX=MX
         IF (MX.GT.MAXX) MAXX=MX
         IF (MY.LT.MINY) MINY=MY
         IF (MY.GT.MAXY) MAXY=MY
         IF (MZ.LT.MINZ) MINZ=MZ
         IF (MZ.GT.MAXZ) MAXZ=MZ
      ENDDO
C
      DO NON=1,NSBOX(1)
C
         IF (GOPARR) THEN
             MINE=MINE+1
             IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
             IF (NEXT.NE.MINE)  GOTO 100
         ENDIF
C
C        IDXBOX CONTAINS THE ACTUAL (I,J,K) INDEX OF A GIVEN BOX, NON.
         I=IDXBOX(1,NON)
         J=IDXBOX(2,NON)
         K=IDXBOX(3,NON)
C
C        LOOP OVER THE IWS INDEX OF THE FIRST BOX
C
C        IYZTBL RETURNS ACTUAL SEQUENCE OF A GIVEN BOX (I,J,K)
C        MBOX RETURNS THE NUMBER OF PARTICLES IN THAT BOX
C        LEBOX RETURNS THE CUMULATIVE NUMBER OF PATICLES.
C        SO IXYZ NOW POINTS THE ACTUAL SEQUENCE OF A POINT.
C
         IXYZ=LEBOX(IYZTBL(I,J,K))-MBOX(IYZTBL(I,J,K))
         DO IDXWS=1,MAXWS/2
C        IF (GOPARR) THEN
C          IPCOUNT = IPCOUNT + 1
C          IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 200
C        ENDIF
C
C           NUMWS RETURNS THE NUMBER OF PARTICLE OF BOX, NON WITH
            INPTCL=NUMWS(NON,IDXWS)
            IF ( INPTCL.NE.0 ) THEN
C
C              NOW PUT SHELL PAIR AND PRIMITIVE PAIR INDICES OF I
C              BRANCH PARTICLES WITH IWS=IDXWS*2 INTO TEMPORARY MEMORY.
C
               DO M=1,INPTCL
                  IXYZ=IXYZ+1
                  IPTCL=INDX(IXYZ)
C
C                 PUT THE SHELL PAIR AND PRIMITIVE GAUSSIAN PRODUCT
C                 INDICES IN THE TEMPORARY SPACE.
C
                  ITSP(M,1)=ISP(IPTCL,1)
                  ITSP(M,2)=ISP(IPTCL,2)
                  ITPP(M,1)=IPP(IPTCL,1)
                  ITPP(M,2)=IPP(IPTCL,2)
               ENDDO
C              SORTING OUT ITSP AND ITPP IN ORDER TO OPTIMIZE INTEGRAL.
               CALL SORTSP(MIJKL,M-1,ITSP,ITPP,X(LPTR),
     *               X(LTBL),IXTBL)
C
C              LOOP OVER THE IWS INDEX OF THE SECOND BOX
C
               DO IDXIT=1,MAXWS/2
                  IJWS=IDXWS+IDXIT
                  CALL GETNBR(I,J,K,IJWS,NS,NTBOX,
     *               NBR,IDX,IYZTBL,IDXIT,MAXWS,IYZPNT,
     *             MINX,MAXX,MINY,MAXY,MINZ,MAXZ)
C
C                 LOOP OVER THE NEIGHBORS
C
                  IF ( IDX.GT.0 ) THEN
                     IST=0
                     DO NN=1,IDX
                        JXYZ=LEBOX(NBR(NN))-MBOX(NBR(NN))
                        DO MWS=1,IDXIT-1
                           JNPTCL=NUMWS(NBR(NN),MWS)
                           JXYZ=JXYZ+JNPTCL
                        ENDDO
                        JNPTCL=NUMWS(NBR(NN),IDXIT)
                        IF ( JNPTCL.NE.0 ) THEN
                           DO M=1,JNPTCL
                              JXYZ=JXYZ+1
                              JPTCL=INDX(JXYZ)
                              IST=IST+1
C                    PUT THE SHELL PAIR AND PRIMITIVE GAUSSIAN PRODUCT
C                    INDICES IN THE TEMPORARY SPACE.
                              ITSP2(IST,1)=ISP(JPTCL,1)
                              ITSP2(IST,2)=ISP(JPTCL,2)
                              ITPP2(IST,1)=IPP(JPTCL,1)
                              ITPP2(IST,2)=IPP(JPTCL,2)
                           ENDDO
                        ENDIF
                     ENDDO
C
C             SORTING OUT ITSP2 AND ITPP2 IN ORDER TO OPTIMIZE INTEGRAL.
C
                     CALL SORTSP(MIJKL,IST,ITSP2,ITPP2,X(LPTR2),
     *                      X(LTBL2),IXTBL2)
                     IF (JANDK) THEN
                     CALL NBRJK(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                          XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                          IA,DA,FA,DB,FB,DSH,NXYZ,MIJKL,
     *                          ITSP,ITPP,ITSP2,ITPP2,IXTBL,IXTBL2,
     *                          X(LTBL),X(LTBL2),X(LPPIJ),X(LPPKL))
                     ELSE
                     CALL NBRJ(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                         XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                         IA,DA,FA,DB,FB,DSH,NXYZ,MIJKL,
     *                         ITSP,ITPP,ITSP2,ITPP2,IXTBL,IXTBL2,
     *                         X(LTBL),X(LTBL2),X(LPPIJ),X(LPPKL),
     *                         X(LXIJKL))
                     ENDIF
C
                  ENDIF
               ENDDO
C           IF OF INPTCL
            ENDIF
         ENDDO
 100  ENDDO
C
      CALL RETFM(NEED)
C
      IF (GOPARR) CALL DDI_DLBRESET
C
      RETURN
      END
C*MODULE QMFM    *DECK COREJK
      SUBROUTINE COREJK(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                  XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                  IA,DA,FA,DB,FB,DSH,NXYZ,NCXYZ,
     *                  ITSP,ITPP,IXTBL,ITBL,IPPIJ,IPPKL)
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 NLO: DNLO, FNLO
C  DIRECT TRANSFORMATION: BUFP, IX
C     RESPONSE EQUATIONS: MUST DEFINE NXYZ.NE.1
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,OUT,SCHWRZ,SCHSKP
C
      DIMENSION XINTS(NSH2),GHONDO(MAXG),IA(L1),DA(L2),FA(L2),
     *          DB(*),FB(*),DSH(NSH2),DDIJ(*)
C
      DIMENSION ITPP(NCXYZ,2), ITSP(NCXYZ,2), ITBL(IXTBL)
      DIMENSION IPPIJ(NCXYZ,2), IPPKL(NCXYZ,2)
C
      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)
C
C     ----- TWO-ELECTRON INTEGRALS -----
C
      TIM = ZERO
      CALL TSECND(TIM)
C
      SCHSKP=.FALSE.
      DENMAX = ZERO
C
C     ----- I & J SHELL -----
C
      IJSP=0
      QQ4=1.0D+00
      DO 920 IJSHLL = 1,IXTBL
         IJNUM=ITBL(IJSHLL)
         IJSP=IJSP+IJNUM
         ISH=ITSP(IJSP,1)
         JSH=ITSP(IJSP,2)
         CALL GETSHL(1,ISH,JSH,1,1,NCXYZ,ITPP,IPPIJ,IJNUM,IJSP)
         CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
C
C        K & L SHELL
C
         KLSP=0
         DO 880 KLSHLL=1,IJSHLL
            KLNUM=ITBL(KLSHLL)
            KLSP=KLSP+KLNUM
            KSH=ITSP(KLSP,1)
            LSH=ITSP(KLSP,2)
C
C           APPLY THE SCHWARZ INEQUALITY, WHICH IS
C           (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C           SEE 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
C
C           QFMM USES ONLY HONDO CODE
C
            IF(SCHSKP) GO TO 820
C
C        ----- GET INFORMATION ABOUT ISH AND JSH -----
C        ----- FORM PAIRS OF PRIMITIVES FROM ISH AND JSH -----
C        ----- GET INFORMATION ABOUT KSH AND LSH -----
C
            IF(NIJ.EQ.0) GO TO 820
            CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPKL,
     *           KLNUM,KLSP)
            CALL ZQOUT(GHONDO)
C
C        ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
            IF(IJKL.EQ.1) THEN
               CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
            ELSE
               CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
            END IF
            CALL FORMJK(SCFTYP,IA,DA,FA,DB,FB,GHONDO,L2,NINT,NXYZ)
  820       CONTINUE
  880    CONTINUE
  920 CONTINUE
C
C     ----- END OF SHELL LOOPS -----
C
      RETURN
      END
C*MODULE QMFM    *DECK COREJ
      SUBROUTINE COREJ(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                 XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                 IA,DA,FA,DB,FB,DSH,NXYZ,NCXYZ,
     *                 ITSP,ITPP,IXTBL,ITBL,IPPIJ,IPPKL,IXIJKL)
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 NLO: DNLO, FNLO
C  DIRECT TRANSFORMATION: BUFP, IX
C     RESPONSE EQUATIONS: MUST DEFINE NXYZ.NE.1
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,OUT,SCHWRZ,SCHSKP
      PARAMETER (MXSH=5000, MXATM=2000)
C
      DIMENSION XINTS(NSH2),GHONDO(MAXG),IA(L1),DA(L2),FA(L2),
     *          DB(*),FB(*),DSH(NSH2),DDIJ(*)
      DIMENSION MI(48)
C
      DIMENSION ITPP(NCXYZ,2), ITSP(NCXYZ,2),ITBL(IXTBL)
      DIMENSION IPPIJ(NCXYZ,2), IPPKL(NCXYZ,2), IXIJKL(NCXYZ,2)
C
      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
      TIM = ZERO
      CALL TSECND(TIM)
C
C     ----- INITIALIZATION -----
C
      SCHSKP=.FALSE.
      DENMAX = ZERO
C
C    ----- PRE-SCREENING FOR SYMMETRIC MOLECULE -----
C
      IF (NT.NE.1) THEN
         IJSP=0
         DO II=1,IXTBL
            IJNUM=ITBL(II)
            IJSP=IJSP+IJNUM
            IXIJKL(IJSP,1)=0
         ENDDO
C
         IJSP=0
         DO 925 IJSHLL = 1,IXTBL
            IJNUM=ITBL(IJSHLL)
            IJSP=IJSP+IJNUM
            ISH=ITSP(IJSP,1)
            JSH=ITSP(IJSP,2)
            DO IT = 1,NT
               ID = MAPSHL(ISH,IT)
               IF (ID .GT. ISH) GO TO 925
               MI(IT) = ID
            ENDDO
C
            N4=0
            DO 205 IT = 1,NT
               ID = MI(IT)
               JD = MAPSHL(JSH,IT)
               IF (ID .GE. JD) GO TO 165
                  ND = ID
                  ID = JD
                  JD = ND
  165          IF (ID-ISH) 205,185,925
  185          IF (JD-JSH) 205,207,925
  207          N4=N4+1
  205       CONTINUE
            IXIJKL(IJSP,1)=N4
  925    CONTINUE
C
C     ----- THE REAL CALCULATIONS ------
C
         IJSP=0
         DO 930 IJSHLL = 1,IXTBL
            IJNUM=ITBL(IJSHLL)
            IJSP=IJSP+IJNUM
            ISH=ITSP(IJSP,1)
            JSH=ITSP(IJSP,2)
            IJN4=IXIJKL(IJSP,1)
            CALL GETSHL(1,ISH,JSH,1,1,NCXYZ,ITPP,IPPIJ,IJNUM,IJSP)
            CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
C
C           K & L SHELL
C
            KLSP=0
            DO 890 KLSHLL=1,IJSHLL
               KLNUM=ITBL(KLSHLL)
               KLSP=KLSP+KLNUM
               KSH=ITSP(KLSP,1)
               LSH=ITSP(KLSP,2)
               KLN4=IXIJKL(KLSP,1)
C
               N4P=IJN4+KLN4
               IF (N4P.EQ.0) GO TO 890
               N4M=IJN4*KLN4
               IF (N4M.EQ.0) THEN
                  IF (IJN4.EQ.0) THEN
                     Q4=KLN4
                     QQ2=NT/Q4
                     IFDX=3
                  ELSEIF (KLN4.EQ.0) THEN
                     Q4=IJN4
                     QQ2=NT/Q4
                     IFDX=2
                  ENDIF
               ELSE
                  Q4=MAX(IJN4,KLN4)
                  QQ2=NT/Q4
               ENDIF
C
C           APPLY THE SCHWARZ INEQUALITY, WHICH IS
C           (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C           SEE 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 = QQ2*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
C
C
               IF(SCHSKP) GO TO 830
C
C        ----- GET INFORMATION ABOUT ISH AND JSH -----
C        ----- FORM PAIRS OF PRIMITIVES FROM ISH AND JSH -----
C        ----- GET INFORMATION ABOUT KSH AND LSH -----
C
               IF(NIJ.EQ.0) GO TO 830
               CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPKL,
     *           KLNUM,KLSP)
               CALL ZQOUT(GHONDO)
C
C        ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
C               QQ4=1.0D+00
               IF(IJKL.EQ.1) THEN
                  CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
               ELSE
                  CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
               END IF
               IF (N4M.EQ.0) THEN
                  QQ4=QQ2
                  CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFDX)
               ELSE
                  IFDX=2
                  Q4=IJN4
                  QQ4=NT/Q4
                  CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFDX)
                  IFDX=3
                  Q4=KLN4
                  QQ4=NT/Q4
                  CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFDX)
               ENDIF
  830          CONTINUE
  890       CONTINUE
  930    CONTINUE
C
      ELSE
C
C
C     ----- I & J SHELL -----
C
      IFDX=1
      IJSP=0
      QQ4=1.0D+00
      DO 920 IJSHLL = 1,IXTBL
         IJNUM=ITBL(IJSHLL)
         IJSP=IJSP+IJNUM
         ISH=ITSP(IJSP,1)
         JSH=ITSP(IJSP,2)
         CALL GETSHL(1,ISH,JSH,1,1,NCXYZ,ITPP,IPPIJ,IJNUM,IJSP)
         CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
C
C        K & L SHELL
C
         KLSP=0
         DO 880 KLSHLL=1,IJSHLL
            KLNUM=ITBL(KLSHLL)
            KLSP=KLSP+KLNUM
            KSH=ITSP(KLSP,1)
            LSH=ITSP(KLSP,2)
C
C           APPLY THE SCHWARZ INEQUALITY, WHICH IS
C           (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C           SEE 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
C
C           QFMM USES ONLY HONDO CODE
C
            IF(SCHSKP) GO TO 820
C
C        ----- GET INFORMATION ABOUT ISH AND JSH -----
C        ----- FORM PAIRS OF PRIMITIVES FROM ISH AND JSH -----
C        ----- GET INFORMATION ABOUT KSH AND LSH -----
C
            IF(NIJ.EQ.0) GO TO 820
            CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPKL,
     *           KLNUM,KLSP)
            CALL ZQOUT(GHONDO)
C
C        ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
            IF(IJKL.EQ.1) THEN
               CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
            ELSE
               CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
            END IF
            CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFDX)
  820       CONTINUE
  880    CONTINUE
  920 CONTINUE
      ENDIF
C
C     ----- END OF SHELL LOOPS -----
C
      RETURN
      END
C*MODULE QMFM    *DECK NBRJK
      SUBROUTINE NBRJK(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                 XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                 IA,DA,FA,DB,FB,DSH,NXYZ,
     *                 NCXYZ,ITSP,ITPP,ITSP2,ITPP2,IXTBL,
     *                 IXTBL2,ITBL,ITBL2,IPPIJ,IPPKL)
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 NLO: DNLO, FNLO
C     DIRECT TRANSFORMATION: BUFP, IX
C     RESPONSE EQUATIONS: MUST DEFINE NXYZ.NE.1
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,OUT,SCHWRZ,SCHSKP
C
      DIMENSION XINTS(NSH2),GHONDO(MAXG),IA(L1),DA(L2),FA(L2),
     *          DB(*),FB(*),DSH(NSH2),DDIJ(*)
C
      DIMENSION ITPP(NCXYZ,2), ITSP(NCXYZ,2), ITBL(IXTBL)
      DIMENSION ITPP2(NCXYZ,2), ITSP2(NCXYZ,2), ITBL2(IXTBL2)
      DIMENSION IPPIJ(NCXYZ,2), IPPKL(NCXYZ,2)
C
      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)
C
C     ----- TWO-ELECTRON INTEGRALS -----
C     ----- THIS VERSION CAN HANDLE G SHELLS -----
C
      TIM = ZERO
      CALL TSECND(TIM)
C
      SCHSKP=.FALSE.
      DENMAX = ZERO
C
C
C    ----- PRE-SCREENING FOR SYMMETRIC MOLECULE -----
C
C
C     ----- I & J SHELL -----
C
         IJSP=0
         QQ4=1.0D+00
         DO 920 IJSHLL = 1,IXTBL
            IJNUM=ITBL(IJSHLL)
            IJSP=IJSP+IJNUM
            ISH=ITSP(IJSP,1)
            JSH=ITSP(IJSP,2)
            CALL GETSHL(1,ISH,JSH,1,1,NCXYZ,ITPP,IPPIJ,IJNUM,IJSP)
            CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
C
C      ----- K & L SHELL -----
C
            KLSP=0
            DO 880 KLSHLL=1,IXTBL2
            KLNUM=ITBL2(KLSHLL)
            KLSP=KLSP+KLNUM
            KSH=ITSP2(KLSP,1)
            LSH=ITSP2(KLSP,2)
C
C        ----- COMPUTE TWO-ELECTRON INTEGRALS ----
C
C
C           APPLY THE SCHWARZ INEQUALITY, WHICH IS
C           (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C           SEE 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
C
C           QFMM ONLY USES HONDO INTEGRAL
C
            IF(SCHSKP) GO TO 880
C
            IF(NIJ.EQ.0) GO TO 880
            CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP2,IPPKL,
     *              KLNUM,KLSP)
            CALL ZQOUT(GHONDO)
C
C           ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
            IF(IJKL.EQ.1) THEN
               CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
            ELSE
               CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
            END IF
            CALL FORMJK(SCFTYP,IA,DA,FA,DB,FB,GHONDO,L2,NINT,NXYZ)
C
C           ----- IF ISH=KSH AND JSH=LSH, COMPUTE -----
C
            IF ( (ISH.EQ.KSH).AND.(JSH.EQ.LSH) ) THEN
              CALL GETSHL(1,ISH,JSH,KSH,LSH,NCXYZ,ITPP2,IPPKL,
     *              KLNUM,KLSP)
              CALL GETIJPP(DDIJ,KLNUM,NCXYZ,IPPKL)
              IF(NIJ.EQ.0) GO TO 880
              CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPIJ,
     *              IJNUM,IJSP)
              CALL ZQOUT(GHONDO)
              IF(IJKL.EQ.1) THEN
               CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPIJ,IJNUM)
              ELSE
               CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPIJ,IJNUM)
              END IF
              CALL FORMJK(SCFTYP,IA,DA,FA,DB,FB,GHONDO,L2,NINT,NXYZ)
              CALL GETSHL(1,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPIJ,IJNUM,IJSP)
              CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
            ENDIF
C
  880    CONTINUE
  920 CONTINUE
C
C     ----- END OF SHELL LOOPS -----
C
      RETURN
      END
C*MODULE QMFM    *DECK NBRJ
      SUBROUTINE NBRJ(SCFTYP,DIRSCF,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                IA,DA,FA,DB,FB,DSH,NXYZ,
     *                NCXYZ,ITSP,ITPP,ITSP2,ITPP2,IXTBL,
     *                IXTBL2,ITBL,ITBL2,IPPIJ,IPPKL,IXIJKL)
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 NLO: DNLO, FNLO
C     DIRECT TRANSFORMATION: BUFP, IX
C     RESPONSE EQUATIONS: MUST DEFINE NXYZ.NE.1
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,OUT,SCHWRZ,SCHSKP
      PARAMETER (MXSH=5000, MXATM=2000)
C
      DIMENSION XINTS(NSH2),GHONDO(MAXG),IA(L1),DA(L2),FA(L2),
     *          DB(*),FB(*),DSH(NSH2),DDIJ(*)
      DIMENSION MI(48),MK(48)
C
      DIMENSION ITPP(NCXYZ,2), ITSP(NCXYZ,2),ITBL(IXTBL)
      DIMENSION ITPP2(NCXYZ,2), ITSP2(NCXYZ,2) , ITBL2(IXTBL2)
      DIMENSION IPPIJ(NCXYZ,2), IPPKL(NCXYZ,2) , IXIJKL(NCXYZ,2)
C
      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 G SHELLS -----
C
      TIM = ZERO
      CALL TSECND(TIM)
C
      SCHSKP=.FALSE.
      DENMAX = ZERO
C
C    ----- PRE-SCREENING FOR SYMMETRIC MOLECULE -----
C
      IF (NT.NE.1) THEN
         IJSP=0
         KLSP=0
         DO II=1,NCXYZ
            IXIJKL(II,1)=0
            IXIJKL(II,2)=0
         ENDDO
C
         IJSP=0
         DO 925 IJSHLL = 1,IXTBL
            IJNUM=ITBL(IJSHLL)
            IJSP=IJSP+IJNUM
            ISH=ITSP(IJSP,1)
            JSH=ITSP(IJSP,2)
            DO IT = 1,NT
               ID = MAPSHL(ISH,IT)
               IF (ID .GT. ISH) GO TO 925
               MI(IT) = ID
            ENDDO
C
            N4=0
            DO 205 IT = 1,NT
               ID = MI(IT)
               JD = MAPSHL(JSH,IT)
               IF (ID .GE. JD) GO TO 165
                  ND = ID
                  ID = JD
                  JD = ND
  165          IF (ID-ISH) 205,185,925
  185          IF (JD-JSH) 205,207,925
  207          N4=N4+1
  205       CONTINUE
            IXIJKL(IJSP,1)=N4
  925    CONTINUE
C
         KLSP=0
         DO 935 KLSHLL = 1,IXTBL2
            KLNUM=ITBL2(KLSHLL)
            KLSP=KLSP+KLNUM
            KSH=ITSP2(KLSP,1)
            LSH=ITSP2(KLSP,2)
            DO IT = 1,NT
               KD = MAPSHL(KSH,IT)
               IF (KD .GT. KSH) GO TO 935
               MK(IT) = KD
            ENDDO
C
            N4=0
            DO 215 IT = 1,NT
               KD = MK(IT)
               LD = MAPSHL(LSH,IT)
               IF (KD .GE. LD) GO TO 175
                  ND = KD
                  KD = LD
                  LD = ND
  175          IF (KD-KSH) 215,195,935
  195          IF (LD-LSH) 215,217,935
  217          N4=N4+1
  215       CONTINUE
            IXIJKL(KLSP,2)=N4
  935    CONTINUE
C
C     ----- THE REAL CALCULATIONS ------
C
C     ----- I & J SHELL -----
C
         IJSP=0
         DO 940 IJSHLL = 1,IXTBL
            IJNUM=ITBL(IJSHLL)
            IJSP=IJSP+IJNUM
            ISH=ITSP(IJSP,1)
            JSH=ITSP(IJSP,2)
            IJN4=IXIJKL(IJSP,1)
            CALL GETSHL(1,ISH,JSH,1,1,NCXYZ,ITPP,IPPIJ,IJNUM,IJSP)
            CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
C
C      ----- K & L SHELL -----
C
            KLSP=0
            DO 890 KLSHLL=1,IXTBL2
               KLNUM=ITBL2(KLSHLL)
               KLSP=KLSP+KLNUM
               KSH=ITSP2(KLSP,1)
               LSH=ITSP2(KLSP,2)
               KLN4=IXIJKL(KLSP,2)
C
               N4P=IJN4+KLN4
               IF (N4P.EQ.0) GO TO 890
               N4M=IJN4*KLN4
               IF (N4M.EQ.0) THEN
                  IF (IJN4.EQ.0) THEN
                     IFDX=3
                     Q4=KLN4
                     QQ2=NT/Q4
                  ELSEIF (KLN4.EQ.0) THEN
                     IFDX=2
                     Q4=IJN4
                     QQ2=NT/Q4
                  ENDIF
               ELSE
                  Q4=MAX(IJN4,KLN4)
                  QQ2=NT/Q4
               ENDIF
C
C           APPLY THE SCHWARZ INEQUALITY, WHICH IS
C           (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C           SEE 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 = QQ2*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
C
C           QFMM ONLY USES HONDO INTEGRAL
C
               IF(SCHSKP) GO TO 890
C
               IF(NIJ.EQ.0) GO TO 890
               CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP2,IPPKL,
     *              KLNUM,KLSP)
               CALL ZQOUT(GHONDO)
C
C           ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
               IF(IJKL.EQ.1) THEN
                  CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
               ELSE
                  CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
               END IF
               IF (N4M.EQ.0) THEN
                  QQ4=QQ2
                  CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFDX)
               ELSE
                  IFDX=2
                  Q4=IJN4
                  QQ4=NT/Q4
                  CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFDX)
                  IFDX=3
                  Q4=KLN4
                  QQ4=NT/Q4
                  CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFDX)
               ENDIF
C
C           ----- IF ISH=KSH AND JSH=LSH, COMPUTE -----
C
               IF ( (ISH.EQ.KSH).AND.(JSH.EQ.LSH) ) THEN
                  CALL GETSHL(1,ISH,JSH,KSH,LSH,NCXYZ,ITPP2,IPPKL,
     *              KLNUM,KLSP)
                  CALL GETIJPP(DDIJ,KLNUM,NCXYZ,IPPKL)
                  IF(NIJ.EQ.0) GO TO 890
                  CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPIJ,
     *              IJNUM,IJSP)
                  CALL ZQOUT(GHONDO)
                  QQ4=1.0D+00
                  IF(IJKL.EQ.1) THEN
                     CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPIJ,IJNUM)
                  ELSE
                     CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPIJ,IJNUM)
                  END IF
C
                     IFDX=1
                     Q4=KLN4
                     QQ4=NT/Q4
                     CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFDX)
C                  ENDIF
                  CALL GETSHL(1,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPIJ,
     *              IJNUM,IJSP)
                  CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
               ENDIF
C
  890       CONTINUE
  940    CONTINUE
C
      ELSE
C
C     ----- I & J SHELL -----
C
         IJSP=0
         QQ4=1.0D+00
         DO 920 IJSHLL = 1,IXTBL
            IJNUM=ITBL(IJSHLL)
            IJSP=IJSP+IJNUM
            ISH=ITSP(IJSP,1)
            JSH=ITSP(IJSP,2)
            CALL GETSHL(1,ISH,JSH,1,1,NCXYZ,ITPP,IPPIJ,IJNUM,IJSP)
            CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
C
C      ----- K & L SHELL -----
C
            KLSP=0
            DO 880 KLSHLL=1,IXTBL2
            KLNUM=ITBL2(KLSHLL)
            KLSP=KLSP+KLNUM
            KSH=ITSP2(KLSP,1)
            LSH=ITSP2(KLSP,2)
C
C        ----- COMPUTE TWO-ELECTRON INTEGRALS ----
C
C
C           APPLY THE SCHWARZ INEQUALITY, WHICH IS
C           (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C           SEE 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
C
C           QFMM ONLY USES HONDO INTEGRAL
C
            IF(SCHSKP) GO TO 880
C
            IF(NIJ.EQ.0) GO TO 880
            CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP2,IPPKL,
     *              KLNUM,KLSP)
            CALL ZQOUT(GHONDO)
C
C           ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
            IF(IJKL.EQ.1) THEN
               CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
            ELSE
               CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
            END IF
            IFLAG=1
            CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                 L2,NINT,NXYZ,IFLAG)
C
C           ----- IF ISH=KSH AND JSH=LSH, COMPUTE -----
C
            IF ( (ISH.EQ.KSH).AND.(JSH.EQ.LSH) ) THEN
              CALL GETSHL(1,ISH,JSH,KSH,LSH,NCXYZ,ITPP2,IPPKL,
     *              KLNUM,KLSP)
              CALL GETIJPP(DDIJ,KLNUM,NCXYZ,IPPKL)
              IF(NIJ.EQ.0) GO TO 880
              CALL GETSHL(2,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPIJ,
     *              IJNUM,IJSP)
              CALL ZQOUT(GHONDO)
              IF(IJKL.EQ.1) THEN
               CALL GETSSSS(GHONDO,DDIJ,NCXYZ,IPPIJ,IJNUM)
              ELSE
               CALL GETHNT(GHONDO,DDIJ,NCXYZ,IPPIJ,IJNUM)
              END IF
              IFLAG=1
              CALL FORMJ(SCFTYP,IA,DA,FA,DB,FB,GHONDO,
     *                   L2,NINT,NXYZ,IFLAG)
C
              CALL GETSHL(1,ISH,JSH,KSH,LSH,NCXYZ,ITPP,IPPIJ,
     *              IJNUM,IJSP)
             CALL GETIJPP(DDIJ,IJNUM,NCXYZ,IPPIJ)
            ENDIF
C
  880    CONTINUE
  920    CONTINUE
      ENDIF
      RETURN
      END
C*MODULE QMFM    *DECK SORTSP
      SUBROUTINE SORTSP(NCXYZ,M,ITSP,ITPP,IPTR,ITBL,IXTBL)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION ITPP(NCXYZ,2),ITSP(NCXYZ,2),IPTR(NCXYZ,2),
     *          ITBL(NCXYZ)
C
      CALL IDIVIDE(NCXYZ,M,ITSP,ITPP,IPTR,ITBL,IXTBL)
C
      RETURN
      END
C*MODULE QMFM    *DECK SLCTR
      SUBROUTINE SLCTR
C
C     THIS ROUTINE COMPUTES THE ATOM CENTER AND ITS RADIUS
C     OF HIGH LEVEL QUANTUM REGION.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXQATM=100,ZERO=0.0D+00)
      PARAMETER (MXATM=2000)
C
      LOGICAL SLQFMM
C
      COMMON /SLFM  / SLQFMM,IQMATM(MAXQATM),NSLQMATM,SLQMCTR(3),SLRDS,
     *                SLTRNS(3)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
C
      SLQMCTR(1)=ZERO
      SLQMCTR(2)=ZERO
      SLQMCTR(3)=ZERO
      SLRDS=ZERO
C
      SMINX=C(1,IQMATM(1))
      SMAXX=C(1,IQMATM(1))
      SMINY=C(2,IQMATM(1))
      SMAXY=C(2,IQMATM(1))
      SMINZ=C(3,IQMATM(1))
      SMAXZ=C(3,IQMATM(1))
      DO I=2,NSLQMATM
         IF (C(1,IQMATM(I)).LT.SMINX) SMINX=C(1,IQMATM(I))
         IF (C(1,IQMATM(I)).GE.SMAXX) SMAXX=C(1,IQMATM(I))
         IF (C(2,IQMATM(I)).LT.SMINY) SMINY=C(2,IQMATM(I))
         IF (C(2,IQMATM(I)).GE.SMAXY) SMAXY=C(2,IQMATM(I))
         IF (C(3,IQMATM(I)).LT.SMINZ) SMINZ=C(3,IQMATM(I))
         IF (C(3,IQMATM(I)).GE.SMAXZ) SMAXZ=C(3,IQMATM(I))
      ENDDO
      SLQMCTR(1)=(SMAXX+SMINX)/2
      SLQMCTR(2)=(SMAXY+SMINY)/2
      SLQMCTR(3)=(SMAXZ+SMINZ)/2
      DO I=1,NSLQMATM
         DIST=(SLQMCTR(1)-C(1,IQMATM(I)))**2+(SLQMCTR(2)
     *        -C(2,IQMATM(I)))**2+(SLQMCTR(3)-C(3,IQMATM(I)))**2
         IF (DIST.GT.SLRDS) SLRDS=DIST
      ENDDO
      SLRDS=SQRT(SLRDS)
C
      RETURN
      END
C*MODULE QMFM    *DECK SLDISP
      SUBROUTINE SLDISP
C
C     THIS ROUTINE FINDS THE DISPLACEMENT VECTOR FOR SLQFMM
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXQATM=100,ZERO=0.0D+00,HALF=0.5D+00)
C
      LOGICAL SLQFMM
      LOGICAL QFMM,QOPS
C
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /SLFM  / SLQFMM,IQMATM(MAXQATM),NSLQMATM,SLQMCTR(3),SLRDS,
     *                SLTRNS(3)
      DIMENSION CTR(3)
C
      SLTRNS(1)=ZERO
      SLTRNS(2)=ZERO
      SLTRNS(3)=ZERO
      NS2=2**NS
      UNIT=SIZE/NS2
      BASE=-HALF*SIZE
      DO I=1,NS2
         CTR(1)=BASE+(I-1)*UNIT
         IF (CTR(1).GT.SLQMCTR(1)) THEN
            SLTRNS(1)=CTR(1)-UNIT*HALF
            GOTO 100
         ENDIF
      ENDDO
  100 CONTINUE
      DO I=1,NS2
         CTR(2)=BASE+(I-1)*UNIT
         IF (CTR(2).GT.SLQMCTR(2)) THEN
            SLTRNS(2)=CTR(2)-UNIT*HALF
            GOTO 200
         ENDIF
      ENDDO
  200 CONTINUE
      DO I=1,NS2
         CTR(3)=BASE+(I-1)*UNIT
         IF (CTR(3).GT.SLQMCTR(3)) THEN
            SLTRNS(3)=CTR(3)-UNIT*HALF
            GOTO 300
         ENDIF
      ENDDO
  300 CONTINUE
C
      SLTRNS(1)=SLTRNS(1)-SLQMCTR(1)
      SLTRNS(2)=SLTRNS(2)-SLQMCTR(2)
      SLTRNS(3)=SLTRNS(3)-SLQMCTR(3)
C
      RETURN
      END
C*MODULE QMFM    *DECK GETSHL
      SUBROUTINE GETSHL(NELEC,ISH,JSH,KSH,LSH,NCXYZ,
     *                  ITPP,ISPP,ISNUM,ISPNUM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,FIRST
C
      DIMENSION ITPP(NCXYZ,2),ISPP(NCXYZ,2)
      DIMENSION IX(35),IY(35),IZ(35),
     *          JX(35),JY(35),JZ(35),
     *          KX(35),KY(35),KZ(35),
     *          LX(35),LY(35),LZ(35)
C
      PARAMETER (MXSH=5000, MXGSH=30, MXGTOT=20000, MXATM=2000)
C
      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 /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     +                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     +                NIJ,IJ,KL,IJKL
      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
C
      SAVE FIRST,IGT,JGT,KGT,LGT
C
C          TABLE IS FOR SPDFG, BUT USES 7'S AS IF FOR SPDFGHI, I.E.
C          IT IS ONLY THE FIRST 35 ELEMENTS OF THE TRUE TABLES.
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/
      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/
      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/
      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/
      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/
      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/
      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/
      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/
      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/
      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/
      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/
      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/
C
      DATA FIRST/.TRUE./
C
      IF(FIRST) THEN
         FIRST=.FALSE.
         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
         LGT = 1
         KGT = LGT * NANGM
         JGT = KGT * NANGM
         IGT = JGT * NANGM
      END IF
      IST=ISPNUM-ISNUM+1
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
      IANDJ = ISH .EQ. JSH
      IF (KTYPE(ISH) .LT. KTYPE(JSH)) THEN
         INU = JSH
         JNU = ISH
         NGTI = JGT
         NGTJ = IGT
         DO IJNUM=IST,ISPNUM
            IJNUMPP=IJNUM-IST+1
            ISPP(IJNUMPP,1)=ITPP(IJNUM,2)
            ISPP(IJNUMPP,2)=ITPP(IJNUM,1)
         ENDDO
      ELSE
         INU = ISH
         JNU = JSH
         NGTI = IGT
         NGTJ = JGT
         DO IJNUM=IST,ISPNUM
            IJNUMPP=IJNUM-IST+1
            ISPP(IJNUMPP,2)=ITPP(IJNUM,2)
            ISPP(IJNUMPP,1)=ITPP(IJNUM,1)
         ENDDO
      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)
  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)
  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)) THEN
         KNU = LSH
         LNU = KSH
         NGTK = LGT
         NGTL = KGT
         DO IJNUM=IST,ISPNUM
            IJNUMPP=IJNUM-IST+1
            ISPP(IJNUMPP,1)=ITPP(IJNUM,2)
            ISPP(IJNUMPP,2)=ITPP(IJNUM,1)
         ENDDO
      ELSE
         KNU = KSH
         LNU = LSH
         NGTK = KGT
         NGTL = LGT
         DO IJNUM=IST,ISPNUM
            IJNUMPP=IJNUM-IST+1
            ISPP(IJNUMPP,2)=ITPP(IJNUM,2)
            ISPP(IJNUMPP,1)=ITPP(IJNUM,1)
         ENDDO
      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)
  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)
  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 QMFM    *DECK GETIJPP
      SUBROUTINE GETIJPP(DDIJ,IJNUM,NCXYZ,ISPP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,NORM
C
      PARAMETER (MXGSH=30, MXG2=MXGSH*MXGSH)
C
      DIMENSION ISPP(NCXYZ,2)
      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,
     *           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),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),J
  140       NN = NN+1
  160       N = N+1
            IJD(N) = NN
  170    CONTINUE
  180 CONTINUE
C
C     ----- I PRIMITIVE
C
      NIJ = 0
      DO 540 IJAB=1,IJNUM
         IA=ISPP(IJAB,1)
         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)
C
C        ----- J PRIMITIVE
C
         JB=ISPP(IJAB,2)
         AJ = BG(JB)
         AA = AI+AJ
         AAINV = ONE/AA
         DUM = AJ*ARRI*AAINV
         IF (DUM .GT. TOL) GO TO 540
         CSJ = CSB(JB)
         CPJ = CPB(JB)
         CDJ = CDB(JB)
         CFJ = CFB(JB)
         CGJ = CGB(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),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
  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),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
  380          NN = NN+1
               DDIJ(NN) = DUM2
  400       CONTINUE
  420    CONTINUE
         IF ( .NOT. IANDJ) GO TO 540
         IF (IA .EQ. JB) GO TO 540
         GO TO (500,440,460,455,450),LIT
  440    IF (MINI .EQ. 2) GO TO 500
         DDIJ(NM+2) = DDIJ(NM+2)+CSI*CPJ*AAINV
         GO TO 480
  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)
  540 CONTINUE
      RETURN
      END
C*MODULE QMFM    *DECK GETSSSS
      SUBROUTINE GETSSSS(GHONDO,DDIJ,NCXYZ,ISPP,IPPNUM)
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)
      DIMENSION ISPP(NCXYZ,2)
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
      DO 300 IPP=1,IPPNUM
         KG=ISPP(IPP,1)
C
         BK = CG(KG)
         BRRK = BK*RRK
         BXK = BK*XK
         BYK = BK*YK
         BZK = BK*ZK
         CSK = CSC(KG)
C
         LG=ISPP(IPP,2)
         BL = DG(LG)
         BB = BK+BL
         BBINV = ONE/BB
         DUM = BL*BRRK*BBINV
         IF (DUM .GT. TOL) GO TO 300
         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
         DO 260 N = 1,NIJ
         NN=(N-1)*49+1
         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     CONTINUE
         GGOUT = GGOUT+D2*SUM
  300 CONTINUE
      GHONDO(1) = GGOUT*PI252
      RETURN
      END
C*MODULE QMFM    *DECK S0000X
      SUBROUTINE S0000X(GHONDO,DDIJ,KLPP,KLCNT,IJTBLP,IJTBL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT
C
      PARAMETER (MXGSH=30, MXG2=MXGSH*MXGSH)
C
      COMMON /QFMLEX/ MAXGP
      DIMENSION GHONDO(*),DDIJ(49*MXG2)
      DIMENSION KLPP(MAXGP,2),IJTBLP(MAXGP+1),IJTBL(*)
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
      DO 300 IPP=1,KLCNT
         KG=KLPP(IPP,1)
C
         BK = CG(KG)
         BRRK = BK*RRK
         BXK = BK*XK
         BYK = BK*YK
         BZK = BK*ZK
         CSK = CSC(KG)
C
         LG=KLPP(IPP,2)
         BL = DG(LG)
         BB = BK+BL
         BBINV = ONE/BB
         DUM = BL*BRRK*BBINV
         IF (DUM .GT. TOL) GO TO 300
         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
         DO 260 M = IJTBLP(IPP),IJTBLP(IPP+1)-1
         N=IJTBL(M)
         NN=(N-1)*49+1
         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     CONTINUE
         GGOUT = GGOUT+D2*SUM
  300 CONTINUE
      GHONDO(1) = GGOUT*PI252*QQ4
      RETURN
      END
C*MODULE QMFM    *DECK HONDOX
      SUBROUTINE HONDOX(GHONDO,DDIJ,KLPP,KLCNT,
     *   IJTBLP,IJTBL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /QFMLEX/ MAXGP
      DIMENSION GHONDO(*),DDIJ(*)
      DIMENSION KLPP(MAXGP,2),IJTBLP(MAXGP+1),IJTBL(*)
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(9)
C
      PARAMETER (SQRT3=1.73205080756888D+00, SQRT5=2.23606797749979D+00,
     *           SQRT7=2.64575131106459D+00, PI252=34.986836655250D+00,
     *           ZERO=0.0D+00, HALF=0.5D+00, ONE=1.0D+00)
C
C     GENERAL INTEGRAL ROUTINE FOR SPD 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
C
      DO 480 IKL=1,KLCNT
         KG=KLPP(IKL,1)
C
C      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
C
C        ----- L PRIMITIVE
C
         LG=KLPP(IKL,2)
         AL = DG(LG)
         B = AK+AL
         BINV = ONE/B
         BBRRK = AL*BRRK*BINV
         IF (BBRRK .GT. TOL) GO TO 480
         CSL = CSD(LG)
         CPL = CPD(LG)
         CDL = CDD(LG)
         CFL = CFD(LG)
         CGL = CGD(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),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
  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),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
  340          N = N+1
               DKL(N) = DUM2
  360       CONTINUE
  370    CONTINUE
C
C           ----- PAIR OF I,J PRIMITIVES
C
         NN = 0
C         DO 440 N = 1,NIJ
         DO 440 MX = IJTBLP(IKL),IJTBLP(IKL+1)-1
            N=IJTBL(MX)
            NN=(N-1)*49
            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    CONTINUE
  480 CONTINUE
C
      RETURN
      END
C*MODULE QMFM    *DECK GETHNT
      SUBROUTINE GETHNT(GHONDO,DDIJ,NCXYZ,IPPKL,KLNUM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION GHONDO(*),DDIJ(*)
      DIMENSION IPPKL(NCXYZ,2)
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(9)
C
      PARAMETER (SQRT3=1.73205080756888D+00, SQRT5=2.23606797749979D+00,
     *           SQRT7=2.64575131106459D+00, PI252=34.986836655250D+00,
     *           ZERO=0.0D+00, HALF=0.5D+00, ONE=1.0D+00)
C
C     GENERAL INTEGRAL ROUTINE FOR SPD FUNCTIONS
C
      FACTOR = PI252
C*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
C
      DO 480 IKL=1,KLNUM
         KG=IPPKL(IKL,1)
C
C      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
C
C        ----- L PRIMITIVE
C
         LG=IPPKL(IKL,2)
C
         AL = DG(LG)
         B = AK+AL
         BINV = ONE/B
         BBRRK = AL*BRRK*BINV
         IF (BBRRK .GT. TOL) GO TO 480
         CSL = CSD(LG)
         CPL = CPD(LG)
         CDL = CDD(LG)
         CFL = CFD(LG)
         CGL = CGD(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),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
  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),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
  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
            NN=(N-1)*49
            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    CONTINUE
  480 CONTINUE
C
      RETURN
      END
C*MODULE QMFM    *DECK SORTS
      SUBROUTINE SORTS(S,L2,LDST,NDST,LSLN,TS,ISHELL)
C
C     SORTS RETURNS THE SIGNIFICANT SHELL PAIRS(LDST) AND CORRESPONDING
C     LSLN THAT ARE PRESELECTED BY USING OVERLAP INTERGRAL(S) AND
C     PREORDERED BY THE SIZE OF THE INTEGRAL ESTIMATE.
C     THE SIZE OF LDST IS NSHELL*NSHELL.
C     LDST IS USED IN THE LINEAR EXCHANGE ROUTINE LEX TO ACHIEVE LINEAR
C     SCALING CONSTRUCTIONS OF EXCHANGE MATRIX(K).
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,OUT
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
      PARAMETER (TEN=1.0D+01)
C
      DIMENSION S(L2),TS(ISHELL),LDST(NDST),LSLN(ISHELL+1)
C
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      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
      ISTART = 1
      IEND   = NSHELL
      JSTART = 1
      LOCIJ  = 0
C
      IJ=0
      LSLN(1)=1
C
C     ----- I SHELL -----
C
      DO 720 II = ISTART,IEND
         MINI = KMIN(II)
         MAXI = KMAX(II)
         LOCI = KLOC(II)-MINI-LOCIJ
C
C     ----- J SHELL -----
C
         CALL VCLR(TS,1,NSHELL)
         NIJ=1
         DO 700 JJ = JSTART,IEND
            MINJ = KMIN(JJ)
            MAXJ = KMAX(JJ)
            LOCJ = KLOC(JJ)-MINJ-LOCIJ
            IANDJ = II .EQ. JJ
C
            MAX = MAXJ
            DO 620 I = MINI,MAXI
               LI = LOCI+I
               IN = (LI*(LI-1))/2
               IF (IANDJ) MAX = I
               DO 600 J = MINJ,MAX
                  LJ = LOCJ+J
                  IF (JJ.GT.II) THEN
                     JN = (LJ*(LJ-1))/2
                     IJN = LI+JN
                  ELSE
                     IJN = LJ+IN
                  ENDIF
                  IF (ABS(S(IJN)).GT.ABS(TS(NIJ))) TS(NIJ)=ABS(S(IJN))
  600          CONTINUE
  620       CONTINUE
            IF (ABS(TS(NIJ)).GT.CUTOFF) THEN
               IJ=IJ+1
               LDST(IJ)=JJ
               NIJ=NIJ+1
            ELSEIF ((ABS(TS(NIJ)).LE.CUTOFF).AND.(KATOM(II).EQ.
     *           KATOM(JJ))) THEN
               IJ=IJ+1
               LDST(IJ)=JJ
               TS(NIJ)=TEN
               NIJ=NIJ+1
            ENDIF
C
C     ----- END OF SHELL LOOPS -----
C
  700    CONTINUE
         LSLN(II+1)=IJ+1
C
         LSIZE=LSLN(II+1)-LSLN(II)
         IF (LSIZE.EQ.0) GOTO 720
         CALL DSORT(LSIZE,TS,LDST(IJ-LSIZE+1))
C
         DO III=1,(LSIZE+1)/2
           IDX=IJ-LSIZE+III
           ITEMP=LDST(IDX)
           LDST(IDX) = LDST(IJ-III+1)
           LDST(IJ-III+1) = ITEMP
         ENDDO
C
  720 CONTINUE
C
      RETURN
      END
C*MODULE QMFM    *DECK SORTD
      SUBROUTINE SORTD(LDLIST,NSHL2,LDLN,TS,ISHELL,EXMAXIJ,XINTS,SHLDEN,
     *  NSH2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT
      DIMENSION TS(ISHELL),LDLIST(NSHL2),LDLN(ISHELL+1),
     *          SHLDEN(NSH2),XINTS(NSH2),EXMAXIJ(ISHELL)
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
C     XINTS IS THE SQURE ROOT OF THE LARGEST (IJ|IJ) OVER SHELL PAIR IJ.
C     LIKEWISE, SHLDEN IS THE LARGEST DENSITY ELEMENT P(IJ) OVER SHELL
C     PAIR IJ.
C
C     THIS ROUTINE FIRST LOOP OVER ALL I'S IN SIGNIFICANT "BRA-SHELL"
C     PAIRS AND FIND OUT ALL SIGNIFICANT J'S IN SIGNIFICANT "KET-SHELL"
C     FOR A GIVEN I. AFTER THAT, SORT J'S BY SIZE OF |P(IJ)|*(JMAX|JMAX)
C     FOR EACH I.
C
C     FIND OUT (IMAX|IMAX), THE MAXIMUM OVER ALL INTEGRAL ESTIMATES
C     OF SHELL PAIR (IJ|IJ) THAT INVOLVE SHELL I.
C
      DO ISH=1,ISHELL
         LI=(ISH*ISH-ISH)/2
         TEST=ABS(XINTS(LI+1))
         DO JSH=1,ISH
            IF(ABS(XINTS(LI+JSH)).GT.TEST) TEST=XINTS(LI+JSH)
         ENDDO
         EXMAXIJ(ISH)=TEST
      ENDDO
C
      IJ=0
      LDLN(1)=1
C
C     ----- I SHELL -----
C
      DO 720 II = 1,ISHELL
         CALL VCLR(TS,1,ISHELL)
         LI = (II*II-II)/2
C
C     ----- J SHELL -----
C
         NIJ=1
         DO 700 JJ = 1,ISHELL
            LJ = (JJ*JJ-JJ)/2
            IF (JJ.GT.II) THEN
               IJN = LJ+II
            ELSE
               IJN = LI+JJ
            ENDIF
C
            TEST=ABS(SHLDEN(IJN)*EXMAXIJ(II)*EXMAXIJ(JJ))
            IF (TEST.GT.CUTOFF) THEN
               IJ=IJ+1
               LDLIST(IJ)=JJ
               TS(NIJ)=ABS(SHLDEN(IJN)*EXMAXIJ(JJ))
               NIJ=NIJ+1
            ENDIF
C
C
C     ----- END OF SHELL LOOPS -----
C
  700    CONTINUE
         LDLN(II+1)=IJ+1
C
         LSIZE=LDLN(II+1)-LDLN(II)
         IF (LSIZE.EQ.0) GOTO 720
         CALL DSORT(LSIZE,TS,LDLIST(IJ-LSIZE+1))
C
         DO III=1,(LSIZE+1)/2
           ITEMP=LDLIST(IJ-LSIZE+III)
           LDLIST(IJ-LSIZE+III) = LDLIST(IJ-III+1)
           LDLIST(IJ-III+1) = ITEMP
         ENDDO
  720 CONTINUE
      RETURN
C
      END
C*MODULE QMFM    *DECK SORTDER
      SUBROUTINE SORTDER(LDLIST,NSHL2,LDLN,TS,ISHELL,EXMAXIJ,PMAX,
     * XINTS,SHLDEN,NSH2)
C
C     PRE-SORTING FOR LEXDER
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT
      DIMENSION TS(ISHELL),LDLIST(NSHL2),LDLN(ISHELL+1),
     *          SHLDEN(NSH2),XINTS(NSH2),EXMAXIJ(ISHELL),PMAX(ISHELL)
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
C     XINTS IS THE SQURE ROOT OF THE LARGEST (IJ|IJ) OVER SHELL PAIR IJ.
C     LIKEWISE, SHLDEN IS THE LARGEST DENSITY ELEMENT P(IJ) OVER SHELL
C     PAIR IJ.
C
C     THIS ROUTINE FIRST LOOP OVER ALL I'S IN SIGNIFICANT "BRA-SHELL
C     PAIRS AND FIND OUT ALL SIGNIFICANT J'S IN SIGNIFICANT "KET-SHELL"
C     FOR A GIVEN I. AFTER THAT, SORT J'S BY SIZE OF |P(IJ)|*(JMAX|JMAX)
C     FOR EACH I.
C
C     FIND OUT (IMAX|IMAX), THE MAXIMUM OVER ALL INTEGRAL ESTIMATES
C     OF SHELL PAIR (IJ|IJ) THAT INVOLVE SHELL I.
C
      DO ISH=1,ISHELL
         LI=(ISH*ISH-ISH)/2
         TEST=ABS(XINTS(LI+1))
         TESTP=ABS(SHLDEN(LI+1))
         DO JSH=1,ISH
            IF(ABS(XINTS(LI+JSH)).GT.TEST) TEST=XINTS(LI+JSH)
            IF(ABS(SHLDEN(LI+JSH)).GT.TESTP) TESTP=SHLDEN(LI+JSH)
         ENDDO
         EXMAXIJ(ISH)=TEST
         PMAX(ISH)=TESTP
      ENDDO
C
      IJ=0
      LDLN(1)=1
C
C     ----- I SHELL -----
C
      DO 720 II = 1,ISHELL
         CALL VCLR(TS,1,ISHELL)
         LI = (II*II-II)/2
C
C     ----- J SHELL -----
C
         NIJ=1
         PMAXIJ=PMAX(II)
         DO 700 JJ = 1,ISHELL
            LJ = (JJ*JJ-JJ)/2
            IF (JJ.GT.II) THEN
               IJN = LJ+II
            ELSE
               IJN = LI+JJ
            ENDIF
            IF (ABS(PMAX(JJ)).GT.ABS(PMAXIJ)) PMAXIJ=PMAX(JJ)
C
            TEST=ABS(SHLDEN(IJN)*EXMAXIJ(II)*EXMAXIJ(JJ)*PMAXIJ)
            IF (TEST.GT.CUTOFF) THEN
               IJ=IJ+1
               LDLIST(IJ)=JJ
               TS(NIJ)=ABS(SHLDEN(IJN)*EXMAXIJ(JJ))
               NIJ=NIJ+1
            ENDIF
C
C
C     ----- END OF SHELL LOOPS -----
C
  700    CONTINUE
         LDLN(II+1)=IJ+1
C
         LSIZE=LDLN(II+1)-LDLN(II)
         IF (LSIZE.EQ.0) GOTO 720
         CALL DSORT(LSIZE,TS,LDLIST(IJ-LSIZE+1))
C
         DO III=1,(LSIZE+1)/2
           ITEMP=LDLIST(IJ-LSIZE+III)
           LDLIST(IJ-LSIZE+III) = LDLIST(IJ-III+1)
           LDLIST(IJ-III+1) = ITEMP
         ENDDO
  720 CONTINUE
      RETURN
C
      END
C*MODULE QMFM    *DECK LEX
      SUBROUTINE LEX(SCFTYP,NINT,L1,L2,
     *               XINTS,NSH2,NSHL2,GHONDO,MAXG,DDIJ,
     *               IA,DA,FA,DB,FB,DSH,NXYZ,LSLIST,LDLIST,LSLN,
     *               LDLN,ISHELL,MLLIST,LMLPNT,IDXSHL,
     *               IPP,INDX2,IDXIJK,IDXWS,NCXYZ,IJTPP,KLTPP,IJSPP,
     *               KLSPP,IJTBLP,IJTBL)
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     RESPONSE EQUATIONS: MUST DEFINE NXYZ.NE.1
C
C     LSLIST CONTAINES THE SIGNIFICANT SHELL PAIRS THAT ARE PRESECTED
C     BY USING OVERLAP INTERGRAL(S) AND PREORDERED BY THE SIZE OF THE
C     INTEGRAL ESTIMATE. THE SIZE OF LDST IS NSHELL*NSHELL.
C
C     LDLIST CONTAINS THE SHELL PAIRS OF THE LARGEST INTEGRAL VALUES
C     OF <IMAX|IMAX> OVER ALL INTEGRAL ESTIMATES OF THIS SHELL PAIR
C     TYPE <IJ|IJ>, THAT INVOLVE SHELL I.
C     THE SIGNIFICANT SHELL PAIRS ARE PREORDERED BY THE SIZE BY USING
C     THE TWO INDEX EXCHANGE INTEGRAL(XINTS) OF <IJ|IJ> AND THE DENSITY
C     ELEMENTS OF SHELL(SHLDEN).
C
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXSH=5000, MXATM=2000)
C
      LOGICAL OUT,GOPARR,DSKWRK,MASWRK,QFMM,QOPS,POPLE,NEARSC
C
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      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
      COMMON /QFMLEX/ MAXGP
C
      DIMENSION XINTS(NSH2),
     *          GHONDO(MAXG),IA(L1),DA(L2),FA(L2),DB(*),FB(*),
     *          DSH(NSH2),DDIJ(*)
      DIMENSION LDLIST(NSHL2),LSLIST(NSHL2),LSLN(ISHELL+1),
     *          MLLIST(2*NSHL2,2),LDLN(ISHELL+1),
     *          LMLPNT(ISHELL,2),IDXSHL(NSH2+1),IPP(NCXYZ,2),
     *          IDXWS(NCXYZ),IDXIJK(NCXYZ,3),INDX2(NCXYZ)
      DIMENSION IJTPP(MAXGP,2),KLTPP(MAXGP,2),IJTBLP(MAXGP+1),
     *          IJTBL(MAXGP*NSHL2),IJSPP(MAXGP,2),KLSPP(MAXGP,2)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
C     ----- TWO-ELECTRON EXCHANGE INTEGRALS -----
C
C     ONLY USE HONDO INTEGRAL
C
      POPLE=.FALSE.
      IEXCH=1
      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
      DO I=1,3
         NORGSH(I) = 0
         NORGSP(I) = 0
      ENDDO
C
C     SETTING THE THRESHOLD
C     THE CUTOFF WAS DETERMINED IN INITPRMT
C
      CUTINT = CUTOFF
      ISHLCNT=0
      ISHRCNT=0
C
C     SYMMETRY & K
C
      NEARSC=(ITERMS.EQ.0).AND.(NT.EQ.1)
C
C     ----- INITIALIZATION FOR PARALLEL WORK -----
C
      NEXT = -1
      MINE = -1
C
C     ----- I SHELL -----
C
      DO II = 1,ISHELL
C
C     ----- J SHELL -----
C
         INX=(II*II-II)/2
         JJMIN=LSLN(II)
         JJMAX=LSLN(II+1)-1
         DO JJA = JJMIN,JJMAX
            JJ=LSLIST(JJA)
            IF (JJ.GT.II) GOTO 1000
C
C           PARALLEL RUNS
C
            IF ( GOPARR) THEN
                  MINE=MINE+1
                  IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
                  IF (NEXT.NE.MINE)  GOTO 1000
            END IF
C
            JNX=(JJ*JJ-JJ)/2
            IJIJ = INX + JJ
            ML=0
            IFLAG=0
C
C           ----- FIRST KL PAIRS -----
C
            DO KKA=LDLN(II),LDLN(II+1)-1
               KK=LDLIST(KKA)
               IF (KK.GT.II) GOTO 150
               KNX=(KK*KK-KK)/2
               KNXD=INX+KK
               TESTIJK=DSH(KNXD)*XINTS(IJIJ)
               DO LLA=LSLN(KK),LSLN(KK+1)-1
                  LL=LSLIST(LLA)
                  IF (LL.GT.KK) GOTO 50
                  KLKL=KNX+LL
                  TEST = ABS(TESTIJK*XINTS(KLKL))
                  IF (TEST.GE.CUTINT) THEN
                     ML=ML+1
                     MLLIST(ML,1)=KK
                     MLLIST(ML,2)=LL
                  ELSE
                     GOTO 100
                  ENDIF
 50            ENDDO
 100           CONTINUE
               IF (ML.EQ.IFLAG) THEN
                  GOTO 200
               ELSE
                  IFLAG=ML
               ENDIF
 150        ENDDO
 200        CONTINUE
            IFLAG=ML
C
C     ----- SECOND KL PAIRS -----
C
            DO KKA=LDLN(JJ),LDLN(JJ+1)-1
               KK=LDLIST(KKA)
               IF (KK.GT.II) GOTO 350
               KNX=(KK*KK-KK)/2
               IF (KK.GT.JJ) THEN
                  KNXD=KNX+JJ
               ELSE
                  KNXD=JNX+KK
               ENDIF
               TESTIJK=DSH(KNXD)*XINTS(IJIJ)
               DO LLA=LSLN(KK),LSLN(KK+1)-1
                  LL=LSLIST(LLA)
                  IF (LL.GT.KK) GOTO 250
                  KLKL=KNX+LL
                  TEST = ABS(TESTIJK*XINTS(KLKL))
                  IF (TEST.GE.CUTINT) THEN
                     ML=ML+1
                     MLLIST(ML,1)=KK
                     MLLIST(ML,2)=LL
                  ELSE
                     GOTO 300
                  ENDIF
 250           ENDDO
 300           CONTINUE
               IF (ML.EQ.IFLAG) THEN
                  GOTO 400
               ELSE
                  IFLAG=ML
               ENDIF
 350        ENDDO
 400        CONTINUE
C
            IF (ML.EQ.0) GOTO 1000
C
C           ------ SORT ------
C
            CALL IDIVIDEML(NSHL2,ML,ISHELL,MLLIST,LMLPNT,
     *           IXTBL)
C
C           ------ PURGE THE DUPLICATED KL PAIRS ------
C
            MLSS=0
            ITAG=MLLIST(1,1)
            JTAG=MLLIST(1,2)
            IF (ITAG.GT.JJ) THEN
               IF (.NOT.((II.EQ.ITAG).AND.(JTAG.GT.JJ)) ) THEN
                  MLSS=1
               ENDIF
            ELSE
               MLSS=1
            ENDIF
C
            DO I=1,ML
               IF (ITAG.NE.MLLIST(I,1)) THEN
                  ITAG=MLLIST(I,1)
                  JTAG=MLLIST(I,2)
                  IF (ITAG.GT.JJ) THEN
                     IF (.NOT.((II.EQ.ITAG).AND.(JTAG.GT.JJ))) THEN
                        MLSS=MLSS+1
                        MLLIST(MLSS,1)=ITAG
                        MLLIST(MLSS,2)=JTAG
                     ENDIF
                  ELSE
                     MLSS=MLSS+1
                     MLLIST(MLSS,1)=ITAG
                     MLLIST(MLSS,2)=JTAG
                  ENDIF
               ELSE
                  IF (JTAG.NE.MLLIST(I,2)) THEN
                     JTAG=MLLIST(I,2)
                     IF (ITAG.GT.JJ) THEN
                        IF (.NOT.((II.EQ.ITAG).AND.(JTAG.GT.JJ))) THEN
                           MLSS=MLSS+1
                           MLLIST(MLSS,1)=ITAG
                           MLLIST(MLSS,2)=JTAG
                        ENDIF
                     ELSE
                        MLSS=MLSS+1
                        MLLIST(MLSS,1)=ITAG
                        MLLIST(MLSS,2)=JTAG
                     ENDIF
                  ENDIF
               ENDIF
            ENDDO
C
C           ----- SCREENING FOR J AND K FORMATION IN NEARJ -----
C
            IF (NEARSC) THEN
               IPST=IDXSHL(INX+JJ)+1
               IPED=IDXSHL(INX+JJ+1)
               DO IJPP=IPST,IPED
                  ISTRT=IJPP-IPST+1
                  IJTPP(ISTRT,1)=IPP(IJPP,1)
                  IJTPP(ISTRT,2)=IPP(IJPP,2)
               ENDDO
               IJSIZE=IPED-IPST+1
               CALL GETSHL(1,II,JJ,1,1,MAXGP,
     *            IJTPP,IJSPP,IJSIZE,IJSIZE)
               CALL GETIJPP(DDIJ,IJSIZE,MAXGP,IJSPP)
               Q4 = 1.0D+00
               QQ4 = Q4
C
               ISHLCNT=ISHLCNT+MLSS
               IJTBLP(1)=1
               DO KLSHLL=1,MLSS
                  KK=MLLIST(KLSHLL,1)
                  KNX=(KK*KK-KK)/2
                  LL=MLLIST(KLSHLL,2)
C
                  JPST=IDXSHL(KNX+LL)+1
                  JPED=IDXSHL(KNX+LL+1)
                  KLCNT=0
                  IJCNT=0
                  IKLFLAG=IJCNT
                  DO KLBOX=JPST,JPED
                     LBOX=INDX2(KLBOX)
                     IBOXJ=IDXIJK(LBOX,1)
                     JBOXJ=IDXIJK(LBOX,2)
                     KBOXJ=IDXIJK(LBOX,3)
                     DO IJBOX=IPST,IPED
                        MBOX=INDX2(IJBOX)
                        IBOXI=IDXIJK(MBOX,1)
                        JBOXI=IDXIJK(MBOX,2)
                        KBOXI=IDXIJK(MBOX,3)
C
                        ID=ABS(IBOXI-IBOXJ)
                        JD=ABS(JBOXI-JBOXJ)
                        KD=ABS(KBOXI-KBOXJ)
                        IJWS=(IDXWS(MBOX)+IDXWS(LBOX))/2
                        IF ((ID.GT.IJWS).OR.(JD.GT.IJWS).OR.
     *                     (KD.GT.IJWS)) THEN
                           IJCNT=IJCNT+1
                           IJTBL(IJCNT)=IJBOX-IPST+1
                        ENDIF
                     ENDDO
                     IF (IJCNT.GT.IKLFLAG) THEN
                        IKLFLAG=IJCNT
                        KLCNT=KLCNT+1
                        KLTPP(KLCNT,1)=IPP(KLBOX,1)
                        KLTPP(KLCNT,2)=IPP(KLBOX,2)
                        IJTBLP(KLCNT+1)=IJCNT+1
                     ENDIF
                  ENDDO
C
C           ----- DOING THE INTEGRAL AND FORMING K -----
C
                  IF (IJCNT.GT.0) THEN
                     ISHRCNT=ISHRCNT+1
                     KLSIZE=JPED-JPST+1
C                     KLSIZE=KLCNT
                     IF(NIJ.EQ.0) GO TO 840
                     CALL GETSHL(2,II,JJ,KK,LL,MAXGP,
     *                  KLTPP,KLSPP,KLSIZE,KLSIZE)
                     CALL ZQOUT(GHONDO)
C
C           ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
                     IF(IJKL.EQ.1) THEN
                        CALL S0000X(GHONDO,DDIJ,KLSPP,
     *                     KLCNT,IJTBLP,IJTBL)
                     ELSE
                        CALL HONDOX(GHONDO,DDIJ,KLSPP,
     *                     KLCNT,IJTBLP,IJTBL)
                     END IF
                        CALL FORMK(SCFTYP,1,POPLE,IA,DA,
     *                     FA,DB,FB,GHONDO,L2,NINT,NXYZ)
                  ENDIF
 840           ENDDO
            ELSE
               CALL SHELLS(1,II,JJ,1,1,.TRUE.)
               CALL IJPRIM(DDIJ)
C
               Q4 = 1.0D+00
               QQ4 = Q4
C
               ISHLCNT=ISHLCNT+MLSS
               DO KLSHLL=1,MLSS
                  KK=MLLIST(KLSHLL,1)
                  LL=MLLIST(KLSHLL,2)
C
C                 QFMM USES ONLY HONDO CODE
C
                  CALL SHELLS(2,II,JJ,KK,LL,.TRUE.)
                  CALL ZQOUT(GHONDO)
C
C           ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
                  IF(IJKL.EQ.1) THEN
                     CALL S0000(GHONDO,DDIJ)
                  ELSE
                     CALL GENRAL(GHONDO,DDIJ)
                  END IF
                  CALL FORMK(SCFTYP,IEXCH,POPLE,IA,DA,FA,DB,FB,
     *                GHONDO,L2,NINT,NXYZ)
               ENDDO
               ISHRCNT=ISHLCNT
            ENDIF
 1000    ENDDO
      ENDDO
C
      IF (GOPARR) CALL DDI_DLBRESET
C
      RETURN
      END
C*MODULE QMFM    *DECK LEXDER
      SUBROUTINE LEXDER(L2,DA,DB,XINTS,NSH2,NSHL2,SHLDEN,LSLIST,
     *   LDLIST,LSLN,LDLN,ISHELL,MLLIST,LMLN,LMLPNT,DABCUT,DABMAX,
     *   MAXXYZ,MINVEC,PMAX,IDXSHL,IPP,INDX2,IDXIJK,IDXWS,NCXYZ,
     *   DCHGIJ,DCHGKL,IJTPP,KLTPP)
C
C     DA: ALPHA DENSITY MATRIX: NUM*NUM
C     XINTS: EXCHANGE INTEGRAL OF <IJ|IJ>, THE SQURE ROOT OF THE
C     LARGEST <IJ|IJ> OVER SHELL PAIR IJ: (NSHELL*NSHELL+NSHELL)/2
C     SHLDEN: THE LARGEST DENSITY ELEMENT P(IJ) OVER SHELL PAIR IJ
C     PMAX: THE MAXIMUM MATRIX ELEMENT OF THE DENSITY MATRIX INVOLVED
C     IN THE SHELL-PAIR BLOCK.
C
C     LSLIST CONTAINES THE SIGNIFICANT SHELL PAIRS THAT ARE PRESECTED
C     BY USING OVERLAP INTERGRAL(S) AND PREORDERED BY THE SIZE OF THE
C     INTEGRAL ESTIMATE. THE SIZE OF LDST IS NSHELL*NSHELL.
C
C     LDLIST CONTAINS THE SHELL PAIRS OF THE LARGEST INTEGRAL VALUES
C     OF <IMAX|IMAX> OVER ALL INTEGRAL ESTIMATES OF THIS SHELL PAIR
C     TYPE <IJ|IJ>, THAT INVOLVE SHELL I.
C     THE SIGNIFICANT SHELL PAIRS ARE PREORDERED BY THE SIZE BY USING
C     THE TWO INDEX EXCHANGE INTEGRAL(XINTS) OF <IJ|IJ> AND THE DENSITY
C     ELEMENTS OF SHELL(SHLDEN).
C
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL SKIPI,SKIPJ,SKIPK,SKIPL
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL UHFTYP,OUT,QFMM,QOPS
C
      COMMON /FMCOM / X(1)
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /DSHLNO/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
      COMMON /IJPAIR/ IA(MXAO)
      COMMON/DERMEM/IWFN,IXCH,INIJG,IGINT,IFINT,ISINT,IIJKLG,
     1 IDAB,ICHRG,IXY,IXZ,IYZ,IX,IY,IZ,ISJ,ISK,ISL,IGIJKL,IGNKL,IGNM,
     2 IDIJ,IDKL,IB00,IB01,IB10,IC00,ID00,IF00,
     3 IAAI,IAAJ,IBBK,IBBL,IFI,IFJ,IFK,IFL,
     4 ISII,ISJJ,ISKK,ISLL,ISIJ,ISIK,ISIL,ISJK,ISJL,ISKL,
     5 IDIJSI,IDIJSJ,IDKLSK,IDKLSL,IABV,ICV,IRW
      COMMON /DERSKP/ IIAT,JJAT,KKAT,LLAT,SKIPI,SKIPJ,SKIPK,SKIPL
      COMMON /QFMLEX/ MAXGP
C
      DIMENSION XINTS(NSH2),SHLDEN(NSH2)
      DIMENSION LDLIST(NSHL2),LSLIST(NSHL2),LSLN(ISHELL+1),
     *          MLLIST(2*NSHL2,2),LDLN(ISHELL+1),
     *          LMLPNT(ISHELL,2),LMLN(NSHL2),IDXSHL(NSH2+1),
     *          IPP(NCXYZ,2),IDXWS(NCXYZ),IDXIJK(NCXYZ,3),INDX2(NCXYZ)
      DIMENSION IJTPP(MAXGP,2),KLTPP(MAXGP,2),
     *          DCHGIJ(15,*),DCHGKL(15,*)
      DIMENSION DA(L2),DB(*)
      DIMENSION PMAX(ISHELL)
C
      DATA UHF,ROHF /8HUHF     ,8HROHF    /
C
      UHFTYP= SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF
C
C     SETTING THE THRESHOLD
C     THE CUTOFF WAS DETERMINED IN INITPRMT
C
      CUTINT = CUTOFF
      ISHLCNT=0
      ISHRCNT=0
C
C     PARALLEL INITIALIZATION
C
      MINE=-1
      NEXT=-1
C
      NC=1
      LDF=1
C
C     ----- II,JJ SHELLS -----
C
C     LOOP OVER SIGNIFICANT "BRA"-SHELL PAIRS OF <II,JJ|
C     ON THE BASIS OF THE PRESORTED "BRA"-SHELL PAIR ARRAYS
C     OF LSLIST BY USING OVERLAP INREGRALS.
C
      DO II = 1,ISHELL
         INX=(II*II-II)/2
         JJMIN=LSLN(II)
         JJMAX=LSLN(II+1)-1
         DO JJA = JJMIN,JJMAX
            JJ=LSLIST(JJA)
            IF (JJ.GT.II) GOTO 1000
C
C    PARALLEL RUNS
C
            IF ( GOPARR) THEN
                  MINE=MINE+1
                  IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
                  IF (NEXT.NE.MINE)  GOTO 1000
            END IF
C
            JNX=(JJ*JJ-JJ)/2
            IJIJ = INX + JJ
            ML=0
            IFLAG=0
            TESTIJ=XINTS(IJIJ)*PMAX(JJ)
C
C     ----- FIRST KL PAIRS -----
C
C     ----- K SHELL -----
C     LOOP OVER SIGNIFICANT K'S CORRESPONDING TO I OF (IJ|KL) WHICH
C     WAS PRESORTED BY THE SIZE OF |P(IK)|(KMAX|KMAX) FOR EACH I.
C
            DO KKA=LDLN(II),LDLN(II+1)-1
               KK=LDLIST(KKA)
               IF (KK.GT.II) GOTO 150
               KNX=(KK*KK-KK)/2
               KNXD=INX+KK
               TESTIJK=SHLDEN(KNXD)*TESTIJ
               TESTCIJK=SHLDEN(KNXD)*XINTS(IJIJ)
C
C     ----- L SHELL -----
C
C     LOOP OVER SIGNIFICANT L'S OF K
C
               LCOUNT=0
               DO LLA=LSLN(KK),LSLN(KK+1)-1
                  LL=LSLIST(LLA)
                  IF (LL.GT.KK) GOTO 50
                  KLKL=KNX+LL
                  TEST = ABS(TESTIJK*XINTS(KLKL))
                  IF (TEST.GE.CUTINT) THEN
                     LCOUNT=LCOUNT+1
                     LMLN(LCOUNT)=LL
                  ELSE
                      GOTO 100
                  ENDIF
 50            ENDDO
 100           CONTINUE
               DO LCNT=1,LCOUNT
                  KLKL=KNX+LMLN(LCNT)
                  LJNX=JNX+LMLN(LCNT)
                  TEST = ABS(TESTCIJK*XINTS(KLKL)*SHLDEN(LJNX))
                  IF (TEST.GE.CUTINT) THEN
                     ML=ML+1
                     MLLIST(ML,1)=KK
                     MLLIST(ML,2)=LMLN(LCNT)
                  ENDIF
               ENDDO
C
               IF (ML.EQ.IFLAG) THEN
                  GOTO 200
               ELSE
                  IFLAG=ML
               ENDIF
 150        ENDDO
 200        CONTINUE
            IFLAG=ML
C
C     ----- SECOND KL PAIRS -----
C
C     ----- K SHELL -----
C
            DO KKA=LDLN(JJ),LDLN(JJ+1)-1
               KK=LDLIST(KKA)
               IF (KK.GT.II) GOTO 350
               KNX=(KK*KK-KK)/2
               IF (KK.GT.JJ) THEN
                  KNXD=KNX+JJ
               ELSE
                  KNXD=JNX+KK
               ENDIF
               TESTIJK=SHLDEN(KNXD)*TESTIJ
               TESTCIJK=SHLDEN(KNXD)*XINTS(IJIJ)
C
C     ----- L SHELL -----
C
               LCOUNT=0
               DO LLA=LSLN(KK),LSLN(KK+1)-1
                  LL=LSLIST(LLA)
                  IF (LL.GT.KK) GOTO 250
                  KLKL=KNX+LL
                  TEST = ABS(TESTIJK*XINTS(KLKL))
                  IF (TEST.GE.CUTINT) THEN
                     LCOUNT=LCOUNT+1
                     LMLN(LCOUNT)=LL
                  ELSE
                     GOTO 300
                  ENDIF
 250           ENDDO
 300           CONTINUE
C
C               LOOP OVER LCOUNT
C
               DO LCNT=1,LCOUNT
                  KLKL=KNX+LMLN(LCNT)
                  LINX=INX+LMLN(LCNT)
                  TEST = ABS(TESTCIJK*XINTS(KLKL)*SHLDEN(LINX))
                  IF (TEST.GE.CUTINT) THEN
                     ML=ML+1
                     MLLIST(ML,1)=KK
                     MLLIST(ML,2)=LMLN(LCNT)
                  ENDIF
               ENDDO
C
               IF (ML.EQ.IFLAG) THEN
                  GOTO 400
               ELSE
                  IFLAG=ML
               ENDIF
 350        ENDDO
 400        CONTINUE
C
            IF (ML.EQ.0) GOTO 1000
C
C           ------ SORT ------
C
            CALL IDIVIDEML(NSHL2,ML,ISHELL,MLLIST,LMLPNT,
     *           IXTBL)
C
C           ------ PURGE ------
C
            MLSS=0
            ITAG=MLLIST(1,1)
            JTAG=MLLIST(1,2)
            IF (ITAG.GT.JJ) THEN
               IF (.NOT.((II.EQ.ITAG).AND.(JTAG.GT.JJ)) ) THEN
                  MLSS=1
               ENDIF
            ELSE
               MLSS=1
            ENDIF
C
            DO I=1,ML
               IF (ITAG.NE.MLLIST(I,1)) THEN
                  ITAG=MLLIST(I,1)
                  JTAG=MLLIST(I,2)
                  IF (ITAG.GT.JJ) THEN
                     IF (.NOT.((II.EQ.ITAG).AND.(JTAG.GT.JJ))) THEN
                        MLSS=MLSS+1
                        MLLIST(MLSS,1)=ITAG
                        MLLIST(MLSS,2)=JTAG
                     ENDIF
                  ELSE
                     MLSS=MLSS+1
                     MLLIST(MLSS,1)=ITAG
                     MLLIST(MLSS,2)=JTAG
                  ENDIF
               ELSE
                  IF (JTAG.NE.MLLIST(I,2)) THEN
                     JTAG=MLLIST(I,2)
                     IF (ITAG.GT.JJ) THEN
                        IF (.NOT.((II.EQ.ITAG).AND.(JTAG.GT.JJ))) THEN
                           MLSS=MLSS+1
                           MLLIST(MLSS,1)=ITAG
                           MLLIST(MLSS,2)=JTAG
                        ENDIF
                     ELSE
                        MLSS=MLSS+1
                        MLLIST(MLSS,1)=ITAG
                        MLLIST(MLSS,2)=JTAG
                     ENDIF
                  ENDIF
               ENDIF
            ENDDO
C
C
C           ----- PREPARE INTEGRAL INDEX OF I AND J SHELLS -----
C
C           IF ITERMS.EQ.0, THEN WE FORM THE J AND K MATRICES TOGETHER.
C           SO WE NEED TO DELAY DUPLICATED INTEGRATION.
C           ONLY THE K_FAR WILL BE COMPUTED.
C
            IF (ITERMS.EQ.0) THEN
               IPST=IDXSHL(INX+JJ)+1
               IPED=IDXSHL(INX+JJ+1)
               DO IJPP=IPST,IPED
                  ISTRT=IJPP-IPST+1
                  IJTPP(ISTRT,1)=IPP(IJPP,1)
                  IJTPP(ISTRT,2)=IPP(IJPP,2)
               ENDDO
               IJSIZE=IPED-IPST+1
               IIJJ=IA(MAX0(II,JJ))+MIN0(II,JJ)
               Q4 = 1.0D+00
C
               ISHLCNT=ISHLCNT+MLSS
               DO 840 KLSHLL=1,MLSS
                  KK=MLLIST(KLSHLL,1)
                  KNX=(KK*KK-KK)/2
                  LL=MLLIST(KLSHLL,2)
C
                  JPST=IDXSHL(KNX+LL)+1
                  JPED=IDXSHL(KNX+LL+1)
                  KLCNT=0
                  IJCNT=0
                  DO 700 KLBOX=JPST,JPED
                     LBOX=INDX2(KLBOX)
                     IBOXJ=IDXIJK(LBOX,1)
                     JBOXJ=IDXIJK(LBOX,2)
                     KBOXJ=IDXIJK(LBOX,3)
                     IJCNT=0
                     KLCNT=0
                     DO IJBOX=IPST,IPED
                        MBOX=INDX2(IJBOX)
                        IBOXI=IDXIJK(MBOX,1)
                        JBOXI=IDXIJK(MBOX,2)
                        KBOXI=IDXIJK(MBOX,3)
C
                        ID=ABS(IBOXI-IBOXJ)
                        JD=ABS(JBOXI-JBOXJ)
                        KD=ABS(KBOXI-KBOXJ)
                        IJWS=(IDXWS(MBOX)+IDXWS(LBOX))/2
                        IF ((ID.GT.IJWS).OR.(JD.GT.IJWS).OR.
     *                     (KD.GT.IJWS)) THEN
                           IJCNT=IJCNT+1
                           IJTPP(IJCNT,1)=IPP(IJBOX,1)
                           IJTPP(IJCNT,2)=IPP(IJBOX,2)
                        ENDIF
                     ENDDO
                     IF (IJCNT.GT.0) THEN
                        KLCNT=KLCNT+1
                        KLTPP(KLCNT,1)=IPP(KLBOX,1)
                        KLTPP(KLCNT,2)=IPP(KLBOX,2)
                        ISHRCNT=ISHRCNT+1
                        KLSIZE=KLCNT
                        IJSIZE=IJCNT
                        CALL LEDSHL(II,JJ,DCHGIJ,NIJ,0,IJSIZE,IJSIZE,
     *                     MAXGP,IJTPP)
                        CALL LEDSHL(KK,LL,DCHGKL,NKL,0,KLSIZE,KLSIZE,
     *                     MAXGP,KLTPP)
                        IJIJ=IA(MAX0(II,JJ))+MIN0(II,JJ)
                        KLKL=IA(MAX0(KK,LL))+MIN0(KK,LL)
                        GMAX=(X(IXCH+IJIJ-1)*X(IXCH+KLKL-1))
                        IF (GMAX.LT.CUTOFF) GO TO 700
                        KKLL=IA(MAX0(KK,LL))+MIN0(KK,LL)
                        ISH=II
                        JSH=JJ
                        KSH=KK
                        LSH=LL
C
C     ----- SELECT CENTERS FOR DERIVATIVES -----
C
                        CALL JKDATM(ISH,JSH,KSH,LSH)
                        IF(SKIPI.AND.SKIPJ.AND.SKIPK.AND.SKIPL)
     *                     GOTO 840
C
C     ----- SET INDICES FOR SHELL BLOCK -----
C
                        CALL JKDSHL(ISH,JSH,KSH,LSH)
                        CALL JKDNDX(X(IIJKLG))
C
C     ----- OBTAIN 2 BODY DENSITY FOR THIS SHELL BLOCK -----
C
                        CALL DABEX(ISH,JSH,KSH,LSH,UHFTYP,DA,
     *                             DB,X(IDAB),DABMAX)
                        IF(DABMAX*GMAX.LT.CUTOFF) GO TO 700
C
                        CALL JKLSPD(NKL,X(IGINT),
     *                     X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),
     *                     X(IGNKL),X(IGNM),X(IXY),X(IXZ),X(IYZ),
     *                     X(IX),X(IY),X(IZ),X(ISJ),X(ISK),X(ISL),
     *                     X(IB00),X(IB01),X(IB10),X(IC00),X(ID00),
     *                     X(IF00),X(IDIJ),X(IDKL),X(IDIJSI),
     *                     X(IDIJSJ),X(IDKLSK),X(IDKLSL),X(IABV),
     *                     X(ICV),X(IRW),X(IAAI),X(IAAJ),X(IBBK),
     *                     X(IBBL),X(IFI),X(IFJ),X(IFK),X(IFL),
     *                     X(ISII),X(ISJJ),X(ISKK),X(ISLL),X(ISIJ),
     *                     X(ISIK),X(ISIL),X(ISJK),X(ISJL),X(ISKL),
     *                     X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,DDA,Q4,
     *                     MINVEC,DABCUT,DABMAX,DCHGIJ,DCHGKL)
                        IJCNT=0
                        KLCNT=0
                     ENDIF
 700              CONTINUE
 840           CONTINUE
            ELSE
               IIJJ=IA(MAX0(II,JJ))+MIN0(II,JJ)
               CALL OEDRD(X(INIJG),NIJ,NIJ0,IIJJ)
               Q4 = 1.0D+00
C
               ISHLCNT=ISHLCNT+MLSS
               DO KLSHLL=1,MLSS
                  KK=MLLIST(KLSHLL,1)
                  LL=MLLIST(KLSHLL,2)
                  IJIJ=IA(MAX0(II,JJ))+MIN0(II,JJ)
                  KLKL=IA(MAX0(KK,LL))+MIN0(KK,LL)
                  GMAX=(X(IXCH+IJIJ-1)*X(IXCH+KLKL-1))
                  IF (GMAX.LT.CUTOFF) GO TO 500
C
                  KKLL=IA(MAX0(KK,LL))+MIN0(KK,LL)
                  CALL OEDRD(X(INIJG),NKL,NKL0,KKLL)
                  ISH=II
                  JSH=JJ
                  KSH=KK
                  LSH=LL
C
C     ----- SELECT CENTERS FOR DERIVATIVES -----
C
                  CALL JKDATM(ISH,JSH,KSH,LSH)
                  IF(SKIPI.AND.SKIPJ.AND.SKIPK.AND.SKIPL) GO TO 500
C
C     ----- SET INDICES FOR SHELL BLOCK -----
C
                  CALL JKDSHL(ISH,JSH,KSH,LSH)
                  CALL JKDNDX(X(IIJKLG))
C
C     ----- OBTAIN 2 BODY DENSITY FOR THIS SHELL BLOCK -----
C
                  CALL DABEX(ISH,JSH,KSH,LSH,UHFTYP,DA,
     *                       DB,X(IDAB),DABMAX)
                  IF(DABMAX*GMAX.LT.CUTOFF) GO TO 500
C
C     ----- EVALUATE DERIVATIVE INTEGRAL, AND ADD TO THE GRADIENT -----
C
                  CALL JKDSPD(NIJ0,NKL,NKL0,X(ICHRG),X(IGINT),
     1               X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),X(IGNKL),
     2               X(IGNM),X(IXY),X(IXZ),X(IYZ),X(IX),X(IY),X(IZ),
     3               X(ISJ),X(ISK),X(ISL),X(IB00),X(IB01),X(IB10),
     4               X(IC00),X(ID00),X(IF00),X(IDIJ),X(IDKL),
     5               X(IDIJSI),X(IDIJSJ),X(IDKLSK),X(IDKLSL),X(IABV),
     6               X(ICV),X(IRW),X(IAAI),X(IAAJ),X(IBBK),X(IBBL),
     7               X(IFI),X(IFJ),X(IFK),X(IFL),X(ISII),X(ISJJ),
     8               X(ISKK),X(ISLL),X(ISIJ),X(ISIK),X(ISIL),X(ISJK),
     *               X(ISJL),X(ISKL),X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,
     *               DDA,Q4,MINVEC, DABCUT,DABMAX)
C
 500           ENDDO
               ISHRCNT=ISHLCNT
            ENDIF
 1000    ENDDO
      ENDDO
      IF (GOPARR) CALL DDI_DLBRESET
C
      RETURN
      END
C*MODULE QMFM    *DECK Q_FMM
      SUBROUTINE Q_FMM(SCFTYP,NCXYZ,IYP,INDX2,IDXIJK,IDXWS,CXYZ,
     *   IBS,IYZTBL,NTMPL,YP,ZP,DMAT,DMATB,NTBOX,MAXWS,IYZPNT,
     *   F,G,ZLL,CLM,FLM,IDXBOX,NSBOX,
     *   NZ,FAO,FBO,ISP,IPP)
C
C     MAIN DRIVER OF QFMM (QUANTUM FAST MULTIPOLE METHOD)
C
C     THIS ROUTINE CONSTRUCTS THE COULOMB MATRIX ON THE BASIS OF
C     LINEAR SCALING ALGORITHM.
C
C     C. H. CHOI OCT 2000
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMPLEX*16 YP,ZP
      LOGICAL QFMM,QOPS,GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /QMFM  /SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *       ITERMS,QOPS,ISCUT
C
      DIMENSION IYP(NCXYZ),CXYZ(NCXYZ,3),IBS(NCXYZ,4),IDXIJK(NCXYZ,3),
     *   INDX2(NCXYZ),IDXWS(NCXYZ),
     *   IYZTBL(2**(NS+1)-1,2**(NS+1)-1,2**(NS+1)-1),
     *   F((NP*(NP+1)*(NP+2)*4/3)+(NP+1)),CLM(-NP:NP),
     *   G((NP*(NP+1)*(NP+2)*4/3)+(NP+1)),FLM(-NP:NP),
     *   ZLL(0:2*NP+1),YP((NP+1)*(NP+2)/2,NTMPL),
     *   ZP((NP+1)*(NP+2)/2,NTMPL),DMAT(*),DMATB(*),
     *   IYZPNT(NTBOX,MAXWS/2),ISP(*),IPP(*)
      DIMENSION FAO(*),FBO(*),IDXBOX(*),NSBOX(20)
C
C     PHASE I : OBTAIN THE MULTIPOLE EXPANSION OF NON-EMPTY BOXS IN THE
C               LOWEST SUBDIVISION LEVEL, NS.
C
      CALL GETY(SCFTYP,NCXYZ,IYP,INDX2,IDXIJK,IDXWS,CXYZ,IBS,
     *   IYZTBL,NTMPL,YP,DMAT,DMATB,NTBOX,MAXWS,IYZPNT,F,G,ZLL,
     *   CLM,FLM,ISP,IPP)
      ILYP=(NP+1)*(NP+2)*NTMPL
      IF(GOPARR) CALL DDI_GSUMF(4000,YP,ILYP)
C
C     PHASE II : OBTAIN THE LONG-RANGE POTENTIAL USING FMM
C     THIS PROCESS IS COMPOSED OF C2P, P2P AND P2C.
C
      CALL C2P(IYZTBL,F,G,CLM,FLM,ZLL,NTMPL,YP,NTBOX,IDXBOX,NSBOX,
     *   MAXWS,IYZPNT,IC2P)
C
      CALL SP2P(IYZTBL,F,G,CLM,FLM,ZLL,NTMPL,YP,ZP,NTBOX,IDXBOX,
     *   NSBOX,MAXWS,IYZPNT,IP2P)
C
      IF(GOPARR) THEN
         CALL DDI_GSUMF(4001,ZP,ILYP)
         CALL DDI_GSUMI(4002,IP2P,1)
      END IF
C
      CALL P2C(IYZTBL,F,G,CLM,FLM,ZLL,NTMPL,ZP,IP2C,NTBOX,MAXWS,IYZPNT)
C
C     PHASE III: CONSTRUCT COULOMB MATRIX OF THE LONG-RANGE POTENTIAL
C
      CALL FORMFJ(SCFTYP,NCXYZ,IYP,INDX2,IDXIJK,CXYZ,IBS,FAO,
     *   FBO,NZ,IYZTBL,ZP,NTBOX,MAXWS,IYZPNT,IDXWS,F,G,ZLL,CLM,FLM,
     *   ISP,IPP)
C
      RETURN
      END
C*MODULE QMFM    *DECK GXYZLM
      SUBROUTINE GXYZLM
C
C     THIS ROUTINE COMPUTES THE INTEGRAL VALUES OF G(LX,LY,LZ;LMAX,L,M)
C     LX, LY,LZ : THE ANGULAR MOMENTUM OF CARTESIAN GAUSSIAN FUNCTIONS
C     LMAX : THE HIGHEST VALUE OF L
C     L,M : ORDER OF MOMENTS IN SPHERICAL POLAR COORDINATES.
C     NOTE THAT IT ONLY CONTAINS THE M >= ZERO.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16 G
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00,THREE=3.0D+00,
     *          FOUR=4.0D+00)
      PARAMETER (PI=3.141592653589793238D+00)
      PARAMETER (MAXGLM=226,MAXFL=8)
      COMMON /FGLM   / G(MAXGLM),
     *           FCTRL(0:2,0:2),F(0:MAXFL),ILMAXL(0:4,0:4)
C      DIMENSION G(MAXGLM)
C
C     G(LX,LY,LZ;L,M)
C
C     FACTORS FOR EACH L
C
      F0=FOUR*PI
      F1=FOUR*PI/(TWO*ONE+ONE)
      F2=FOUR*PI/(TWO*TWO+ONE)
      F3=FOUR*PI/(TWO*THREE+ONE)
      F4=FOUR*PI/(TWO*FOUR+ONE)
C
C   LMAX = 0, L = 0
      G(1)=F0
C   LMAX = 1, L = 1
      T0=F1*ONE
      T1=F1*ONE/SQRT(TWO)
      G(2)=ZERO
      G(3)=-T1
      G(4)=ZERO
      G(5)=DCMPLX(ZERO,T1)
      G(6)=T0
      G(7)=ZERO
C   LMAX = 2, L = 0
      T0=F0/THREE
      G(8)=T0
      G(9)=ZERO
      G(10)=ZERO
      G(11)=T0
      G(12)=ZERO
      G(13)=T0
C   LMAX = 2, L = 2
      T0=F2/THREE
      T1=F2*SQRT(TWO/THREE)/TWO
      G(14)=-T0
      G(15)=ZERO
      G(16)=T1
      G(17)=ZERO
      G(18)=ZERO
      G(19)=DCMPLX(ZERO,-T1)
      G(20)=ZERO
      G(21)=-T1
      G(22)=ZERO
      G(23)=-T0
      G(24)=ZERO
      G(25)=-T1
      G(26)=ZERO
      G(27)=DCMPLX(ZERO,T1)
      G(28)=ZERO
      G(29)=T0*TWO
      G(30)=ZERO
      G(31)=ZERO
C   LMAX = 3, L = 1
      T0=F1/5.0D+00
      T1=-F1*ONE/(5.0D+00*SQRT(TWO))
      G(32)=ZERO
      G(33)=THREE*T1
      G(34)=ZERO
      G(35)=DCMPLX(ZERO,-T1)
      G(36)=T0
      G(37)=ZERO
      G(38)=ZERO
      G(39)=T1
      G(40)=ZERO
      G(41)=ZERO
      G(42)=ZERO
      G(43)=T1
      G(44)=ZERO
      G(45)=DCMPLX(ZERO,-THREE*T1)
      G(46)=T0
      G(47)=ZERO
      G(48)=ZERO
      G(49)=DCMPLX(ZERO,-T1)
      G(50)=T0*THREE
      G(51)=ZERO
C   LMAX = 3, L = 3
      T0=F3/5.0D+00
      T1=F3*SQRT(THREE)/(10.0D+00)
      T2=F3/(TWO*SQRT(5.0D+00))
      T3=F3/(10.0D+00*SQRT(THREE))
      T4=F3/SQRT(30.0D+00)
      T5=F3*SQRT(TWO/15.0D+00)
      T6=F3*TWO/(5.0D+00*SQRT(THREE))
      G(52)=ZERO
      G(53)=T1
      G(54)=ZERO
      G(55)=-T2
      G(56)=ZERO
      G(57)=DCMPLX(ZERO,-T3)
      G(58)=ZERO
      G(59)=DCMPLX(ZERO,T2)
      G(60)=-T0
      G(61)=ZERO
      G(62)=T4
      G(63)=ZERO
      G(64)=ZERO
      G(65)=T3
      G(66)=ZERO
      G(67)=T2
      G(68)=ZERO
      G(69)=ZERO
      G(70)=DCMPLX(ZERO,-T4)
      G(71)=ZERO
      G(72)=ZERO
      G(73)=-T6
      G(74)=ZERO
      G(75)=ZERO
      G(76)=ZERO
      G(77)=DCMPLX(ZERO,-T1)
      G(78)=ZERO
      G(79)=DCMPLX(ZERO,-T2)
      G(80)=-T0
      G(81)=ZERO
      G(82)=-T4
      G(83)=ZERO
      G(84)=ZERO
      G(85)=DCMPLX(ZERO,T6)
      G(86)=ZERO
      G(87)=ZERO
      G(88)=TWO*T0
      G(89)=ZERO
      G(90)=ZERO
      G(91)=ZERO
C   LMAX = 4, L = 0
      T0=F0/5.0D+00
      T1=T0/THREE
      G(92)=T0
      G(93)=ZERO
      G(94)=ZERO
      G(95)=T1
      G(96)=ZERO
      G(97)=T1
      G(98)=ZERO
      G(99)=ZERO
      G(100)=ZERO
      G(101)=ZERO
      G(102)=T0
      G(103)=ZERO
      G(104)=T1
      G(105)=ZERO
      G(106)=T0
C   LMAX = 4, L = 2
      T1=F2*TWO/7.0D+00
      T2=F2*SQRT(6.0D+00)/7.0D+00
      T3=F2*SQRT(THREE/TWO)/7.0D+00
      T4=F2*TWO/21.0D+00
      T5=F2/(7.0D+00*SQRT(6.0D+00))
      T6=F2/21.0D+00
      G(107)=-T1
      G(108)=ZERO
      G(109)=T2
      G(110)=ZERO
      G(111)=ZERO
      G(112)=DCMPLX(ZERO,-T3)
      G(113)=ZERO
      G(114)=-T3
      G(115)=ZERO
      G(116)=-T4
      G(117)=ZERO
      G(118)=ZERO
      G(119)=ZERO
      G(120)=DCMPLX(ZERO,T5)
      G(121)=ZERO
      G(122)=T6
      G(123)=ZERO
      G(124)=T5
      G(125)=ZERO
      G(126)=ZERO
      G(127)=DCMPLX(ZERO,-T3)
      G(128)=ZERO
      G(129)=-T5
      G(130)=ZERO
      G(131)=ZERO
      G(132)=ZERO
      G(133)=DCMPLX(ZERO,-T5)
      G(134)=ZERO
      G(135)=-T3
      G(136)=ZERO
      G(137)=-T1
      G(138)=ZERO
      G(139)=-T2
      G(140)=ZERO
      G(141)=DCMPLX(ZERO,T3)
      G(142)=ZERO
      G(143)=T6
      G(144)=ZERO
      G(145)=-T5
      G(146)=ZERO
      G(147)=DCMPLX(ZERO,T3)
      G(148)=ZERO
      G(149)=T1*TWO
      G(150)=ZERO
      G(151)=ZERO
C   LMAX = 4, L = 4
      T1=F4/35.0D+00
      T2=F4*SQRT(TWO/5.0D+00)/7.0D+00
      T3=F4/SQRT(70.0D+00)
      T4=F4/(7.0D+00*SQRT(10.0D+00))
      T5=F4/(14.0D+00*SQRT(5.0D+00))
      T6=F4/(TWO*SQRT(35.0D+00))
      T7=F4*TWO/(7.0D+00*SQRT(5.0D+00))
      G(152)=T1*THREE
      G(153)=ZERO
      G(154)=-T2
      G(155)=ZERO
      G(156)=T3
C
      G(157)=ZERO
      G(158)=ZERO
      G(159)=DCMPLX(ZERO,T4)
      G(160)=ZERO
      G(161)=DCMPLX(ZERO,-T3)
C
      G(162)=ZERO
      G(163)=T5*THREE
      G(164)=ZERO
      G(165)=-T6
      G(166)=ZERO
C
      G(167)=T1
      G(168)=ZERO
      G(169)=ZERO
      G(170)=ZERO
      G(171)=-T3
C
      G(172)=ZERO
      G(173)=DCMPLX(ZERO,-T5)
      G(174)=ZERO
      G(175)=DCMPLX(ZERO,T6)
      G(176)=ZERO
C
      G(177)=-T1*FOUR
      G(178)=ZERO
      G(179)=T2
      G(180)=ZERO
      G(181)=ZERO
C
      G(182)=ZERO
      G(183)=ZERO
      G(184)=DCMPLX(ZERO,T4)
      G(185)=ZERO
      G(186)=DCMPLX(ZERO,T3)
C
      G(187)=ZERO
      G(188)=T5
      G(189)=ZERO
      G(190)=T6
      G(191)=ZERO
C
      G(192)=ZERO
      G(193)=ZERO
      G(194)=DCMPLX(ZERO,-T2)
      G(195)=ZERO
      G(196)=ZERO
C
      G(197)=ZERO
      G(198)=-T7
      G(199)=ZERO
      G(200)=ZERO
      G(201)=ZERO
C
      G(202)=T1*THREE
      G(203)=ZERO
      G(204)=T2
      G(205)=ZERO
      G(206)=T3
C
      G(207)=ZERO
      G(208)=DCMPLX(ZERO,-T5*THREE)
      G(209)=ZERO
      G(210)=DCMPLX(ZERO,-T6)
      G(211)=ZERO
C
      G(212)=-T1*FOUR
      G(213)=ZERO
      G(214)=-T2
      G(215)=ZERO
      G(216)=ZERO
C
      G(217)=ZERO
      G(218)=DCMPLX(ZERO,T7)
      G(219)=ZERO
      G(220)=ZERO
      G(221)=ZERO
C
      G(222)=T1*8.0D+00
      G(223)=ZERO
      G(224)=ZERO
      G(225)=ZERO
      G(226)=ZERO
C
C     F(LMAX)
C
      SPI=SQRT(PI)
      F(0)=SPI/(TWO*TWO)
      F(1)=ONE/TWO
      F(2)=3.0D+00*SPI/(TWO*TWO*TWO)
      F(3)=ONE
      F(4)=5.0D+00*3.0D+00*SPI/(TWO*TWO*TWO*TWO)
      F(5)=3.0D+00
      F(6)=7.0D+00*5.0D+00*3.0D+00*SPI/(TWO*TWO*TWO*TWO*TWO)
      F(7)=4.0D+00*3.0D+00
      F(8)=9.0D+00*7.0D+00*5.0D+00*3.0D+00*SPI/(TWO*TWO*TWO*TWO*TWO*TWO)
C
      ILMAXL(0,0)=1
      ILMAXL(1,1)=2
      ILMAXL(2,0)=8
      ILMAXL(2,2)=14
      ILMAXL(3,1)=32
      ILMAXL(3,3)=52
      ILMAXL(4,0)=92
      ILMAXL(4,2)=107
      ILMAXL(4,4)=152
C
      FCTRL(0,0)=ONE
      FCTRL(1,0)=ONE
      FCTRL(1,1)=ONE
      FCTRL(2,0)=ONE
      FCTRL(2,1)=TWO
      FCTRL(2,2)=ONE
C
      RETURN
      END
C*MODULE QMFM    *DECK MOMSPC
      SUBROUTINE MOMSPC(LIT,LJT,IBS,JBS,YLM,PA,PB,YOTA,DIJ)
C
C     THIS ROUTINE COMPUTES MULTIPOLE MOMENTS OF CARTESIAN GAUSSIAN
C     FUNCTIONS IN SPHERICAL POLAR COORDINATES.
C
C     LMAX : THE HIGHEST VALUE OF L
C     L,M : ORDER OF MOMENTS IN SPHERICAL POLAR COORDINATES.
C     NOTE THAT IT ONLY CONTAINS THE M >= ZERO.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16 G,YLM
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00)
      PARAMETER (MAXGLM=226,MAXFL=8,MAXNP=45)
      LOGICAL QOPS,QFMM
      COMMON /QMFM  /SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *       ITERMS,QOPS,ISCUT
      COMMON /FGLM   / G(MAXGLM),
     *           FCTRL(0:2,0:2),F(0:MAXFL),ILMAXL(0:4,0:4)
      DIMENSION YLM((MAXNP+1)*(MAXNP+2)/2),PA(3),PB(3)
C
      LAX=0
      LAY=0
      LAZ=0
      LBX=0
      LBY=0
      LBZ=0
      DO I=1,(NP+1)*(NP+2)/2
         YLM(I)=ZERO
      ENDDO
C
      GOTO (500,100,200) LIT
 100  GOTO (500,110,120,130) IBS
 110  LAX=1
      GOTO 500
 120  LAY=1
      GOTO 500
 130  LAZ=1
      GOTO 500
 200  GOTO (210,220,230,240,250,260) IBS-4
 210  LAX=2
      GOTO 500
 220  LAY=2
      GOTO 500
 230  LAZ=2
      GOTO 500
 240  LAX=1
      LAY=1
      GOTO 500
 250  LAX=1
      LAZ=1
      GOTO 500
 260  LAY=1
      LAZ=1
      GOTO 500
 500  GOTO (1000,600,700) LJT
 600  GOTO (1000,610,620,630) JBS
 610  LBX=1
      GOTO 1000
 620  LBY=1
      GOTO 1000
 630  LBZ=1
      GOTO 1000
 700  GOTO (710,720,730,740,750,760) JBS-4
 710  LBX=2
      GOTO 1000
 720  LBY=2
      GOTO 1000
 730  LBZ=2
      GOTO 1000
 740  LBX=1
      LBY=1
      GOTO 1000
 750  LBX=1
      LBZ=1
      GOTO 1000
 760  LBY=1
      LBZ=1
 1000 CONTINUE
C
C
      TPA1=ONE
      DO IAX=LAX,0,-1
         FA1=TPA1*FCTRL(LAX,IAX)
         TPB1=ONE
         DO IBX=LBX,0,-1
            FB1=TPB1*FCTRL(LBX,IBX)
            LAMAXX=IAX+IBX
            TPA2=ONE
            DO IAY=LAY,0,-1
               FA2=TPA2*FCTRL(LAY,IAY)
               TPB2=ONE
               DO IBY=LBY,0,-1
                  FB2=TPB2*FCTRL(LBY,IBY)
                  LAMAXY=IAY+IBY
                  TPA3=ONE
                  DO IAZ=LAZ,0,-1
                     FA3=TPA3*FCTRL(LAZ,IAZ)
                     TPB3=ONE
                     DO IBZ=LBZ,0,-1
                        FB3=TPB3*FCTRL(LBZ,IBZ)
                        LAMAXZ=IAZ+IBZ
                        LAMAXXY=LAMAXX+LAMAXY
                        LAMAX=LAMAXXY+LAMAXZ
                        LS=MOD(LAMAX,2)
                        MS=MOD(LAMAXXY,2)
                        DO L=LS,LAMAX,2
                           LDXLM=L*(L+1)/2+1
                           IDXG=ILMAXL(LAMAX,L)
                           IRELP=(LAMAX-LAMAXX)
                           IXYZ=IRELP*(IRELP+1)/2+1+LAMAXZ
                           IDXG=IDXG+(L+1)*(IXYZ-1)
                           IF (MOD(LAMAX+L,2).EQ.0) THEN
                              TEMP=F(LAMAX+L)/
     *                            YOTA**((LAMAX+L+2.0D+00)/TWO+0.5D+00)
                           ELSE
                              TEMP=F(LAMAX+L)/
     *                            YOTA**((LAMAX+L+3.0D+00)/TWO)
                           ENDIF
                           DO M=MS,L,2
                              IDXGA=IDXG+M
                              LDXLMA=LDXLM+M
                              YLM(LDXLMA)=YLM(LDXLMA)
     *                           -FA1*FA2*FA3*FB1*FB2*FB3
     *                           *TEMP*G(IDXGA)*DIJ
                           ENDDO
                        ENDDO
                        TPB3=TPB3*PB(3)
                     ENDDO
                     TPA3=TPA3*PA(3)
                  ENDDO
                  TPB2=TPB2*PB(2)
               ENDDO
               TPA2=TPA2*PA(2)
            ENDDO
            TPB1=TPB1*PB(1)
         ENDDO
         TPA1=TPA1*PA(1)
      ENDDO
C
      RETURN
      END
C*MODULE QMFM    *DECK MOMAB
      SUBROUTINE MOMAB(LIT,LJT,IBS,JBS,YLM,PA,PB,ALP,BET,YOTA,DIJ,
     *IX,IY,IZ)
C
C     THIS ROUTINE COMPUTES MULTIPOLE MOMENTS OF CARTESIAN GAUSSIAN
C     FUNCTIONS IN SPHERICAL POLAR COORDINATES.
C
C     LMAX : THE HIGHEST VALUE OF L
C     L,M : ORDER OF MOMENTS IN SPHERICAL POLAR COORDINATES.
C     NOTE THAT IT ONLY CONTAINS THE M >= ZERO.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16 G,YLM
      LOGICAL QFMM,QOPS
C
      PARAMETER (ZERO=0.0D+00, TWO=2.0D+00)
      PARAMETER (MAXGLM=226,MAXFL=8,MAXNP=45)
      COMMON /FGLM   / G(MAXGLM),
     *                 FCTRL(0:2,0:2),F(0:MAXFL),ILMAXL(0:4,0:4)
      COMMON /QMFM   / SIZE,EPSLN,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                 ITERMS,QOPS,ISCUT
      DIMENSION YLM((MAXNP+1)*(MAXNP+2)/2),PA(3),PB(3)
C
      LAX=0
      LAY=0
      LAZ=0
      LBX=0
      LBY=0
      LBZ=0
      DO I=1,(NP+1)*(NP+2)/2
         YLM(I)=ZERO
      ENDDO
C
      GOTO (500,100,200) LIT
 100  GOTO (500,110,120,130) IBS
 110  LAX=1
      GOTO 500
 120  LAY=1
      GOTO 500
 130  LAZ=1
      GOTO 500
 200  GOTO (210,220,230,240,250,260) IBS-4
 210  LAX=2
      GOTO 500
 220  LAY=2
      GOTO 500
 230  LAZ=2
      GOTO 500
 240  LAX=1
      LAY=1
      GOTO 500
 250  LAX=1
      LAZ=1
      GOTO 500
 260  LAY=1
      LAZ=1
      GOTO 500
 500  GOTO (1000,600,700) LJT
 600  GOTO (1000,610,620,630) JBS
 610  LBX=1
      GOTO 1000
 620  LBY=1
      GOTO 1000
 630  LBZ=1
      GOTO 1000
 700  GOTO (710,720,730,740,750,760) JBS-4
 710  LBX=2
      GOTO 1000
 720  LBY=2
      GOTO 1000
 730  LBZ=2
      GOTO 1000
 740  LBX=1
      LBY=1
      GOTO 1000
 750  LBX=1
      LBZ=1
      GOTO 1000
 760  LBY=1
      LBZ=1
 1000 CONTINUE
C
C
C
      DO IAX=LAX-IX,0,-1
         DO IBX=LBX,0,-1
            LAMAXX=IAX+IBX
            DO IAY=LAY-IY,0,-1
               DO IBY=LBY,0,-1
                  LAMAXY=IAY+IBY
                  DO IAZ=LAZ-IZ,0,-1
                     DO IBZ=LBZ,0,-1
                        LAMAXZ=IAZ+IBZ
                        LAMAXXY=LAMAXX+LAMAXY
                        LAMAX=LAMAXXY+LAMAXZ
                        LS=MOD(LAMAX,2)
                        MS=MOD(LAMAXXY,2)
                        DO L=LS,LAMAX,2
                           LDXLM=L*(L+1)/2+1
                           IDXG=ILMAXL(LAMAX,L)
                           IRELP=(LAMAX-LAMAXX)
                           IXYZ=IRELP*(IRELP+1)/2+1+LAMAXZ
                           IDXG=IDXG+(L+1)*(IXYZ-1)
                           IF (MOD(LAMAX+L,2).EQ.0) THEN
                              TEMP=F(LAMAX+L)/
     *                            YOTA**((LAMAX+L+2.0D+00)/TWO+0.5D+00)
                           ELSE
                              TEMP=F(LAMAX+L)/
     *                            YOTA**((LAMAX+L+3.0D+00)/TWO)
                           ENDIF
             FA1=PA(1)**(LAX-IX-IAX)*FCTRL(LAX,IAX)*(LAX-IAX)**IX
             FA2=PA(2)**(LAY-IY-IAY)*FCTRL(LAY,IAY)*(LAY-IAY)**IY
             FA3=PA(3)**(LAZ-IZ-IAZ)*FCTRL(LAZ,IAZ)*(LAZ-IAZ)**IZ
             FB1=PB(1)**(LBX-IBX)*FCTRL(LBX,IBX)
             FB2=PB(2)**(LBY-IBY)*FCTRL(LBY,IBY)
             FB3=PB(3)**(LBZ-IBZ)*FCTRL(LBZ,IBZ)
                           DO M=MS,L,2
                              IDXGA=IDXG+M
                              LDXLMA=LDXLM+M
                              YLM(LDXLMA)=YLM(LDXLMA)
     *                           +BET/YOTA*FA1*FA2*FA3*FB1*FB2*FB3
     *                           *TEMP*G(IDXGA)*DIJ
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
C
      DO IAX=LAX,0,-1
         DO IBX=LBX-IX,0,-1
            LAMAXX=IAX+IBX
            DO IAY=LAY,0,-1
               DO IBY=LBY-IY,0,-1
                  LAMAXY=IAY+IBY
                  DO IAZ=LAZ,0,-1
                     DO IBZ=LBZ-IZ,0,-1
                        LAMAXZ=IAZ+IBZ
                        LAMAXXY=LAMAXX+LAMAXY
                        LAMAX=LAMAXXY+LAMAXZ
                        LS=MOD(LAMAX,2)
                        MS=MOD(LAMAXXY,2)
                        DO L=LS,LAMAX,2
                           LDXLM=L*(L+1)/2+1
                           IDXG=ILMAXL(LAMAX,L)
                           IRELP=(LAMAX-LAMAXX)
                           IXYZ=IRELP*(IRELP+1)/2+1+LAMAXZ
                           IDXG=IDXG+(L+1)*(IXYZ-1)
                           IF (MOD(LAMAX+L,2).EQ.0) THEN
                              TEMP=F(LAMAX+L)/
     *                            YOTA**((LAMAX+L+2.0D+00)/TWO+0.5D+00)
                           ELSE
                              TEMP=F(LAMAX+L)/
     *                            YOTA**((LAMAX+L+3.0D+00)/TWO)
                           ENDIF
C
             FA1=PA(1)**(LAX-IAX)*FCTRL(LAX,IAX)
             FA2=PA(2)**(LAY-IAY)*FCTRL(LAY,IAY)
             FA3=PA(3)**(LAZ-IAZ)*FCTRL(LAZ,IAZ)
             FB1=PB(1)**(LBX-IX-IBX)*FCTRL(LBX,IBX)*(LBX-IBX)**IX
             FB2=PB(2)**(LBY-IY-IBY)*FCTRL(LBY,IBY)*(LBY-IBY)**IY
             FB3=PB(3)**(LBZ-IZ-IBZ)*FCTRL(LBZ,IBZ)*(LBZ-IBZ)**IZ
                           DO M=MS,L,2
                              IDXGA=IDXG+M
                              LDXLMA=LDXLM+M
                              YLM(LDXLMA)=YLM(LDXLMA)
     *                           -ALP/YOTA*FA1*FA2*FA3*FB1*FB2*FB3
     *                           *TEMP*G(IDXGA)*DIJ
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
C
      RETURN
      END
C*MODULE QMFM    *DECK JKLDER
      SUBROUTINE JKLDER
C
C     THE MAIN DRIVER FOR THE LINEAR SCALING TWO ELECTRON GRADIENT
C
C     C. H. CHOI JUL 2004
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL QOPS,QFMM,DOUT,DBG,NOCORE,NOOPEN
      LOGICAL HFSCF,UHFTYP,ROGVB,PACK2E,POPLE
      LOGICAL GOPARR,DSKWRK,MASWRK,SOME
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000, MXAO=8192)
      PARAMETER (NUMRA=23)
C
      PARAMETER (RLN10=2.30258D+00,TEN=10.0D+00,ONE=1.0D+00)
      PARAMETER (TENM11=1.0D-11, TENM12=1.0D-12, TENM20=1.0D-20)
C
      COMMON /FMCOM / X(1)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /IJPAIR/ IA(MXAO)
      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 /GRAD  / DE(3,MXATM)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      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 /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,DOUT,DBG
      COMMON /QMFM  / SIZE,EPSLN,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON/DERMEM/IWFN,IXCH,INIJG,IGINT,IFINT,ISINT,IIJKLG,
     1 IDAB,ICHRG,IXY,IXZ,IYZ,IX,IY,IZ,ISJ,ISK,ISL,IGIJKL,IGNKL,IGNM,
     2 IDIJ,IDKL,IB00,IB01,IB10,IC00,ID00,IF00,
     3 IAAI,IAAJ,IBBK,IBBL,IFI,IFJ,IFK,IFL,
     4 ISII,ISJJ,ISKK,ISLL,ISIJ,ISIK,ISIL,ISJK,ISJL,ISKL,
     5 IDIJSI,IDIJSJ,IDKLSK,IDKLSL,IABV,ICV,IRW
      COMMON /FMMDER/ MAXWS,NTBOX,NCXYZ,NTMPL,MAXNYP
      COMMON /QFMMRA/IORA(NUMRA),IRAF,MIJKL
      COMMON /QFMLEX/ MAXGP
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
C
      DATA RHF,UHF,ROHF,GVB
     *    /8HRHF     ,8HUHF     ,8HROHF    ,8HGVB     /
C
C     WE ONLY USE HONDO DERIVATIVE INTEGRALS CURRENTLY.
C
      IGRDTYP_SAVE=IGRDTYP
      IGRDTYP=2
      POPLE = IGRDTYP.EQ.1
C
      SOME = MASWRK  .AND.  NPRINT.NE.-5
      IF(SOME) WRITE (IW,9008)
C
C     ITOL HAS BEEN CHANGED IN QFMMIN, IT USED TO BE 20
C
      ITOL2=ITOL*2
      DTOL = TEN**(-ITOL2)
      RTOL = RLN10*ITOL2
      VTOL1 = TENM12
      VTOL2 = TENM12
      VTOLS = TENM20
C
      ZBIG = 0.0D+00
      DO ISH=1,NSHELL
         I1=KSTART(ISH)
         I2=I1+KNG(ISH)-1
         DO IG=I1,I2
            IF(EX(IG).GT.ZBIG) ZBIG = EX(IG)
         ENDDO
      ENDDO
      DABCUT=TENM11
      IF(ZBIG.GT.1.0D+06) DABCUT = DABCUT/TEN
      IF(ZBIG.GT.1.0D+07) DABCUT = DABCUT/TEN
C
      DO I = 1,NUM
         IA(I) = (I*I-I)/2
      ENDDO
C
C     MATRIX DIMENSIONS
C
      LL1 =NUM
      LL2 = (NUM*NUM+NUM)/2
      LL3 = NUM*NUM
      L4=NUM+NAUXFUN
      L6=L4*L4
      NSH2=(NSHELL*NSHELL+NSHELL)/2
      NSHL2=NSHELL*NSHELL
      HFSCF = MPLEVL.EQ.0   .AND.
     *        (SCFTYP.EQ.RHF .OR. SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF)
      UHFTYP=                     SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF
      ROGVB = SCFTYP.EQ.GVB
      LENRHF = LL2
      LENUHF = LL2+LL2
      LENGTH=LENRHF
      IF (UHFTYP) LENGTH=LENUHF
C
      NIJG=0
      MAXIJG=0
      DO II=1,NSHELL
        DO JJ=1,II
          ITEMP=KNG(II)*KNG(JJ)
          NIJG=NIJG+ITEMP
          IF (ITEMP.GT.MAXIJG) MAXIJG=ITEMP
        ENDDO
      ENDDO
C
C     ----- RESERVE FAST MEMORY -----
C
      CALL VALFM(LOADFM)
      CALL JKDMEM(1,LOADFM,IADDR,LENGTH,MINXYZ,MAXXYZ,MINVEC,POPLE,
     *            .FALSE.)
C
C     FAST MEMORY FOR COULOMB PART
C
      LYP     = IADDR   + 1
      LZP     = LYP     + (NP+1)*(NP+2)*NTMPL
      LINDX2  = LZP     + (NP+1)*(NP+2)*NTMPL
      LIYP    = LINDX2  + NCXYZ/NWDVAR+1
      LIDXIJK = LIYP    + NCXYZ/NWDVAR+1
      LIDXWS  = LIDXIJK + NCXYZ*3/NWDVAR+2
      LYZPNT  = LIDXWS  + NCXYZ/NWDVAR+1
      LIBS    = LYZPNT  + MAXWS/2*(NTBOX+1)/NWDVAR+1
      LIDXBOX = LIBS    + NCXYZ*4/NWDVAR
      NSBOX   = LIDXBOX + 3*(NTBOX+1)/NWDVAR+1
      LEBOX   = NSBOX   + 20/NWDVAR
      LMBOX   = LEBOX   + (NTBOX+1)/NWDVAR+1
      LYZTBL  = LMBOX   + (NTBOX+1)/NWDVAR+1
      LINDX   = LYZTBL  + ((2**(NS+1)-1)**3+1)/NWDVAR+1
      LISP    = LINDX   + NCXYZ/NWDVAR+1
      LIPP    = LISP    + NCXYZ*2/NWDVAR
      LNUMWS  = LIPP    + NCXYZ*2/NWDVAR
      LCLM    = LNUMWS  + MAXWS/2*(NTBOX+1)/NWDVAR+1
      LITSP   = LCLM    + 2*NP+1
      LITPP   = LITSP   + MIJKL*2/NWDVAR
      LITSP2  = LITPP   + MIJKL*2/NWDVAR
      LITPP2  = LITSP2  + MIJKL*2/NWDVAR
      LNBR    = LITPP2  + MIJKL*2/NWDVAR
      ICHGIJ  = LNBR    + (MAXWS*2+1)**3/NWDVAR+1
      ICHGKL  = ICHGIJ  + 15*MAXIJG
      LFLM    = ICHGKL  + 15*MAXIJG
      LG      = LFLM    + 2*NP+1
      LF      = LG      + 8*((NP*(NP+1)*(NP+2)*4/3)+(NP+1))
      LZLL    = LF      + 8*((NP*(NP+1)*(NP+2)*4/3)+(NP+1))
      LDSH    = LZLL    + (2*NP+2)*2
C
C     FAST MEMORY FOR EXCHANGE PART
C
      LSLIST  = LDSH    + NSH2
      LDLIST  = LSLIST  + NSHL2/NWDVAR+1
      LSLN    = LDLIST  + NSHL2/NWDVAR+1
      LDLN    = LSLN    + NSHELL/NWDVAR+2
      LMLN    = LDLN    + NSHELL/NWDVAR+2
      LMLIST  = LMLN    + NSHL2/NWDVAR+2
      LMLPNT  = LMLIST  + 4*NSHL2/NWDVAR+2
      LXINTS  = LMLPNT  + 2*NSHELL/NWDVAR+1
      LMAXIJ  = LXINTS  + NSH2
      LMAXP   = LMAXIJ  + NSHELL
      LTS     = LMAXP   + NSHELL
      LDEN    = LTS     + NSHELL
      LVEC    = LDEN    + LL2
      LIDXSHL = LVEC    + MAX(LL3,LL2)
      IJTPP   = LIDXSHL + NSH2/NWDVAR+2
      KLTPP   = IJTPP  + 2*MAXGP/NWDVAR
      LAST    = KLTPP  + 2*MAXGP/NWDVAR
      NEED    = LAST -LOADFM -1
C
C     ADD IN DFT MEMORY
C
      IF((LAST-LOADFM).LT.(5*L6+L4+3*MXATM)  .AND.
     *   DFTTYP(1).NE.0.0D+00) THEN
C
C        GENERALLY, THE MEMORY THAT WE NEED FOR DFT IS LESS THAN THAT
C        NEEDED FOR NON-DFT RUNS, SO ALLOCATING IT IS NOT A PROBLEM
C        UNLESS IT'S A RUN WITH AUX FUNCTIONS
C
         LAST=LOADFM+5*L6+L4+3*MXATM
         IDFT1=LOADFM+1
         IDFT2=IDFT1+L6
         IDFT3=IDFT2+L6
         IDFT4=IDFT3+L6
         IDFT5=IDFT4+L6
         IDFT6=IDFT5+L6
         IDFT7=IDFT6+L4
      ELSE
         IDFT1=LOADFM+1
         IDFT2=IDFT1+L6
         IDFT3=IDFT2+L6
         IDFT4=IDFT3+L6
         IDFT5=IDFT4+L6
         IDFT6=IDFT5+L6
         IDFT7=IDFT6+L4
      END IF
C
      CALL GETFM(NEED)
C
C     ----- READ WAVEFUNCTION INFORMATION -----
C            IT IS A DENSITY MATRIX.
C
      NOCORE=.FALSE.
      NOOPEN=.FALSE.
      CALL DDEBUT(IA,X(LDEN),X(LVEC),LL1,LL2,LL3,NOCORE,NOOPEN,
     *        HFSCF,UHFTYP,ROGVB)
C
C---     WRITE(IW,*) 'JKLDER ALPHA'
C---     CALL PRTRIL(X(LDEN),LL1)
C---     WRITE(IW,*) 'JKLDER BETA'
C---     CALL PRTRIL(X(LVEC),LL1)
C
C     ----- READ THE ONES SAVED AT THE END OF SCF CYCLES -----
C
      CALL REDFMM(X(LYP),X(LZP),NP,NTMPL,NCXYZ,X(LIYP),X(LINDX2),
     *   X(LIDXIJK),X(LIDXWS),X(LIBS),X(LYZTBL),NTBOX,MAXWS,
     *   X(LYZPNT),X(LCLM),X(LIDXBOX),X(NSBOX),X(LISP),X(LIPP),
     *   X(LEBOX),X(LMBOX),X(LINDX),X(LNUMWS),X(LDSH),X(LSLIST),
     *   X(LIDXSHL),X(LSLN),X(LXINTS),NSHELL,NSH2,NSHL2,NS)
C
C     ----- READ 1-ELECTRON GRADIENT -----
C
      CALL DAREAD(IDAF,IODA,DE,3*NAT,3,0)
      IF (GOPARR) CALL DSCAL(3*NAT,ONE/NPROC,DE,1)
C
C     ----- GRID-DFT EXCHANGE-CORRELATION -----
C     -----    DERIVATIVE CONTRIBUTION    -----
C
      IF (NDFTFG.EQ.1) CALL DFTDER
C
C     READ EXCHNAGE INTEGRAL FOR SCHWARZ SCREENING
C
      IF(ISCHWZ.EQ.1) THEN
         CALL DAREAD(IDAF,IODA,X(IXCH),NSH2,54,0)
      ELSE
         DO 400 I=0,NSH2-1
            X(IXCH+I) = ONE
  400    CONTINUE
      END IF
C
C     CHARGE FOR HONDO INTEGRAL
C
      CALL OEDHND(X(INIJG),X(ICHRG))
C
C     ---- EXCHANGE PART ----
C
      IF (ITERMS.NE.1) THEN
         CALL SORTDER(X(LDLIST),NSHL2,X(LDLN),X(LTS),NSHELL,X(LMAXIJ),
     *      X(LMAXP),X(LXINTS),X(LDSH),NSH2)
         CALL LEXDER(LL2,X(LDEN),X(LVEC),X(LXINTS),NSH2,NSHL2,X(LDSH),
     *      X(LSLIST),X(LDLIST),X(LSLN),X(LDLN),NSHELL,X(LMLIST),
     *      X(LMLN),X(LMLPNT),DABCUT,DABMAX,MAXXYZ,MINVEC,
     *      X(LMAXP),X(LIDXSHL),X(LIPP),X(LINDX2),X(LIDXIJK),
     *      X(LIDXWS),NCXYZ,X(ICHGIJ),X(ICHGKL),X(IJTPP),X(KLTPP))
         IF (MASWRK) THEN
            WRITE(IW,9100)
            CALL TIMIT(1)
         ENDIF
      ENDIF
C
C     ----- FAR FIELD COULOMB DERIVATIVE -----
C
      IF (ITERMS.NE.2) THEN
         CALL GETFLM(X(LFLM))
         CALL FARDER(NCXYZ,X(LIYP),X(LINDX2),X(LIDXIJK),X(LIBS),
     *      X(LISP),NTMPL,X(LYZTBL),X(LZP),NTBOX,MAXWS,
     *      X(LYZPNT),X(LIDXWS),LL2,X(LDEN),X(LCLM),X(LIPP),X(LFLM),
     *      X(LG),X(LF),X(LZLL))
         IF (MASWRK) THEN
            WRITE(IW,9200)
            CALL TIMIT(1)
         ENDIF
C
C     ----- NEAR FIELD COULOMB DERIVATIVE -----
C
         CALL NRJDER(LL2,X(LDEN),X(LVEC),NCXYZ,X(LINDX),X(LIPP),
     *      X(LISP),MIJKL,X(LITSP),X(LITPP),X(LITSP2),X(LITPP2),NTBOX,
     *      X(LIDXBOX),X(LMBOX),X(LEBOX),X(NSBOX),X(LYZTBL),X(LNBR),
     *      MAXWS,X(LNUMWS),X(LYZPNT),X(ICHGIJ),
     *      X(ICHGKL),MAXXYZ,MINVEC)
         IF (MASWRK) THEN
            WRITE(IW,9300)
            CALL TIMIT(1)
         ENDIF
      ENDIF
C
      IF (GOPARR) CALL DDI_GSUMF(1600,DE,3*NAT)
C
C     ADD IN THE REST OF THE DFT GRADIENT
C
      IF(DFTTYP(1) .NE. 0.0D+00) THEN
         CALL DFTGRD(X(IDFT1),X(IDFT2),X(IDFT3),X(IDFT4),X(IDFT5),
     *               X(IDFT6),X(IDFT7),NAUXFUN)
         CALL VADD(X(IDFT7),1,DE,1,DE,1,3*NAT)
      END IF
C
C     ----- SYMMETRIZE SKELETON GRADIENT VECTOR -----
C
      CALL SYMEG(DE)
C
      CALL DFINAL(1)
      CALL RETFM(NEED)
      IF (MASWRK) WRITE(IW,9400)
      IGRDTYP=IGRDTYP_SAVE
      RETURN
 9008 FORMAT(/10X,22(1H-)/10X,22HGRADIENT OF THE ENERGY/10X,22(1H-))
 9100 FORMAT(/1X,'..... END OF LINEAR SCALING EXCHANGE GRADIENT .....')
 9200 FORMAT(/1X,'..... END OF FAR FIELD COULOMB GRADIENT .....')
 9300 FORMAT(/1X,'..... END OF NEAR FIELD COULOMB GRADIENT .....')
 9400 FORMAT(/1X,'..... END OF LINEAR SCALING 2-ELECTRON GRADIENT ......
     *')
      END
C*MODULE QMFM    *DECK NRJDER
      SUBROUTINE NRJDER(L2,DA,DB,NCXYZ,INDX,IPP,ISP,MIJKL,ITSP,ITPP,
     *                  ITSP2,ITPP2,NTBOX,IDXBOX,MBOX,LEBOX,NSBOX,
     *                  IYZTBL,NBR,MAXWS,NUMWS,IYZPNT,DCHGIJ,DCHGKL,
     *                  MAXXYZ,MINVEC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL QFMM,QOPS,OK,JANDK
      LOGICAL PACK2E,POPLE
      LOGICAL OUT,DBG
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXGTOT=20000, MXSH=5000, MXATM=2000, MXAO=8192)
C
      DIMENSION IDXBOX(3,NTBOX),MBOX(NTBOX),LEBOX(0:NTBOX),NSBOX(20),
     *          DA(L2),DB(*),NUMWS(NTBOX,MAXWS/2),IYZPNT(NTBOX,MAXWS/2)
      DIMENSION INDX(NCXYZ),IPP(NCXYZ,2),ISP(NCXYZ,2),ITPP(MIJKL,2),
     *          ITSP(MIJKL,2),ITPP2(MIJKL,2),ITSP2(MIJKL,2),
     *          IYZTBL(2**(NS+1)-1,2**(NS+1)-1,2**(NS+1)-1),
     *          NBR((MAXWS*2+1)**3)
      DIMENSION DCHGIJ(15,*),DCHGKL(15,*)
C
      COMMON /FMCOM / X(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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 /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON/DERMEM/IWFN,IXCH,INIJG,IGINT,IFINT,ISINT,IIJKLG,
     1 IDAB,ICHRG,IXY,IXZ,IYZ,IX,IY,IZ,ISJ,ISK,ISL,IGIJKL,IGNKL,IGNM,
     2 IDIJ,IDKL,IB00,IB01,IB10,IC00,ID00,IF00,
     3 IAAI,IAAJ,IBBK,IBBL,IFI,IFJ,IFK,IFL,
     4 ISII,ISJJ,ISKK,ISLL,ISIJ,ISIK,ISIL,ISJK,ISJL,ISKL,
     5 IDIJSI,IDIJSJ,IDKLSK,IDKLSL,IABV,ICV,IRW
C
      PARAMETER (RLN10=2.30258D+00)
      PARAMETER (TEN=10.0D+00, ONE=1.0D+00)
      PARAMETER (TENM9=1.0D-09, TENM11=1.0D-11)
      PARAMETER (TENM20=1.0D-20, TENM12=1.0D-12)
C
C     PARALLEL INITIALIZATION
C
      NEXT = -1
      MINE = -1
      POPLE = IGRDTYP.EQ.0
C
      OK =  NDFTFG.EQ.1 .OR. DFTTYP(1).NE.1.0D+00
      JANDK=.NOT.(OK.AND.(DFTTYP(3).EQ.0.0D+00))
C
C
C      CUTOFF IS THE SCHWARZ SCREENING CUT OFF
C      DABCUT IS THE TWO PARTICLE DENSITY CUT OFF
C
      CUTOFF=TENM9
      IF(.NOT.POPLE) CUTOFF=CUTOFF/TEN
      CUTOFF2=CUTOFF/2.0D+00
C
      ZBIG = 0.0D+00
      DO ISH=1,NSHELL
         I1=KSTART(ISH)
         I2=I1+KNG(ISH)-1
         DO IG=I1,I2
            IF(EX(IG).GT.ZBIG) ZBIG = EX(IG)
         ENDDO
      ENDDO
      DABCUT=TENM11
      IF(ZBIG.GT.1.0D+06) DABCUT = DABCUT/TEN
      IF(ZBIG.GT.1.0D+07) DABCUT = DABCUT/TEN
C
C      VTOLS ARE CUT OFFS USED BY THE POPLE PACKAGE
C      CURRENT VALUES ARE FROM HONDO 8, SEE G92 FOR OTHER POSSIBILITIES
C
      VTOL1 = TENM12
      VTOL2 = TENM12
      VTOLS = TENM20
      DTOL = TEN**(-ITOL)
      RTOL = RLN10*ITOL
C
      NSH2=(NSHELL*NSHELL+NSHELL)/2
C
      DO I = 1,NUM
         IA(I) = (I*I-I)/2
      ENDDO
C
      CALL VALFM(LOADFM)
      LPTR     = 1     + LOADFM
      LTBL     = LPTR  + MIJKL*2/NWDVAR
      LPTR2    = LTBL  + MIJKL/NWDVAR+2
      LTBL2    = LPTR2 + MIJKL*2/NWDVAR
      LPPIJ    = LTBL2 + MIJKL/NWDVAR+2
      LPPKL    = LPPIJ + MIJKL*2/NWDVAR
      LAST     = LPPKL + MIJKL*2/NWDVAR
      NEED = LAST - LOADFM
      CALL GETFM(NEED)
C
C     ----- CARRY OUT SET UP TASKS -----
C
C        READ IN THE EXCHANGE INTEGRALS FROM DISK. IF THEY WERE NOT
C        PREVIOUSLY COMPUTED, THEN JUST SET THE ARRAY TO ONE, WHICH
C        EFFECTIVELY DEACTIVATES THE SCHWARZ SCREENING
C
      IF(ISCHWZ.EQ.1) THEN
         CALL DAREAD(IDAF,IODA,X(IXCH),NSH2,54,0)
      ELSE
         DO 400 I=0,NSH2-1
            X(IXCH+I) = ONE
  400    CONTINUE
      END IF
C
C
C     STEP1: LOOP OVER NON-EMPTY BOXES IN THE LOWEST LEVEL.
C            COMPUTE INTERACTIONS WITHIN THE BOXES.
C
      DO NON=1,NSBOX(1)
       IF (GOPARR) THEN
          MINE=MINE+1
          IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
          IF (NEXT.NE.MINE)  GOTO 50
       ENDIF
         I=IDXBOX(1,NON)
         J=IDXBOX(2,NON)
         K=IDXBOX(3,NON)
C
         IXYZ=LEBOX(IYZTBL(I,J,K))-MBOX(IYZTBL(I,J,K))
C
C        DO LOOP OVER DISTRIBUTIONS IN A GIVEN BOX.
C
         DO M=1,MBOX(NON)
            IXYZ=IXYZ+1
            IEND=INDX(IXYZ)
C
C           PUT THE SHELL PAIR AND PRIMITIVE GAUSSIAN PRODUCT
C           INDICES IN THE TEMPORARY SPACE.
C
            ITSP(M,1)=ISP(IEND,1)
            ITSP(M,2)=ISP(IEND,2)
            ITPP(M,1)=IPP(IEND,1)
            ITPP(M,2)=IPP(IEND,2)
         ENDDO
C
C        SORTING OUT ITSP AND ITPP IN ORDER TO OPTIMIZE INTEGRAL.
C
         CALL SORTSP(MIJKL,M-1,ITSP,ITPP,X(LPTR),X(LTBL),IXTBL)
         IF (JANDK) THEN
         CALL COREJKD(MIJKL,ITSP,ITPP,IXTBL,X(LTBL),
     *                DCHGIJ,DCHGKL,MAXXYZ,MINVEC,DA,DB,
     *                CUTOFF,CUTOFF2,DABCUT)
         ELSE
         CALL COREJD(MIJKL,ITSP,ITPP,IXTBL,X(LTBL),
     *                DCHGIJ,DCHGKL,MAXXYZ,MINVEC,DA,DB,
     *                CUTOFF,CUTOFF2,DABCUT)
         ENDIF
C
C        MANY ARGUMENTS ARE OPTIONAL, YOU MUST ALLOCATE STORAGE FOR
C
 50   ENDDO
C
C     STEP2: INTEGRALS BETWEEN BOXES
C     NSBOX(1) CONTAINS THE NUMBER OF NON-EMPTY BOXES IN THE LOWEST
C     LEVEL, NS. REMOVE BLANK SPACE.
C
      IBOXS=1
      IBOXE=NSBOX(1)
      MAXSIZE=2**NS
      MINX=MAXSIZE
      MAXX=1
      MINY=MAXSIZE
      MAXY=1
      MINZ=MAXSIZE
      MAXZ=1
C
      DO I=IBOXS,IBOXE
         MX=IDXBOX(1,I)
         MY=IDXBOX(2,I)
         MZ=IDXBOX(3,I)
         IF (MX.LT.MINX) MINX=MX
         IF (MX.GT.MAXX) MAXX=MX
         IF (MY.LT.MINY) MINY=MY
         IF (MY.GT.MAXY) MAXY=MY
         IF (MZ.LT.MINZ) MINZ=MZ
         IF (MZ.GT.MAXZ) MAXZ=MZ
      ENDDO
C
      DO NON=1,NSBOX(1)
       IF (GOPARR) THEN
          MINE=MINE+1
          IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
          IF (NEXT.NE.MINE)  GOTO 100
       ENDIF
C
C        IDXBOX CONTAINS THE ACTUAL (I,J,K) INDEX OF A GIVEN BOX, NON.
         I=IDXBOX(1,NON)
         J=IDXBOX(2,NON)
         K=IDXBOX(3,NON)
C
C        LOOP OVER THE IWS INDEX OF THE FIRST BOX
C
C        IYZTBL RETURNS ACTUAL SEQUENCE OF A GIVEN BOX (I,J,K)
C        MBOX RETURNS THE NUMBER OF PARTICLES IN THAT BOX
C        LEBOX RETURNS THE CUMULATIVE NUMBER OF PATICLES.
C        SO IXYZ NOW POINTS THE ACTUAL SEQUENCE OF A POINT.
C
         IXYZ=LEBOX(IYZTBL(I,J,K))-MBOX(IYZTBL(I,J,K))
         DO IDXWS=1,MAXWS/2
C
C           NUMWS RETURNS THE NUMBER OF PARTICLE OF BOX, NON WITH
            INPTCL=NUMWS(NON,IDXWS)
            IF ( INPTCL.NE.0 ) THEN
C
C              NOW PUT SHELL PAIR AND PRIMITIVE PAIR INDICES OF I
C              BRANCH PARTICLES WITH IWS=IDXWS*2 INTO TEMPORARY MEMORY.
C
               DO M=1,INPTCL
                  IXYZ=IXYZ+1
                  IPTCL=INDX(IXYZ)
C
C                 PUT THE SHELL PAIR AND PRIMITIVE GAUSSIAN PRODUCT
C                 INDICES IN THE TEMPORARY SPACE.
C
                  ITSP(M,1)=ISP(IPTCL,1)
                  ITSP(M,2)=ISP(IPTCL,2)
                  ITPP(M,1)=IPP(IPTCL,1)
                  ITPP(M,2)=IPP(IPTCL,2)
               ENDDO
C              SORTING OUT ITSP AND ITPP IN ORDER TO OPTIMIZE INTEGRAL.
               CALL SORTSP(MIJKL,M-1,ITSP,ITPP,X(LPTR),
     *               X(LTBL),IXTBL)
C
C              LOOP OVER THE IWS INDEX OF THE SECOND BOX
C
               DO IDXIT=1,MAXWS/2
                  IJWS=IDXWS+IDXIT
                  CALL GETNBR(I,J,K,IJWS,NS,NTBOX,
     *               NBR,IDX,IYZTBL,IDXIT,MAXWS,IYZPNT,
     *             MINX,MAXX,MINY,MAXY,MINZ,MAXZ)
C
C                 LOOP OVER THE NEIGHBORS
C
                  IF ( IDX.GT.0 ) THEN
                     IST=0
                     DO NN=1,IDX
                        JXYZ=LEBOX(NBR(NN))-MBOX(NBR(NN))
                        DO MWS=1,IDXIT-1
                           JNPTCL=NUMWS(NBR(NN),MWS)
                           JXYZ=JXYZ+JNPTCL
                        ENDDO
                        JNPTCL=NUMWS(NBR(NN),IDXIT)
                        IF ( JNPTCL.NE.0 ) THEN
                           DO M=1,JNPTCL
                              JXYZ=JXYZ+1
                              JPTCL=INDX(JXYZ)
                              IST=IST+1
C                    PUT THE SHELL PAIR AND PRIMITIVE GAUSSIAN PRODUCT
C                    INDICES IN THE TEMPORARY SPACE.
                              ITSP2(IST,1)=ISP(JPTCL,1)
                              ITSP2(IST,2)=ISP(JPTCL,2)
                              ITPP2(IST,1)=IPP(JPTCL,1)
                              ITPP2(IST,2)=IPP(JPTCL,2)
                           ENDDO
                        ENDIF
                     ENDDO
C
C             SORTING OUT ITSP2 AND ITPP2 IN ORDER TO OPTIMIZE INTEGRAL.
C
                     CALL SORTSP(MIJKL,IST,ITSP2,ITPP2,X(LPTR2),
     *                      X(LTBL2),IXTBL2)
                     IF (JANDK) THEN
                     CALL NBRJKD(MIJKL,ITSP,ITSP2,IXTBL,X(LTBL),
     *                           IXTBL2,X(LTBL2),DCHGIJ,DCHGKL,
     *                           ITPP,ITPP2,MAXXYZ,MINVEC,
     *                           DA,DB,CUTOFF,CUTOFF2,DABCUT)
                     ELSE
                     CALL NBRJD(MIJKL,ITSP,ITSP2,IXTBL,X(LTBL),
     *                           IXTBL2,X(LTBL2),DCHGIJ,DCHGKL,
     *                           ITPP,ITPP2,MAXXYZ,MINVEC,
     *                           DA,DB,CUTOFF,CUTOFF2,DABCUT)
                     ENDIF
C
                  ENDIF
               ENDDO
C           IF OF INPTCL
            ENDIF
         ENDDO
 100  ENDDO
C
      CALL RETFM(NEED)
      IF (GOPARR) CALL DDI_DLBRESET
C
      RETURN
      END
C*MODULE QMFM    *DECK NBRJD
      SUBROUTINE NBRJD(NCXYZ,ITSP,ITSP2,IXTBL,ITBL,IXTBL2,
     *                  ITBL2,DCHGIJ,DCHGKL,ITPP,ITPP2,
     *                  MAXXYZ,MINVEC,DA,DB,
     *                  CUTOFF,CUTOFF2,DABCUT)
C
C       THE DRIVER FOR THE TWO ELECTRON GRADIENT
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SKIPI,SKIPJ,SKIPK,SKIPL,UHFTYP,OUT,DBG
C
      PARAMETER (MXAO=8192)
C
      DIMENSION DCHGIJ(15,*),DCHGKL(15,*)
C
      COMMON /DERSKP/ IIAT,JJAT,KKAT,LLAT,SKIPI,SKIPJ,SKIPK,SKIPL
      COMMON /DSHLNO/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /FMCOM / X(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /MP2PAR/ OSPT,TOL,METHOD,NWDMP2,MPPROP,NACORE,NBCORE,
     *                NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      COMMON/DERMEM/IWFN,IXCH,INIJG,IGINT,IFINT,ISINT,IIJKLG,
     1 IDAB,ICHRG,IXY,IXZ,IYZ,IX,IY,IZ,ISJ,ISK,ISL,IGIJKL,IGNKL,IGNM,
     2 IDIJ,IDKL,IB00,IB01,IB10,IC00,ID00,IF00,
     3 IAAI,IAAJ,IBBK,IBBL,IFI,IFJ,IFK,IFL,
     4 ISII,ISJJ,ISKK,ISLL,ISIJ,ISIK,ISIL,ISJK,ISJL,ISKL,
     5 IDIJSI,IDIJSJ,IDKLSK,IDKLSL,IABV,ICV,IRW
C
      DIMENSION ITSP(NCXYZ,2),ITPP(NCXYZ,2),ITBL(IXTBL)
      DIMENSION ITSP2(NCXYZ,2),ITPP2(NCXYZ,2),ITBL2(IXTBL2)
      DIMENSION DA(*),DB(*)
C
      DATA GRD2,DEBUG/8HGRD2    ,8HDEBUG   /
      DATA UHF,ROHF/8HUHF     ,8HROHF    /
C
C     ----- THIS IS THE MAIN 2E- GRADIENT DRIVER -----
C
      DBG = EXETYP.EQ.DEBUG
      OUT = EXETYP.EQ.GRD2.OR.NPRINT.EQ.-4
C
C     ----- SET STARTING PARAMETERS -----
C
      UHFTYP= SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF
C
C      INITIALIZE THE INTEGRAL BLOCK COUNTERS TO ZERO
C
      IISKIP1= 0
      IISKIP2= 0
      IDID = 0
C
      NC=1
      LDF=1
      IJSP=0
C
C     ----- I SHELL -----
C
      DO 560 IJSHLL=1,IXTBL
         IJNUM=ITBL(IJSHLL)
         IJSP=IJSP+IJNUM
         II=ITSP(IJSP,1)
         JJ=ITSP(IJSP,2)
         NIJ=IJNUM
         CALL LEDSHL(II,JJ,DCHGIJ,NIJ,0,IJSP,IJNUM,NCXYZ,ITPP)
         IF(NIJ.EQ.0) GO TO 540
         KLSP=0
         DO 520 KLSHLL=1,IXTBL2
            KLNUM=ITBL2(KLSHLL)
            KLSP=KLSP+KLNUM
            KK=ITSP2(KLSP,1)
            LL=ITSP2(KLSP,2)
            NKL=KLNUM
            CALL LEDSHL(KK,LL,DCHGKL,NKL,0,KLSP,KLNUM,NCXYZ,ITPP2)
            Q4=1
C
C         IMPLEMENT INTEGRAL SCREENING HERE USING EXCHANGE INTEGRALS
C         SEE H.HORN, H.WEISS, M.HAESER, M.EHRIG, R.AHLRICHS
C             J.COMPUT.CHEM. 12, 1058-1064(1991)
C         REGARDING THE ESTIMATION FORMULA (31) THAT IS USED HERE.
C
            IJIJ=IA(MAX0(II,JJ))+MIN0(II,JJ)
            KLKL=IA(MAX0(KK,LL))+MIN0(KK,LL)
            GMAX=(X(IXCH+IJIJ-1)*X(IXCH+KLKL-1))
C
C            COARSE SCREENING, ON JUST THE INTEGRAL VALUE
C
            IF (GMAX.LT.CUTOFF) THEN
               IISKIP1 = IISKIP1+1
               GO TO 500
            END IF
C
            ISH=II
            JSH=JJ
            KSH=KK
            LSH=LL
C
C
C     ----- GET -KL- CHARGE DISTRIBUTION -----
C       ACTUALLY JUST THE POINTERS
C
            IF(NKL.EQ.0) GO TO 500
C
C     ----- SELECT CENTERS FOR DERIVATIVES -----
C
            CALL JKDATM(ISH,JSH,KSH,LSH)
            IF(SKIPI.AND.SKIPJ.AND.SKIPK.AND.SKIPL) GO TO 500
C
C     ----- SET INDICES FOR SHELL BLOCK -----
C
            CALL JKDSHL(ISH,JSH,KSH,LSH)
            CALL JKDNDX(X(IIJKLG))
            INEW = ISH
            JNEW = JSH
            KNEW = KSH
            LNEW = LSH
C
C     ----- OBTAIN 2 BODY DENSITY FOR THIS SHELL BLOCK -----
C
            CALL DABCOU(INEW,JNEW,KNEW,LNEW,DA,DB,X(IDAB),DABMAX,UHFTYP)
C
C           FINE SCREENING, ON INTEGRAL VALUE TIMES DENSITY FACTOR
C
            IF(DABMAX*GMAX.LT.CUTOFF2) THEN
               IISKIP2 = IISKIP2+1
               GO TO 500
            END IF
C
C     ----- EVALUATE DERIVATIVE INTEGRAL, AND ADD TO THE GRADIENT -----
C
            IDID = IDID+1
            CALL JKLSPD(NKL,
     *      X(IGINT),X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),
     1      X(IGNKL),X(IGNM),X(IXY),X(IXZ),X(IYZ),X(IX),X(IY),X(IZ),
     2      X(ISJ),X(ISK),X(ISL),X(IB00),X(IB01),X(IB10),X(IC00),
     3      X(ID00),X(IF00),X(IDIJ),X(IDKL),X(IDIJSI),X(IDIJSJ),
     4      X(IDKLSK),X(IDKLSL),X(IABV),X(ICV),X(IRW),X(IAAI),X(IAAJ),
     5      X(IBBK),X(IBBL),X(IFI),X(IFJ),X(IFK),X(IFL),X(ISII),X(ISJJ),
     6      X(ISKK),X(ISLL),X(ISIJ),X(ISIK),X(ISIL),X(ISJK),X(ISJL),
     7      X(ISKL),X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,DDA,Q4,MINVEC,
     8      DABCUT,DABMAX,DCHGIJ,DCHGKL)
            IF ( (ISH.EQ.KSH).AND.(JSH.EQ.LSH) ) THEN
            CALL JKDATM(KSH,LSH,ISH,JSH)
            NIJT=NIJ
            NIJ=NKL
            CALL JKLSPD(NIJT,
     *      X(IGINT),X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),
     1      X(IGNKL),X(IGNM),X(IXY),X(IXZ),X(IYZ),X(IX),X(IY),X(IZ),
     2      X(ISJ),X(ISK),X(ISL),X(IB00),X(IB01),X(IB10),X(IC00),
     3      X(ID00),X(IF00),X(IDIJ),X(IDKL),X(IDIJSI),X(IDIJSJ),
     4      X(IDKLSK),X(IDKLSL),X(IABV),X(ICV),X(IRW),X(IAAI),X(IAAJ),
     5      X(IBBK),X(IBBL),X(IFI),X(IFJ),X(IFK),X(IFL),X(ISII),X(ISJJ),
     6      X(ISKK),X(ISLL),X(ISIJ),X(ISIK),X(ISIL),X(ISJK),X(ISJL),
     7      X(ISKL),X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,DDA,Q4,MINVEC,
     8      DABCUT,DABMAX,DCHGKL,DCHGIJ)
            NIJ=NIJT
         END IF
C
C     ----- END OF *SHELL* LOOPS -----
C
  500 CONTINUE
  520 CONTINUE
  540 CONTINUE
      IF (TIM .GE. TIMLIM) GO TO 600
  560 CONTINUE
C
  600 CONTINUE
      RETURN
      END
C*MODULE QMFM    *DECK NBRJKD
      SUBROUTINE NBRJKD(NCXYZ,ITSP,ITSP2,IXTBL,ITBL,IXTBL2,
     *                  ITBL2,DCHGIJ,DCHGKL,ITPP,ITPP2,
     *                  MAXXYZ,MINVEC,DA,DB,
     *                  CUTOFF,CUTOFF2,DABCUT)
C
C       THE DRIVER FOR THE TWO ELECTRON GRADIENT
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SKIPI,SKIPJ,SKIPK,SKIPL
      LOGICAL UHFTYP,PACK2E,POPLE
      LOGICAL OUT,DBG
C
      PARAMETER (MXAO=8192)
C
      DIMENSION DCHGIJ(15,*),DCHGKL(15,*)
C
      COMMON /DERSKP/ IIAT,JJAT,KKAT,LLAT,SKIPI,SKIPJ,SKIPK,SKIPL
      COMMON /DSHLNO/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /FMCOM / X(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /MP2PAR/ OSPT,TOL,METHOD,NWDMP2,MPPROP,NACORE,NBCORE,
     *                NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      COMMON/DERMEM/IWFN,IXCH,INIJG,IGINT,IFINT,ISINT,IIJKLG,
     1 IDAB,ICHRG,IXY,IXZ,IYZ,IX,IY,IZ,ISJ,ISK,ISL,IGIJKL,IGNKL,IGNM,
     2 IDIJ,IDKL,IB00,IB01,IB10,IC00,ID00,IF00,
     3 IAAI,IAAJ,IBBK,IBBL,IFI,IFJ,IFK,IFL,
     4 ISII,ISJJ,ISKK,ISLL,ISIJ,ISIK,ISIL,ISJK,ISJL,ISKL,
     5 IDIJSI,IDIJSJ,IDKLSK,IDKLSL,IABV,ICV,IRW
C
      DIMENSION ITSP(NCXYZ,2),ITPP(NCXYZ,2),ITBL(IXTBL)
      DIMENSION ITSP2(NCXYZ,2),ITPP2(NCXYZ,2),ITBL2(IXTBL2)
      DIMENSION DA(*),DB(*)
C
      DATA GRD2,DEBUG/8HGRD2    ,8HDEBUG   /
      DATA UHF,ROHF/8HUHF     ,8HROHF    /
C
C     ----- THIS IS THE MAIN 2E- GRADIENT DRIVER -----
C
      DBG = EXETYP.EQ.DEBUG
      OUT = EXETYP.EQ.GRD2.OR.NPRINT.EQ.-4
C
C     ----- SET STARTING PARAMETERS -----
C
      POPLE = IGRDTYP.EQ.0
      UHFTYP= SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF
C
C      INITIALIZE THE INTEGRAL BLOCK COUNTERS TO ZERO
C
      IISKIP1= 0
      IISKIP2= 0
      IDID = 0
C
      NC=1
      LDF=1
      IJSP=0
C
C     ----- I SHELL -----
C
      DO 560 IJSHLL=1,IXTBL
         IJNUM=ITBL(IJSHLL)
         IJSP=IJSP+IJNUM
         II=ITSP(IJSP,1)
         JJ=ITSP(IJSP,2)
         NIJ=IJNUM
         CALL LEDSHL(II,JJ,DCHGIJ,NIJ,0,IJSP,IJNUM,NCXYZ,ITPP)
         IF(NIJ.EQ.0) GO TO 540
         KLSP=0
         DO 520 KLSHLL=1,IXTBL2
            KLNUM=ITBL2(KLSHLL)
            KLSP=KLSP+KLNUM
            KK=ITSP2(KLSP,1)
            LL=ITSP2(KLSP,2)
            NKL=KLNUM
            CALL LEDSHL(KK,LL,DCHGKL,NKL,0,KLSP,KLNUM,NCXYZ,ITPP2)
            Q4=1
C
C         IMPLEMENT INTEGRAL SCREENING HERE USING EXCHANGE INTEGRALS
C         SEE H.HORN, H.WEISS, M.HAESER, M.EHRIG, R.AHLRICHS
C             J.COMPUT.CHEM. 12, 1058-1064(1991)
C         REGARDING THE ESTIMATION FORMULA (31) THAT IS USED HERE.
C
            IJIJ=IA(MAX0(II,JJ))+MIN0(II,JJ)
            KLKL=IA(MAX0(KK,LL))+MIN0(KK,LL)
            GMAX=(X(IXCH+IJIJ-1)*X(IXCH+KLKL-1))
C
C            COARSE SCREENING, ON JUST THE INTEGRAL VALUE
C
            IF (GMAX.LT.CUTOFF) THEN
               IISKIP1 = IISKIP1+1
               GO TO 500
            END IF
C
            ISH=II
            JSH=JJ
            KSH=KK
            LSH=LL
C
C
C     ----- GET -KL- CHARGE DISTRIBUTION -----
C       ACTUALLY JUST THE POINTERS
C
            IF(NKL.EQ.0) GO TO 500
C
C     ----- SELECT CENTERS FOR DERIVATIVES -----
C
            CALL JKDATM(ISH,JSH,KSH,LSH)
            IF(SKIPI.AND.SKIPJ.AND.SKIPK.AND.SKIPL) GO TO 500
C
C     ----- SET INDICES FOR SHELL BLOCK -----
C
            CALL JKDSHL(ISH,JSH,KSH,LSH)
            CALL JKDNDX(X(IIJKLG))
            INEW = ISH
            JNEW = JSH
            KNEW = KSH
            LNEW = LSH
C
C     ----- OBTAIN 2 BODY DENSITY FOR THIS SHELL BLOCK -----
C
            CALL DABDFT(INEW,JNEW,KNEW,LNEW,UHFTYP,DA,
     *                         DB,X(IDAB),DABMAX,Q4,POPLE)
C
C           FINE SCREENING, ON INTEGRAL VALUE TIMES DENSITY FACTOR
C
            IF(DABMAX*GMAX.LT.CUTOFF2) THEN
               IISKIP2 = IISKIP2+1
               GO TO 500
            END IF
C
C     ----- EVALUATE DERIVATIVE INTEGRAL, AND ADD TO THE GRADIENT -----
C
            IDID = IDID+1
            CALL JKLSPD(NKL,
     *      X(IGINT),X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),
     1      X(IGNKL),X(IGNM),X(IXY),X(IXZ),X(IYZ),X(IX),X(IY),X(IZ),
     2      X(ISJ),X(ISK),X(ISL),X(IB00),X(IB01),X(IB10),X(IC00),
     3      X(ID00),X(IF00),X(IDIJ),X(IDKL),X(IDIJSI),X(IDIJSJ),
     4      X(IDKLSK),X(IDKLSL),X(IABV),X(ICV),X(IRW),X(IAAI),X(IAAJ),
     5      X(IBBK),X(IBBL),X(IFI),X(IFJ),X(IFK),X(IFL),X(ISII),X(ISJJ),
     6      X(ISKK),X(ISLL),X(ISIJ),X(ISIK),X(ISIL),X(ISJK),X(ISJL),
     7      X(ISKL),X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,DDA,Q4,MINVEC,
     8      DABCUT,DABMAX,DCHGIJ,DCHGKL)
            IF ( (ISH.EQ.KSH).AND.(JSH.EQ.LSH) ) THEN
            CALL JKDATM(KSH,LSH,ISH,JSH)
            NIJT=NIJ
            NIJ=NKL
            CALL JKLSPD(NIJT,
     *      X(IGINT),X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),
     1      X(IGNKL),X(IGNM),X(IXY),X(IXZ),X(IYZ),X(IX),X(IY),X(IZ),
     2      X(ISJ),X(ISK),X(ISL),X(IB00),X(IB01),X(IB10),X(IC00),
     3      X(ID00),X(IF00),X(IDIJ),X(IDKL),X(IDIJSI),X(IDIJSJ),
     4      X(IDKLSK),X(IDKLSL),X(IABV),X(ICV),X(IRW),X(IAAI),X(IAAJ),
     5      X(IBBK),X(IBBL),X(IFI),X(IFJ),X(IFK),X(IFL),X(ISII),X(ISJJ),
     6      X(ISKK),X(ISLL),X(ISIJ),X(ISIK),X(ISIL),X(ISJK),X(ISJL),
     7      X(ISKL),X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,DDA,Q4,MINVEC,
     8      DABCUT,DABMAX,DCHGKL,DCHGIJ)
            NIJ=NIJT
         END IF
C
C     ----- END OF *SHELL* LOOPS -----
C
  500 CONTINUE
  520 CONTINUE
  540 CONTINUE
      IF (TIM .GE. TIMLIM) GO TO 600
  560 CONTINUE
C
  600 CONTINUE
      RETURN
      END
C*MODULE QMFM    *DECK FARDER
      SUBROUTINE FARDER(NCXYZ,IYP,INDX2,IDXIJK,IBS,ISP,NZ,
     *                  IYZTBL,ZP,NTBOX,MAXWS,IYZPNT,IDXWS,LL2,DA,
     *                  CLM,IPP,FLM,G,F,ZLL)
C
C     THIS ROUTINE FORMS FAR FIELD J MATRIX (COULOMB POTENTIAL ONLY).
C
C     C. H. CHOI AUG 2004
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000)
      PARAMETER (MAXNP=45)
C
      COMPLEX*16 ZP, YLM, YLM2, PYP2
C
      LOGICAL QOPS,GOPARR,DSKWRK,MASWRK,QFMM
C
      LOGICAL IANDJ,DOUBLE,NORM
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /GRAD  / DE(3,MXATM)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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
      DIMENSION IYZTBL(2**(NS+1)-1,2**(NS+1)-1,2**(NS+1)-1),
     *          IYZPNT(NTBOX,MAXWS/2),IDXWS(NCXYZ)
      DIMENSION IYP(NCXYZ),IBS(NCXYZ,4),DA(LL2),ISP(NCXYZ,2),
     *          IDXIJK(NCXYZ,3),INDX2(NCXYZ),
     *          ZP((NP+1)*(NP+2)/2,NZ),
     *          IPP(NCXYZ,2),CLM(-NP:NP),CTR(4),
     *          F((NP*(NP+1)*(NP+2)*4/3)+(NP+1)),
     *          G((NP*(NP+1)*(NP+2)*4/3)+(NP+1)),FLM(-NP:NP),
     *          ZLL(0:2*NP+1)
      DIMENSION YLM((MAXNP+1)*(MAXNP+2)/2),RT(3,3),PA(3),PB(3),
     *          CXYZ(3),DIJ(255),EZ(3),PNT(4)
      DIMENSION YLM2((MAXNP+1)*(MAXNP+2)/2),
     *          PYP2((MAXNP+1)*(MAXNP+2)/2),
     *          YTP2((MAXNP+1)*(MAXNP+2)/2)
C
      PARAMETER (SQRT3=1.73205080756888D+00,SQRT5=2.23606797749979D+00)
C
      NORM=NORMF.NE.1.OR.NORMP.NE.1
C
C     PARALLEL INITIALIZATION
C
      IPCOUNT = ME - 1
C
      NS2=2**NS
      LNP=(NP+1)*(NP+2)/2
      LFG=(NP*(NP+1)*(NP+2)*4/3)+(NP+1)
      LNPGP=(NPGP+1)*(NPGP+2)/2
C
      EZ(1)=0.0D+00
      EZ(2)=0.0D+00
      EZ(3)=1.0D+00
C
      IIP=0
      KP=0
      DO N=1,NCXYZ,NUMRD
         NNEW=N+NUMRD-1
         IF (NNEW.GT.NCXYZ) NNEW=NCXYZ
         IIP=IYP(NNEW)-KP
         KP=KP+IIP
         JP=0
C
C        STATIC LOAD-BALANCING
C
         IF (GOPARR) THEN
            IPCOUNT = IPCOUNT + 1
            IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 100
         ENDIF
C
         DO M=N,NNEW
         INEW=INDX2(M)
C
C        SHELL PAIR AND PRIMITIVE PAIR
C
         IISP=ISP(M,1)
         JJSP=ISP(M,2)
         I1=KSTART(IISP)
         J1=KSTART(JJSP)
         IGP=IPP(M,1)
         JGP=IPP(M,2)
         IG=IGP+I1-1
         JG=JGP+J1-1
         IATOM=KATOM(IISP)
         JATOM=KATOM(JJSP)
         LIT=KTYPE(IISP)
         MINI=KMIN(IISP)
         MAXI=KMAX(IISP)
         ILOC=KLOC(IISP)
         LJT=KTYPE(JJSP)
         MINJ=KMIN(JJSP)
         MAXJ=KMAX(JJSP)
         JLOC=KLOC(JJSP)
         IANDJ=IISP.EQ.JJSP
C
         AI=EX(IG)
         CSI=CS(IG)
         CPI=CP(IG)
         CDI=CD(IG)
         CFI=CF(IG)
         AJ=EX(JG)
         CSJ=CS(JG)
         CPJ=CP(JG)
         CDJ=CD(JG)
         CFJ=CF(JG)
C
         XI=C(1,IATOM)
         YI=C(2,IATOM)
         ZI=C(3,IATOM)
         XJ=C(1,JATOM)
         YJ=C(2,JATOM)
         ZJ=C(3,JATOM)
         DFX=XI-XJ
         DFY=YI-YJ
         DFZ=ZI-ZJ
C
         RR=DFX*DFX + DFY*DFY + DFZ*DFZ
         ARRI=AI*RR
         AA=AI+AJ
         DUM=AJ*ARRI/AA
         AXI=AI*XI
         AYI=AI*YI
         AZI=AI*ZI
         CXYZ(1)=(AXI+AJ*XJ)/AA
         CXYZ(2)=(AYI+AJ*YJ)/AA
         CXYZ(3)=(AZI+AJ*ZJ)/AA
         FAC= EXP(-DUM)
C
         DOUBLE=IANDJ.AND.IG.NE.JG
         MAX=MAXJ
         NN=0
         DO 310 I=MINI,MAXI
         GO TO ( 70, 80,180,180, 90,180,180,101,180,180,
     *   110,180,180,120,180,180,180,180,180,130),I
   70    DUM1=CSI*FAC
         GO TO 180
   80    DUM1=CPI*FAC
         GO TO 180
   90    DUM1=CDI*FAC
         GO TO 180
  101    IF(NORM) DUM1=DUM1*SQRT3
         GO TO 180
  110    DUM1=CFI*FAC
         GO TO 180
  120    IF(NORM) DUM1=DUM1*SQRT5
         GO TO 180
  130    IF(NORM) DUM1=DUM1*SQRT3
  180    IF(IANDJ) MAX=I
         DO 310 J=MINJ,MAX
            GO TO (190,200,300,300,210,300,300,220,300,300,
     *      230,300,300,240,300,300,300,300,300,250),J
  190       DUM2=DUM1*CSJ
            IF(.NOT.DOUBLE) GO TO 300
            IF(I.GT.1) GO TO 195
            DUM2=DUM2+DUM2
            GO TO 300
  195       DUM2=DUM2+CSI*CPJ*FAC
            GO TO 300
  200       DUM2=DUM1*CPJ
            IF(DOUBLE) DUM2=DUM2+DUM2
            GO TO 300
  210       DUM2=DUM1*CDJ
            IF(DOUBLE) DUM2=DUM2+DUM2
            GO TO 300
  220       IF(NORM) DUM2=DUM2*SQRT3
            GO TO 300
  230       DUM2=DUM1*CFJ
            IF(DOUBLE) DUM2=DUM2+DUM2
            GO TO 300
  240       IF(NORM) DUM2=DUM2*SQRT5
            GO TO 300
  250       IF(NORM) DUM2=DUM2*SQRT3
  300       NN=NN+1
  310    DIJ(NN)=DUM2
C
C        FIND OUT THE CENTER OF THE BOX TO WHICH THE POINT BELONGS.
C
         I=IDXIJK(INEW,1)
         J=IDXIJK(INEW,2)
         K=IDXIJK(INEW,3)
         CALL GETCTR(SIZE,NS2,I,J,K,CTR)
C
C        FIND OUT THE TRANSLATION VECTOR OF THE POINT
C
         DO II=1,3
            PNT(II)=CXYZ(II)-CTR(II)
         ENDDO
C
C        OBTAIN PA AND PB
C
         DO II=1,3
            PA(II)=CXYZ(II)-C(II,IATOM)
            PB(II)=CXYZ(II)-C(II,JATOM)
         ENDDO
C
C        FIND OUT THE WS INDEX
C
         NWS=IDXWS(INEW)/2
C
C        FIND OUT THE ACTUAL POSITION OF YP OF BOX (I,J,K)
C
         IZP=IYZPNT(IYZTBL(I,J,K),NWS)
C        GET THE ROTATION MATRICES
         TY2Y=SQRT(PNT(1)*PNT(1)+PNT(2)*PNT(2)+
     *        PNT(3)*PNT(3))
         IF (NP.LT.NPGP) NP=NPGP
         CALL GETZLL(ZLL,TY2Y,2*NP+2)
         CALL ROTR(PNT,EZ,RT)
         CALL GETROT(F,G,RT,NP,CLM)
C
         CALL RZ2ZIR(LNP,ZP(1,IZP),YTP2,PYP2,LFG,F,G,NP,FLM,ZLL)
C
C
C        LOOP OVER BASIS SET PAIR, <IJ|
C
         DO IB=IBS(M,1),IBS(M,2)
            LIN=IB*(IB-1)/2
            DO JB=IBS(M,3),IBS(M,4)
               LJN=JB+LIN
               IF (IB.GE.JB) THEN
                  JP=JP+1
                  CALL MOMSPC(LIT,LJT,IB-ILOC+MINI,JB-JLOC+MINJ,
     *               YLM,PA,PB,AA,DIJ(JP))
                  CALL F0DER(IB,JB,NPGP,LNPGP,YLM,YTP2,SUM)
                  CALL MOMAB(LIT,LJT,IB-ILOC+MINI,JB-JLOC+MINJ,
     *               YLM2,PA,PB,AI,AJ,AA,DIJ(JP),0,0,1)
                  CALL FPDER(IB,JB,NPGP,LNPGP,YLM2,YTP2,SUMPZ)
                  CALL FZDER(IB,JB,NP,YLM,YTP2,CLM,DA(LJN),AI,AJ,
     *               DFZ,SUM,SUMPZ,DZA,DZB)
C
                  CALL MOMAB(LIT,LJT,IB-ILOC+MINI,JB-JLOC+MINJ,
     *               YLM2,PA,PB,AI,AJ,AA,DIJ(JP),1,0,0)
                  CALL FPDER(IB,JB,NPGP,LNPGP,YLM2,YTP2,SUMPX)
                  CALL FXDER(IB,JB,NP,YLM,YTP2,CLM,DA(LJN),AI,AJ,
     *               DFX,SUM,SUMPX,DXA,DXB)
                  CALL MOMAB(LIT,LJT,IB-ILOC+MINI,JB-JLOC+MINJ,
     *               YLM2,PA,PB,AI,AJ,AA,DIJ(JP),0,1,0)
                  CALL FPDER(IB,JB,NPGP,LNPGP,YLM2,YTP2,SUMPY)
                  CALL FYDER(IB,JB,NP,YLM,YTP2,CLM,DA(LJN),AI,AJ,
     *               DFY,SUM,SUMPY,DYA,DYB)
C
                  DE(1,IATOM)=DE(1,IATOM)+DXA
                  DE(1,JATOM)=DE(1,JATOM)+DXB
                  DE(2,IATOM)=DE(2,IATOM)+DYA
                  DE(2,JATOM)=DE(2,JATOM)+DYB
                  DE(3,IATOM)=DE(3,IATOM)+DZA
                  DE(3,JATOM)=DE(3,JATOM)+DZB
               ENDIF
            ENDDO
         ENDDO
C
         ENDDO
 100  ENDDO
C
      RETURN
      END
C*MODULE QFMM    *DECK FZDER
      SUBROUTINE FZDER(IB,JB,NP,YP,ZP,CLM,DA,GA,GB,DFZ,SUM,SUMPZ,
     *DZA,DZB)
C
C     QFMM DERIVATIVE WRT Z DIRECTION
C     NP : HIGHEST MULTIPOLE ORDER L
C     YP : YLM
C     ZP : ZLM
C     DA : ONE BODY DENSITY MATRIX ELEMENT
C     GA,GB : EXPONENTS OF GAUSSIAN FUNCTIONS OF ATOM A AND B
C     DFZ : ZA-ZB
C     DZA : ENERGY DERIVATIVE WRT Z DIRECTION OF ATOM A
C     DZB : ENERGY DERIVATIVE WRT Z DIRECTION OF ATOM B
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMPLEX*16 YP, ZP
      PARAMETER (TWO=2.0D+00)
      DIMENSION CLM(-NP:NP),ZP((NP+1)*(NP+2)/2),YP((NP+1)*(NP+2)/2)
C
      IY=0
      IZ=0
      SUMZ=0.0D+00
      TSUM=0.0D+00
      DO I=0,NP-1
         IZ=IZ+1
         DO J=0,I
            IY=IY+1
            IZ=IZ+1
            FACTOR=CLM(I+1+J-NP)*CLM(I+1-J-NP)
            TSUM=TSUM+FACTOR*DREAL(YP(IY)*ZP(IZ))
         ENDDO
      ENDDO
      SUMZ=TSUM
      TSUM=0.0D+00
      IY=1
      DO I=0,NP-1
         IY=IY+I
         IZ=IY+I+1
         TSUM=TSUM+(I+1)*DREAL(YP(IY)*ZP(IZ))
      ENDDO
      SUMZ=TWO*SUMZ-TSUM
      IF (IB.NE.JB) SUMZ=TWO*SUMZ
C
      GP=GA+GB
      DZA=DA*(GA/GP*(SUMZ-TWO*GB*DFZ*SUM)+SUMPZ)
      DZB=DA*(GB/GP*(SUMZ+TWO*GA*DFZ*SUM)-SUMPZ)
C
      RETURN
      END
C*MODULE QFMM    *DECK FXDER
      SUBROUTINE FXDER(IB,JB,NP,YP,ZP,CLM,DA,GA,GB,DFX,SUM,SUMPX,
     *DXA,DXB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMPLEX*16 YP, ZP, SUMXA,SUMXB
      PARAMETER (TWO=2.0D+00)
      DIMENSION CLM(-NP:NP),ZP((NP+1)*(NP+2)/2),YP((NP+1)*(NP+2)/2)
C
C     QFMM DERIVATIVE WRT X DIRECTION
C
      LY=1
      LZ=1
      SUMXA=0.0D+00
      SUMXB=0.0D+00
      SUMX=0.0D+00
      DO L=0,NP-1
         LY=LY+L
         LZ=LZ+L+1
         DO MY=-L,L
            MZ=MY-1
            FAC=CLM(L-MY+2-NP)*CLM(L-MY+1-NP)
            IF (MY.GE.0) THEN
               IF (MZ.GE.0) THEN
                   SUMXA=SUMXA+FAC*(YP(LY+MY)*ZP(LZ+MZ))
               ELSE
                   SUMXA=SUMXA+EO(MZ)*FAC*YP(LY+MY)*DCONJG(ZP(LZ-MZ))
               ENDIF
            ELSE
               IF (MZ.GE.0) THEN
                  SUMXA=SUMXA+EO(MY)*FAC*DCONJG(YP(LY-MY))*ZP(LZ+MZ)
               ELSE
                  SUMXA=SUMXA+EO(MY+MZ)*FAC*DCONJG(YP(LY-MY)*ZP(LZ-MZ))
               ENDIF
            ENDIF
         ENDDO
      ENDDO
C
      LY=1
      LZ=1
      DO L=0,NP-1
         LY=LY+L
         LZ=LZ+L+1
         DO MY=L,-L,-1
            MZ=MY+1
            FAC=CLM(L+MY+2-NP)*CLM(L+MY+1-NP)
            IF (MY.GE.0) THEN
               IF (MZ.GE.0) THEN
                  SUMXB=SUMXB+FAC*YP(LY+MY)*ZP(LZ+MZ)
               ELSE
                  SUMXB=SUMXB+EO(MZ)*FAC*YP(LY+MY)*DCONJG(ZP(LZ-MZ))
               ENDIF
            ELSE
               IF (MZ.GE.0) THEN
                  SUMXB=SUMXB+EO(MY)*FAC*DCONJG(YP(LY-MY))*ZP(LZ+MZ)
               ELSE
                  SUMXB=SUMXB+EO(MY+MZ)*FAC*DCONJG(YP(LY-MY)*ZP(LZ-MZ))
               ENDIF
            ENDIF
         ENDDO
      ENDDO
C
      SUMX=DREAL(SUMXA-SUMXB)/2
      IF (IB.NE.JB) SUMX=TWO*SUMX
C
      GP=GA+GB
      DXA=DA*(GA/GP*(SUMX-TWO*GB*DFX*SUM)+SUMPX)
      DXB=DA*(GB/GP*(SUMX+TWO*GA*DFX*SUM)-SUMPX)
C
      RETURN
      END
C*MODULE QFMM    *DECK FYDER
      SUBROUTINE FYDER(IB,JB,NP,YP,ZP,CLM,DA,GA,GB,DFY,SUM,SUMPY,DYA,
     *DYB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMPLEX*16 YP, ZP, SUMXA,SUMXB
      PARAMETER (TWO=2.0D+00)
      DIMENSION CLM(-NP:NP),ZP((NP+1)*(NP+2)/2),YP((NP+1)*(NP+2)/2)
C
C     QFMM DERIVATIVE WRT Y DIRECTION
C
      LY=1
      LZ=1
      SUMXA=0.0D+00
      SUMY=0.0D+00
      DO L=0,NP-1
         LY=LY+L
         LZ=LZ+L+1
         DO MY=-L,L
            MZ=MY-1
            FAC=CLM(L-MY+2-NP)*CLM(L-MY+1-NP)
            IF (MY.GE.0) THEN
               IF (MZ.GE.0) THEN
                  SUMXA=SUMXA+FAC*(YP(LY+MY)*ZP(LZ+MZ))
               ELSE
                  SUMXA=SUMXA+EO(MZ)*FAC*YP(LY+MY)*DCONJG(ZP(LZ-MZ))
               ENDIF
            ELSE
               IF (MZ.GE.0) THEN
                  SUMXA=SUMXA+EO(MY)*FAC*DCONJG(YP(LY-MY))*ZP(LZ+MZ)
               ELSE
                  SUMXA=SUMXA+EO(MY+MZ)*FAC*DCONJG(YP(LY-MY)*ZP(LZ-MZ))
               ENDIF
            ENDIF
         ENDDO
      ENDDO
C
      LY=1
      LZ=1
      SUMXB=0.0D+00
      DO L=0,NP-1
         LY=LY+L
         LZ=LZ+L+1
         DO MY=L,-L,-1
            MZ=MY+1
            FAC=CLM(L+MY+2-NP)*CLM(L+MY+1-NP)
            IF (MY.GE.0) THEN
               IF (MZ.GE.0) THEN
                  SUMXB=SUMXB+FAC*YP(LY+MY)*ZP(LZ+MZ)
               ELSE
                  SUMXB=SUMXB+EO(MZ)*FAC*YP(LY+MY)*DCONJG(ZP(LZ-MZ))
               ENDIF
            ELSE
               IF (MZ.GE.0) THEN
                  SUMXB=SUMXB+EO(MY)*FAC*DCONJG(YP(LY-MY))*ZP(LZ+MZ)
               ELSE
                  SUMXB=SUMXB+EO(MY+MZ)*FAC*DCONJG(YP(LY-MY)*ZP(LZ-MZ))
               ENDIF
            ENDIF
         ENDDO
      ENDDO
      SUMY=-DIMAG(SUMXA+SUMXB)/2
      IF (IB.NE.JB) SUMY=TWO*SUMY
C
      GP=GA+GB
      DYA=DA*(GA/GP*(SUMY-TWO*GB*DFY*SUM)+SUMPY)
      DYB=DA*(GB/GP*(SUMY+TWO*GA*DFY*SUM)-SUMPY)
C
      RETURN
      END
C*MODULE QFMM    *DECK F0DER
      SUBROUTINE F0DER(IB,JB,NP,LNP,YP,ZP,SUM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMPLEX*16 YP, ZP
      PARAMETER (TWO=2.0D+00)
      DIMENSION ZP((NP+1)*(NP+2)/2),YP((NP+1)*(NP+2)/2)
C
      SUM=0.0D+00
      SUB=0.0D+00
      DO II=1,LNP
         SUM=SUM + DREAL(YP(II)*ZP(II))
      ENDDO
      IK=1
      DO II=0,NP
         IK=IK+II
         SUB=SUB + DREAL(YP(IK)*ZP(IK))
      ENDDO
      SUM=TWO*SUM-SUB
      IF (IB.NE.JB) SUM=SUM*TWO
C
      RETURN
      END
C*MODULE QFMM    *DECK FPDER
      SUBROUTINE FPDER(IB,JB,NP,LNP,YP,ZP,SUM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMPLEX*16 YP, ZP
      PARAMETER (TWO=2.0D+00)
      DIMENSION ZP((NP+1)*(NP+2)/2),YP((NP+1)*(NP+2)/2)
C
      SUM=0.0D+00
      SUB=0.0D+00
      DO II=1,LNP
         SUM=SUM + DREAL(YP(II)*ZP(II))
      ENDDO
      IK=1
      DO II=0,NP
         IK=IK+II
         SUB=SUB + DREAL(YP(IK)*ZP(IK))
      ENDDO
      SUM=TWO*SUM-SUB
      IF (IB.NE.JB) SUM=SUM*TWO
C
      RETURN
      END
C*MODULE QMFM    *DECK LEDSHL
      SUBROUTINE LEDSHL(ISH,JSH,DCHRG,NIJS,NIJ0,IJSP,IJNUM,NCXYZ,ITPP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXGTOT=20000, MXSH=5000, MXGSH=30, MXATM=2000)
C
      DIMENSION GA(MXGSH),CCA(MXGSH),CCAS(MXGSH),
     *          GB(MXGSH),CCB(MXGSH),CCBS(MXGSH)
      DIMENSION CSPDFG(MXGTOT,5)
      DIMENSION DCHRG(15,*),ITPP(NCXYZ,2)
C
      LOGICAL IIEQJJ,KKEQLL,IJEQKL,IJGTKL,IJLTKL
      LOGICAL SPI,SPJ,SPK,SPL,SPIJ,SPKL,SPIJKL
      LOGICAL EXPNDI,EXPNDK,OUT,DBG
C
      COMMON /DSHLNO/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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/SHLEQU/IIEQJJ,KKEQLL,IJEQKL,IJGTKL,IJLTKL
      COMMON/SHLNUM/NUMI,NUMJ,NUMK,NUML,IJKL
      COMMON/SHLTYP/SPI,SPJ,SPK,SPL,SPIJ,SPKL,SPIJKL
      COMMON/SHLXPN/EXPNDI,EXPNDK
C
      EQUIVALENCE (CSPDFG(1,1),CS(1))
C
      PARAMETER (ONE=1.0D+00)
C
      IIEQJJ=ISH.EQ.JSH
C
C     ----- ISHELL -----
C
      I=KATOM(ISH)
      XI=C(1,I)
      YI=C(2,I)
      ZI=C(3,I)
      I1=KSTART(ISH)
      I2=I1+KNG(ISH)-1
      LIT=KTYPE(ISH)
      MINI=KMIN(ISH)
      MAXI=KMAX(ISH)
      NUMI=MAXI-MINI+1
      LOCI=KLOC(ISH)-MINI
      SPI=LIT.EQ.2.AND.MINI.EQ.1
      NGA=0
      DO 10 I=I1,I2
        NGA=NGA+1
        GA(NGA)=EX(I)
        CCA(NGA)=CSPDFG(I,LIT)
        IF(SPI) CCAS(NGA)=CSPDFG(I,1)/CSPDFG(I,2)
   10 CONTINUE
C
C     ----- JSHELL -----
C
      J=KATOM(JSH)
      XJ=C(1,J)
      YJ=C(2,J)
      ZJ=C(3,J)
      J1=KSTART(JSH)
      J2=J1+KNG(JSH)-1
      LJT=KTYPE(JSH)
      MINJ=KMIN(JSH)
      MAXJ=KMAX(JSH)
      NUMJ=MAXJ-MINJ+1
      LOCJ=KLOC(JSH)-MINJ
      SPJ=LJT.EQ.2.AND.MINJ.EQ.1
      NGB=0
      DO 20 J=J1,J2
        NGB=NGB+1
        GB(NGB)=EX(J)
        CCB(NGB)=CSPDFG(J,LJT)
        IF(SPJ) CCBS(NGB)=CSPDFG(J,1)/CSPDFG(J,2)
   20 CONTINUE
      RRI=((XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2)
      SPIJ=SPI.OR.SPJ
      EXPNDI=LIT.GE.LJT
C
C     ----- -IJ- CHARGE DISTRIBUTION -----
C
      XC=XI
      YC=YI
      ZC=ZI
      DXIJ=XI-XJ
      DYIJ=YI-YJ
      DZIJ=ZI-ZJ
      IF(EXPNDI) GO TO 100
      XC=XJ
      YC=YJ
      ZC=ZJ
      DXIJ=XJ-XI
      DYIJ=YJ-YI
      DZIJ=ZJ-ZI
  100 CONTINUE
C
C     ----- - I- PRIMITIVE           -----
C
      NIJT=0
      DO IJPP=IJSP-IJNUM+1,IJSP
        IA=ITPP(IJPP,1)
        JB=ITPP(IJPP,2)
        AI=GA(IA)
        ARRI=AI*RRI
        AXI=AI*XI
        AYI=AI*YI
        AZI=AI*ZI
        CCI=CCA(IA)
C
C     ----- - J- PRIMITIVE           -----
C
          AJ=GB(JB)
          AA=AI+AJ
          AA1=ONE/AA
          DUM=AJ*ARRI*AA1
          IF(DUM.GT.RTOL) GO TO 200
          DAEXPA=CCI*CCB(JB)* EXP(-DUM)*AA1
          DUM=  ABS(DAEXPA)
          IF(DUM.LE.DTOL) GO TO 200
C
          NIJT=NIJT+1
          DCHRG( 1,NIJT+NIJ0)= DAEXPA
          DCHRG( 2,NIJT+NIJ0)= AA
          DCHRG( 3,NIJT+NIJ0)=(AXI+AJ*XJ)*AA1
          DCHRG( 4,NIJT+NIJ0)=(AYI+AJ*YJ)*AA1
          DCHRG( 5,NIJT+NIJ0)=(AZI+AJ*ZJ)*AA1
          DCHRG( 6,NIJT+NIJ0)= XC
          DCHRG( 7,NIJT+NIJ0)= YC
          DCHRG( 8,NIJT+NIJ0)= ZC
          DCHRG( 9,NIJT+NIJ0)= DXIJ
          DCHRG(10,NIJT+NIJ0)= DYIJ
          DCHRG(11,NIJT+NIJ0)= DZIJ
          DCHRG(12,NIJT+NIJ0)= AI+AI
          DCHRG(13,NIJT+NIJ0)= AJ+AJ
          IF(SPI) DCHRG(14,NIJT+NIJ0)=CCAS(IA)
          IF(SPJ) DCHRG(15,NIJT+NIJ0)=CCBS(JB)
C
  200   CONTINUE
C
        IF (IIEQJJ.AND.IA.GT.JB) THEN
        ITEMP=IA
        IA=JB
        JB=ITEMP
C
C     ----- - I- PRIMITIVE           -----
C
        AI=GA(IA)
        ARRI=AI*RRI
        AXI=AI*XI
        AYI=AI*YI
        AZI=AI*ZI
        CCI=CCA(IA)
C
C     ----- - J- PRIMITIVE           -----
C
          AJ=GB(JB)
          AA=AI+AJ
          AA1=ONE/AA
          DUM=AJ*ARRI*AA1
          IF(DUM.GT.RTOL) GO TO 300
          DAEXPA=CCI*CCB(JB)* EXP(-DUM)*AA1
          DUM=  ABS(DAEXPA)
          IF(DUM.LE.DTOL) GO TO 300
C
          NIJT=NIJT+1
          DCHRG( 1,NIJT+NIJ0)= DAEXPA
          DCHRG( 2,NIJT+NIJ0)= AA
          DCHRG( 3,NIJT+NIJ0)=(AXI+AJ*XJ)*AA1
          DCHRG( 4,NIJT+NIJ0)=(AYI+AJ*YJ)*AA1
          DCHRG( 5,NIJT+NIJ0)=(AZI+AJ*ZJ)*AA1
          DCHRG( 6,NIJT+NIJ0)= XC
          DCHRG( 7,NIJT+NIJ0)= YC
          DCHRG( 8,NIJT+NIJ0)= ZC
          DCHRG( 9,NIJT+NIJ0)= DXIJ
          DCHRG(10,NIJT+NIJ0)= DYIJ
          DCHRG(11,NIJT+NIJ0)= DZIJ
          DCHRG(12,NIJT+NIJ0)= AI+AI
          DCHRG(13,NIJT+NIJ0)= AJ+AJ
          IF(SPI) DCHRG(14,NIJT+NIJ0)=CCAS(IA)
          IF(SPJ) DCHRG(15,NIJT+NIJ0)=CCBS(JB)
C
  300   CONTINUE
      ENDIF
      ENDDO
      NIJS=NIJT
      RETURN
      END
C*MODULE QMFM    *DECK JKLSPD
      SUBROUTINE JKLSPD(NKL,GINT,FINT,SINT,IJKLG,
     1                  GIJKL,GNKL,GNM,XY,XZ,YZ,X,Y,Z,SJ,SK,SL,
     2                  B00,B01,B10,C00,D00,F00,DIJ,DKL,DIJSI,DIJSJ,
     3                  DKLSK,DKLSL,ABV,CV,RWV,AAI,AAJ,BBK,BBL,FI,FJ,
     4                  FK,FL,SII,SJJ,SKK,SLL,SIJ,SIK,SIL,SJK,SJL,SKL,
     5                  DAB,MAXXYZ,FC,NC,DF,LDF,NBF,DEN,QQ4,MINVEC,
     6                  DABCUT,DABMAX,DCHGIJ,DCHGKL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL SKIPI,SKIPJ,SKIPK,SKIPL
      LOGICAL SPI,SPJ,SPK,SPL,SPIJ,SPKL,SPIJKL
      LOGICAL NMAXS,NMAXP,MMAXS,MMAXP
      LOGICAL EXPNDI,EXPNDK
      LOGICAL FIRST
      LOGICAL LAST
      LOGICAL OUT,DBG
      COMMON /DSHLNO/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON/SHLGNM/NMAXS,NMAXP,MMAXS,MMAXP
      COMMON/SHLTYP/SPI,SPJ,SPK,SPL,SPIJ,SPKL,SPIJKL
      COMMON/SHLXPN/EXPNDI,EXPNDK
      COMMON/DERPAR/IDER,JDER,KDER,LDER,NDER
      COMMON/DERSKP/IIAT,JJAT,KKAT,LLAT,SKIPI,SKIPJ,SKIPK,SKIPL
      DIMENSION DCHGIJ(15,*),DCHGKL(15,*)
      DIMENSION GINT(1),FINT(12,1),SINT(78,1),IJKLG(4,1)
      DIMENSION XY(1),XZ(1),YZ(1),X(1),Y(1),Z(1),SJ(1),SK(1),SL(1)
      DIMENSION GIJKL(1),GNKL(1),GNM(1)
      DIMENSION DIJ(1),DKL(1),DIJSI(1),DIJSJ(1),DKLSK(1),DKLSL(1)
      DIMENSION FI(1),FJ(1),FK(1),FL(1)
      DIMENSION SII(1),SJJ(1),SKK(1),SLL(1)
      DIMENSION SIJ(1),SIK(1),SIL(1),SJK(1),SJL(1),SKL(1)
      DIMENSION B00(1),B01(1),B10(1),C00(1),D00(1),F00(1)
      DIMENSION AAI(1),AAJ(1),BBK(1),BBL(1)
      DIMENSION ABV(5,1),CV(18,1),RWV(2,1)
      DIMENSION DAB(1)
      DIMENSION FC(NC,1),DF(LDF,1),DEN(1)
      PARAMETER(PI252=34.986836655250D+00, ONE=1.0D+00)
C
      Q4=PI252*QQ4
C
      NIMAX=LIT + IDER
      NJMAX=LJT + JDER
      NKMAX=LKT + KDER
      NLMAX=LLT + LDER
      NMAX=LIT+LJT-1 + MIN0(IDER+JDER,NDER)
      MMAX=LKT+LLT-1 + MIN0(KDER+LDER,NDER)
      NMAXS=NMAX.EQ.1
      NMAXP=NMAX.LE.2
      MMAXS=MMAX.EQ.1
      MMAXP=MMAX.LE.2
      DTOL2=DTOL*DTOL
C
      MAXG=MAXXYZ/NROOTS
C
C     ----- PAIR OF K,L PRIMITIVES -----
C
      FIRST=.TRUE.
      NG=0
      KLG=0
  100 KLG=KLG+1
      IF(KLG.GT.NKL) GO TO 300
      DB=DCHGKL(1,KLG)
      BB=DCHGKL(2,KLG)
      XB=DCHGKL(3,KLG)
      YB=DCHGKL(4,KLG)
      ZB=DCHGKL(5,KLG)
      XD=DCHGKL(6,KLG)
      YD=DCHGKL(7,KLG)
      ZD=DCHGKL(8,KLG)
      DXKL=DCHGKL(9,KLG)
      DYKL=DCHGKL(10,KLG)
      DZKL=DCHGKL(11,KLG)
      Q4DB=Q4*DB
C
C     ----- PAIR OF I,J PRIMITIVES -----
C
      IJG=0
  200 IJG=IJG+1
      IF(IJG.GT.NIJ) GO TO 100
      DA=DCHGIJ(1,IJG)
      AA=DCHGIJ( 2,IJG)
      XA=DCHGIJ( 3,IJG)
      YA=DCHGIJ( 4,IJG)
      ZA=DCHGIJ( 5,IJG)
      AANDB1=ONE/(AA+BB)
      Q4DBDA=Q4DB*DA
      DUM   =Q4DBDA*Q4DBDA*AANDB1
      IF(DUM.LE.DTOL2) GO TO 200
      Q4DBDA=Q4DBDA* SQRT(AANDB1)
      IF( ABS(Q4DBDA*DABMAX).LT.DABCUT) GO TO 200
      RHO   =AA*BB*AANDB1
      XX=RHO*((XA-XB)**2+(YA-YB)**2+(ZA-ZB)**2)
C
      NG=NG+1
      ABV(1,NG)=AA
      ABV(2,NG)=BB
      ABV(3,NG)=RHO
      ABV(4,NG)=Q4DBDA
      ABV(5,NG)=XX
C
      XC=DCHGIJ( 6,IJG)
      YC=DCHGIJ( 7,IJG)
      ZC=DCHGIJ( 8,IJG)
      DXIJ=DCHGIJ( 9,IJG)
      DYIJ=DCHGIJ(10,IJG)
      DZIJ=DCHGIJ(11,IJG)
C
      AAI(NG)=DCHGIJ(12,IJG)
      AAJ(NG)=DCHGIJ(13,IJG)
      BBK(NG)=DCHGKL(12,KLG)
      BBL(NG)=DCHGKL(13,KLG)
C
      IF(MMAXS) GO TO 210
      CV( 1,NG)=AA*(XA-XD)
      CV( 2,NG)=BB*(XB-XD)
      CV( 3,NG)=AA*(YA-YD)
      CV( 4,NG)=BB*(YB-YD)
      CV( 5,NG)=AA*(ZA-ZD)
      CV( 6,NG)=BB*(ZB-ZD)
  210 IF(NMAXS) GO TO 220
      CV( 7,NG)=AA*(XA-XC)
      CV( 8,NG)=BB*(XB-XC)
      CV( 9,NG)=AA*(YA-YC)
      CV(10,NG)=BB*(YB-YC)
      CV(11,NG)=AA*(ZA-ZC)
      CV(12,NG)=BB*(ZB-ZC)
  220 CONTINUE
      CV(13,NG)=DXIJ
      CV(14,NG)=DYIJ
      CV(15,NG)=DZIJ
      CV(16,NG)=DXKL
      CV(17,NG)=DYKL
      CV(18,NG)=DZKL
      IF(SPI) DIJSI(NG)=DCHGIJ(14,IJG)
      IF(SPJ) DIJSJ(NG)=DCHGIJ(15,IJG)
      IF(SPK) DKLSK(NG)=DCHGKL(14,KLG)
      IF(SPL) DKLSL(NG)=DCHGKL(15,KLG)
C
      IF(NG.LT.MAXG) GO TO 200
      LAST=.FALSE.
      GO TO 310
C
  300 CONTINUE
      LAST=.TRUE.
  310 CONTINUE
      NUMG=NG
      IF(NUMG.EQ.0) GO TO 1000
C
      IF(NROOTS.EQ.1) GO TO 480
      IF (SPI) THEN
          DO 410 IROOT=2,NROOTS
          DO 410 IG=1,NUMG
              DIJSI(IG+NUMG*(IROOT-1))=DIJSI(IG)
  410     CONTINUE
      ENDIF
      IF (SPJ) THEN
         DO 430 IROOT=2,NROOTS
         DO 430 IG=1,NUMG
            DIJSJ(IG+NUMG*(IROOT-1))=DIJSJ(IG)
  430    CONTINUE
      ENDIF
      IF (SPK) THEN
         DO 450 IROOT=2,NROOTS
         DO 450 IG=1,NUMG
            DKLSK(IG+NUMG*(IROOT-1))=DKLSK(IG)
  450    CONTINUE
      ENDIF
      IF (SPL) THEN
         DO 470 IROOT=2,NROOTS
         DO 470 IG=1,NUMG
            DKLSL(IG+NUMG*(IROOT-1))=DKLSL(IG)
  470    CONTINUE
      ENDIF
C
  480 IF(SKIPI) GO TO 520
      DO 510 IRXYZ=2,NROOTS*3
      DO 510 IG=1,NUMG
      AAI(IG+NUMG*(IRXYZ-1))=AAI(IG)
  510 CONTINUE
  520 IF(SKIPJ) GO TO 540
      DO 530 IRXYZ=2,NROOTS*3
      DO 530 IG=1,NUMG
      AAJ(IG+NUMG*(IRXYZ-1))=AAJ(IG)
  530 CONTINUE
  540 IF(SKIPK) GO TO 560
      DO 550 IRXYZ=2,NROOTS*3
      DO 550 IG=1,NUMG
      BBK(IG+NUMG*(IRXYZ-1))=BBK(IG)
  550 CONTINUE
  560 IF(SKIPL) GO TO 580
      DO 570 IRXYZ=2,NROOTS*3
      DO 570 IG=1,NUMG
      BBL(IG+NUMG*(IRXYZ-1))=BBL(IG)
  570 CONTINUE
  580 CONTINUE
C
C     ----- COMPUTE ROOTS AND WEIGHTS FOR QUADRATURE -----
C
      CALL JKWRYS(RWV,ABV,NUMG)
C
C     ----- COMPUTE COEFFICIENTS FOR RECURSION FORMULAE -----
C
      CALL JKBCDF(B00,B01,B10,C00,D00,F00,DIJ,DKL,
     1            ABV,CV,RWV,NUMG,NROOTS)
C
C     ----- COMPUTE -X- , -Y- , -Z- INTEGRALS ( 2 CENTERS, 2-D ) -----
C
      IF(NUMG*NROOTS*3.LT.MINVEC)
     1 CALL JKGNMS(GNM,NUMG*NROOTS*3,NMAX,MMAX,
     2             B00,B01,B10,C00,D00,F00)
      IF(NUMG*NROOTS*3.GE.MINVEC)
     1 CALL JKGNMV(GNM,NUMG*NROOTS*3,NMAX,MMAX,
     2             B00,B01,B10,C00,D00,F00)
C
C     ----- COMPUTE -X- , -Y- , -Z- INTEGRALS ( 4 CENTERS, 2-D ) -----
C
      IF(NUMG*NROOTS*3.LT.MINVEC)
     1 CALL JKXYZS(GIJKL,GIJKL,GNKL,GNKL,GNKL,GNM,GNM,
     2 NUMG*NROOTS*3,NMAX,MMAX,NIMAX,NJMAX,NKMAX,NLMAX,DIJ,DKL,
     3 EXPNDI,EXPNDK)
      IF(NUMG*NROOTS*3.GE.MINVEC)
     1 CALL JKXYZV(GIJKL,GIJKL,GNKL,GNKL,GNKL,GNM,GNM,
     2 NUMG*NROOTS*3,NMAX,MMAX,NIMAX,NJMAX,NKMAX,NLMAX,DIJ,DKL,
     3 EXPNDI,EXPNDK)
C
C     ----- COMPUTE -X- , -Y- , -Z- INTEGRALS FOR DERIVATIVES -----
C
      IF(NUMG*NROOTS*3.LT.MINVEC)
     1 CALL JDXYZS(GIJKL,GIJKL,GIJKL,GIJKL,GIJKL,GIJKL,GIJKL,GIJKL,
     2 NUMG*NROOTS*3,NIMAX,NJMAX,NKMAX,NLMAX,LIT,LJT,LKT,LLT,
     3 AAI,AAJ,BBK,BBL,
     4 FI,FJ,FK,FL,SII,SJJ,SKK,SLL,SIJ,SIK,SIL,SJK,SJL,SKL)
      IF(NUMG*NROOTS*3.GE.MINVEC)
     1 CALL JDXYZV(GIJKL,GIJKL,GIJKL,GIJKL,GIJKL,GIJKL,GIJKL,GIJKL,
     2 NUMG*NROOTS*3,NIMAX,NJMAX,NKMAX,NLMAX,LIT,LJT,LKT,LLT,
     3 AAI,AAJ,BBK,BBL,
     4 FI,FJ,FK,FL,SII,SJJ,SKK,SLL,SIJ,SIK,SIL,SJK,SJL,SKL)
C
C     ----- ZERO OUT FIRST TIME AROUND -----
C
      IF(FIRST) THEN
         CALL JKDZER(GINT,FINT,SINT,IJKLG)
         FIRST=.FALSE.
      ENDIF
C
C     ----- COMPUTE DERIVATIVE INTEGRALS -----
C
      IF(NUMG*NROOTS.LT.MINVEC)
     1 CALL DSPDFS(NUMG,NROOTS,IJKLG,GINT,FINT,SINT,
     2 GIJKL,FI,FJ,FK,FL,SII,SJJ,SKK,SLL,SIJ,SIK,SIL,SJK,SJL,SKL,
     3 XY,XZ,YZ,X,Y,Z,SJ,SK,SL,DIJSI,DIJSJ,DKLSK,DKLSL,DAB)
      IF(NUMG*NROOTS.GE.MINVEC)
     1 CALL DSPDFV(NUMG,NROOTS,IJKLG,GINT,FINT,SINT,
     2 GIJKL,FI,FJ,FK,FL,SII,SJJ,SKK,SLL,SIJ,SIK,SIL,SJK,SJL,SKL,
     3 XY,XZ,YZ,X,Y,Z,SJ,SK,SL,DIJSI,DIJSJ,DKLSK,DKLSL,DAB)
C
      IF(LAST) GO TO 1000
      NG=0
      GO TO 200
 1000 IF(NUMG.EQ.0.AND.FIRST) RETURN
C
C     ----- PROCESS DERIVATIVE INTEGRALS -----
C
      CALL JKDINV(FINT,SINT,IJKLG,FC,NC,DF,LDF,NBF,DEN)
      IF (OUT) CALL JKDOUT(GINT,FINT,SINT,IJKLG,DAB)
      RETURN
      END
C*MODULE QMFM    *DECK COREJKD
      SUBROUTINE COREJKD(NCXYZ,ITSP,ITPP,IXTBL,ITBL,
     *                   DCHGIJ,DCHGKL,MAXXYZ,MINVEC,DA,DB,
     *                   CUTOFF,CUTOFF2,DABCUT)
C
C       THE DRIVER FOR THE TWO ELECTRON GRADIENT
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SKIPI,SKIPJ,SKIPK,SKIPL
      LOGICAL UHFTYP,PACK2E,POPLE
      LOGICAL OUT,DBG
C
      PARAMETER (MXAO=8192)
C
      DIMENSION DCHGIJ(15,*),DCHGKL(15,*),DA(*),DB(*)
      DIMENSION ITSP(NCXYZ,2),ITPP(NCXYZ,2),ITBL(IXTBL)
C
      COMMON /DERSKP/ IIAT,JJAT,KKAT,LLAT,SKIPI,SKIPJ,SKIPK,SKIPL
      COMMON /DSHLNO/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /FMCOM / X(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /MP2PAR/ OSPT,TOL,METHOD,NWDMP2,MPPROP,NACORE,NBCORE,
     *                NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      COMMON/DERMEM/IWFN,IXCH,INIJG,IGINT,IFINT,ISINT,IIJKLG,
     1 IDAB,ICHRG,IXY,IXZ,IYZ,IX,IY,IZ,ISJ,ISK,ISL,IGIJKL,IGNKL,IGNM,
     2 IDIJ,IDKL,IB00,IB01,IB10,IC00,ID00,IF00,
     3 IAAI,IAAJ,IBBK,IBBL,IFI,IFJ,IFK,IFL,
     4 ISII,ISJJ,ISKK,ISLL,ISIJ,ISIK,ISIL,ISJK,ISJL,ISKL,
     5 IDIJSI,IDIJSJ,IDKLSK,IDKLSL,IABV,ICV,IRW
C
      DATA GRD2,DEBUG/8HGRD2    ,8HDEBUG   /
      DATA UHF,ROHF /8HUHF     ,8HROHF    /
C
C     ----- THIS IS THE MAIN 2E- GRADIENT DRIVER WITHIN A BOX -----
C
      DBG = EXETYP.EQ.DEBUG
      OUT = EXETYP.EQ.GRD2.OR.NPRINT.EQ.-4
      UHFTYP=                     SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF
C
C     ----- SET STARTING PARAMETERS -----
C
      POPLE = IGRDTYP.EQ.0
C
C      INITIALIZE THE INTEGRAL BLOCK COUNTERS TO ZERO
C
      IISKIP1= 0
      IISKIP2= 0
      IDID = 0
C
      NC=1
      LDF=1
      IJSP=0
C
C     ----- I SHELL -----
C
      DO 560 IJSHLL=1,IXTBL
         IJNUM=ITBL(IJSHLL)
         IJSP=IJSP+IJNUM
         II=ITSP(IJSP,1)
         JJ=ITSP(IJSP,2)
         NIJ=IJNUM
         IF(NIJ.EQ.0) GO TO 540
         KLSP=0
         CALL LEDSHL(II,JJ,DCHGIJ,NIJ,0,IJSP,IJNUM,NCXYZ,ITPP)
         DO 520 KLSHLL=1,IJSHLL
            KLNUM=ITBL(KLSHLL)
            KLSP=KLSP+KLNUM
            KK=ITSP(KLSP,1)
            LL=ITSP(KLSP,2)
            NKL=KLNUM
            CALL LEDSHL(KK,LL,DCHGKL,NKL,0,KLSP,KLNUM,NCXYZ,ITPP)
            Q4=1
C
C         IMPLEMENT INTEGRAL SCREENING HERE USING EXCHANGE INTEGRALS
C         SEE H.HORN, H.WEISS, M.HAESER, M.EHRIG, R.AHLRICHS
C             J.COMPUT.CHEM. 12, 1058-1064(1991)
C         REGARDING THE ESTIMATION FORMULA (31) THAT IS USED HERE.
C
              IJIJ=IA(MAX0(II,JJ))+MIN0(II,JJ)
              KLKL=IA(MAX0(KK,LL))+MIN0(KK,LL)
              GMAX=(X(IXCH+IJIJ-1)*X(IXCH+KLKL-1))
C
C                COARSE SCREENING, ON JUST THE INTEGRAL VALUE
C
              IF (GMAX.LT.CUTOFF) THEN
                 IISKIP1 = IISKIP1+1
                 GO TO 500
              END IF
C
           ISH=II
           JSH=JJ
           KSH=KK
           LSH=LL
C
C     ----- GET -KL- CHARGE DISTRIBUTION -----
C       ACTUALLY JUST THE POINTERS
C
              IF(NKL.EQ.0) GO TO 500
C
C     ----- SELECT CENTERS FOR DERIVATIVES -----
C
              CALL JKDATM(ISH,JSH,KSH,LSH)
              IF(SKIPI.AND.SKIPJ.AND.SKIPK.AND.SKIPL) GO TO 500
C
C     ----- SET INDICES FOR SHELL BLOCK -----
C
              CALL JKDSHL(ISH,JSH,KSH,LSH)
              CALL JKDNDX(X(IIJKLG))
              INEW = ISH
              JNEW = JSH
              KNEW = KSH
              LNEW = LSH
C
C     ----- OBTAIN 2 BODY DENSITY FOR THIS SHELL BLOCK -----
C
           CALL DABDFT(INEW,JNEW,KNEW,LNEW,UHFTYP,DA,
     *                         DB,X(IDAB),DABMAX,Q4,POPLE)
C
C                FINE SCREENING, ON INTEGRAL VALUE TIMES DENSITY FACTOR
C
         IF(DABMAX*GMAX.LT.CUTOFF2) THEN
            IISKIP2 = IISKIP2+1
            GO TO 500
         END IF
C     ----- EVALUATE DERIVATIVE INTEGRAL, AND ADD TO THE GRADIENT -----
C
         IDID = IDID+1
C
            CALL JKLSPD(NKL,
     *      X(IGINT),X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),
     1      X(IGNKL),X(IGNM),X(IXY),X(IXZ),X(IYZ),X(IX),X(IY),X(IZ),
     2      X(ISJ),X(ISK),X(ISL),X(IB00),X(IB01),X(IB10),X(IC00),
     3      X(ID00),X(IF00),X(IDIJ),X(IDKL),X(IDIJSI),X(IDIJSJ),
     4      X(IDKLSK),X(IDKLSL),X(IABV),X(ICV),X(IRW),X(IAAI),X(IAAJ),
     5      X(IBBK),X(IBBL),X(IFI),X(IFJ),X(IFK),X(IFL),X(ISII),X(ISJJ),
     6      X(ISKK),X(ISLL),X(ISIJ),X(ISIK),X(ISIL),X(ISJK),X(ISJL),
     7      X(ISKL),X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,DDA,Q4,MINVEC,
     8      DABCUT,DABMAX,DCHGIJ,DCHGKL)
C         END IF
C
C     ----- END OF *SHELL* LOOPS -----
C
  500 CONTINUE
  520 CONTINUE
  540 CONTINUE
      IF (TIM .GE. TIMLIM) GO TO 600
  560 CONTINUE
C
  600 CONTINUE
      RETURN
      END
C*MODULE QMFM    *DECK COREJD
      SUBROUTINE COREJD(NCXYZ,ITSP,ITPP,IXTBL,ITBL,
     *                   DCHGIJ,DCHGKL,MAXXYZ,MINVEC,DA,DB,
     *                   CUTOFF,CUTOFF2,DABCUT)
C
C       THE DRIVER FOR THE TWO ELECTRON GRADIENT
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SKIPI,SKIPJ,SKIPK,SKIPL,UHFTYP,OUT,DBG
C
      PARAMETER (MXAO=8192)
C
      DIMENSION DCHGIJ(15,*),DCHGKL(15,*),DA(*),DB(*)
      DIMENSION ITSP(NCXYZ,2),ITPP(NCXYZ,2),ITBL(IXTBL)
C
      COMMON /DERSKP/ IIAT,JJAT,KKAT,LLAT,SKIPI,SKIPJ,SKIPK,SKIPL
      COMMON /DSHLNO/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /FMCOM / X(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /MP2PAR/ OSPT,TOL,METHOD,NWDMP2,MPPROP,NACORE,NBCORE,
     *                NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      COMMON/DERMEM/IWFN,IXCH,INIJG,IGINT,IFINT,ISINT,IIJKLG,
     1 IDAB,ICHRG,IXY,IXZ,IYZ,IX,IY,IZ,ISJ,ISK,ISL,IGIJKL,IGNKL,IGNM,
     2 IDIJ,IDKL,IB00,IB01,IB10,IC00,ID00,IF00,
     3 IAAI,IAAJ,IBBK,IBBL,IFI,IFJ,IFK,IFL,
     4 ISII,ISJJ,ISKK,ISLL,ISIJ,ISIK,ISIL,ISJK,ISJL,ISKL,
     5 IDIJSI,IDIJSJ,IDKLSK,IDKLSL,IABV,ICV,IRW
C
      DATA GRD2,DEBUG/8HGRD2    ,8HDEBUG   /
      DATA UHF,ROHF /8HUHF     ,8HROHF    /
C
C     ----- THIS IS THE MAIN 2E- GRADIENT DRIVER WITHIN A BOX -----
C
      DBG = EXETYP.EQ.DEBUG
      OUT = EXETYP.EQ.GRD2.OR.NPRINT.EQ.-4
      UHFTYP= SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF
C
C     ----- SET STARTING PARAMETERS -----
C
C      INITIALIZE THE INTEGRAL BLOCK COUNTERS TO ZERO
C
      IISKIP1= 0
      IISKIP2= 0
      IDID = 0
C
      NC=1
      LDF=1
      IJSP=0
C
C     ----- I SHELL -----
C
      DO 560 IJSHLL=1,IXTBL
         IJNUM=ITBL(IJSHLL)
         IJSP=IJSP+IJNUM
         II=ITSP(IJSP,1)
         JJ=ITSP(IJSP,2)
         NIJ=IJNUM
         IF(NIJ.EQ.0) GO TO 540
         KLSP=0
         CALL LEDSHL(II,JJ,DCHGIJ,NIJ,0,IJSP,IJNUM,NCXYZ,ITPP)
         DO 520 KLSHLL=1,IJSHLL
            KLNUM=ITBL(KLSHLL)
            KLSP=KLSP+KLNUM
            KK=ITSP(KLSP,1)
            LL=ITSP(KLSP,2)
            NKL=KLNUM
            CALL LEDSHL(KK,LL,DCHGKL,NKL,0,KLSP,KLNUM,NCXYZ,ITPP)
            Q4=1
C
C         IMPLEMENT INTEGRAL SCREENING HERE USING EXCHANGE INTEGRALS
C         SEE H.HORN, H.WEISS, M.HAESER, M.EHRIG, R.AHLRICHS
C             J.COMPUT.CHEM. 12, 1058-1064(1991)
C         REGARDING THE ESTIMATION FORMULA (31) THAT IS USED HERE.
C
              IJIJ=IA(MAX0(II,JJ))+MIN0(II,JJ)
              KLKL=IA(MAX0(KK,LL))+MIN0(KK,LL)
              GMAX=(X(IXCH+IJIJ-1)*X(IXCH+KLKL-1))
C
C                COARSE SCREENING, ON JUST THE INTEGRAL VALUE
C
              IF (GMAX.LT.CUTOFF) THEN
                 IISKIP1 = IISKIP1+1
                 GO TO 500
              END IF
C
           ISH=II
           JSH=JJ
           KSH=KK
           LSH=LL
C
C     ----- GET -KL- CHARGE DISTRIBUTION -----
C       ACTUALLY JUST THE POINTERS
C
              IF(NKL.EQ.0) GO TO 500
C
C     ----- SELECT CENTERS FOR DERIVATIVES -----
C
              CALL JKDATM(ISH,JSH,KSH,LSH)
              IF(SKIPI.AND.SKIPJ.AND.SKIPK.AND.SKIPL) GO TO 500
C
C     ----- SET INDICES FOR SHELL BLOCK -----
C
              CALL JKDSHL(ISH,JSH,KSH,LSH)
              CALL JKDNDX(X(IIJKLG))
              INEW = ISH
              JNEW = JSH
              KNEW = KSH
              LNEW = LSH
C
C     ----- OBTAIN 2 BODY DENSITY FOR THIS SHELL BLOCK -----
C
         CALL DABCOU(INEW,JNEW,KNEW,LNEW,DA,DB,X(IDAB),DABMAX,UHFTYP)
C
C               FINE SCREENING, ON INTEGRAL VALUE TIMES DENSITY FACTOR
C
         IF(DABMAX*GMAX.LT.CUTOFF2) THEN
            IISKIP2 = IISKIP2+1
            GO TO 500
         END IF
C
C     ----- EVALUATE DERIVATIVE INTEGRAL, AND ADD TO THE GRADIENT -----
C
         IDID = IDID+1
C
            CALL JKLSPD(NKL,
     *      X(IGINT),X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),
     1      X(IGNKL),X(IGNM),X(IXY),X(IXZ),X(IYZ),X(IX),X(IY),X(IZ),
     2      X(ISJ),X(ISK),X(ISL),X(IB00),X(IB01),X(IB10),X(IC00),
     3      X(ID00),X(IF00),X(IDIJ),X(IDKL),X(IDIJSI),X(IDIJSJ),
     4      X(IDKLSK),X(IDKLSL),X(IABV),X(ICV),X(IRW),X(IAAI),X(IAAJ),
     5      X(IBBK),X(IBBL),X(IFI),X(IFJ),X(IFK),X(IFL),X(ISII),X(ISJJ),
     6      X(ISKK),X(ISLL),X(ISIJ),X(ISIK),X(ISIL),X(ISJK),X(ISJL),
     7      X(ISKL),X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,DDA,Q4,MINVEC,
     8      DABCUT,DABMAX,DCHGIJ,DCHGKL)
C         END IF
C
C     ----- END OF *SHELL* LOOPS -----
C
  500 CONTINUE
  520 CONTINUE
  540 CONTINUE
      IF (TIM .GE. TIMLIM) GO TO 600
  560 CONTINUE
C
  600 CONTINUE
      RETURN
      END
C*MODULE QMFM    *DECK DENWZP
      SUBROUTINE DENWZP(SCFTYP,NCXYZ,IYP,INDX2,IDXIJK,IDXWS,CXYZ,
     *   IBS,IYZTBL,NTMPL,YP,ZP,L2,DMAT,DMATB,NTBOX,MAXWS,IYZPNT,
     *   F,G,ZLL,CLM,FLM,IDXBOX,NSBOX,ISP,IPP)
C
C     THIS ROUTINE OBTAINS THE FINAL SCF DENSITY MATRIX WEIGHTED
C     ZP OF EACH BOXES FOR FMM GRADIENT CALCULATIONS.
C
C     C. H. CHOI JUL 2003
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMPLEX*16 YP,ZP
      LOGICAL QFMM,QOPS,GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /QMFM  /SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *       ITERMS,QOPS,ISCUT
C
      DIMENSION IYP(NCXYZ),CXYZ(NCXYZ,3),IBS(NCXYZ,4),IDXIJK(NCXYZ,3),
     *   INDX2(NCXYZ),IDXWS(NCXYZ),
     *   IYZTBL(2**(NS+1)-1,2**(NS+1)-1,2**(NS+1)-1),
     *   F((NP*(NP+1)*(NP+2)*4/3)+(NP+1)),CLM(-NP:NP),
     *   G((NP*(NP+1)*(NP+2)*4/3)+(NP+1)),FLM(-NP:NP),
     *   ZLL(0:2*NP+1),YP((NP+1)*(NP+2)/2,NTMPL),
     *   ZP((NP+1)*(NP+2)/2,NTMPL),DMAT(L2),DMATB(*),
     *   IYZPNT(NTBOX,MAXWS/2),ISP(*),IPP(*)
      DIMENSION IDXBOX(3,NTBOX),NSBOX(20)
C
C     PHASE I : OBTAIN THE MULTIPOLE EXPANSION OF NON-EMPTY BOXS IN THE
C               LOWEST SUBDIVISION LEVEL, NS.
C
      CALL GETY(SCFTYP,NCXYZ,IYP,INDX2,IDXIJK,IDXWS,CXYZ,IBS,IYZTBL,
     *   NTMPL,YP,DMAT,DMATB,NTBOX,MAXWS,IYZPNT,F,G,ZLL,CLM,FLM,
     *   ISP,IPP)
C
      ILYP=(NP+1)*(NP+2)*NTMPL
      IF(GOPARR) THEN
         CALL DDI_GSUMF(4000,YP,ILYP)
      END IF
C
C     PHASE II : OBTAIN THE LONG-RANGE POTENTIAL USING FMM
C     THIS PROCESS IS COMPOSED OF C2P, P2P AND P2C.
C
      CALL C2P(IYZTBL,F,G,CLM,FLM,ZLL,NTMPL,YP,NTBOX,IDXBOX,NSBOX,
     *   MAXWS,IYZPNT,IC2P)
C
      CALL SP2P(IYZTBL,F,G,CLM,FLM,ZLL,NTMPL,YP,ZP,NTBOX,IDXBOX,
     *   NSBOX,MAXWS,IYZPNT,IP2P)
      IF(GOPARR) THEN
         CALL DDI_GSUMF(4001,ZP,ILYP)
         CALL DDI_GSUMI(4002,IP2P,1)
      END IF
C
      CALL P2C(IYZTBL,F,G,CLM,FLM,ZLL,NTMPL,ZP,
     *         IP2C,NTBOX,MAXWS,IYZPNT)
C
      RETURN
      END
C*MODULE QMFM    *DECK DABEX
      SUBROUTINE DABEX(II,JJ,KK,LL,UHFTYP,DA,DB,DAB,DABMAX)
C
C     ----- THIS ROUTINE FORMS THE PRODUCT OF DENSITY       -----
C           MATRICES FOR USE IN FORMING THE TWO ELECTRON
C           EXCHANGE GRADIENT.  VALID FOR CLOSED AND OPEN SHELL SCF.
C           THE PORTIONS OF THE DENSITY MATRIX THAT CORRESPOND TO
C           HARTREE-FOCK EXCHANGE ARE "MODIFIED" TO WORK WITH
C           DFT.  OFTEN THIS MEANS THAT THEY ARE SET TO ZERO
C     NOTE THAT THIS ROUTINE IS A CLOSE COUSIN TO -DFTCLU- ROUTINE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION DA(*),DB(*),DAB(*)
      LOGICAL UHFTYP
C
      PARAMETER (MXGTOT=20000, MXSH=5000, MXAO=8192)
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      LOGICAL OUT,DBG
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /INDD80/ IMAX,JMAX,KKMAX,LMAX
      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 /SHLLMN/ IGXYZ(4,35),JGXYZ(4,35),KGXYZ(4,35),LGXYZ(4,35)
      COMMON /SHLNRM/ PNRM(84)
      LOGICAL IIEQJJ,KKEQLL,IJEQKL,IJGTKL,IJLTKL
      COMMON /SHLEQU/ IIEQJJ,KKEQLL,IJEQKL,IJGTKL,IJLTKL
C
C      COMMON /GSPG80/ E(4,4,4,4)
C
      PARAMETER (ZER=0.0D+00, PT5=0.5D+00, P25=.25D+00, F04=4.0D+00)
C
      QFS= DFTTYP(3)*P25
C
      DABMAX= ZER
      MINI= KMIN(II)
      MINJ= KMIN(JJ)
      MINK= KMIN(KK)
      MINL= KMIN(LL)
      LOCI= KLOC(II)-MINI
      LOCJ= KLOC(JJ)-MINJ
      LOCK= KLOC(KK)-MINK
      LOCL= KLOC(LL)-MINL
C
C D AND HIGHER FUNCTIONS OR HONDO ONLY RUNS
C
      MAXI= KMAX(II)
      MAXJ= KMAX(JJ)
      MAXK= KMAX(KK)
      MAXL= KMAX(LL)
      DO 800 I=MINI,MAXI
         P1I = PNRM(I)
         JMAX= MAXJ
         IF(IIEQJJ) JMAX= I
         DO 700 J=MINJ,JMAX
            P2J = P1I*PNRM(J)
            IAJ= MAX0(LOCI+I,LOCJ+J)
            IIJ= MIN0(LOCI+I,LOCJ+J)
            KMMAX=MAXK
            IF(IJEQKL) KMMAX= I
            DO 600 K=MINK,KMMAX
               P3K = P2J*PNRM(K)
               LMAX= MAXL
               IF(KKEQLL) LMAX= K
               IF(IJEQKL .AND. K.EQ.I) LMAX= J
               DO 500 L=MINL,LMAX
                  P4L= P3K*PNRM(L)
                  KAL= MAX0(LOCK+K,LOCL+L)
                  KIL= MIN0(LOCK+K,LOCL+L)
                  IN = IAJ
                  JN = IIJ
                  KN = KAL
                  LN = KIL
                  IF(IN.LT.KN .OR.(IN.EQ.KN .AND. JN.LT.LN)) THEN
                     IN = KAL
                     JN = KIL
                     KN = IAJ
                     LN = IIJ
                  ENDIF
                  IF(QFS.NE.ZER) THEN
                     IK = IA(IN)+KN
                     IL = IA(IN)+LN
                     JK = IA(MAX0(JN,KN))+MIN0(JN,KN)
                     JL = IA(JN)+LN
                     IF(JN.LT.KN) JL = IA(MAX0(JN,LN))+MIN0(JN,LN)
                     DQ1= DA(IK)*DA(JL)+DA(IL)*DA(JK)
                     IF(UHFTYP) DQ1=DQ1+DB(IK)*DB(JL)+DB(IL)*DB(JK)
                    DF1=-QFS*DQ1
                  ENDIF
                  DF1= DF1*F04
                  IF(JN.EQ.IN               ) DF1= DF1*PT5
                  IF(LN.EQ.KN               ) DF1= DF1*PT5
                  IF(KN.EQ.IN .AND. LN.EQ.JN) DF1= DF1*PT5
                  IF(DABMAX.LT. ABS(DF1)) DABMAX= ABS(DF1)
C
C IGXYZ AND J, K, AND L ARE SET UP IN JKDNDX
C
                  IJKL=IGXYZ(1,I)+JGXYZ(1,J)+KGXYZ(1,K)+LGXYZ(1,L)
                  DAB(IJKL)= DF1*P4L
                  IF(OUT) WRITE(IW,9020) II,JJ,KK,LL,I,J,K,L,IJKL,DF1
  500         CONTINUE
  600       CONTINUE
  700     CONTINUE
  800   CONTINUE
      RETURN
 9020 FORMAT(' -DABEX,HONDO- ',4I4,4I3,I5,D20.12)
      END
C*MODULE QMFM     *DECK DABCOU
      SUBROUTINE DABCOU(II,JJ,KK,LL,DA,DB,DAB,DABMAX,UHFTYP)
C
C     ----- THIS ROUTINE FORMS THE PRODUCT OF DENSITY       -----
C           MATRICES FOR USE IN FORMING THE TWO ELECTRON
C           EXCHANGE GRADIENT.  VALID FOR CLOSED AND OPEN SHELL SCF.
C           THE PORTIONS OF THE DENSITY MATRIX THAT CORRESPOND TO
C           HARTREE-FOCK EXCHANGE ARE "MODIFIED" TO WORK WITH
C           DFT.  OFTEN THIS MEANS THAT THEY ARE SET TO ZERO
C     NOTE THAT THIS ROUTINE IS A CLOSE COUSIN TO -DFTCLU- ROUTINE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION DA(*),DB(*),DAB(*)
C
      PARAMETER (MXGTOT=20000, MXSH=5000, MXAO=8192)
C
      LOGICAL OUT,DBG,UHFTYP
      LOGICAL IIEQJJ,KKEQLL,IJEQKL,IJGTKL,IJLTKL
C
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /INDD80/ IMAX,JMAX,KKMAX,LMAX
      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 /SHLLMN/ IGXYZ(4,35),JGXYZ(4,35),KGXYZ(4,35),LGXYZ(4,35)
      COMMON /SHLNRM/ PNRM(84)
      COMMON /SHLEQU/ IIEQJJ,KKEQLL,IJEQKL,IJGTKL,IJLTKL
C
      PARAMETER (ZER=0.0D+00, PT5=0.5D+00, F04=4.0D+00)
C
      IF(UHFTYP) THEN
         DB(1)=0.0D+00
         WRITE(6,*) 'QFMM GRADIENT NOT CODED'
         CALL ABRT
      END IF
C
      DABMAX= ZER
      MINI= KMIN(II)
      MINJ= KMIN(JJ)
      MINK= KMIN(KK)
      MINL= KMIN(LL)
      LOCI= KLOC(II)-MINI
      LOCJ= KLOC(JJ)-MINJ
      LOCK= KLOC(KK)-MINK
      LOCL= KLOC(LL)-MINL
C
C D AND HIGHER FUNCTIONS OR HONDO ONLY RUNS
C
      MAXI= KMAX(II)
      MAXJ= KMAX(JJ)
      MAXK= KMAX(KK)
      MAXL= KMAX(LL)
      DO 800 I=MINI,MAXI
         P1I = PNRM(I)
         JMAX= MAXJ
         IF(IIEQJJ) JMAX= I
         DO 700 J=MINJ,JMAX
            P2J = P1I*PNRM(J)
            IAJ= MAX0(LOCI+I,LOCJ+J)
            IIJ= MIN0(LOCI+I,LOCJ+J)
            KMMAX=MAXK
            IF(IJEQKL) KMMAX= I
            DO 600 K=MINK,KMMAX
               P3K = P2J*PNRM(K)
               LMAX= MAXL
               IF(KKEQLL) LMAX= K
               IF(IJEQKL .AND. K.EQ.I) LMAX= J
               DO 500 L=MINL,LMAX
                  P4L= P3K*PNRM(L)
                  KAL= MAX0(LOCK+K,LOCL+L)
                  KIL= MIN0(LOCK+K,LOCL+L)
                  IN = IAJ
                  JN = IIJ
                  KN = KAL
                  LN = KIL
                  IF(IN.LT.KN .OR.(IN.EQ.KN .AND. JN.LT.LN)) THEN
                     IN = KAL
                     JN = KIL
                     KN = IAJ
                     LN = IIJ
                  ENDIF
                  IJ = IA(IN)+JN
                  KL = IA(KN)+LN
                  DF1= DA(IJ)*DA(KL)
                  DF1= DF1*F04
                  IF(JN.EQ.IN               ) DF1= DF1*PT5
                  IF(LN.EQ.KN               ) DF1= DF1*PT5
                  IF(KN.EQ.IN .AND. LN.EQ.JN) DF1= DF1*PT5
                  IF(DABMAX.LT. ABS(DF1)) DABMAX= ABS(DF1)
C
C IGXYZ AND J, K, AND L ARE SET UP IN JKDNDX
C
                  IJKL=IGXYZ(1,I)+JGXYZ(1,J)+KGXYZ(1,K)+LGXYZ(1,L)
                  DAB(IJKL)= DF1*P4L
                  IF(OUT) WRITE(IW,9020) II,JJ,KK,LL,I,J,K,L,IJKL,DF1
  500         CONTINUE
  600       CONTINUE
  700     CONTINUE
  800   CONTINUE
      RETURN
 9020 FORMAT(' -DABCOU,HONDO- ',4I4,4I3,I5,D20.12)
      END
C*MODULE QMFM    *DECK WRTFMM
      SUBROUTINE WRTFMM(YP,ZP,NP,NTMPL,NCXYZ,IYP,INDX2,
     *         IDXIJK,IDXWS,IBS,IYZTBL,
     *         NTBOX,MAXWS,IYZPNT,CLM,IDXBOX,NSBOX,ISP,IPP,
     *         IEBOX,IMBOX,INDX,INUMWS,DSH,ISLIST,IDXSHL,
     *         ISLN,XINTS,NSHELL,NSH2,NSHL2,NS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (NUMRA=23)
C
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /QFMMRA/IORA(NUMRA),IRAF,MIJKL
C
      DIMENSION YP(*),ZP(*),IYP(*),INDX2(*),IDXIJK(*),IDXWS(*),
     *   IBS(*),IYZTBL(*),IYZPNT(*),CLM(*),IDXBOX(*),
     *   NSBOX(*),ISP(*),IPP(*),IEBOX(*),IMBOX(*),INDX(*),
     *   INUMWS(*),DSH(*),ISLIST(*),IDXSHL(*),ISLN(*),XINTS(*)
C
      IRAF=20
      NPRINT=-5
      LPHYS=0
      LENREC=MAX((NP+1)*(NP+2)*NTMPL,NCXYZ/NWDVAR+1,NCXYZ*3/NWDVAR+2,
     *   MAXWS/2*(NTBOX+1)/NWDVAR+1,NCXYZ*4/NWDVAR,
     *   3*(NTBOX+1)/NWDVAR+1,20/NWDVAR,(NTBOX+1)/NWDVAR+1,
     *   ((2**(NS+1)-1)**3+1)/NWDVAR+1,NCXYZ*2/NWDVAR,2*NP+1,NSH2,
     *   NSHL2/NWDVAR+1,NSH2/NWDVAR+2,NSHELL/NWDVAR+2)
C
C     OPEN RA FILE
C
      CALL RAOPEN(IRAF,IORA,LPHYS,NUMRA,LENREC,NPRINT)
C
C     COULOMB PART
C
      CALL RAWRIT(IRAF,IORA,YP,(NP+1)*(NP+2)*NTMPL,1,0)
      CALL RAWRIT(IRAF,IORA,ZP,(NP+1)*(NP+2)*NTMPL,2,0)
      CALL RAWRIT(IRAF,IORA,INDX2,NCXYZ/NWDVAR+1,3,1)
      CALL RAWRIT(IRAF,IORA,IYP,NCXYZ/NWDVAR+1,4,1)
      CALL RAWRIT(IRAF,IORA,IDXIJK,NCXYZ*3/NWDVAR+2,5,1)
      CALL RAWRIT(IRAF,IORA,IDXWS,NCXYZ/NWDVAR+1,6,1)
      CALL RAWRIT(IRAF,IORA,IYZPNT,
     *   MAXWS/2*(NTBOX+1)/NWDVAR+1,7,1)
      CALL RAWRIT(IRAF,IORA,IBS,NCXYZ*4/NWDVAR,8,1)
      CALL RAWRIT(IRAF,IORA,IDXBOX,3*(NTBOX+1)/NWDVAR+1,9,1)
      CALL RAWRIT(IRAF,IORA,NSBOX,20,10,1)
      CALL RAWRIT(IRAF,IORA,IEBOX,(NTBOX+1)/NWDVAR+1,11,1)
      CALL RAWRIT(IRAF,IORA,IMBOX,(NTBOX+1)/NWDVAR+1,12,1)
      CALL RAWRIT(IRAF,IORA,IYZTBL,
     *           ((2**(NS+1)-1)**3+1)/NWDVAR+1,13,1)
      CALL RAWRIT(IRAF,IORA,INDX,NCXYZ/NWDVAR+1,14,1)
      CALL RAWRIT(IRAF,IORA,ISP,NCXYZ*2/NWDVAR,15,1)
      CALL RAWRIT(IRAF,IORA,IPP,NCXYZ*2/NWDVAR,16,1)
      CALL RAWRIT(IRAF,IORA,INUMWS,
     *           MAXWS/2*(NTBOX+1)/NWDVAR+1,17,1)
      CALL RAWRIT(IRAF,IORA,CLM,2*NP+1,18,0)
C
C     EXCHANGE PART
C
      CALL RAWRIT(IRAF,IORA,DSH,NSH2,19,0)
      CALL RAWRIT(IRAF,IORA,ISLIST,NSHL2/NWDVAR+1,20,1)
      CALL RAWRIT(IRAF,IORA,IDXSHL,NSH2/NWDVAR+2,21,1)
      CALL RAWRIT(IRAF,IORA,ISLN,NSHELL/NWDVAR+2,22,1)
      CALL RAWRIT(IRAF,IORA,XINTS,NSH2,23,0)
C
      RETURN
      END
C*MODULE QMFM    *DECK REDFMM
      SUBROUTINE REDFMM(YP,ZP,NP,NTMPL,NCXYZ,IYP,INDX2,IDXIJK,IDXWS,
     *    IBS,IYZTBL,NTBOX,MAXWS,IYZPNT,CLM,IDXBOX,NSBOX,ISP,IPP,
     *    IEBOX,IMBOX,INDX,INUMWS,DSH,ISLIST,IDXSHL,ISLN,XINTS,NSHELL,
     *    NSH2,NSHL2,NS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (NUMRA=23)
C
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /QFMMRA/IORA(NUMRA),IRAF,MIJKL
C
      DIMENSION YP(*),ZP(*),IYP(*),INDX2(*),IDXIJK(*),IDXWS(*),
     *   IBS(*),IYZTBL(*),IYZPNT(*),
     *   CLM(*),IDXBOX(*),
     *   NSBOX(*),ISP(*),IPP(*),IEBOX(*),IMBOX(*),INDX(*),
     *   INUMWS(*),DSH(*),ISLIST(*),IDXSHL(*),ISLN(*),XINTS(*)
C
      IRAF=20
C
C     COULOMB PART
C
      CALL RAREAD(IRAF,IORA,YP,(NP+1)*(NP+2)*NTMPL,1,0)
      CALL RAREAD(IRAF,IORA,ZP,(NP+1)*(NP+2)*NTMPL,2,0)
      CALL RAREAD(IRAF,IORA,INDX2,NCXYZ/NWDVAR+1,3,1)
      CALL RAREAD(IRAF,IORA,IYP,NCXYZ/NWDVAR+1,4,1)
      CALL RAREAD(IRAF,IORA,IDXIJK,NCXYZ*3/NWDVAR+2,5,1)
      CALL RAREAD(IRAF,IORA,IDXWS,NCXYZ/NWDVAR+1,6,1)
      CALL RAREAD(IRAF,IORA,IYZPNT,
     *   MAXWS/2*(NTBOX+1)/NWDVAR+1,7,1)
      CALL RAREAD(IRAF,IORA,IBS,NCXYZ*4/NWDVAR,8,1)
      CALL RAREAD(IRAF,IORA,IDXBOX,3*(NTBOX+1)/NWDVAR+1,9,1)
      CALL RAREAD(IRAF,IORA,NSBOX,20,10,1)
      CALL RAREAD(IRAF,IORA,IEBOX,(NTBOX+1)/NWDVAR+1,11,1)
      CALL RAREAD(IRAF,IORA,IMBOX,(NTBOX+1)/NWDVAR+1,12,1)
      CALL RAREAD(IRAF,IORA,IYZTBL,
     *           ((2**(NS+1)-1)**3+1)/NWDVAR+1,13,1)
      CALL RAREAD(IRAF,IORA,INDX,NCXYZ/NWDVAR+1,14,1)
      CALL RAREAD(IRAF,IORA,ISP,NCXYZ*2/NWDVAR,15,1)
      CALL RAREAD(IRAF,IORA,IPP,NCXYZ*2/NWDVAR,16,1)
      CALL RAREAD(IRAF,IORA,INUMWS,
     *           MAXWS/2*(NTBOX+1)/NWDVAR+1,17,1)
      CALL RAREAD(IRAF,IORA,CLM,2*NP+1,18,0)
C
C     EXCHANGE PART
C
      CALL RAREAD(IRAF,IORA,DSH,NSH2,19,0)
      CALL RAREAD(IRAF,IORA,ISLIST,NSHL2/NWDVAR+1,20,1)
      CALL RAREAD(IRAF,IORA,IDXSHL,NSH2/NWDVAR+2,21,1)
      CALL RAREAD(IRAF,IORA,ISLN,NSHELL/NWDVAR+2,22,1)
      CALL RAREAD(IRAF,IORA,XINTS,NSH2,23,0)
C
C     CLOSE RA FILE
C
      CALL RACLOS(IRAF,'DELETE')
C
      RETURN
      END
C*MODULE QMFM    *DECK MAXJK
      SUBROUTINE MAXJK(NTBOX,IDXBOX,MBOX,LEBOX,NSBOX,IYZTBL,NBR,
     *                 MAXWS,NUMWS,IYZPNT,MAXIJ,MAXKL)
C
C     C. H. CHOI DEC 1999
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL QFMM,QOPS
C
      DIMENSION IDXBOX(3,NTBOX),MBOX(NTBOX),LEBOX(0:NTBOX),NSBOX(20),
     *          NUMWS(NTBOX,MAXWS/2),IYZPNT(NTBOX,MAXWS/2)
      DIMENSION IYZTBL(2**(NS+1)-1,2**(NS+1)-1,2**(NS+1)-1),
     *          NBR((MAXWS*2+1)**3)
C
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
C
C     LOOP OVER NON-EMPTY BOXES IN THE LOWEST LEVEL.
C
C     INTEGRALS WITHIN A BOX
C
      MAXKL=0
      DO NON=1,NSBOX(1)
         IF (MBOX(NON).GT.MAXKL) MAXKL=MBOX(NON)
      ENDDO
C
C     INTEGRALS BETWEEN BOXES
C     NSBOX(1) CONTAINS THE NUMBER OF NON-EMPTY BOXES IN THE LOWEST
C     LEVEL, NS. REMOVE BLANK SPACE.
C
      IBOXS=1
      IBOXE=NSBOX(1)
      MAXSIZE=2**NS
      MINX=MAXSIZE
      MAXX=1
      MINY=MAXSIZE
      MAXY=1
      MINZ=MAXSIZE
      MAXZ=1
C
      DO I=IBOXS,IBOXE
         MX=IDXBOX(1,I)
         MY=IDXBOX(2,I)
         MZ=IDXBOX(3,I)
         IF (MX.LT.MINX) MINX=MX
         IF (MX.GT.MAXX) MAXX=MX
         IF (MY.LT.MINY) MINY=MY
         IF (MY.GT.MAXY) MAXY=MY
         IF (MZ.LT.MINZ) MINZ=MZ
         IF (MZ.GT.MAXZ) MAXZ=MZ
      ENDDO
C
      MAXIJ=0
      DO NON=1,NSBOX(1)
C
C        IDXBOX CONTAINS THE ACTUAL (I,J,K) INDEX OF A GIVEN BOX, NON.
         I=IDXBOX(1,NON)
         J=IDXBOX(2,NON)
         K=IDXBOX(3,NON)
C
C        LOOP OVER THE IWS INDEX OF THE FIRST BOX
C
C        IYZTBL RETURNS ACTUAL SEQUENCE OF A GIVEN BOX (I,J,K)
C        MBOX RETURNS THE NUMBER OF PARTICLES IN THAT BOX
C        LEBOX RETURNS THE CUMULATIVE NUMBER OF PATICLES.
C        SO IXYZ NOW POINTS THE ACTUAL SEQUENCE OF A POINT.
C        IXYZ=LEBOX(IYZTBL(I,J,K))-MBOX(IYZTBL(I,J,K))
C
         DO IDXWS=1,MAXWS/2
C        NUMWS RETURNS THE NUMBER OF PARTICLE OF BOX, NON WITH
            INPTCL=NUMWS(NON,IDXWS)
            IF ( INPTCL.NE.0 ) THEN
C
C           NOW PUT SHELL PAIR AND PRIMITIVE PAIR INDICES OF I
C           BRANCH PARTICLES WITH IWS=IDXWS*2 INTO TEMPORARY MEMORY.
C
            IF (INPTCL.GT.MAXIJ) MAXIJ=INPTCL
C
C              LOOP OVER THE IWS INDEX OF THE SECOND BOX
C
               DO IDXIT=1,MAXWS/2
                  IJWS=IDXWS+IDXIT
                  CALL GETNBR(I,J,K,IJWS,NS,NTBOX,
     *               NBR,IDX,IYZTBL,IDXIT,MAXWS,IYZPNT,
     *             MINX,MAXX,MINY,MAXY,MINZ,MAXZ)
C
C                 LOOP OVER THE NEIGHBORS
C
                  IF ( IDX.GT.0 ) THEN
                     IST=0
                     DO NN=1,IDX
                        JXYZ=LEBOX(NBR(NN))-MBOX(NBR(NN))
                        DO MWS=1,IDXIT-1
                           JNPTCL=NUMWS(NBR(NN),MWS)
                           JXYZ=JXYZ+JNPTCL
                        ENDDO
                        JNPTCL=NUMWS(NBR(NN),IDXIT)
                        IF ( JNPTCL.NE.0 ) THEN
                           DO M=1,JNPTCL
                              JXYZ=JXYZ+1
                              IST=IST+1
                           ENDDO
                        ENDIF
                     ENDDO
                     IF (IST.GT.MAXKL) MAXKL=IST
                  ENDIF
               ENDDO
C           IF OF INPTCL
            ENDIF
         ENDDO
      ENDDO
C
      RETURN
      END
C*MODULE QMFM    *DECK LSTWOEI
      SUBROUTINE LSTWOEI(LDLIST,NSHL2,LDLN,LTS,NSHELL,LMAXIJ,
     *   LDSH,NSH2,NINT,L1,L2,LXINTS,LGHOND,MAXG,LDDIJ,LWRK1,LFAO,
     *   LSLIST,LMLIST,LIDXSHL,LIPP,LINDX2,LIDXIJK,LIDXWS,NCXYZ,
     *   LSLN,LMLPNT,LIYP,LCXYZ,LIBS,LYZTBL,NTMPL,LYP,LZP,NTBOX,MAXWS,
     *   LYZPNT,LF,LG,LZLL,LCLM,LFLM,LIDXBOX,
     *   NSBOX,NZ,LISP,SCHWRZ,NSCHWZ,LINDX,LITSP,LITPP,LITSP2,
     *   LITPP2,LMBOX,LEBOX,LNBR,LNUMWS,MIJKL,LWRK2,LFBO,
     *   IJTPP,KLTPP,IJSPP,KLSPP,IJTBLP,IJTBL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXAO=8192)
      PARAMETER (ZERO=0.0D+00)
      LOGICAL QFMM,QOPS,QFMMOK
      LOGICAL DIRSCF,FDIFF,SCHWRZ
C
      COMMON /FMCOM / X(1)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0
      COMMON /QMFM  / SIZE,EPSLN,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
C     LINEAR SCALING EXACT EXCHANGE
C
      NINT  = 0
      NSCHWZ= 0
      QFMMOK = DFTTYP(3).EQ.ZERO  .AND.
     *   ( NDFTFG.EQ.1 .OR. DFTTYP(1).NE.ZERO)
      IF (.NOT.QFMMOK) THEN
         IF (ITERMS.NE.1) THEN
            CALL SORTD(X(LDLIST),NSHL2,X(LDLN),X(LTS),NSHELL,
     *         X(LMAXIJ),X(LXINTS),X(LDSH),NSH2)
C
            CALL LEX(SCFTYP,NINT,L1,L2,X(LXINTS),NSH2,NSHL2,
     *         X(LGHOND),MAXG,X(LDDIJ),IA,X(LWRK1),X(LFAO),
     *         X(LWRK2),X(LFBO),X(LDSH),1,X(LSLIST),X(LDLIST),
     *         X(LSLN),X(LDLN),NSHELL,X(LMLIST),X(LMLPNT),
     *         X(LIDXSHL),X(LIPP),X(LINDX2),X(LIDXIJK),
     *         X(LIDXWS),NCXYZ,X(IJTPP),X(KLTPP),X(IJSPP),
     *         X(KLSPP),X(IJTBLP),X(IJTBL))
         ENDIF
      ENDIF
C
C     LINEAR SCALING COULOMB MATRIX
C
      IF (ITERMS.NE.2) THEN
         CALL Q_FMM(SCFTYP,NCXYZ,X(LIYP),X(LINDX2),X(LIDXIJK),
     *      X(LIDXWS),X(LCXYZ),X(LIBS),X(LYZTBL),NTMPL,X(LYP),
     *      X(LZP),X(LWRK1),X(LWRK2),NTBOX,MAXWS,X(LYZPNT),
     *      X(LF),X(LG),X(LZLL),X(LCLM),X(LFLM),X(LIDXBOX),
     *      NSBOX,NZ,X(LFAO),X(LFBO),X(LISP),X(LIPP))
C
C        SOME LEFTOVERS OF COULOMB POTENTIAL
C
         CALL NEARJ(SCFTYP,DIRSCF,SCHWRZ,
     *      NINT,NSCHWZ,L1,L2,X(LXINTS),
     *      NSH2,X(LGHOND),MAXG,X(LDDIJ),IA,X(LWRK1),X(LFAO),
     *      X(LWRK2),X(LFBO),X(LDSH),1,NCXYZ,X(LINDX),
     *      X(LIPP),X(LISP),X(LITSP),X(LITPP),X(LITSP2),
     *      X(LITPP2),NTBOX,X(LIDXBOX),X(LMBOX),X(LEBOX),NSBOX,
     *      X(LYZTBL),X(LNBR),MAXWS,X(LNUMWS),X(LYZPNT),MIJKL)
      ENDIF
C
      RETURN
      END
