C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C 19 SEP 05 - MWS - KILL H OR I FUNCTION RUNS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL, ROOT
C  5 FEB 05 - OQ  - DDJK: INITIALIZE MORE FOR TDHFX
C  7 SEP 04 - MWS - DDINI: MCSCF SHOULD NOT TOUCH FILE 16
C 23 JUL 04 - OQ  - DDERJK,DDINI,DDJK MODIFIED FOR TDHFX PACKAGE
C                   DDERJKOLIX AND DDERJKX ADDED FOR TDHFX PACKAGE
C 16 JAN 04 - TJD - DDJK: FIX SWITCHING OFF SYMMETRY FOR MCSCF HESSIAN
C  9 DEC 03 - TJD - ADD 2E- DERIV. INT. TO ANALYTIC MCSCF HESSIAN
C 26 MAR 03 - HN  - AVOID COARSE SCREENING FOR CI/MCSCF
C 20 JUN 02 - YA  - IMPLEMENT SCHWARZ SCREENING
C 25 JUN 01 - MWS - ALTER COMMON BLOCK WFNOPT
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 17 OCT 96 - SPW - DDERJK,DDINI,DDJK: CHANGES FOR CI GRADIENTS
C 13 JUN 96 - VAG - ADD VARIABLE FOR CI TYPE TO SCFOPT COMMON
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C 11 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C 21 JUL 94 - MWS - DDERJK: DELETE CALL TO TRF2DM
C  1 JUN 94 - MWS - DDINI, DDERJK,DDJK: CHANGE PARALLEL, ADD LOOP BAL
C  4 JAN 94 - MWS - DDERJK: RUN TRF2DM IN PARALLEL
C 16 JUL 93 - TLW - DDJK: MOVE NEXT VALUE TO SECOND DO LOOP
C 16 SEP 92 - TLW - PARALLELIZE
C 21 MAR 92 - MWS - REPLACE /DDIJKL/,/DDWXYZ/ WITH DYNAMIC STORAGE
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C 10 JAN 92 - TLW - CHANGE REWINDS TO CALL SEQREW
C  6 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR
C  7 OCT 91 - MWS - CHANGE UNIX BYTE UNPACKING
C  7 AUG 90 - TLW - ADD CF AND CG TO COMMON NSHEL
C 24 JUN 90 - MWS - REORGANIZE STORAGE FOR J-A AND K-A FOR ROGVB
C  3 JUN 90 - JAM - CHANGE VAX BYTE PACKING TO FULL 8 BITS
C 15 DEC 89 - MWS - DDINI: INITIALIZE ZERO
C 23 JUN 89 - MWS - DDERJK,DDINI,DDJK: CHANGES RELATING TO THE
C                   COMPUTATION OF ROHF AND GVB FOCK DERIVATIVES
C 30 MAR 89 - MWS - DDINI: ALLOCATE MEMORY FOR GVB,MCSCF CASES
C 14 MAR 89 - MWS - CHANGES RELATED TO ROHF DERIVATIVE FOCK MATRIX
C  9 MAR 89 - MWS - GENERATE CORRECT 2 BODY DENSITY FOR ROHF,GVB,MCSCF
C 23 FEB 89 - MWS - REINTRODUCE /DDIJKL/ TO AVOID ARGUMENT PASSING
C 18 JAN 89 - MWS - ADAPT ANALYTIC RHF HESSIAN CODE FROM MICHEL'S HONDO7
C
C*MODULE HSS2A   *DECK CPINI
      SUBROUTINE CPINI(DLAG,FCD,HCD,FVD,GD,DENC,V,TPDM,HBDM,IA,L1,L2,
     *                 NCOR,NACT,N2,NXYZ,NFT18)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION DLAG(*),FCD(L2,NXYZ),HCD(NXYZ),FVD(L2,NXYZ),GD(*),
     *          DENC(L2),V(L1,L1),TPDM(NACT,NACT,NACT,NACT),HBDM(L2,N2)
      DIMENSION IA(L1)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00,HALF=0.5D+00,ONE=1.0D+00)
C
      CALL SEQREW(NFT18)
      NNACT = (NACT**2+NACT)/2
      MIJKL = (NNACT**2+NNACT)/2
      CALL VCLR(GD,1,MIJKL*NXYZ)
      CALL VCLR(DLAG,1,L1*L1*NXYZ)
C
C     INITIALIZE DERIVATIVE CORE HAMILTONIAN AND
C     FOCK MATRICES
C
      DO 100 IXYZ=1,NXYZ
        CALL SQREAD(NFT18,FCD(1,IXYZ),L2)
        CALL VCLR(FVD(1,IXYZ),1,L2)
C
        DVAL = ZERO
        DO 80 M=1,L1
          DO 80 N=1,M
            MN = (M*M-M)/2 + N
            IF(NCOR.EQ.0) DENC(MN) = ZERO
            DLT = DENC(MN)
            IF(M.EQ.N) FCD(MN,IXYZ) = HALF*FCD(MN,IXYZ)
            DVAL = DVAL + DLT*FCD(MN,IXYZ)
   80   CONTINUE
C
        HCD(IXYZ) = DVAL
  100 CONTINUE
C
      IF(GOPARR) CALL DSCAL(L2*NXYZ,ONE/NPROC,FCD,1)
C
C     CONSTRUCT HALF BACK-TRANSFORMED TWO-PARTICLE DENSITY MATRIX
C     OVER ACTIVE ORBITALS
C
      DO 500 M=1,L1
        DO 500 N=1,M
          MN = IA(M) + N
          DO 500 K=1,NACT
            DO 500 L=1,K
              KL = IA(K) + L
              DVAL = ZERO
              DO 400 I=1,NACT
                DO 400 J=1,NACT
                  DVAL = DVAL + V(M,I+NCOR)*V(N,J+NCOR)*TPDM(I,J,K,L)
  400         CONTINUE
              HBDM(MN,KL) = DVAL
  500 CONTINUE
C
      RETURN
      END
C*MODULE HSS2A   *DECK DDERJK
      SUBROUTINE DDERJK
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION MCSCF
C
      LOGICAL FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF,
     *        SOME,OUT,PACK2E,MCCI,ROGVB,GOPARR,DSKWRK,MASWRK,GUGACI
C
      PARAMETER (MXATM=2000,MXAO=8192,MXGTOT=20000,MXSH=5000,MXRT=100)
C
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,S,SZ,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACT,NORB,
     *                MNA,MNB,K,KST,IROOT,IPURES,MAXW1,NITER,MAXP,
     *                NCIDET,IGPDET,KSTSYM,NFTGCI
      COMMON /FMCOM / X(1)
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NMOGVB,NCONF(MXAO),NHAM
      COMMON /HSSPAR/ FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      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 /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SHLBAS/ LMAX,MAXNUM
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DIMENSION LENSHL(5)
C
      DATA LENSHL /1,4,10,20,35/
      DATA MCSCF,GUGA /8HMCSCF   ,8HGUGA    /
      DATA UHF,ROHF,GVB/8HUHF     ,8HROHF    ,8HGVB     /
      DATA HSS2/8HHSS2    /, CHECK/8HCHECK   /
      DATA SDEFAULT/8HDEFAULT /
      CALTYP = SDEFAULT
C
C     ----- DRIVER FOR 2 ELECTRON (GRAD+HESS) TERMS -----
C     THESE ARE INTEGRAL SECOND DERIVATIVES, AND FOCK DERIVATIVES.
C
      OUT  = MASWRK  .AND.  EXETYP.EQ.HSS2
      SOME = MASWRK  .AND.  NPRINT.NE.-5
C
      MCCI  = SCFTYP.EQ.MCSCF
      GUGACI= CITYP .EQ.GUGA
      ROGVB = SCFTYP.EQ.ROHF  .OR.  SCFTYP.EQ.GVB
C
C     FILE FOR DERIVATIVE FOCK MATRICES
C
      NFT18 = 18
C
      DO 5 I=1,NUM
         IA(I) = (I*I-I)/2
    5 CONTINUE
C
C         CARRY OUT EXPLICIT BACK TRANSFORMATION FOR -CI- FUNCTIONS
C
      IF(GUGACI) CALL TRF2DM
C
      IF(SOME) WRITE(IW,9000)
C
      L1= NUM
      L2= (NUM*NUM+NUM)/2
      L3= NUM*NUM
      NNACT = (NACT**2+NACT)/2
      MIJKL = (NNACT**2+NNACT)/2
      NXYZ = 3*NAT
      IF(SCFTYP.EQ.UHF) NXYZ=6*NAT
      NSH2=(NSHELL*NSHELL+NSHELL)/2
C
C     ----- ALLOCATE MEMORY -----
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      LEGH  = LOADFM + 1
      LEG   = LEGH
      LEH   = LEG   + NXYZ
      LFD   = LEH   + 9*(NAT*NAT+NAT)/2
      LTRI  = LFD   + NXYZ*L2
C
C     NOTE:  LFD IS THE DERIVATIVE CORE FOCK MATRIX FOR MCSCF RUNS.
C
C     CAUTION, JDDEND USES THE ARRAY STARTING AT -LDA- AS A WORK
C     ARRAY OF LENGTH L2, AND THE ARRAY STARTING AT -LDB- AS A
C     WORK ARRAY OF LENGTH L3, THUS OVERLAPPING INTO -LDTOT-.
C
      LDA   = LTRI  + L2
      LDB   = LDA   + L2
      LDTOT = LDB   + L2
      LDSPN = LDTOT + L2
      LDC   = LDSPN + L2
      LAST  = LDC   + L2
C
C     6 JAN 2004 : THE FOLLOWING CODE HAS BEEN MOVED TO DDERJKX
CC
CC     CAUTION, -JDDFCK- USES G1-G4,G7-G9 ARRAYS AS LENGTH 3888.
CC
C      LWX   = LAST
C      LWY   = LWX   + 2808
C      LWZ   = LWY   + 2808
C      LG1   = LWZ   + 2808
C      LG2   = LG1   + MAX(2808,3888)
C      LG3   = LG2   + MAX(2808,3888)
C      LG4   = LG3   + MAX(2808,3888)
C      LG5   = LG4   + MAX(4752,3888)
C      LG6   = LG5   +     4752
C      LG7   = LG6   +     4752
C      LG8   = LG7   + MAX(6084,3888)
C      LG9   = LG8   + MAX(6084,3888)
C      LAST  = LG9   + MAX(6084,3888)
C
      LTX  = LAST
      LTY  = LTX + 35*35
      LTZ  = LTY + 35*35
      LUX  = LTZ + 35*35
      LUY  = LUX + 35*35
      LUZ  = LUY + 35*35
      LAST = LUZ + 35*35
C
      IF(ROGVB) THEN
         LDSHL  = LAST
         LSHLJ  = LDSHL  + L2*NHAM
         LSHLK  = LSHLJ  + L2*NHAM*NXYZ
         LDHAM  = LSHLK  + L2*NHAM*NXYZ
         LAST   = LDHAM  + 3*NPAIR*NXYZ
      ELSE
         LDSHL = LAST
         LSHLJ = LAST
         LSHLK = LAST
         LDHAM = LAST
      END IF
C
      LXCHNG= LAST
      LDSH  = LXCHNG + NSH2
      LAST  = LDSH   + NSH2
C
      LV    = LAST
      LWRK  = LV    + L3
      LAST  = LWRK  + L1
C
      LDM2 = LAST
      IF(GUGACI) THEN
         NBUF=1
         LIDM2 = LDM2 + NBUF*NINTMX
      ELSE IF(MCCI) THEN
         NBUF=1
         CALL BASCHK(LMAX)
         IF(LMAX.GE.3) THEN
            IF(MASWRK) WRITE(IW,*)
     *          '2ND DERIVATIVE INTEGRALS CODED FOR SPD ONLY'
            CALL ABRT
         END IF
         MAXSHL = LENSHL(LMAX+1)
         LTPDM  = LDM2  + NBUF*NINTMX
         LHBDM  = LTPDM + NACT**4
         LHCD   = LHBDM + L2*NNACT
         LDLAG  = LHCD  + NXYZ
         LGD    = LDLAG + L3*NXYZ
         LFVD   = LGD   + MIJKL*NXYZ
         LIDM2  = LFVD  + L2*NXYZ + MAXSHL*(NACT**3) +
     *            (MAXSHL**2)*(NACT**2) + NACT*(MAXSHL**3) +
     *            MAXSHL**4 + 4*NACT*(MAXSHL**3)
      ELSE
         NBUF=0
         LIDM2 = LDM2 + NBUF*NINTMX
      END IF
C
      LAST = LIDM2 + NBUF*NINTMX
      NEED = LAST-LOADFM-1
      IF (SOME) WRITE(IW,9010) NEED,NGOTMX
      CALL GETFM(NEED)
C
      IF(EXETYP.EQ.CHECK) GO TO 900
C
C     6 JAN 2004 : THE FOLLOWING CODE HAS BEEN MOVED TO DDERJKX
C      CALL DDINI(X(LEGH),X(LEG),X(LEH),X(LFD),X(LDA),
C     *           X(LDB),X(LDC),X(LDTOT),X(LDSPN),X(LV),X(LTRI),
C     *           X(LDSHL),NHAM,NXYZ,IA,L1,L2,L3,MCPHF,OUT,NFT18)
C      IF(MCCI) THEN
C        CALL JKDMC(X(LDB),X(LDC),X(LV),X(LTPDM),X(LDTOT),X(LIDM2),
C     *             X(LDM2),IA,NUM,NCORSV,NACT)
C        CALL CPINI(X(LDLAG),X(LFD),X(LHCD),X(LFVD),X(LGD),X(LDB),
C     *             X(LV),X(LTPDM),X(LHBDM),IA,L1,L2,NCORSV,NACT,NNACT,
C     *             NXYZ,NFT18)
C      END IF
CC
C      CALL DDJK(X(LEGH),X(LEG),X(LEH),X(LFD),X(LDA),
C     *          X(LDB),X(LDC),X(LDTOT),X(LDSPN),X(LV),X(LWRK),
C     *          X(LDM2),X(LIDM2),X(LDSHL),X(LSHLJ),X(LSHLK),
C     *          X(LDHAM),X(LWX),X(LWY),X(LWZ),X(LG1),X(LG2),
C     *          X(LG3),X(LG4),X(LG5),X(LG6),X(LG7),X(LG8),X(LG9),
C     *          X(LTX),X(LTY),X(LTZ),X(LUX),X(LUY),X(LUZ),
C     *          IA,X(LDSH),X(LXCHNG),NXYZ,NSH2,NHAM,NCO,NSETO,NPAIR,
C     *          L1,L2,L3,NINTMX,OUT,NFT18)
      CALL DDERJKX(CALTYP,DUMMY,DUMMY,0,NXYZ,0,
     &             MCCI,X(LTPDM),X(LHBDM),X(LHCD),X(LDLAG),X(LGD),
     &             X(LFVD),NUM,NCORSV,NACT,NNACT,
     &             X(LEGH),X(LEG),X(LEH),X(LFD),X(LDA),
     &             X(LDB),X(LDC),X(LDTOT),X(LDSPN),X(LV),X(LTRI),
     &             X(LWRK),
     &             X(LDM2),X(LIDM2),X(LDSHL),X(LSHLJ),X(LSHLK),
     &             X(LDHAM),
     &             X(LTX),X(LTY),X(LTZ),X(LUX),X(LUY),X(LUZ),
     &             IA,X(LDSH),X(LXCHNG),NSH2,NHAM,NCO,NSETO,NPAIR,
     &             L1,L2,L3,NINTMX,MCPHF,OUT,NFT18)
C
  900 CONTINUE
C
      CALL RETFM(NEED)
      IF(MASWRK) THEN
         IF(CITYP.NE.GUGA) THEN
            IF(MCCI) THEN
              WRITE(IW,9025)
            ELSE
              WRITE(IW,9020)
            END IF
         ELSE
            WRITE(IW,9030)
         END IF
      END IF
      CALL TIMIT(1)
      RETURN
C
 9000 FORMAT(/5X,46(1H-)/
     *        5X,'TWO ELECTRON INTEGRAL DERIVATIVE CONTRIBUTIONS'/
     *        5X,46(1H-))
 9010 FORMAT(/1X,I10,' WORDS REQUIRED,',I10,' WORDS AVAILABLE')
 9020 FORMAT(1X,'...... END OF 2-ELECTRON GRAD+HESS+FOCKDER ......')
 9025 FORMAT(1X,'...... END OF 2-ELECTRON GRAD+HESS+LAGDER ......')
 9030 FORMAT(1X,'...... END OF 2-ELECTRON GRAD+FOCKDER ......')
      END
C
C*MODULE HSS2A   *DECK DDERJKOLIX
      SUBROUTINE DDERJKOLIX(D,DJK,NORB,NXYZ,NPARAMS,IDER)
      IMPLICIT NONE
C     ARGUMENTS
      INTEGER NORB,NXYZ,NPARAMS,IDER
      DOUBLE PRECISION D(NORB,NORB,NPARAMS)
      DOUBLE PRECISION DJK(NPARAMS,NXYZ,NORB,NORB)
C     VARIABLES AND CONSTANTS
      INTEGER IZERO
      DOUBLE PRECISION DUMMY
      PARAMETER (DUMMY=0.0D+00, IZERO=0)
      DOUBLE PRECISION CALTYP
      DOUBLE PRECISION SFIRST,SSECOND
      DATA SFIRST/8HFIRST   /,SSECOND/8HSECOND  /
C     BODY OF THE SUBPROGRAM
      IF(IDER.EQ.1)  THEN
         CALTYP = SFIRST
      ELSE IF(IDER.EQ.2) THEN
         CALTYP = SSECOND
      ELSE
         STOP
      END IF
C
      CALL DDERJKX(CALTYP,D,DJK,NORB,NXYZ,NPARAMS,
     &             .FALSE.,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,
     &             IZERO,IZERO,IZERO,IZERO,
     &             DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,
     &             DUMMY,DUMMY,DUMMY,
     &             DUMMY,
     &             DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,
     &             DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,
     &             IZERO,DUMMY,DUMMY,IZERO,IZERO,IZERO,IZERO,IZERO,
     &             IZERO,IZERO,IZERO,IZERO,.FALSE.,.FALSE.,IZERO)
      RETURN
      END
C*MODULE HSS2A   *DECK DDERJKX
      SUBROUTINE DDERJKX(CALTYP,D,DJK,NORB,NXYZ,NPARAMS,
     &                   MCCI,TPDM,HBDM,HCD,DLAG,GD,FVD,
     &                   NUM,NCORSV,NACT,NNACT,
     &                   EGH,EG,EH,FD,DA,DB,DC,DTOT,DSPN,V,TRI,
     &                   WRK,
     &                   DM2,IDM2,DSHL,SHLJ,SHLK,DHAM,
     &                   TX,TY,TZ,UX,UY,UZ,
     &                   IA,DSH,XCHNG,NSH2,NHAM,NCO,NSETO,NPAIR,
     &                   L1,L2,L3,NINTMX,MCPHF,OUT,NFT18)
      IMPLICIT NONE
C     ARGUMENTS
      DOUBLE PRECISION CALTYP
      INTEGER NORB,NXYZ,NPARAMS
      DOUBLE PRECISION D(NORB,NORB,NPARAMS)
      DOUBLE PRECISION DJK(NPARAMS,NXYZ,NORB,NORB)
C
      LOGICAL MCCI
      DOUBLE PRECISION TPDM(*),HBDM(*),HCD(*),DLAG(*),GD(*),FVD(*)
      INTEGER NUM,NCORSV,NACT,NNACT
C
      DOUBLE PRECISION EGH(*),EG(*),EH(*),FD(*),DA(*),DB(*),DC(*)
      DOUBLE PRECISION DTOT(*),DSPN(*),V(*),TRI(*),WRK(*)
      DOUBLE PRECISION DM2(*),DSHL(*),SHLJ(*),SHLK(*)
      DOUBLE PRECISION DHAM(*),TX(*),TY(*),TZ(*),UX(*),UY(*),UZ(*)
      DOUBLE PRECISION DSH(*),XCHNG(*)
      INTEGER IDM2(*),IA(*)
      INTEGER NSH2,NHAM,NCO,NSETO,NPAIR,L1,L2,L3,NINTMX,NFT18
      LOGICAL MCPHF,OUT
C     USED COMMON BLOCK
      DOUBLE PRECISION XX
      COMMON /FMCOM / XX(1)
C     VARIABLES
      INTEGER LAST,LOADFM,NEED
      INTEGER LWX,LWY,LWZ,LG1,LG2,LG3,LG4,LG5,LG6,LG7,LG8,LG9,LG10
      INTEGER NIJKL10
      LOGICAL BSECOND
      DOUBLE PRECISION SSECOND
      DATA SSECOND/8HSECOND  /
C
C     BODY OF THE SUBPROGRAM
C
      BSECOND  = CALTYP.EQ.SSECOND
C     ---------------
C     ALLOCATE MEMORY
C     ---------------
      CALL VALFM(LOADFM)
      LAST  = LOADFM + 1
C
C     CAUTION, -JDDFCK- USES G1-G4,G7-G9 ARRAYS AS LENGTH 3888.
C
      LWX   = LAST
      LWY   = LWX   + 2808
      LWZ   = LWY   + 2808
      LG1   = LWZ   + 2808
      LG2   = LG1   + MAX(2808,3888)
      LG3   = LG2   + MAX(2808,3888)
      LG4   = LG3   + MAX(2808,3888)
      LG5   = LG4   + MAX(4752,3888)
      LG6   = LG5   +     4752
      LG7   = LG6   +     4752
      LG8   = LG7   + MAX(6084,3888)
      LG9   = LG8   + MAX(6084,3888)
      LAST  = LG9   + MAX(6084,3888)
C
      NIJKL10=0
      IF(BSECOND) NIJKL10 = 9*6*6*6*6
      LG10  = LAST + 10*NIJKL10
C
      LAST = LG10
C
      NEED = LAST-LOADFM-1
C
      CALL GETFM(NEED)
C     -------------------
C     END ALLOCATE MEMORY
C     -------------------
C
      CALL DDINI(CALTYP,EGH,EG,EH,FD,DA,DB,DC,DTOT,DSPN,V,TRI,
     &           DSHL,NHAM,NXYZ,IA,L1,L2,L3,MCPHF,OUT,NFT18)
C
      IF(MCCI) THEN
        CALL JKDMC(DB,DC,V,TPDM,DTOT,IDM2,
     *             DM2,IA,NUM,NCORSV,NACT)
        CALL CPINI(DLAG,FD,HCD,FVD,GD,DB,
     *             V,TPDM,HBDM,IA,L1,L2,NCORSV,NACT,NNACT,
     *             NXYZ,NFT18)
      END IF
C
      CALL DDJK(CALTYP,DJK,D,NORB,NXYZ,NPARAMS,
     &          EGH,EG,EH,FD,DA,DB,DC,DTOT,DSPN,V,WRK,
     &          DM2,IDM2,DSHL,SHLJ,SHLK,
     &          DHAM,XX(LWX),XX(LWY),XX(LWZ),XX(LG1),XX(LG2),
     &          XX(LG3),XX(LG4),XX(LG5),XX(LG6),XX(LG7),XX(LG8),XX(LG9),
     &          XX(LG10),NIJKL10,TX,TY,TZ,UX,UY,UZ,IA,DSH,XCHNG,
     &          NSH2,NHAM,NCO,NSETO,NPAIR,
     &          L1,L2,L3,NINTMX,OUT,NFT18)
C
      CALL RETFM(NEED)
      CALL TIMIT(1)
      RETURN
      END
C
C*MODULE HSS2A   *DECK DDINI
      SUBROUTINE DDINI(CALTYP,EGH,EG,EH,FD,DA,DB,DC,DTOT,DSPN,V,
     *                 TRI,DSHL,NHAM,NXYZ,IA,L1,L2,L3,
     *                 MCPHF,OUT,NFT18)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION MCSCF
C
      LOGICAL RHFTYP,UHFTYP,HFSCF,MCCI,ROGVB,MCPHF,OUT,GUGACI
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION DA(L2),DB(L2),DC(L2),DTOT(L2),DSPN(L2),IA(L1),V(L1,*),
     *          EGH(*),EG(*),EH(*),FD(L2,NXYZ),TRI(L2),DSHL(L2,NHAM)
C
      PARAMETER (MXATM=2000)
C
      COMMON /CIJDD / NDMAX,ND,MD
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,NREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (HALF=0.5D+00, TWO=2.0D+00, ONE=1.0D+00)
C
      DATA RHF,UHF,ROHF,GVB/8HRHF     ,8HUHF     ,8HROHF    ,8HGVB     /
      DATA MCSCF,GUGA /8HMCSCF   ,8HGUGA    /
      DATA SDEFAULT/8HDEFAULT /
      IF(CALTYP.NE.SDEFAULT) GOTO 500
C
C     ----- MISCELLANEOUS INITIALIZATION FOR HESSIAN COMPUTATION -----
C
      RHFTYP= SCFTYP.EQ.RHF.AND.CITYP.NE.GUGA
      UHFTYP= SCFTYP.EQ.UHF
      HFSCF = SCFTYP.EQ.RHF   .OR. SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF
     *        .AND.CITYP.NE.GUGA
      ROGVB = SCFTYP.EQ.ROHF  .OR. SCFTYP.EQ.GVB
      MCCI  = SCFTYP.EQ.MCSCF
      GUGACI= CITYP .EQ.GUGA
C
C     READ IN THE MO VECTORS.
C
      CALL DAREAD(IDAF,IODA,V,L3,15,0)
C
C     ----- RHF,UHF,ROHF CASE -----
C     FOR RHF - DA=DTOT=TOTAL (ALPHA+BETA) DENSITY
C     FOR UHF,ROHF - DA=ALPHA, DB=BETA, DTOT=TOTAL, DSPN=SPIN DENSITY
C
      IF(HFSCF) THEN
         CALL DAREAD(IDAF,IODA,DA,L2,16,0)
         IF(UHFTYP  .OR.  SCFTYP.EQ.ROHF) THEN
            CALL DAREAD(IDAF,IODA,DB,L2,20,0)
            DO 100 I=1,L2
               DTOT(I)=DA(I)+DB(I)
               DSPN(I)=DA(I)-DB(I)
  100       CONTINUE
         ELSE
            CALL DCOPY(L2,DA,1,DTOT,1)
         END IF
      END IF
C
C     ----- MCSCF HESSIAN/CI GRADIENT CASE -----
C     THE 2 BODY DENSITY FOR CI GRADIENT WILL BE READ FROM FILE -NFT16-
C     CI GRADIENT IS READING THE -RHF- DENSITY MATRIX AT THIS POINT
C
      IF(MCCI.OR.GUGACI) THEN
         IF(GUGACI) THEN
            CALL DAREAD(IDAF,IODA,DA,L2,316,0)
            NFT16 = 16
            CALL SEQREW(NFT16)
         ELSE
            CALL DAREAD(IDAF,IODA,DA,L2,16,0)
         END IF
         CALL DCOPY(L2,DA,1,DTOT,1)
         ND = 0
         MD = 1
      END IF
C
C     ----- GVB CASE -----
C     DA = DTOT = TOTAL (ALPHA+BETA) DENSITY
C     DC = CORE CONTRIBUTION TO DENSITY
C
      IF(SCFTYP.EQ.GVB) THEN
         CALL DAREAD(IDAF,IODA,DA,L2,16,0)
         CALL DAREAD(IDAF,IODA,DB,L2,20,0)
         CALL VADD(DA,1,DB,1,DTOT,1,L2)
         CALL DCOPY(L2,DTOT,1,DA,1)
         CALL DENCOR(DC,V,IA,L1)
      END IF
C
C     ----- SHELL CONTRIBUTIONS TO ONE BODY DENSITY -----
C
      IF(ROGVB) THEN
         DO 280 ISH=1,NHAM
            CALL DENSHL(V,DSHL(1,ISH),ISH,L1,L2)
  280    CONTINUE
      END IF
C
C     ----- READ 1E-GRADIENT AND 1E-HESSIAN -----
C
      NEGH = 3*NAT + 9*(NAT*NAT+NAT)/2
      CALL DAREAD(IDAF,IODA,EGH,NEGH,67,0)
      IF(OUT) THEN
         IF(MASWRK) WRITE(IW,*) '1E- GRADIENT AND HESSIAN'
         CALL HSSPRT(NAT,EG,EH)
      END IF
      IF(GOPARR) CALL DSCAL(NEGH,ONE/NPROC,EGH,1)
C
C     ----- READ ONE ELECTRON DERIVATIVE FOCK MATRICES -----
C
      IF(.NOT.MCPHF) GO TO 500
      IF(MCCI) GO TO 500
      CALL SEQREW(NFT18)
      LXYZ = 1
      DO 440 IAT=1,NAT
         DO 430 IXYZ=1,3
C
            CALL SQREAD(NFT18,TRI,L2)
            IF(OUT) THEN
               WRITE(IW,*) 'H(A) FOR ATOM',IAT,' COORD',IXYZ
               CALL PRTRI(TRI,L1)
            END IF
C
C                  RHF AND UHF FORM THE DERIVATIVE FOCK MATRIX
C                  BY ADDING TWO ELECTRON CONTRIBUTIONS DIRECTLY
C                  INTO THE MATRIX CONTAINING THE 1E- TERMS, AND
C                  THEN HALVE THE ENTIRE MATRIX EXCEPT FOR THE
C                  DIAGONAL.  SO WE DOUBLE THE 1E- PART TO START.
C                  THE MCSCF CODE IS GOOD ONLY IN THE RHF LIMIT.
C                  IN PARALLEL, THE DIVISION BY -NPROC- IS NEEDED
C                  BECAUSE OF THE EVENTUAL GLOBAL SUM.
C
            IF(RHFTYP  .OR.  UHFTYP  .OR. MCCI .OR. GUGACI) THEN
               CALL DSCAL(L2,TWO/NPROC,TRI,1)
               II=0
               DO 410 I=1,L1
                  II=II+I
                  TRI(II) = HALF*TRI(II)
  410          CONTINUE
            END IF
C
            CALL DCOPY(L2,TRI,1,FD(1,LXYZ),1)
            IF(UHFTYP) CALL DCOPY(L2,TRI,1,FD(1,LXYZ+3),1)
            LXYZ = LXYZ+1
  430    CONTINUE
         IF(UHFTYP) LXYZ=LXYZ+3
  440 CONTINUE
      CALL SEQREW(NFT18)
C
  500 CONTINUE
      IST=1
      JST=1
      KST=1
      LST=1
      RETURN
      END
C
C*MODULE HSS2A   *DECK DDJK
      SUBROUTINE DDJK(CALTYP,DJK,D,NORB,NXYZ,NPARAMS,
     &                EGH,EG,EH,FD,DA,DB,DC,DTOT,DSPN,
     &                V,WRK,DM2,IDM2,DSHL,SHLJ,SHLK,DHAM,WX,WY,WZ,
     &                GIJKL1,GIJKL2,GIJKL3,GIJKL4,GIJKL5,GIJKL6,
     &                GIJKL7,GIJKL8,GIJKL9,GIJKL10,NIJKL10,
     &                TX,TY,TZ,UX,UY,UZ,IA,
     &                DSH,XCHNG,NSH2,NHAM,NCO,NSETO,NPAIR,
     &                L1,L2,L3,NINTMX,OUT,NFT18)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION MCSCF
C
      LOGICAL NSKIP1,NSKIP2,NSKIP3,NSKIP4
      LOGICAL NSKIP5,NSKIP6,NSKIP7,NSKIP8,NSKIP9
      LOGICAL SHLON,SKIP,OUT,COARSE
      LOGICAL FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF
      LOGICAL NOCORE,NOOPEN
      LOGICAL RHFTYP,UHFTYP,GVBTYP,HFSCF,ROGVB,MCCI,GUGACI
      LOGICAL GOPARR,DSKWRK,MASWRK,NXT
      LOGICAL BDEFAULT,BFIRST,BSECOND
C
      DIMENSION EGH(*),EG(*),EH(*),FD(L2,NXYZ),DM2(*),IDM2(*),WRK(*),
     *          DA(L2),DB(L2),DC(L2),DTOT(L2),DSPN(L2),V(L3),IA(L1),
     *          DSHL(L2,NHAM),SHLJ(L2,NHAM,NXYZ),SHLK(L2,NHAM,NXYZ),
     *          GIJKL1(*),GIJKL2(*),GIJKL3(*),GIJKL4(*),
     *          GIJKL5(*),GIJKL6(*),GIJKL7(*),GIJKL8(*),GIJKL9(*),
     *          WX(2808),WY(2808),WZ(2808),TX(35,35),TY(35,35),
     *          TZ(35,35),UX(35,35),UY(35,35),UZ(35,35),
     *          DSH(NSH2),XCHNG(NSH2),DJK(NPARAMS,NXYZ,NORB,NORB),
     *          D(NORB,NORB,NPARAMS),GIJKL10(NIJKL10,10)
      DIMENSION M0(48),M1(48),M2(48),M3(48),LENSHL(5)
C
      PARAMETER (MXGTOT=20000, MXSH=5000, MXATM=2000, MXRT=100)
C
C     INTEGRAL WORK AREAS, WORST CASE FOR SPD FUNCTIONS IS
C        D'DDD  = (P+F)DDD     = 13* 6*6*6 = 2808 = G1-G3 ARRAYS
C        D''DDD = (S+D+G)DDD   = 22* 6*6*6 = 4752 = G4-G6 ARRAYS
C        D'D'DD = (P+F)(P+F)DD = 13*13*6*6 = 6084 = G7-G9 ARRAYS
C     NOTE THAT -JDDFCK- USES G1-G4 AND G7-G9 WITH DIFFERENT LENGTHS.
C
      COMMON /ATMJDD/ NATOM(4),NPASS
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,S,SZ,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACT,NORBB,
     *                MNA,MNB,K,KSTDET,IROOT,IPURES,MAXW1,NITER,MAXP,
     *                NCIDET,IGPDET,KSTSYM,NFTGCI
      COMMON /HSSPAR/ FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /JDDSKP/ MSHL(4),MGETDG(3),SHLON(6),SKIP(4)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,NREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /SHLBAS/ LMAX,MAXNUM
      COMMON /SKPJDD/ NSKIP1,NSKIP2,NSKIP3,NSKIP4,NSKIP5,
     *                NSKIP6,NSKIP7,NSKIP8,NSKIP9
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /TMVALS/ TI,TXX,TIM
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00, ONE=1.0D+00, TWO=2.0D+00)
C
      DATA RHF,UHF,ROHF,GVB/8HRHF     ,8HUHF     ,8HROHF    ,8HGVB     /
      DATA MCSCF,GUGA /8HMCSCF   ,8HGUGA    /
      DATA LENSHL /1,4,10,20,35/
C
      DATA SDEFAULT/8HDEFAULT /,SFIRST/8HFIRST   /,SSECOND/8HSECOND  /
      BDEFAULT = CALTYP.EQ.SDEFAULT
      BFIRST   = CALTYP.EQ.SFIRST
      BSECOND  = CALTYP.EQ.SSECOND
      IF(.NOT.(BDEFAULT.OR.BFIRST.OR.BSECOND)) CALL ABRT
C
C     ----- 2 E- CONTRIBUTION TO ENERGY GRADIENT AND HESSIAN -----
C
      NIJKL1=2808
      NIJKL2=4752
      NIJKL3=6084
C
C     SET UP APPROXIMATE SCHWARZ SCREENING
C
      DUMMY =ZERO
      NSKIPC=0
      NSKIPF=0
      NCALC =0
      CUTOFF=1.0D-10
      DATOL =1.0D-09
      DABTOL=1.0D-09
C
C     6 JAN 2004 : SKIP THE FOLLOWING CODE FOR TDHFX PACKAGE
C
      IF(BDEFAULT) THEN
         IF(ISCHWZ.EQ.1) THEN
            CALL DAREAD(IDAF,IODA,XCHNG,NSH2,54,0)
         ELSE
            DO I=1,NSH2
               XCHNG(I) = ONE
            END DO
         END IF
C
C     GENERATE -DSH- FOR SCREENING
C     AT PRESENT, CI GRADIENT IS FOR SCFTYP=RHF ONLY, SO WE DON'T NEED
C     TO DISTINGUISH ANYTHING BUT THE UNDERLYING SCF, ALTHOUGH THE CI'S
C     1PDM WILL BE IN THE -DA- ARRAY AT THIS POINT, AS IT SHOULD BE.
C
         IF(SCFTYP.EQ.RHF  .OR.  CITYP.EQ.GUGA) THEN
            CALL SHLDEN(RHF,DA   ,DUMMY,DUMMY,DSH,IA,L1,L2,NSH2,1)
         ELSE IF(SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF) THEN
            CALL SHLDEN(UHF,DA   ,DB   ,DUMMY,DSH,IA,L1,L2,NSH2,1)
         ELSE IF(SCFTYP.EQ.GVB) THEN
            CALL SHLDEN(GVB,DUMMY,DUMMY,DSHL ,DSH,IA,L1,L2,NSH2,NHAM)
         ELSE
            DO I=1,NSH2
               DSH(I) = ONE
            END DO
         END IF
C
C     ----- DETERMINE TYPE OF 2 BODY DENSITY MATRIX -----
C
         RHFTYP = SCFTYP.EQ.RHF.AND.CITYP.NE.GUGA
         UHFTYP = SCFTYP.EQ.UHF
         GVBTYP = SCFTYP.EQ.GVB
         HFSCF  = SCFTYP.EQ.RHF   .OR. SCFTYP.EQ.UHF .OR. SCFTYP.EQ.ROHF
     *            .AND.CITYP.NE.GUGA
         ROGVB  = SCFTYP.EQ.ROHF  .OR. SCFTYP.EQ.GVB
         MCCI   = SCFTYP.EQ.MCSCF
         GUGACI = CITYP .EQ.GUGA
C
         IF(GVBTYP) THEN
            NOCORE=NCO.EQ.0
            NOOPEN=NSETO.EQ.0  .AND.  NPAIR.EQ.0
         END IF
         IF(ROGVB) THEN
            CALL VCLR(SHLJ,1,L2*NHAM*NXYZ)
            CALL VCLR(SHLK,1,L2*NHAM*NXYZ)
         END IF
C
         DABMAX = ZERO
         COARSE=.TRUE.
         IF(MCCI  .OR.  GUGACI) COARSE=.FALSE.
      ELSE
         RHFTYP = .TRUE.
         UHFTYP = .FALSE.
         GVBTYP = .FALSE.
         HFSCF  = .TRUE.
         ROGVB  = .FALSE.
         MCCI   = .FALSE.
         GUGACI = .FALSE.
      END IF
C
C     ----- PRECALCULATE SOME INDICES -----
C
      CALL STVJDD
C
C     ----- INITIALIZATION FOR PARALLEL WORK -----
C
      NXT = IBTYP.EQ.1
      IPCOUNT = ME - 1
      NEXT = -1
      MINE = -1
C
      IF(MCCI) THEN
        NTSV = NT
        NT = 0
        NNACT = (NACT**2+NACT)/2
        MIJKL = (NNACT**2+NNACT)/2
        CALL BASCHK(LMAX)
        IF(LMAX.GE.3) THEN
           IF(MASWRK) WRITE(IW,*)
     *          '2ND DERIVATIVE INTEGRALS CODED FOR SPD ONLY'
           CALL ABRT
        END IF
        MAXSHL = LENSHL(LMAX+1)
        LTPDM = 1     + NINTMX
        LHBDM = LTPDM + NACT**4
        LHCD  = LHBDM + L2*NNACT
        LDLAG = LHCD  + NXYZ
        LGD   = LDLAG + L3*NXYZ
        LFVD  = LGD   + MIJKL*NXYZ
        LFQDM = LFVD  + L2*NXYZ
        LHDM  = LFQDM + MAXSHL*(NACT**3)
        LTQDM = LHDM  + (MAXSHL**2)*(NACT**2)
        LBTDM = LTQDM + NACT*(MAXSHL**3)
        LTBDM = LBTDM + MAXSHL**4
      END IF
C
C     ----- I SHELL -----
C
      IF(IST.GT.NSHELL) GO TO 9100
      DO 9000 II=IST,NSHELL
      DO 110 IT=1,NT
         ID=MAPSHL(II,IT)
         IF(ID.GT.II) GO TO 9000
         M0(IT)=ID
  110 CONTINUE
      IF(MCCI) CALL DABMCI(V,DM2(LTPDM),DM2(LFQDM),NACT,II,NUM,
     *                     MAXSHL,NCORSV)
C
C     ----- J SHELL -----
C
      J0=JST
      JST=1
      DO 8000 JJ=J0,II
      DO 220 IT=1,NT
         ID=M0(IT)
         JD=MAPSHL(JJ,IT)
         IF(JD.GT.II) GO TO 8000
         IF(ID.GE.JD) GO TO 210
         ND=ID
         ID=JD
         JD=ND
  210    IF(ID.EQ.II.AND.JD.GT.JJ) GO TO 8000
         M1(IT)=ID
         M2(IT)=JD
  220 CONTINUE
      IF(MCCI) CALL DABMCJ(V,DM2(LFQDM),DM2(LHDM),NACT,II,JJ,NUM,
     *                     MAXSHL,NCORSV)
C
C           GO PARALLEL!
C
      IF (NXT  .AND.  GOPARR) THEN
         MINE = MINE + 1
         IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
         IF (NEXT.NE.MINE) GO TO 8000
      END IF
C
C     ----- K SHELL -----
C
      K0=KST
      KST=1
      DO 7000 KK=K0,II
      DO 310 IT=1,NT
         KD=MAPSHL(KK,IT)
         IF(KD.GT.II) GO TO 7000
         M3(IT)=KD
  310 CONTINUE
      IF(MCCI) CALL DABMCK(V,DM2(LHDM),DM2(LTQDM),NACT,II,JJ,KK,NUM,
     *                     MAXSHL,NCORSV)
C
C     ----- L SHELL -----
C
      L0=LST
      LST=1
      MAXLL=KK
      IF(KK.EQ.II) MAXLL=JJ
      DO 6000 LL=L0,MAXLL
      N4=0
      DO 430 IT=1,NT
         LD=MAPSHL(LL,IT)
         IF(LD.GT.II) GO TO 6000
         KD=M3(IT)
         IF(KD.GE.LD) GO TO 410
         ND=KD
         KD=LD
         LD=ND
  410    ID=M1(IT)
         JD=M2(IT)
         IF(ID.NE.II.AND.KD.NE.II) GO TO 430
         IF(KD.LT.ID) GO TO 420
         IF(KD.EQ.ID.AND.LD.LE.JD) GO TO 420
         ND=ID
         ID=KD
         KD=ND
         ND=JD
         JD=LD
         LD=ND
  420    IF(JD.LT.JJ) GO TO 430
         IF(JD.GT.JJ) GO TO 6000
         IF(KD.LT.KK) GO TO 430
         IF(KD.GT.KK) GO TO 6000
         IF(LD.LT.LL) GO TO 430
         IF(LD.GT.LL) GO TO 6000
         N4=N4+1
  430 CONTINUE
C
C           GO PARALLEL!
C
      IF(.NOT.NXT .AND. GOPARR) THEN
         IPCOUNT = IPCOUNT + 1
         IF(MOD(IPCOUNT,NPROC).NE.0) GO TO 6000
      END IF
C
C     ----- CALCULATE Q4 FACTOR FOR THIS GROUP OF SHELLS -----
C
        IF(MCCI) THEN
          Q4 = ONE
        ELSE
          Q4 = NT
          Q4 = Q4/N4
        END IF
C
C     COARSE SCREENING ON DERIVATIVE INTEGRALS, WHICH CONTRIBUTE
C     TO BOTH THE GRADIENT AND HESSIAN WEIGHTED BY THE 2PDM,
C     AND TO THE DERIVATIVE FOCK MATRIX WEIGHTED BY THE 1PDM.
C     NOTE THAT WE MUST NEVER SKIP THE DM2 PROCESSING IN -JDDDCI-
C
C     6 JAN 2004 : SKIP THE FOLLOWING CODE FOR TDHFX PACKAGE
      IF(BDEFAULT) THEN
         IJIJ=IA(MAX(II,JJ))+MIN(II,JJ)
         KLKL=IA(MAX(KK,LL))+MIN(KK,LL)
         GMAX=XCHNG(IJIJ)*XCHNG(KLKL)
         DAMAX=SCHWDN(DSH,II,JJ,KK,LL,IA)
         IF(COARSE  .AND.  GMAX*DAMAX.LT.CUTOFF) THEN
            NSKIPC=NSKIPC+1
            GO TO 6000
         END IF
      END IF
C
C     ----- CHECK FOR REDUNDANT COMBINATIONS -----
C
      CALL JDDATM(II,JJ,KK,LL,OUT)
      IF(NPASS.EQ.0) GO TO 6000
      ISH = MSHL(1)
      JSH = MSHL(2)
      KSH = MSHL(3)
      LSH = MSHL(4)
      NSKIP1 = .NOT. ( MFIRST .AND. .NOT. SHLON(1))
      NSKIP2 = .NOT. ( MFIRST .AND. .NOT. SHLON(2))
      NSKIP3 = .NOT. ( MFIRST .AND. .NOT. SHLON(3))
      NSKIP4 = .NOT. ( MSECND .AND. .NOT. SHLON(1))
      NSKIP5 = .NOT. ( MSECND .AND. .NOT. SHLON(2))
      NSKIP6 = .NOT. ( MSECND .AND. .NOT. SHLON(3))
      NSKIP7 = .NOT. ( MSECND .AND. .NOT. SHLON(4))
      NSKIP8 = .NOT. ( MSECND .AND. .NOT. SHLON(5))
      NSKIP9 = .NOT. ( MSECND .AND. .NOT. SHLON(6))
C
C     ----- FORM PRODUCTS OF DENSITY MATRIX ELEMENTS -----
C           SKIP CALCULATION IF DABMAX.LT.DABTOL
C
C     6 JAN 2004 : SKIP THE FOLLOWING CODE FOR TDHFX PACKAGE
      IF(BDEFAULT) THEN
         IF(HFSCF)  CALL JDDDHF(ISH,JSH,KSH,LSH,Q4,RHFTYP,
     *                          IA,DTOT,DSPN,DABMAX)
         IF(GVBTYP) CALL JDDDGV(ISH,JSH,KSH,LSH,Q4,NOCORE,NOOPEN,
     *                          IA,DC,V,NUM,DABMAX)
         IF(GUGACI)
     *              CALL JDDDCI(II,JJ,KK,LL,DM2,IDM2,NINTMX,DABMAX)
         IF(MCCI) THEN
            CALL DABMCL(V,DM2(LTQDM),DM2(LBTDM),NACT,II,JJ,KK,LL,NUM,
     *                  MAXSHL,NCORSV)
            CALL JDDDMC(II,JJ,KK,LL,ISH,JSH,KSH,LSH,DM2(LBTDM),
     *                  MAXSHL,NCORSV,NACT,Q4,DABMAX,DB,DC)
         END IF
C
C        FINE SCREENING ON DERIVATIVE INTS, NOW THAT 2PDM IS AVAILABLE
C
         IF(DABMAX*GMAX.LT.DABTOL .AND. DAMAX*GMAX.LT.DATOL) THEN
            NSKIPF=NSKIPF+1
            GO TO 6000
         ELSE
            NCALC=NCALC+1
         END IF
      END IF
C
C     ----- GET SHELL INFORMATION -----
C           GET INDEX TABLES
C
      CALL JDDSHL(ISH,JSH,KSH,LSH)
      CALL JDDIDX
C
C     ----- INITIALIZE TO ZERO -----
C
      CALL VCLR(GIJKL1,1,NIJKL1)
      CALL VCLR(GIJKL2,1,NIJKL1)
      CALL VCLR(GIJKL3,1,NIJKL1)
      CALL VCLR(GIJKL4,1,NIJKL2)
      CALL VCLR(GIJKL5,1,NIJKL2)
      CALL VCLR(GIJKL6,1,NIJKL2)
      CALL VCLR(GIJKL7,1,NIJKL3)
      CALL VCLR(GIJKL8,1,NIJKL3)
      CALL VCLR(GIJKL9,1,NIJKL3)
C
C     ----- COMPUTE TWO-ELECTRON INTEGRALS -----
C
      CALL JDDGEN(GIJKL1,GIJKL2,GIJKL3,GIJKL4,GIJKL5,GIJKL6,
     *            GIJKL7,GIJKL8,GIJKL9)
      CALL JDDFSD(GIJKL1,GIJKL2,GIJKL3,GIJKL4,GIJKL5,GIJKL6,
     *            GIJKL7,GIJKL8,GIJKL9,GIJKL10,NIJKL10,WX,WY,WZ)
C
C     ----- GENERATE PARTIAL CONTRIBUTIONS ----
C           TO GRADIENT AND HESSIAN
C
C     6 JAN 2004 : SKIP THE FOLLOWING CODE FOR TDHFX PACKAGE
      IF(BDEFAULT) THEN
         CALL JDDEGH(EG,EH,ISH,JSH,KSH,LSH,OUT)
      END IF
C
C     ----- CONTRIBUTION TO FOCK DERIVATIVE MATRIX -----
C
      IF(MCCI) THEN
        CALL JDDTRN(DM2(LTBDM),V,DM2(LHBDM),IA,NCORSV,NACT,NNACT,L1,
     *              L2,MAXSHL)
        CALL JDDLAG(Q4,GIJKL1,GIJKL2,GIJKL3,GIJKL4,GIJKL7,GIJKL8,
     *              GIJKL9,V,DM2(LDLAG),FD,DM2(LFVD),DM2(LGD),DB,DC,
     *              DM2(LTBDM),L1,L2,NCORSV,NACT,MIJKL,NXYZ,MAXSHL)
        GO TO 6000
      END IF
C
      IF(MCPHF.OR.BFIRST.OR.BSECOND)
     &          CALL JDDFCK(MCPHF,BFIRST,BSECOND,
     &                      DJK,D,NORB,NXYZ,NPARAMS,
     &                      Q4,FD,DA,DB,DSHL,SHLJ,SHLK,GIJKL1,GIJKL2,
     &                      GIJKL3,GIJKL4,GIJKL7,GIJKL8,GIJKL9,
     &                      GIJKL10,NIJKL10,
     &                      L1,L2,NHAM,RHFTYP,UHFTYP,ROGVB,MCCI,OUT,
     &                      GUGACI)
C
 6000 CONTINUE
 7000 CONTINUE
 8000 CONTINUE
C
C     ----- SAVE GRADIENT + HESSIAN AND RESTART DATA -----
C
      IF(BDEFAULT) THEN
         IF (.NOT.GOPARR .AND. .NOT.MCCI)
     *        CALL JDDESH(II,EGH,EG,FD,NAT,NUM,MCPHF,UHFTYP,ROGVB,NFT18)
      END IF
      CALL TSECND(TIM)
      IF(TIM.GE.TIMLIM) GO TO 9200
 9000 CONTINUE
C
      IF(MCCI) NT = NTSV
C
C     ----- END OF *SHELL* LOOPS -----
C
      IF (GOPARR) THEN
         IF(NXT) CALL DDI_DLBRESET
         IF(BDEFAULT) THEN
            LEGH = (3*NAT) + 9*((NAT*NAT+NAT)/2)
            CALL DDI_GSUMF(1650,EGH,LEGH)
            CALL DDI_GSUMI(1651,NSKIPF,1)
            CALL DDI_GSUMI(1652,NSKIPC,1)
            CALL DDI_GSUMI(1653,NCALC ,1)
            IF (.NOT.ROGVB) THEN
               CALL DDI_GSUMF(1655,FD  ,L2*NXYZ)
               IF(MCCI) THEN
                  CALL DDI_GSUMF(1656,DM2(LDLAG),L3*NXYZ)
                  CALL DDI_GSUMF(1657,DM2(LFVD),L2*NXYZ)
                  CALL DDI_GSUMF(1658,DM2(LGD),MIJKL*NXYZ)
               END IF
            ELSE
               CALL DDI_GSUMF(1660,SHLJ,L2*NHAM*NXYZ)
               CALL DDI_GSUMF(1665,SHLK,L2*NHAM*NXYZ)
            END IF
         END IF
      END IF
C
C     ----- SYMMETRIZE GRADIENT, HESSIAN, FOCK DERIVATIVES -----
C     (FIRST, HALVE OFF-DIAGONAL OF FOCK DERIVATIVE MATRICES)
C
 9100 CONTINUE
      IF(BDEFAULT) THEN
         IF(MFIRST) CALL SYMEG(EG)
         IF(MSECND) CALL SYMEH(EH)
         IF(MCPHF) THEN
C
            IF(RHFTYP .OR. UHFTYP .OR. GUGACI) THEN
               CALL DSCAL(L2*NXYZ,PT5,FD,1)
               DO 9120 I=1,NXYZ
                  II = 0
                  DO 9110 IUM=1,L1
                     II = II + IUM
                     FD(II,I)=FD(II,I)+FD(II,I)
 9110             CONTINUE
 9120          CONTINUE
               IF(RHFTYP .OR. GUGACI) CALL SYMDF(FD,L2,1,3,NAT,1,1,2,3,
     *                                           TX,TY,TZ,UX,UY,UZ)
               IF(UHFTYP) CALL SYMDF(FD,L2,1,6,NAT,1,1,2,3,
     *                               TX,TY,TZ,UX,UY,UZ)
               IF(UHFTYP) CALL SYMDF(FD,L2,1,6,NAT,1,4,5,6,
     *                               TX,TY,TZ,UX,UY,UZ)
            END IF
C
            IF(ROGVB) THEN
               CALL DSCAL(L2*NHAM*NXYZ,PT5,SHLJ,1)
               CALL DSCAL(L2*NHAM*NXYZ,PT5,SHLK,1)
               DO 9150 IXYZ=1,NXYZ
                  DO 9140 ISH=1,NHAM
                     II = 0
                     DO 9130 I=1,L1
                        II = II + I
                        SHLJ(II,ISH,IXYZ) = TWO * SHLJ(II,ISH,IXYZ)
                        SHLK(II,ISH,IXYZ) = TWO * SHLK(II,ISH,IXYZ)
 9130                CONTINUE
 9140             CONTINUE
 9150          CONTINUE
               DO 9160 ISH=1,NHAM
                  CALL SYMDF(SHLJ,L2,NHAM,3,NAT,ISH,1,2,3,
     *                            TX,TY,TZ,UX,UY,UZ)
                  CALL SYMDF(SHLK,L2,NHAM,3,NAT,ISH,1,2,3,
     *                            TX,TY,TZ,UX,UY,UZ)
 9160          CONTINUE
            END IF
         END IF
C
         IF(MASWRK) WRITE(IW,9800) NSKIPC,NSKIPF,NCALC
      END IF
C
C     ----- WRITE THE FINAL RESULTS OUT -----
C     DA IS USED AS WORK STORAGE (LENGTH L2   ), AND SO IS DESTROYED
C     DB IS USED AS WORK STORAGE (LENGTH L3 ! ), AND SO IS DESTROYED
C
      IF(MCCI) THEN
        CALL JCPEND(EGH,EG,DM2(LDLAG),FD,DM2(LHCD),DM2(LGD),
     *              DM2(LFVD),V,DTOT,IA,DA,WRK,L1,L2,NAT,NCORSV,NACT,
     *              MIJKL,NFT18)
        GO TO 9200
      END IF
      I36 = 3
      IF(UHFTYP) I36=6
      CALL JDDEND(CALTYP,EGH,EG,EH,FD,V,DB,DA,WRK,SHLJ,SHLK,IA,
     *            DHAM,MCPHF,NFT18,I36,NAT,NHAM,L1,L2,L3,
     *            RHFTYP,UHFTYP,ROGVB,OUT,GUGACI)
 9200 CONTINUE
      RETURN
 9800 FORMAT(1X,'THE COARSE/FINE SCHWARZ SCREENINGS SKIPPED ',I10,'/',
     *          I10,' BLOCKS.'/
     *  1X,'THE NUMBER OF DERIVATIVE INTEGRAL BLOCKS COMPUTED WAS',I10)
      END
C*MODULE HSS2A   *DECK JDDATM
      SUBROUTINE JDDATM(II0,JJ0,KK0,LL0,OUT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL OUT,GOPARR,DSKWRK,MASWRK
      LOGICAL SKIP1,SKIP2,SKIP3,SKIP4,SHLON
      LOGICAL IANDJ,IANDK,IANDL,JANDK,JANDL,KANDL
      LOGICAL NSKIP1,NSKIP2,NSKIP3,NSKIP(3)
C
      PARAMETER (MXGTOT=20000, MXSH=5000)
C
      COMMON /ATMJDD/ NATOM(4),NPASS
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /JDDSKP/ MSHL(4),MGETDG(3),SHLON(6),SKIP1,SKIP2,SKIP3,SKIP4
      COMMON /JDDDIF/ NSKIP1,NSKIP2,NSKIP3
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- THE SHELL WITH HIGHEST ANGULAR MOMENTUM -----
C           MUST BE ON THE RIGHT HAND SIDE
C
      KIT=KTYPE(II0)
      KJT=KTYPE(JJ0)
      KKT=KTYPE(KK0)
      KLT=KTYPE(LL0)
      MAXTYP=MAX0(KIT,KJT,KKT,KLT)
      IF(MAXTYP.NE.KLT) GO TO 10
      II=II0
      JJ=JJ0
      KK=KK0
      LL=LL0
      GO TO 40
   10 IF(MAXTYP.NE.KKT) GO TO 20
      II=II0
      JJ=JJ0
      KK=LL0
      LL=KK0
      GO TO 40
   20 IF(MAXTYP.NE.KJT) GO TO 30
      II=KK0
      JJ=LL0
      KK=II0
      LL=JJ0
      GO TO 40
   30 CONTINUE
      II=KK0
      JJ=LL0
      KK=JJ0
      LL=II0
   40 CONTINUE
C
      SKIP1 = .TRUE.
      SKIP2 = .TRUE.
      SKIP3 = .TRUE.
      SKIP4 = .TRUE.
      NPASS = 0
      LSKIP = 0
      DO 100 I = 1,4
  100 NATOM(I) = 0
      IAT = KATOM(II)
      JAT = KATOM(JJ)
      KAT = KATOM(KK)
      LAT = KATOM(LL)
      IANDJ = IAT .EQ. JAT
      IANDK = IAT .EQ. KAT
      IANDL = IAT .EQ. LAT
      JANDK = JAT .EQ. KAT
      JANDL = JAT .EQ. LAT
      KANDL = KAT .EQ. LAT
      IF ( .NOT. IANDJ) GO TO 220
      IF ( .NOT. IANDK) GO TO 140
      IF ( .NOT. IANDL) GO TO 120
C
C     ----- IAT = JAT = KAT = LAT -----
C
      GO TO 380
  120 CONTINUE
C
C     ----- IAT = JAT = KAT ; LAT ----
C
      SKIP4 = .FALSE.
      NATOM(1) = LAT
      NATOM(2) = IAT
      NPASS = 1
      GO TO 380
  140 IF ( .NOT. IANDL) GO TO 150
C
C     ----- IAT = JAT = LAT ; KAT -----
C
      SKIP3 = .FALSE.
      NATOM(1) = KAT
      NATOM(2) = IAT
      NPASS = 1
      GO TO 380
  150 IF ( .NOT. KANDL) GO TO 200
C
C     ----- IAT = JAT ; KAT = LAT ----
C
      LSKIP = 1
      IF (KK .EQ. LL) GO TO 160
      SKIP1 = .FALSE.
      SKIP2 = .FALSE.
      NATOM(1) = IAT
      NATOM(2) = KAT
      NPASS = 1
      GO TO 380
  160 CONTINUE
      SKIP3 = .FALSE.
      SKIP4 = .FALSE.
      NATOM(1) = KAT
      NATOM(2) = IAT
      NPASS = 1
      GO TO 380
  200 CONTINUE
C
C     ----- IAT = JAT ; KAT ; LAT -----
C
      SKIP3 = .FALSE.
      SKIP4 = .FALSE.
      NATOM(1) = KAT
      NATOM(2) = LAT
      NATOM(3) = IAT
      NPASS = 2
      GO TO 380
  220 IF ( .NOT. IANDK) GO TO 280
      IF ( .NOT. IANDL) GO TO 240
C
C     ----- IAT = KAT = LAT ; JAT -----
C
      SKIP2 = .FALSE.
      NATOM(1) = JAT
      NATOM(2) = IAT
      NPASS = 1
      GO TO 380
  240 CONTINUE
      IF(.NOT.JANDL) GO TO 260
C
C     ----- IAT = KAT ; JAT = LAT -----
C
      LSKIP = 1
      SKIP1 = .FALSE.
      SKIP3 = .FALSE.
      NATOM(1) = IAT
      NATOM(2) = JAT
      NPASS = 1
      GO TO 380
  260 CONTINUE
C
C     ----- IAT = KAT ; JAT ; LAT -----
C
      SKIP2 = .FALSE.
      SKIP4 = .FALSE.
      NATOM(1) = JAT
      NATOM(2) = LAT
      NATOM(3) = IAT
      NPASS = 2
      GO TO 380
  280 IF ( .NOT. IANDL) GO TO 290
      IF ( .NOT. JANDK) GO TO 285
C
C     ----- IAT = LAT ; JAT = KAT -----
C
      LSKIP = 1
      SKIP2 = .FALSE.
      SKIP3 = .FALSE.
      NATOM(1) = JAT
      NATOM(2) = IAT
      NPASS = 1
      GO TO 380
  285 CONTINUE
C
C     ----- IAT = LAT ; JAT ; KAT
C
      SKIP2 = .FALSE.
      SKIP3 = .FALSE.
      NATOM(1) = JAT
      NATOM(2) = KAT
      NATOM(3) = IAT
      NPASS = 2
      GO TO 380
  290 IF ( .NOT. JANDK) GO TO 320
      IF ( .NOT. JANDL) GO TO 300
C
C     ----- JAT = KAT = LAT ; IAT -----
C
      SKIP1 = .FALSE.
      NATOM(1) = IAT
      NATOM(2) = JAT
      NPASS = 1
      GO TO 380
  300 CONTINUE
C
C     ----- JAT = KAT ; IAT ; LAT -----
C
      SKIP1 = .FALSE.
      SKIP4 = .FALSE.
      NATOM(1) = IAT
      NATOM(2) = LAT
      NATOM(3) = JAT
      NPASS = 2
      GO TO 380
  320 IF ( .NOT. JANDL) GO TO 340
C
C     ----- JAT = LAT ; IAT ; KAT -----
C
      SKIP1 = .FALSE.
      SKIP3 = .FALSE.
      NATOM(1) = IAT
      NATOM(2) = KAT
      NATOM(3) = JAT
      NPASS = 2
      GO TO 380
  340 IF ( .NOT. KANDL) GO TO 360
C
C     ----- KAT = LAT ; IAT ; JAT ----
C
      SKIP1 = .FALSE.
      SKIP2 = .FALSE.
      NATOM(1) = IAT
      NATOM(2) = JAT
      NATOM(3) = KAT
      NPASS = 2
      GO TO 380
  360 CONTINUE
C
C     ----- IAT ; JAT ; KAT ; LAT ----
C
      SKIP1 = .FALSE.
      SKIP2 = .FALSE.
      SKIP3 = .FALSE.
      NATOM(1) = IAT
      NATOM(2) = JAT
      NATOM(3) = KAT
      NATOM(4) = LAT
      NPASS = 3
C
C     -----
C
  380 CONTINUE
C
C     ----- ARRANGMENT OF SHELL  II,  JJ,  KK AND  LL -----
C     ----- FOLLOWING SKIP1, SKIP2, SKIP3 AND SKIP4   -----
C
      IF(.NOT.SKIP4) GO TO 400
      ISH = II
      JSH = JJ
      KSH = KK
      LSH = LL
      NSKIP1 = SKIP1
      NSKIP2 = SKIP2
      NSKIP3 = SKIP3
      GO TO 430
  400 IF(.NOT.SKIP3) GO TO 410
      ISH = II
      JSH = JJ
      KSH = LL
      LSH = KK
      NSKIP1 = SKIP1
      NSKIP2 = SKIP2
      NSKIP3 = SKIP4
      GO TO 430
  410 IF(.NOT.SKIP2) GO TO 420
      ISH = KK
      JSH = LL
      KSH = II
      LSH = JJ
      NSKIP1 = SKIP3
      NSKIP2 = SKIP4
      NSKIP3 = SKIP1
      GO TO 430
  420 IF(.NOT.SKIP1) GO TO 520
      ISH = KK
      JSH = LL
      KSH = JJ
      LSH = II
      NSKIP1 = SKIP3
      NSKIP2 = SKIP4
      NSKIP3 = SKIP2
  430 CONTINUE
      MSHL(1) = ISH
      MSHL(2) = JSH
      MSHL(3) = KSH
      MSHL(4) = LSH
      NSKIP(1) = NSKIP1
      NSKIP(2) = NSKIP2
      NSKIP(3) = NSKIP3
      DO 440 I = 1,3
      MGETDG(I) = 0
      SHLON(I) = .TRUE.
      IF(.NOT.NSKIP(I)) SHLON(I) = .FALSE.
  440 CONTINUE
      DO 445 I =4,6
  445 SHLON(I) = .TRUE.
      IF(.NOT.NSKIP(1) .AND. .NOT.NSKIP(2)) SHLON(4) = .FALSE.
      IF(.NOT.NSKIP(1) .AND. .NOT.NSKIP(3)) SHLON(5) = .FALSE.
      IF(.NOT.NSKIP(2) .AND. .NOT.NSKIP(3)) SHLON(6) = .FALSE.
      IF(NPASS.NE.1) GO TO 500
      IF(LSKIP.NE.1) GO TO 500
      IF(ISH .EQ. JSH . OR. KSH .EQ. LSH) GO TO 450
      IF(ISH .EQ. KSH .AND. JSH .EQ. LSH) GO TO 450
      IF(ISH .EQ. LSH .AND. JSH .EQ. KSH) GO TO 450
      GO TO 500
  450 CONTINUE
      DO 490 I = 1,3
      IF(.NOT.NSKIP(I)) GO TO 490
      GO TO (460,470,480),I
  460 MGETDG(3) = 2
      SHLON (3) = .TRUE.
      GO TO 500
  470 MGETDG(3) = 1
      SHLON (3) = .TRUE.
      GO TO 500
  480 MGETDG(2) = 1
      SHLON (2) = .TRUE.
  490 CONTINUE
  500 CONTINUE
      IF (OUT)
     *    WRITE (IW,9008) II,JJ,KK,LL,SKIP1,SKIP2,SKIP3,SKIP4,
     *                    NPASS,(NATOM(I),I = 1,4)
      RETURN
  520 CONTINUE
      IF (MASWRK) WRITE (IW,9028)
      CALL ABRT
      STOP
 9008 FORMAT(/,24H --------  II,JJ,KK,LL =,4I3,14H SKIP1,2,3,4 =,4L3,
     1     8H NPASS =,I2,10H CENTERS =,4I5,/)
 9028 FORMAT(1X,'IN -JDDATM- , ALL SKIP PARAMETERS ARE TRUE.')
      END
C*MODULE HSS2A   *DECK JDDDCI
      SUBROUTINE JDDDCI(II,JJ,KK,LL,D,IX,NINTMX,DABMAX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SHLON,SKIP1,SKIP2,SKIP3,SKIP4
C
      DIMENSION D(*),IX(*)
      DIMENSION NDIF(4)
C
      PARAMETER (MXGTOT=20000, MXSH=5000, NDAB=1296)
C
      COMMON /CIJDD / NDMAX,ND,MD
      COMMON /INTJDD/ FDRV(3,4),SDRV(9,4,4),ABDENS(NDAB)
      COMMON /JDDSKP/ MSHL(4),MGETDG(3),SHLON(6),SKIP1,SKIP2,SKIP3,SKIP4
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (PT5=0.5D+00, ZERO=0.0D+00)
C
      DATA NFT16 /16/
C
C     ----- READ 2 BODY DENSITY ELEMENTS FROM DISK FOR MCSCF -----
C
      DABMAX = ZERO
      NDABI = 0
      NDABJ = 0
      NDABK = 0
      NDABL = 0
      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
      CALL VCLR(ABDENS,1,NDAB)
C
C     ----- PERMUTE THE SHELLS THE SAME WAY AS JDDATM DOES -----
C     PERMUTE HIGHEST ANGULAR MOMENTUM SHELL TO THE RIGHTMOST
C
      ITYP = KTYPE(II)
      JTYP = KTYPE(JJ)
      KTYP = KTYPE(KK)
      LTYP = KTYPE(LL)
      MAXTYP=MAX(ITYP,JTYP,KTYP,LTYP)
      IF(MAXTYP.NE.LTYP) GO TO 10
      NDENI=1
      NDENJ=2
      NDENK=3
      NDENL=4
      GO TO 40
   10 IF(MAXTYP.NE.KTYP) GO TO 20
      NDENI=1
      NDENJ=2
      NDENK=4
      NDENL=3
      GO TO 40
   20 IF(MAXTYP.NE.JTYP) GO TO 30
      NDENI=3
      NDENJ=4
      NDENK=1
      NDENL=2
      GO TO 40
   30 CONTINUE
      NDENI=3
      NDENJ=4
      NDENK=2
      NDENL=1
   40 CONTINUE
C
C     ----- NOW THE SKIPS, AT LEAST ONE WILL BE TRUE -----
C
      IF(SKIP4) THEN
         NDABI = NDENI
         NDABJ = NDENJ
         NDABK = NDENK
         NDABL = NDENL
         GO TO 100
      END IF
      IF(SKIP3) THEN
         NDABI = NDENI
         NDABJ = NDENJ
         NDABK = NDENL
         NDABL = NDENK
         GO TO 100
      END IF
      IF(SKIP2) THEN
         NDABI = NDENK
         NDABJ = NDENL
         NDABK = NDENI
         NDABL = NDENJ
         GO TO 100
      END IF
      IF(SKIP1) THEN
         NDABI = NDENK
         NDABJ = NDENL
         NDABK = NDENJ
         NDABL = NDENI
      END IF
C
C     END OF DM2 FOR EACH SHELL IS INDICATED BY A ZERO LABEL AND
C     DENSITY ELEMENT, AND IN GENERAL MANY SHELL SETS LIVE IN A
C     SINGLE DISK BUFFER.  IF PART OF A BUFFER IS NOT YET PROCESSED
C     WE BRANCH TO 200, TO PROCESS VALUES REMAINING IN CURRENT BUFFER.
C
  100 CONTINUE
      IF(ND.GT.0) GO TO 200
C
C     ----- READ IN BUFFER OF -2DM- -----
C
  110 CONTINUE
      IF(MD.LE.0) RETURN
      CALL PREAD(NFT16,D,IX,MD,NINTMX)
      IF(MD.EQ.0) RETURN
      NDMAX=IABS(MD)
C
C     ----- SET UP -ABDENS- ARRAY -----
C
      ND=0
  200 CONTINUE
         ND=ND+1
         IF(ND.GT.NDMAX) GO TO 110
         VAL= D(ND)
C
         NPACK = ND
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL1 = IX( 2*NPACK - 1 )
*I32        LABEL2 = IX( 2*NPACK     )
*I32        IPACK = ISHFT( LABEL1, -16 )
*I32        JPACK = IAND( LABEL1, 65535 )
*I32        KPACK = ISHFT( LABEL2, -16 )
*I32        LPACK = IAND( LABEL2, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK = ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND( LABEL, 255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         END IF
C
C         ALL FOUR LABELS VANISHING IS END OF THIS SHELL'S 2PDM
C
         IF(IPACK.EQ.0) RETURN
C
         IG = IPACK + LOCI
         JG = JPACK + LOCJ
         KG = KPACK + LOCK
         LG = LPACK + LOCL
         NDIF(1)= IPACK-MINI
         NDIF(2)= JPACK-MINJ
         NDIF(3)= KPACK-MINK
         NDIF(4)= LPACK-MINL
         NIJKL = 216*NDIF(NDABI) + 36*NDIF(NDABJ)
     *         +   6*NDIF(NDABK) +    NDIF(NDABL) + 1
         IF(IG.EQ.KG  .AND.  JG.EQ.LG) VAL=VAL*PT5
         ABDENS(NIJKL)=VAL
         IF(ABS(VAL).GT.DABMAX) DABMAX=ABS(VAL)
      GO TO 200
      END
C*MODULE HSS2A   *DECK JDDDGV
      SUBROUTINE JDDDGV(II,JJ,KK,LL,Q4,NOCORE,NOOPEN,
     *                  IA,DC,V,NDIM,DABMAX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NOCORE,NOOPEN
C
      DIMENSION IA(*),DC(*),V(NDIM,*)
C
      PARAMETER (MXGTOT=20000, MXSH=5000, MXAO=8192)
C
      COMMON /INTJDD/ FDRV(3,4),SDRV(9,4,4),ABDENS(1296)
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NMOGVB,NCONF(MXAO),NHAM
      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
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00, EIGHT=8.0D+00)
      PARAMETER (NDGTI=216, NDGTJ=36, NDGTK=6, NDGTL=1)
C
C     ----- GENERATE 2 BODY DENSITY FOR GVB WAVEFUNCTIONS -----
C
      DABMAX=ZERO
      MINI=KMIN(II)
      MINJ=KMIN(JJ)
      MINK=KMIN(KK)
      MINL=KMIN(LL)
      MAXI=KMAX(II)
      MAXJ=KMAX(JJ)
      MAXK=KMAX(KK)
      MAXL=KMAX(LL)
      LOCI=KLOC(II)-MINI
      LOCJ=KLOC(JJ)-MINJ
      LOCK=KLOC(KK)-MINK
      LOCL=KLOC(LL)-MINL
      NI=1
      DO 1700 I=MINI,MAXI
      NJ=NI
      DO 1600 J=MINJ,MAXJ
      NK=NJ
      DO 1500 K=MINK,MAXK
      NL=NK
      DO 1400 L=MINL,MAXL
      NN=NL
      I1=LOCI+I
      I2=LOCJ+J
      I3=LOCK+K
      I4=LOCL+L
      IF(I1.GE.I2) GO TO 700
      N=I1
      I1=I2
      I2=N
  700 IF(I3.GE.I4) GO TO 800
      N=I3
      I3=I4
      I4=N
  800 IF(I1-I3) 900,1000,1100
  900 N=I1
      I1=I3
      I3=N
      N=I2
      I2=I4
      I4=N
      GO TO 1100
 1000 IF(I2.LT.I4) GO TO 900
 1100 CONTINUE
      MIJ=IA(I1)+I2
      MIK=IA(I1)+I3
      MIL=IA(I1)+I4
      MKL=IA(I3)+I4
      IF(I2.LT.I3) GO TO 1150
      MJK=IA(I2)+I3
      MJL=IA(I2)+I4
      GO TO 1170
 1150 MJK=IA(I3)+I2
      IF(I2.LT.I4) GO TO 1160
      MJL=IA(I2)+I4
      GO TO 1170
 1160 MJL=IA(I4)+I2
 1170 CONTINUE
      DFAC = ZERO
C
C            CONTRIBUTION FROM CLOSED SHELLS
C
      IF(NOCORE) GO TO 1190
      DFAC = DFAC + ALPHA(1)* DC(MIJ)*DC(MKL) +
     1          PT5* BETA(1)*(DC(MIK)*DC(MJL) + DC(MIL)*DC(MJK))
C
C            INTERACTION BETWEEN CORE AND OPEN/PAIR SHELLS
C
      IF(NOOPEN) GO TO 1210
      NCO1 = NCO + 1
      DO 1180 IO = NCO1,NMOGVB
      IOJO = IA(NCONF(IO)) + 1
      DFAC = DFAC + ALPHA(IOJO)*(DC(MIJ)*V(I3,IO)*V(I4,IO)
     1                          +DC(MKL)*V(I1,IO)*V(I2,IO)) +
     1 PT5*BETA(IOJO)*(V(I2,IO)*(DC(MIK)*V(I4,IO)
     1                          +DC(MIL)*V(I3,IO)) +
     1                 V(I1,IO)*(DC(MJL)*V(I3,IO)
     1                          +DC(MJK)*V(I4,IO)))
 1180 CONTINUE
C
C            INTERACTION BETWEEN OPEN/PAIR AND OPEN/PAIR SHELLS
C
 1190 CONTINUE
      IF(NOOPEN) GO TO 1210
      NCO1 = NCO + 1
      DO 1200  IO = NCO1,NMOGVB
      DO 1200  JO = NCO1,NMOGVB
      IOF = NCONF(IO)
      JOF = NCONF(JO)
      IOJO = IA(IOF) + JOF
      IF(JOF.GT.IOF) IOJO = IA(JOF) + IOF
      DFAC = DFAC +
     1       ALPHA(IOJO)*V(I1,IO)*V(I2,IO)*V(I3,JO)*V(I4,JO) +
     1   PT5* BETA(IOJO)*V(I1,IO)*V(I2,JO)*
     1                  (V(I3,IO)*V(I4,JO)+V(I4,IO)*V(I3,JO))
 1200 CONTINUE
 1210 CONTINUE
      IF(I1.EQ.I2) DFAC=DFAC*PT5
      IF(I3.EQ.I4) DFAC=DFAC*PT5
      IF(I1.EQ.I3.AND.I2.EQ.I4) DFAC=DFAC*PT5
      DFAC=DFAC*EIGHT*Q4
      IF(ABS(DFAC).GT.DABMAX) DABMAX=ABS(DFAC)
      ABDENS(NN)=DFAC
 1400 NL=NL+NDGTL
 1500 NK=NK+NDGTK
 1600 NJ=NJ+NDGTJ
 1700 NI=NI+NDGTI
      RETURN
      END
C*MODULE HSS2A   *DECK JDDDHF
      SUBROUTINE JDDDHF(II,JJ,KK,LL,Q4,RHFTYP,IA,DTOT,DSPN,DABMAX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL RHFTYP
C
      DIMENSION IA(*),DTOT(*),DSPN(*)
C
      PARAMETER (MXGTOT=20000, MXSH=5000)
C
      COMMON /INTJDD/ FDRV(3,4),SDRV(9,4,4),ABDENS(1296)
      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
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00, FOUR=4.0D+00)
C
      DATA NDGTI,NDGTJ,NDGTK,NDGTL /216, 36,  6,  1/
C
C     ----- COMPUTE 2 BODY DENSITY FOR RHF,UHF,ROHF -----
C
      DABMAX=ZERO
      MINI=KMIN(II)
      MINJ=KMIN(JJ)
      MINK=KMIN(KK)
      MINL=KMIN(LL)
      MAXI=KMAX(II)
      MAXJ=KMAX(JJ)
      MAXK=KMAX(KK)
      MAXL=KMAX(LL)
      LOCI=KLOC(II)-MINI
      LOCJ=KLOC(JJ)-MINJ
      LOCK=KLOC(KK)-MINK
      LOCL=KLOC(LL)-MINL
      NI=1
      DO 1700 I=MINI,MAXI
      NJ=NI
      DO 1600 J=MINJ,MAXJ
      NK=NJ
      DO 1500 K=MINK,MAXK
      NL=NK
      DO 1400 L=MINL,MAXL
      NN=NL
      I1=LOCI+I
      I2=LOCJ+J
      I3=LOCK+K
      I4=LOCL+L
      IF(I1.GE.I2) GO TO 700
      N=I1
      I1=I2
      I2=N
  700 IF(I3.GE.I4) GO TO 800
      N=I3
      I3=I4
      I4=N
  800 IF(I1-I3) 900,1000,1100
  900 N=I1
      I1=I3
      I3=N
      N=I2
      I2=I4
      I4=N
      GO TO 1100
 1000 IF(I2.LT.I4) GO TO 900
 1100 CONTINUE
      MIJ=IA(I1)+I2
      MIK=IA(I1)+I3
      MIL=IA(I1)+I4
      MKL=IA(I3)+I4
      IF(I2.LT.I3) GO TO 1150
      MJK=IA(I2)+I3
      MJL=IA(I2)+I4
      GO TO 1170
 1150 MJK=IA(I3)+I2
      IF(I2.LT.I4) GO TO 1160
      MJL=IA(I2)+I4
      GO TO 1170
 1160 MJL=IA(I4)+I2
 1170 CONTINUE
      DFAC= DTOT(MIJ)*DTOT(MKL)*FOUR
     *     -DTOT(MIK)*DTOT(MJL)
     *     -DTOT(MIL)*DTOT(MJK)
      IF(.NOT.RHFTYP) DFAC=DFAC-DSPN(MIK)*DSPN(MJL)
     *                         -DSPN(MIL)*DSPN(MJK)
      IF(I1.EQ.I2) DFAC=DFAC*PT5
      IF(I3.EQ.I4) DFAC=DFAC*PT5
      IF(I1.EQ.I3.AND.I2.EQ.I4) DFAC=DFAC*PT5
      DFAC=DFAC*Q4
      IF(ABS(DFAC).GT.DABMAX) DABMAX=ABS(DFAC)
      ABDENS(NN)=DFAC
 1400 NL=NL+NDGTL
 1500 NK=NK+NDGTK
 1600 NJ=NJ+NDGTJ
 1700 NI=NI+NDGTI
      RETURN
      END
C*MODULE HSS2A   *DECK JDDDIJ
      SUBROUTINE JDDDIJ(NELEC,NGX,NGY,NXY00,NXY01,NXY10,NXY11,
     1                  NXY02,NXY20,
     2                  DXY00,DXY01,DXY10,DXY11,DXY02,DXY20,
     3                  NXY1,NXY2,NXY3,NXY4)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NORM,IANDJ,KANDL,SAME,XANDY
      LOGICAL LSKIP1,LSKIP2,LSKIP3,LSKIP4,LSKIP5,LSKIP6,
     1        NSKIP1,NSKIP2,NSKIP3,NSKIP4,NSKIP5,NSKIP6,
     2        NSKIP7,NSKIP8,NSKIP9
C
      DIMENSION DXY00(NXY1),DXY01(NXY2),DXY10(NXY2),
     1          DXY11(NXY4),DXY02(NXY3),DXY20(NXY3)
C
      PARAMETER (MXGSH=30)
C
      COMMON /EQUJDD/ IANDJ,KANDL,SAME
      COMMON /INFJDD/ GA(MXGSH),CSA(MXGSH),CPA(MXGSH),CDA(MXGSH),
     1                GB(MXGSH),CSB(MXGSH),CPB(MXGSH),CDB(MXGSH),
     2                GC(MXGSH),CSC(MXGSH),CPC(MXGSH),CDC(MXGSH),
     3                GD(MXGSH),CSD(MXGSH),CPD(MXGSH),CDD(MXGSH),
     4                XI,YI,ZI,XJ,YJ,ZJ,RRI,XK,YK,ZK,XL,YL,ZL,RRK,
     5                NGA,NGB,NGC,NGD
      COMMON /JDDSTV/ NFORB(4),NSORB(4),NFTABL(13,4),NSTABL(22,4),
     1                LFTABL(20,2),LSTABL(35,2)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /SHLJDD/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     1                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     2                NIJ,IJD,KLD,IJ,KL
      COMMON /SKPJDD/ NSKIP1,NSKIP2,NSKIP3,NSKIP4,NSKIP5,NSKIP6,
     1                NSKIP7,NSKIP8,NSKIP9
C
      DATA ONE,SQRT3 /1.0D+00,1.73205080756888D+00/
C
      NORM=NORMF.NE.1.OR.NORMP.NE.1
      IF(NELEC.EQ.2) GO TO 200
      LSKIP1 = NSKIP3 .AND. NSKIP6
      LSKIP2 = NSKIP1 .AND. NSKIP8
      LSKIP3 = NSKIP4
      LSKIP4 = NSKIP2 .AND. NSKIP9
      LSKIP5 = NSKIP5
      LSKIP6 = NSKIP7
C
C     ----- COEFFICIENTS FOR II, JJ SHELLS -----
C
      MINX=MINI
      MINY=MINJ
      MAXX=MAXI
      MAXY=MAXJ
      NTYPX=(MAXX-MINX+1)/2+1
      NTYPY=(MAXY-MINY+1)/2+1
      AX=GA(NGX)
      AY=GB(NGY)
      AX2=2.0D+00*AX
      AX4=AX2*AX2
      AY2=2.0D+00*AY
      AY4=AY2*AY2
      GO TO (101,102,103,104),NTYPX
  101 CSX = CSA(NGX)
      CPXF= AX2*CSX
      CSXS=-AX2*CSX
      CDXS= AX4*CSX
      GO TO 150
  102 CPX = CPA(NGX)
      CSXF=-CPX
      CDXF= AX2*CPX
      CPXS=-AX2*CPX
      CFXS= AX4*CPX
      GO TO 150
  103 CSX = CSA(NGX)
      CPX = CPA(NGX)
      CPXF= AX2*CSX
      CSXF=-CPX
      CDXF= AX2*CPX
      CSXS=-AX2*CSX
      CDXS= AX4*CSX
      CPXS=-AX2*CPX
      CFXS= AX4*CPX
      GO TO 150
  104 CDX = CDA(NGX)
      CPXF=-CDX
      CFXF= AX2*CDX
      CSXS= CDX
      CDXS=-AX2*CDX
      CGXS= AX4*CDX
  150 CONTINUE
      GO TO (151,152,153,154),NTYPY
  151 CSY = CSB(NGY)
      CPYF= AY2*CSY
      CSYS=-AY2*CSY
      CDYS= AY4*CSY
      GO TO 180
  152 CPY = CPB(NGY)
      CSYF=-CPY
      CDYF= AY2*CPY
      CPYS=-AY2*CPY
      CFYS= AY4*CPY
      GO TO 180
  153 CSY = CSB(NGY)
      CPY = CPB(NGY)
      CPYF= AY2*CSY
      CSYF=-CPY
      CDYF= AY2*CPY
      CSYS=-AY2*CSY
      CDYS= AY4*CSY
      CPYS=-AY2*CPY
      CFYS= AY4*CPY
      GO TO 180
  154 CDY = CDB(NGY)
      CPYF=-CDY
      CFYF= AY2*CDY
      CSYS= CDY
      CDYS=-AY2*CDY
      CGYS= AY4*CDY
  180 CONTINUE
      XANDY=IANDJ
      GO TO 300
C
C     ----- COEFFICIENTS FOR KK, LL SHELLS -----
C
  200 CONTINUE
      LSKIP1 = NSKIP1 .AND. NSKIP2 .AND. NSKIP4 .AND.
     1         NSKIP5 .AND. NSKIP7
      LSKIP2 = NSKIP3 .AND. NSKIP8 .AND. NSKIP9
      LSKIP3 = NSKIP6
      MINX=MINK
      MINY=MINL
      MAXX=MAXK
      MAXY=MAXL
      NTYPX=(MAXX-MINX+1)/2+1
      NTYPY=(MAXY-MINY+1)/2+1
      AX=GC(NGX)
      AY=GD(NGY)
      AX2=2.0D+00*AX
      AX4=AX2*AX2
      AY2=2.0D+00*AY
      AY4=AY2*AY2
      GO TO (201,202,203,204),NTYPX
  201 CSX = CSC(NGX)
      CPXF= AX2*CSX
      CSXS=-AX2*CSX
      CDXS= AX4*CSX
      GO TO 250
  202 CPX = CPC(NGX)
      CSXF=-CPX
      CDXF= AX2*CPX
      CPXS=-AX2*CPX
      CFXS= AX4*CPX
      GO TO 250
  203 CSX = CSC(NGX)
      CPX = CPC(NGX)
      CPXF= AX2*CSX
      CSXF=-CPX
      CDXF= AX2*CPX
      CSXS=-AX2*CSX
      CDXS= AX4*CSX
      CPXS=-AX2*CPX
      CFXS= AX4*CPX
      GO TO 250
  204 CDX = CDC(NGX)
      CPXF=-CDX
      CFXF= AX2*CDX
      CSXS= CDX
      CDXS=-AX2*CDX
      CGXS= AX4*CDX
  250 CONTINUE
      GO TO (251,252,253,254),NTYPY
  251 CSY = CSD(NGY)
      CPYF= AY2*CSY
      CSYF=-AY2*CSY
      CDYF= AY4*CSY
      GO TO 280
  252 CPY = CPD(NGY)
      CSYF=-CPY
      CDYF= AY2*CPY
      CPYS=-AY2*CPY
      CFYS= AY4*CPY
      GO TO 280
  253 CSY = CSD(NGY)
      CPY = CPD(NGY)
      CPYF= AY2*CSY
      CSYF=-CPY
      CDYF= AY2*CPY
      CSYS=-AY2*CSY
      CDYS= AY4*CSY
      CPYS=-AY2*CPY
      CFYS= AY4*CPY
      GO TO 280
  254 CDY = CDD(NGY)
      CPYF=-CDY
      CFYF= AY2*CDY
      CSYS= CDY
      CDYS=-AY2*CDY
      CGYS= AY4*CDY
  280 CONTINUE
      XANDY=KANDL
  300 CONTINUE
      A=ONE/(AX+AY)
      N00=0
      N10=0
      N20=0
C
C     -----  DO LOOP FOR SHELL Y WITHOUT DEFFERENTIATION    -----
C
      DO 10 JN0=MINY,MAXY
      GO TO (301,302,310,310,303,310,310,304,310,310),JN0
  301 D=A*CSY
      GO TO 310
  302 D=A*CPY
      GO TO 310
  303 D=A*CDY
      GO TO 310
  304 IF(NORM) D=D*SQRT3
C
C     ----- DO LOOP FOR SHELL WITHOUT DIFFERENTIATION -----
C
  310 IF(LSKIP1) GO TO 315
      IF(XANDY ) MAXX=JN0
      DO 20 IN0=MINX,MAXX
      GO TO (311,312,320,320,313,320,320,314,320,320),IN0
  311 F=D*CSX
      GO TO 320
  312 F=D*CPX
      GO TO 320
  313 F=D*CDX
      GO TO 320
  314 IF(NORM) F=F*SQRT3
  320 N00=N00+1
      DXY00(N00)=F
   20 CONTINUE
C
C     -----     DO LOOP FOR X SHELL TO GET FIRST DERIVATIVES    -----
C
  315 IF(LSKIP2) GO TO 340
      MXX=NFORB(NTYPX)
      DO 30 IN1=1,MXX
      NORBX=NFTABL(IN1,NTYPX)
      GO TO (321,322,330,330,323,330,330,330,330,330,
     1       324,330,330,330,330,330,330,330,330,330),NORBX
  321 F=D*CSXF
      GO TO 330
  322 F=D*CPXF
      GO TO 330
  323 F=D*CDXF
      GO TO 330
  324 F=D*CFXF
  330 N10=N10+1
      DXY10(N10)=F
   30 CONTINUE
C
C     ----- DO LOOP FOR X SHELL TO GET SECOND DERIVATIVES -----
C
  340 IF(LSKIP3) GO TO 10
      MXX=NSORB(NTYPX)
      DO 40 IN2=1,MXX
      NORBX=NSTABL(IN2,NTYPX)
      GO TO (341,342,350,350,343,350,350,350,350,350,
     1       344,350,350,350,350,350,350,350,350,350,
     2       345,350,350,350,350,350,350,350,350,350,
     3       350,350,350,350,350),NORBX
  341 F=D*CSXS
      GO TO 350
  342 F=D*CPXS
      GO TO 350
  343 F=D*CDXS
      GO TO 350
  344 F=D*CFXS
      GO TO 350
  345 F=D*CGXS
  350 N20=N20+1
      DXY20(N20)=F
   40 CONTINUE
   10 CONTINUE
      NXY00=N00
      NXY10=N10
      NXY20=N20
C
C     ----- DO LOOP FOR X SHELL WITHOUT DIFFERENTIATION -----
C
      IF(NELEC.EQ.2) GO TO 1000
      N01=0
      N02=0
      DO 50 NI0=MINX,MAXX
      GO TO (501,502,510,510,503,510,510,504,510,510),NI0
  501 D=A*CSX
      GO TO 510
  502 D=A*CPX
      GO TO 510
  503 D=A*CDX
      GO TO 510
  504 IF(NORM) D=D*SQRT3
  510 CONTINUE
C
C     ----- DO LOOP FOR Y SHELL TO GET FIRST DERIVATIVES -----
C
      IF(LSKIP4) GO TO 700
      MXY=NFORB(NTYPY)
      DO 60 JN1=1,MXY
      NORBY=NFTABL(JN1,NTYPY)
      GO TO (601,602,610,610,603,610,610,610,610,610,
     1       604,610,610,610,610,610,610,610,610,610),NORBY
  601 F=D*CSYF
      GO TO 610
  602 F=D*CPYF
      GO TO 610
  603 F=D*CDYF
      GO TO 610
  604 F=D*CFYF
  610 N01=N01+1
      DXY01(N01)=F
   60 CONTINUE
C
C     ----- DO LOOP FOR Y SHELL TO GET SECOND DERIVATIVES -----
C
  700 IF(LSKIP5) GO TO 50
      MXY=NSORB(NTYPY)
      DO 70 JN2=1,MXY
      NORBY=NSTABL(JN2,NTYPY)
      GO TO (701,702,710,710,703,710,710,710,710,710,
     1       704,710,710,710,710,710,710,710,710,710,
     2       705,710,710,710,710,710,710,710,710,710,
     3       710,710,710,710,710),NORBY
  701 F=D*CSYS
      GO TO 710
  702 F=D*CPYS
      GO TO 710
  703 F=D*CDYS
      GO TO 710
  704 F=D*CFYS
      GO TO 710
  705 F=D*CGYS
  710 N02=N02+1
      DXY02(N02)=F
   70 CONTINUE
   50 CONTINUE
C
C     ----- DO LOOP FOR Y SHELL TO GET FIRST DERIVATIVES -----
C
      IF(LSKIP6) GO TO 950
      MXY=NFORB(NTYPY)
      MXX=NFORB(NTYPX)
      N11=0
      DO 80 JN1=1,MXY
      NORBY=NFTABL(JN1,NTYPY)
      GO TO (801,802,810,810,803,810,810,810,810,810,
     1       804,810,810,810,810,810,810,810,810,810),NORBY
  801 D=A*CSYF
      GO TO 810
  802 D=A*CPYF
      GO TO 810
  803 D=A*CDYF
      GO TO 810
  804 D=A*CFYF
  810 CONTINUE
C
C     ----- DO LOOP X SHELL TO GET FIRST DERIVATIVES -----
C
      DO 90 IN1=1,MXX
      NORBX=NFTABL(IN1,NTYPX)
      GO TO (851,852,860,860,853,860,860,860,860,860,
     1       854,860,860,860,860,860,860,860,860,860),NORBX
  851 F=D*CSXF
      GO TO 860
  852 F=D*CPXF
      GO TO 860
  853 F=D*CDXF
      GO TO 860
  854 F=D*CFXF
  860 N11=N11+1
      DXY11(N11)=F
   90 CONTINUE
   80 CONTINUE
  950 CONTINUE
      NXY01=N01
      NXY02=N02
      NXY11=N11
 1000 CONTINUE
      RETURN
      END
C*MODULE HSS2A   *DECK JDDDMC
      SUBROUTINE JDDDMC(II,JJ,KK,LL,ISH,JSH,KSH,LSH,VTPDM,MAXSHL,
     *                  NCORSV,NACT,Q4,DABMAX,DC,DV)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SKIP1,SKIP2,SKIP3,SKIP4,SHLON
      DIMENSION VTPDM(*),DC(*),DV(*)
C
      PARAMETER (MXAO=8192, MXGTOT=20000, MXSH=5000)
      PARAMETER (NDAB=1296)
      PARAMETER (ZERO=0.0D+00,PT25=0.25D+00,PT5=0.5D+00)
      PARAMETER (FOUR=4.0D+00)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTJDD/ FDRV(3,4),SDRV(9,4,4),ABDENS(NDAB)
      COMMON /JDDSKP/ MSHL(4),MGETGG(3),SHLON(6),SKIP1,SKIP2,SKIP3,SKIP4
      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
      ITYP = KTYPE(II)
      JTYP = KTYPE(JJ)
      KTYP = KTYPE(KK)
      LTYP = KTYPE(LL)
      MAXTYP = MAX(ITYP,JTYP,KTYP,LTYP)
      IF(MAXTYP.NE.LTYP) GO TO 10
      NDENI = 1
      NDENJ = MAXSHL
      NDENK = MAXSHL*MAXSHL
      NDENL = MAXSHL*MAXSHL*MAXSHL
      GO TO 40
   10 IF(MAXTYP.NE.KTYP) GO TO 20
      NDENI = 1
      NDENJ = MAXSHL
      NDENK = MAXSHL*MAXSHL*MAXSHL
      NDENL = MAXSHL*MAXSHL
      GO TO 40
   20 IF(MAXTYP.NE.JTYP) GO TO 30
      NDENI = MAXSHL*MAXSHL
      NDENJ = MAXSHL*MAXSHL*MAXSHL
      NDENK = 1
      NDENL = MAXSHL
      GO TO 40
   30 CONTINUE
      NDENI = MAXSHL*MAXSHL
      NDENJ = MAXSHL*MAXSHL*MAXSHL
      NDENK = MAXSHL
      NDENL = 1
   40 CONTINUE
C
      IF(SKIP4) THEN
        IMX = NDENI
        JMX = NDENJ
        KMX = NDENK
        LMX = NDENL
        GO TO 50
      END IF
      IF(SKIP3) THEN
        IMX = NDENI
        JMX = NDENJ
        KMX = NDENL
        LMX = NDENK
        GO TO 50
      END IF
      IF(SKIP2) THEN
        IMX = NDENK
        JMX = NDENL
        KMX = NDENI
        LMX = NDENJ
        GO TO 50
      END IF
      IF(SKIP1) THEN
        IMX = NDENK
        JMX = NDENL
        KMX = NDENJ
        LMX = NDENI
      END IF
   50 CONTINUE
C
C     INITIALIZE ABDENS USING THE VALENCE PORTION OF THE BACK
C     TRANSFORMED TWO-PARTICLE DENSITY MATRIX
C
      MINI = KMIN(ISH)
      MINJ = KMIN(JSH)
      MINK = KMIN(KSH)
      MINL = KMIN(LSH)
      MAXI = KMAX(ISH)
      MAXJ = KMAX(JSH)
      MAXK = KMAX(KSH)
      MAXL = KMAX(LSH)
      LOCI = KLOC(ISH)-MINI
      LOCJ = KLOC(JSH)-MINJ
      LOCK = KLOC(KSH)-MINK
      LOCL = KLOC(LSH)-MINL
C
      DO 200 IDIM=MINI,MAXI
        DO 200 JDIM=MINJ,MAXJ
          DO 200 KDIM=MINK,MAXK
            DO 200 LDIM=MINL,MAXL
              IN = LOCI + IDIM
              JN = LOCJ + JDIM
              IF(IN.LT.JN) THEN
                NN = IN
                IN = JN
                JN = NN
              END IF
              KN = LOCK + KDIM
              LN = LOCL + LDIM
              IF(KN.LT.LN) THEN
                NN = KN
                KN = LN
                LN = NN
              END IF
              IF(IN.LT.KN.OR.(IN.EQ.KN.AND.JN.LT.LN)) THEN
                NN = IN
                IN = KN
                KN = NN
                NN = JN
                JN = LN
                LN = NN
              END IF
C
              NN = 216*(IDIM-MINI) + 36*(JDIM-MINJ) +
     *             6*(KDIM-MINK) + LDIM-MINL + 1
              MM = IMX*(IDIM-1) + JMX*(JDIM-1) + KMX*(KDIM-1) +
     *             LMX*(LDIM-1) + 1
              ABDENS(NN) = ZERO
C
              IF(NACT.EQ.0) GO TO 100
C
C     -------- VALENCE ORBITAL CONTRIBUTION ---------
C
              ABDENS(NN) = VTPDM(MM)
C
  100 CONTINUE
C     -------- CORE-CORE ORBITAL CONTRIBUTION ---------
C
C
              IJ = IA(IN) + JN
              KL = IA(KN) + LN
              IK = IA(IN) + KN
              IL = IA(IN) + LN
              IF(JN.GE.KN) THEN
                JK = IA(JN) + KN
                JL = IA(JN) + LN
              ELSE
                JK = IA(KN) + JN
                JL = IA(LN) + JN
                IF(JN.GT.LN) JL = IA(JN) + LN
              END IF
C
              IF(NCORSV.EQ.0) GO TO 110
C
              ABDENS(NN) = ABDENS(NN) + DC(IJ)*DC(KL)
     *                     - PT25*(DC(IK)*DC(JL) + DC(IL)*DC(JK))
C
C     -------- CORE-VALENCE ORBITAL CONTRIBUTION ---------
C
              IF(NACT.EQ.0) GO TO 110
C
              ABDENS(NN) = ABDENS(NN) + DC(IJ)*DV(KL)
     *                     + DC(KL)*DV(IJ) - PT25*(DC(IK)*DV(JL)
     *                     + DC(IL)*DV(JK) + DC(JK)*DV(IL)
     *                     + DC(JL)*DV(IK))
C
  110 CONTINUE
              IF(IN.EQ.JN) ABDENS(NN) = ABDENS(NN)*PT5
              IF(KN.EQ.LN) ABDENS(NN) = ABDENS(NN)*PT5
              IF(IN.EQ.KN.AND.JN.EQ.LN) THEN
                ABDENS(NN) = ABDENS(NN)*PT5
              END IF
              ABDENS(NN) = ABDENS(NN)*FOUR*Q4
              IF(ABS(ABDENS(NN)).GT.DABMAX) DABMAX = ABS(ABDENS(NN))
  200 CONTINUE
C
      RETURN
      END
C*MODULE HSS2A   *DECK JDDGEN
      SUBROUTINE JDDGEN(GIJKL1,GIJKL2,GIJKL3,GIJKL4,GIJKL5,GIJKL6,
     *                  GIJKL7,GIJKL8,GIJKL9)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NSKIP1,NSKIP2,NSKIP3,NSKIP4,NSKIP5,NSKIP6,
     *        NSKIP7,NSKIP8,NSKIP9
      LOGICAL RSKIP1,RSKIP2,RSKIP3
      LOGICAL FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF
C
      DIMENSION GIJKL1(2808),GIJKL2(2808),GIJKL3(2808),
     *          GIJKL4(4752),GIJKL5(4752),GIJKL6(4752),
     *          GIJKL7(6084),GIJKL8(6084),GIJKL9(6084)
      DIMENSION DIJ00( 36),DIJ01( 78),DIJ10( 78),DIJ11(169),
     *          DIJ02(132),DIJ20(132),DKL00( 36),DKL10( 78),
     *          DKL20(132),IN1(9)
C
      PARAMETER (MXGSH=30)
C
      COMMON /INFJDD/ AG(MXGSH),CSA(MXGSH),CPA(MXGSH),CDA(MXGSH),
     1                BG(MXGSH),CSB(MXGSH),CPB(MXGSH),CDB(MXGSH),
     2                CG(MXGSH),CSC(MXGSH),CPC(MXGSH),CDC(MXGSH),
     3                DG(MXGSH),CSD(MXGSH),CPD(MXGSH),CDD(MXGSH),
     4                XI,YI,ZI,XJ,YJ,ZJ,RRI,XK,YK,ZK,XL,YL,ZL,RRK,
     5                NGA,NGB,NGC,NGD
      COMMON /IDXDIJ/ NADIJ1( 78),NADKL1( 36),NADIJ2( 78),NADKL2( 36),
     1                NADIJ3( 36),NADKL3( 78),NADIJ4(132),NADKL4( 36),
     2                NADIJ5(132),NADKL5( 36),NADIJ6( 36),NADKL6(132),
     3                NADIJ7(169),NADKL7( 36),NADIJ8( 78),NADKL8( 78),
     4                NADIJ9( 78),NADKL9( 78)
      COMMON /IDXIJX/ NPIJX1( 78),NPKLX1( 36),NPIJX2( 78),NPKLX2( 36),
     1                NPIJX3( 36),NPKLX3( 78),NPIJX4(132),NPKLX4( 36),
     2                NPIJX5(132),NPKLX5( 36),NPIJX6( 36),NPKLX6(132),
     3                NPIJX7(169),NPKLX7( 36),NPIJX8( 78),NPKLX8( 78),
     4                NPIJX9( 78),NPKLX9( 78)
      COMMON /IDXIJY/ NPIJY1( 78),NPKLY1( 36),NPIJY2( 78),NPKLY2( 36),
     1                NPIJY3( 36),NPKLY3( 78),NPIJY4(132),NPKLY4( 36),
     2                NPIJY5(132),NPKLY5( 36),NPIJY6( 36),NPKLY6(132),
     3                NPIJY7(169),NPKLY7( 36),NPIJY8( 78),NPKLY8( 78),
     4                NPIJY9( 78),NPKLY9( 78)
      COMMON /IDXIJZ/ NPIJZ1( 78),NPKLZ1( 36),NPIJZ2( 78),NPKLZ2( 36),
     1                NPIJZ3( 36),NPKLZ3( 78),NPIJZ4(132),NPKLZ4( 36),
     2                NPIJZ5(132),NPKLZ5( 36),NPIJZ6( 36),NPKLZ6(132),
     3                NPIJZ7(169),NPKLZ7( 36),NPIJZ8( 78),NPKLZ8( 78),
     4                NPIJZ9( 78),NPKLZ9( 78)
      COMMON /SHLJDD/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     1                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     2                NIJ,IJD,KLD,IJ,KL
      COMMON /JDDDIF/ RSKIP1,RSKIP2,RSKIP3
      COMMON /HSSPAR/ FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /SKPJDD/ NSKIP1,NSKIP2,NSKIP3,NSKIP4,NSKIP5,NSKIP6,
     1                NSKIP7,NSKIP8,NSKIP9
      COMMON /XYZJDD/ BP01,B00,B10,XCP00,XC00,YCP00,YC00,ZCP00,ZC00,
     1                F00,DXIJ,DYIJ,DZIJ,DXKL,DYKL,DZKL,IN(9),
     1                KN(7),NI,NJ,NK,NL,NMAX,MMAX,IJ1,IJ2,KL1,KL2
C
      DATA PT5,ONE /0.5D+00,1.0D+00/
      DATA PI252/34.986836655250D+00/
      DATA RLN10 /2.30258D+00/
      DATA IJN1,IJN2,KLN1,KLN2 /75,15, 3, 1/
      DATA NIJ1,NIJ2,NIJ3,NIJ4 / 36, 78,132,169/
      DATA NIJKL1,NIJKL4,NIJKL7 / 2808, 4752, 6084/
C
      TOL=RLN10*ITOL
C
C     ----- SELECT EXPANSION CENTER FOR -XYZ- INTEGRALS -----
C
      MIT=LIT
      MJT=LJT
      MKT=LKT
      MLT=LLT
      IF(MFIRST     ) NRD = 1
      IF(MSECND     ) NRD = 2
      IF(.NOT.RSKIP1) MIT = LIT + NRD
      IF(.NOT.RSKIP2) MJT = LJT + NRD
      IF(.NOT.RSKIP3) MKT = LKT + NRD
      IF (MIT .LT. MJT) GO TO 100
      NI = MIT-1
      NJ = MJT-1
      IJ1 = IJN1
      IJ2 = IJN2
      XC = XI
      YC = YI
      ZC = ZI
      DXIJ = XI-XJ
      DYIJ = YI-YJ
      DZIJ = ZI-ZJ
      GO TO 120
  100 CONTINUE
      NI = MJT-1
      NJ = MIT-1
      IJ1 = IJN2
      IJ2 = IJN1
      XC = XJ
      YC = YJ
      ZC = ZJ
      DXIJ = XJ-XI
      DYIJ = YJ-YI
      DZIJ = ZJ-ZI
  120 CONTINUE
      IF (MKT .LT. MLT) GO TO 140
      NK = MKT-1
      NL = MLT-1
      KL1 = KLN1
      KL2 = KLN2
      XD = XK
      YD = YK
      ZD = ZK
      DXKL = XK-XL
      DYKL = YK-YL
      DZKL = ZK-ZL
      GO TO 160
  140 CONTINUE
      NK = MLT-1
      NL = MKT-1
      KL1 = KLN2
      KL2 = KLN1
      XD = XL
      YD = YL
      ZD = ZL
      DXKL = XL-XK
      DYKL = YL-YK
      DZKL = ZL-ZK
  160 CONTINUE
      IJ1 = IJ1*NROOTS
      IJ2 = IJ2*NROOTS
      KL1 = KL1*NROOTS
      KL2 = KL2*NROOTS
C
      NMAX = NI+NJ
      MMAX = NK+NL
      MAX = NMAX+1
      DO 180 I = 1,MAX
      N = I-1
      IF (N .LE. NI) IN1(I) = IJ1*N+1
      IF (N .GT. NI) IN1(I) = IJ1*NI+IJ2*(N-NI)+1
  180 CONTINUE
      MAX = MMAX+1
      DO 200 K=1,MAX
      N = K-1
      IF(N.LE.NK) KN(K) = KL1*N
      IF(N.GT.NK) KN(K) = KL1*NK+KL2*(N-NK)
  200 CONTINUE
C
C     ----- I PRIMITIVE -----
C
      DO 5500 IG=1,NGA
      AI = AG(IG)
      ARRI = AI*RRI
      AIXI = AI*XI
      AIYI = AI*YI
      AIZI = AI*ZI
C
C     ----- J PRIMITIVE -----
C
      DO 5400 JG=1,NGB
      AJ = BG(JG)
      A = AI+AJ
      A1 = ONE/A
      AARRI = AJ*ARRI*A1
      IF(AARRI.GT.TOL) GO TO 5400
      XA = (AIXI+AJ*XJ)*A1
      YA = (AIYI+AJ*YJ)*A1
      ZA = (AIZI+AJ*ZJ)*A1
      AXAD = A*(XA-XD)
      AYAD = A*(YA-YD)
      AZAD = A*(ZA-ZD)
      AXAC = A*(XA-XC)
      AYAC = A*(YA-YC)
      AZAC = A*(ZA-ZC)
C
C     ----- GET DENSITY FOR IJ PRIMITIVE PAIR -----
C
      CALL JDDDIJ(1,IG,JG,NIJ00,NIJ01,NIJ10,NIJ11,NIJ02,NIJ20,
     1            DIJ00,DIJ01,DIJ10,DIJ11,DIJ02,DIJ20,
     2            NIJ1,NIJ2,NIJ3,NIJ4)
C
C     ----- K PRIMITIVE
C
      DO 560 KG = 1,NGC
      AK = CG(KG)
      BRRK = AK*RRK
      AKXK = AK*XK
      AKYK = AK*YK
      AKZK = AK*ZK
C
C     ----- L PRIMITIVE
C
      DO 540 LG = 1,NGD
      AL = DG(LG)
      B = AK+AL
      B1 = ONE/B
      BBRRK = AL*BRRK*B1
      IF (BBRRK .GT. TOL) GO TO 540
      XB = (AKXK+AL*XL)*B1
      YB = (AKYK+AL*YL)*B1
      ZB = (AKZK+AL*ZL)*B1
      BXBD = B*(XB-XD)
      BYBD = B*(YB-YD)
      BZBD = B*(ZB-ZD)
      BXBC = B*(XB-XC)
      BYBC = B*(YB-YC)
      BZBC = B*(ZB-ZC)
C
C     ----- GET DENSITY FOR KL PRIMITIVE PAIR -----
C
      CALL JDDDIJ(2,KG,LG,NKL00,NKL01,NKL10,NKL11,NKL02,NKL20,
     1            DKL00,XINT,DKL10,XINT,XINT,DKL20,
     2            NIJ1,NIJ2,NIJ3,NIJ4)
      DUM = AARRI+BBRRK
      AB = A*B
      AANDB = A+B
      EXPE = PI252*  EXP(-DUM)/  SQRT(AANDB)
      RHO = AB/AANDB
      XX = RHO*((XA-XB)**2+(YA-YB)**2+(ZA-ZB)**2)
      C1X = BXBD+AXAD
      C2X = A*BXBD
      C3X = BXBC+AXAC
      C4X = B*AXAC
      C1Y = BYBD+AYAD
      C2Y = A*BYBD
      C3Y = BYBC+AYAC
      C4Y = B*AYAC
      C1Z = BZBD+AZAD
      C2Z = A*BZBD
      C3Z = BZBC+AZAC
      C4Z = B*AZAC
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
C
C     COMPUTE TWO-ELECTRON  INTEGRALS FOR EACH ROOT
C
      MAX = NMAX + 1
      DO 500 M = 1,NROOTS
      U2 = U(M)*RHO
      F00 = EXPE*W(M)
      DO 480 I = 1,MAX
  480 IN(I) = IN1(I)+M-1
      DUM = ONE/(AB+U2*AANDB)
      DUM2 = PT5*DUM
      BP01 = (A+U2)*DUM2
      B00  = U2*DUM2
      B10  = (B+U2)*DUM2
      XCP00 = (U2*C1X+C2X)*DUM
      XC00  = (U2*C3X+C4X)*DUM
      YCP00 = (U2*C1Y+C2Y)*DUM
      YC00  = (U2*C3Y+C4Y)*DUM
      ZCP00 = (U2*C1Z+C2Z)*DUM
      ZC00  = (U2*C3Z+C4Z)*DUM
      CALL JDDXYZ
  500 CONTINUE
C
C     ----- FORM (I,J//K,L) INTEGRALS
C
C
C     ----- CALL SUB. SPDD TO GET TWO ELECTRON INTEGRALS -----
C     ----- WHICH ARE NEEDED FOR DERIVATIVES             -----
C
      IF(.NOT.MFIRST) GO TO 6300
      IF(     NSKIP1) GO TO 6100
      NFDIJ=NIJ2
      NFDKL=NIJ1
      NGIJKL=NIJKL1
      CALL JDDSPD(NIJ10,NKL00,DIJ10,DKL00,
     1          NADIJ1,NADKL1,NPIJX1,NPKLX1,NPIJY1,NPKLY1,
     2          NPIJZ1,NPKLZ1,GIJKL1,NFDIJ,NFDKL,NGIJKL)
 6100 IF(     NSKIP2) GO TO 6200
      NFDIJ=NIJ2
      NFDKL=NIJ1
      NGIJKL=NIJKL1
      CALL JDDSPD(NIJ01,NKL00,DIJ01,DKL00,
     1          NADIJ2,NADKL2,NPIJX2,NPKLX2,NPIJY2,NPKLY2,
     2          NPIJZ2,NPKLZ2,GIJKL2,NFDIJ,NFDKL,NGIJKL)
 6200 IF(     NSKIP3) GO TO 6300
      NFDIJ=NIJ1
      NFDKL=NIJ2
      NGIJKL=NIJKL1
      CALL JDDSPD(NIJ00,NKL10,DIJ00,DKL10,
     1          NADIJ3,NADKL3,NPIJX3,NPKLX3,NPIJY3,NPKLY3,
     2          NPIJZ3,NPKLZ3,GIJKL3,NFDIJ,NFDKL,NGIJKL)
 6300 IF(.NOT.MSECND) GO TO 7000
      IF(     NSKIP4) GO TO 6400
      NFDIJ=NIJ3
      NFDKL=NIJ1
      NGIJKL=NIJKL4
      CALL JDDSPD(NIJ20,NKL00,DIJ20,DKL00,
     1          NADIJ4,NADKL4,NPIJX4,NPKLX4,NPIJY4,NPKLY4,
     2          NPIJZ4,NPKLZ4,GIJKL4,NFDIJ,NFDKL,NGIJKL)
 6400 IF(     NSKIP5) GO TO 6500
      NFDIJ=NIJ3
      NFDKL=NIJ1
      NGIJKL=NIJKL4
      CALL JDDSPD(NIJ02,NKL00,DIJ02,DKL00,
     1          NADIJ5,NADKL5,NPIJX5,NPKLX5,NPIJY5,NPKLY5,
     2          NPIJZ5,NPKLZ5,GIJKL5,NFDIJ,NFDKL,NGIJKL)
 6500 IF(     NSKIP6) GO TO 6600
      NFDIJ=NIJ1
      NFDKL=NIJ3
      NGIJKL=NIJKL4
      CALL JDDSPD(NIJ00,NKL20,DIJ00,DKL20,
     1          NADIJ6,NADKL6,NPIJX6,NPKLX6,NPIJY6,NPKLY6,
     2          NPIJZ6,NPKLZ6,GIJKL6,NFDIJ,NFDKL,NGIJKL)
 6600 IF(     NSKIP7) GO TO 6700
      NFDIJ=NIJ4
      NFDKL=NIJ1
      NGIJKL=NIJKL7
      CALL JDDSPD(NIJ11,NKL00,DIJ11,DKL00,
     1          NADIJ7,NADKL7,NPIJX7,NPKLX7,NPIJY7,NPKLY7,
     2          NPIJZ7,NPKLZ7,GIJKL7,NFDIJ,NFDKL,NGIJKL)
 6700 IF(     NSKIP8) GO TO 6800
      NFDIJ=NIJ2
      NFDKL=NIJ2
      NGIJKL=NIJKL7
      CALL JDDSPD(NIJ10,NKL10,DIJ10,DKL10,
     1          NADIJ8,NADKL8,NPIJX8,NPKLX8,NPIJY8,NPKLY8,
     2          NPIJZ8,NPKLZ8,GIJKL8,NFDIJ,NFDKL,NGIJKL)
 6800 IF(     NSKIP9) GO TO 7000
      NFDIJ=NIJ2
      NFDKL=NIJ2
      NGIJKL=NIJKL7
      CALL JDDSPD(NIJ01,NKL10,DIJ01,DKL10,
     1          NADIJ9,NADKL9,NPIJX9,NPKLX9,NPIJY9,NPKLY9,
     2          NPIJZ9,NPKLZ9,GIJKL9,NFDIJ,NFDKL,NGIJKL)
 7000 CONTINUE
C
  540 CONTINUE
  560 CONTINUE
 5400 CONTINUE
 5500 CONTINUE
      RETURN
      END
C*MODULE HSS2A   *DECK JDDIDX
      SUBROUTINE JDDIDX
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME
      LOGICAL NSKIP1,NSKIP2,NSKIP3,NSKIP4,NSKIP5,NSKIP6,
     1        NSKIP7,NSKIP8,NSKIP9
C
      DIMENSION NPWRX(35),NPWRY(35),NPWRZ(35)
C
      COMMON /EQUJDD/ IANDJ,KANDL,SAME
      COMMON /JDDSTV/ NFORB(4),NSORB(4),NFTABL(13,4),NSTABL(22,4),
     *                LFTABL(20,2),LSTABL(35,2)
      COMMON /IDXDIJ/ NADIJ1( 78),NADKL1( 36),NADIJ2( 78),NADKL2( 36),
     1                NADIJ3( 36),NADKL3( 78),NADIJ4(132),NADKL4( 36),
     2                NADIJ5(132),NADKL5( 36),NADIJ6( 36),NADKL6(132),
     3                NADIJ7(169),NADKL7( 36),NADIJ8( 78),NADKL8( 78),
     4                NADIJ9( 78),NADKL9( 78)
      COMMON /IDXIJX/ NPIJX1( 78),NPKLX1( 36),NPIJX2( 78),NPKLX2( 36),
     1                NPIJX3( 36),NPKLX3( 78),NPIJX4(132),NPKLX4( 36),
     2                NPIJX5(132),NPKLX5( 36),NPIJX6( 36),NPKLX6(132),
     3                NPIJX7(169),NPKLX7( 36),NPIJX8( 78),NPKLX8( 78),
     4                NPIJX9( 78),NPKLX9( 78)
      COMMON /IDXIJY/ NPIJY1( 78),NPKLY1( 36),NPIJY2( 78),NPKLY2( 36),
     2                NPIJY3( 36),NPKLY3( 78),NPIJY4(132),NPKLY4( 36),
     2                NPIJY5(132),NPKLY5( 36),NPIJY6( 36),NPKLY6(132),
     3                NPIJY7(169),NPKLY7( 36),NPIJY8( 78),NPKLY8( 78),
     4                NPIJY9( 78),NPKLY9( 78)
      COMMON /IDXIJZ/ NPIJZ1( 78),NPKLZ1( 36),NPIJZ2( 78),NPKLZ2( 36),
     1                NPIJZ3( 36),NPKLZ3( 78),NPIJZ4(132),NPKLZ4( 36),
     2                NPIJZ5(132),NPKLZ5( 36),NPIJZ6( 36),NPKLZ6(132),
     3                NPIJZ7(169),NPKLZ7( 36),NPIJZ8( 78),NPKLZ8( 78),
     4                NPIJZ9( 78),NPKLZ9( 78)
      COMMON /SHLJDD/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /SKPJDD/ NSKIP1,NSKIP2,NSKIP3,NSKIP4,NSKIP5,NSKIP6,
     1                NSKIP7,NSKIP8,NSKIP9
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
C
      DATA NPWRX/  0, 1, 0, 0, 2, 0, 0, 1, 1, 0, 3, 0, 0,
     1             2, 2, 1, 0, 1, 0, 1, 4, 0, 0, 3, 3, 1,
     2             0, 1, 0, 2, 2, 0, 2, 1, 1/
      DATA NPWRY/  0, 0, 1, 0, 0, 2, 0, 1, 0, 1, 0, 3, 0,
     1             1, 0, 2, 2, 0, 1, 1, 0, 4, 0, 1, 0, 3,
     2             3, 0, 1, 2, 0, 2, 1, 2, 1/
      DATA NPWRZ/  0, 0, 0, 1, 0, 0, 2, 0, 1, 1, 0, 0, 3,
     1             0, 1, 0, 1, 2, 2, 1, 0, 0, 4, 0, 1, 0,
     2             1, 3, 3, 0, 2, 2, 1, 1, 2/
C
C     ----- GENERATION OF INDICES FOR ADDRESS CALCULATION -----
C     -----     AND POWER INDEX OF XINT, YINT AND ZINT    -----
C
      NI0=MAXI-MINI+1
      NJ0=MAXJ-MINJ+1
      NK0=MAXK-MINK+1
      NL0=MAXL-MINL+1
      NTYPI=NI0/2+1
      NTYPJ=NJ0/2+1
      NTYPK=NK0/2+1
      LTYPI=NTYPI/4+1
      LTYPJ=NTYPJ/4+1
      LTYPK=NTYPK/4+1
      NI1=NFORB(NTYPI)
      NJ1=NFORB(NTYPJ)
      NK1=NFORB(NTYPK)
      NI2=NSORB(NTYPI)
      NJ2=NSORB(NTYPJ)
      NK2=NSORB(NTYPK)
      N75=75*NROOTS
      N15=15*NROOTS
      N3 = 3*NROOTS
      N1 =   NROOTS
C
C     -----     INTEGRAL TYPE IS (I'J/KL)     -----
C
      IF(NSKIP1) GO TO 16
      NIJ=13
      NIJK=NIJ*NJ0
      NIJKL=NIJK*NK0
      N=0
      DO 10 JN=1,NJ0
      NORBJ=MINJ+JN-1
      JX=N15*NPWRX(NORBJ)
      JY=N15*NPWRY(NORBJ)
      JZ=N15*NPWRZ(NORBJ)
      NJP=NIJ*(JN-1)
      DO 10 IN=1,NI1
      NORBI=NFTABL(IN,NTYPI)
      INN=LFTABL(NORBI,LTYPI)
      N=N+1
      NPIJX1(N)=N75*NPWRX(NORBI)+JX
      NPIJY1(N)=N75*NPWRY(NORBI)+JY
      NPIJZ1(N)=N75*NPWRZ(NORBI)+JZ
      NADIJ1(N)=NJP+INN
   10 CONTINUE
      N=0
      DO 15 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NIJKL*(LN-1)
      IF(KANDL) NK0=LN
      DO 15 KN=1,NK0
      NORBK=MINK+KN-1
      N=N+1
      NPKLX1(N)=N3*NPWRX(NORBK)+LX
      NPKLY1(N)=N3*NPWRY(NORBK)+LY
      NPKLZ1(N)=N3*NPWRZ(NORBK)+LZ
      NADKL1(N)=NIJK*(KN-1)+NLP
   15 CONTINUE
C
   16 CONTINUE
C
C     ----- INTEGRAL TYPE ; (IJ'/KL)                          -----
C     ----- IN AN ACTUAL ADDRESS CALCULATION , TRANSFORMED TO -----
C     ----- (J'I/KL) TYPE                                     -----
C
      IF(NSKIP2) GO TO 26
      NJI=13
      NJIK=NJI*NI0
      NJIKL=NJIK*NK0
      N=0
      DO 20 IN=1,NI0
      NORBI=MINI+IN-1
      IX=N75*NPWRX(NORBI)
      IY=N75*NPWRY(NORBI)
      IZ=N75*NPWRZ(NORBI)
      NIP=NJI*(IN-1)
      DO 20 JN=1,NJ1
      NORBJ=NFTABL(JN,NTYPJ)
      JNN=LFTABL(NORBJ,LTYPJ)
      N=N+1
      NPIJX2(N)=N15*NPWRX(NORBJ)+IX
      NPIJY2(N)=N15*NPWRY(NORBJ)+IY
      NPIJZ2(N)=N15*NPWRZ(NORBJ)+IZ
      NADIJ2(N)=NIP+JNN
   20 CONTINUE
      N=0
      DO 25 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NJIKL*(LN-1)
      IF(KANDL) NK0=LN
      DO 25 KN=1,NK0
      NORBK=MINK+KN-1
      N=N+1
      NPKLX2(N)=N3*NPWRX(NORBK)+LX
      NPKLY2(N)=N3*NPWRY(NORBK)+LY
      NPKLZ2(N)=N3*NPWRZ(NORBK)+LZ
      NADKL2(N)=NJIK*(KN-1)+NLP
   25 CONTINUE
C
   26 CONTINUE
C
C     ----- INTEGRAL TYPE ; (IJ/K'L)                            -----
C     ----- IN AN ACTUAL ADDRESS CALCULATION , TRANSFORMED TO   -----
C     ----- (K'L/IJ) TYPE                                       -----
C
      IF(NSKIP3) GO TO 36
      NKL=13
      NKLI=NKL*NL0
      NKLIJ=NKLI*NI0
      N=0
      DO 30 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NKL*(LN-1)
      DO 30 KN=1,NK1
      NORBK=NFTABL(KN,NTYPK)
      KNN=LFTABL(NORBK,LTYPK)
      N=N+1
      NPKLX3(N)=N3*NPWRX(NORBK)+LX
      NPKLY3(N)=N3*NPWRY(NORBK)+LY
      NPKLZ3(N)=N3*NPWRZ(NORBK)+LZ
      NADKL3(N)=NLP+KNN
   30 CONTINUE
      N=0
      DO 35 JN=1,NJ0
      NORBJ=MINJ+JN-1
      JX=N15*NPWRX(NORBJ)
      JY=N15*NPWRY(NORBJ)
      JZ=N15*NPWRZ(NORBJ)
      NJP=NKLIJ*(JN-1)
      IF(IANDJ) NI0=JN
      DO 35 IN=1,NI0
      NORBI=MINI+IN-1
      N=N+1
      NPIJX3(N)=N75*NPWRX(NORBI)+JX
      NPIJY3(N)=N75*NPWRY(NORBI)+JY
      NPIJZ3(N)=N75*NPWRZ(NORBI)+JZ
      NADIJ3(N)=NKLI*(IN-1)+NJP
   35 CONTINUE
C
   36 CONTINUE
C
C     ----- INTEGRAL TYPE ; (I''J/KL)  -----
C
      IF(NSKIP4) GO TO 46
      NIJ=22
      NIJK=NIJ*NJ0
      NIJKL=NIJK*NK0
      N=0
      DO 40 JN=1,NJ0
      NORBJ=MINJ+JN-1
      JX=N15*NPWRX(NORBJ)
      JY=N15*NPWRY(NORBJ)
      JZ=N15*NPWRZ(NORBJ)
      NJP=NIJ*(JN-1)
      DO 40 IN=1,NI2
      NORBI=NSTABL(IN,NTYPI)
      INN=LSTABL(NORBI,LTYPI)
      N=N+1
      NPIJX4(N)=N75*NPWRX(NORBI)+JX
      NPIJY4(N)=N75*NPWRY(NORBI)+JY
      NPIJZ4(N)=N75*NPWRZ(NORBI)+JZ
      NADIJ4(N)=NJP+INN
   40 CONTINUE
      N=0
      DO 45 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NIJKL*(LN-1)
      IF(KANDL) NK0=LN
      DO 45 KN=1,NK0
      NORBK=MINK+KN-1
      N=N+1
      NPKLX4(N)=N3*NPWRX(NORBK)+LX
      NPKLY4(N)=N3*NPWRY(NORBK)+LY
      NPKLZ4(N)=N3*NPWRZ(NORBK)+LZ
      NADKL4(N)=NIJK*(KN-1)+NLP
   45 CONTINUE
C
   46 CONTINUE
C
C     ----- INTEGRAL TYPE ; (IJ''/KL)                               ----
C     ----- IN AN ACTUAL ADDRESS CALCULATION , TRANSFORMED TO       ----
C     ----- (J''I/KL) TYPE                                          ----
C
      IF(NSKIP5) GO TO 56
      NJI=22
      NJIK=NJI*NI0
      NJIKL=NJIK*NK0
      N=0
      DO 50 IN=1,NI0
      NORBI=MINI+IN-1
      IX=N75*NPWRX(NORBI)
      IY=N75*NPWRY(NORBI)
      IZ=N75*NPWRZ(NORBI)
      NIP=NJI*(IN-1)
      DO 50 JN=1,NJ2
      NORBJ=NSTABL(JN,NTYPJ)
      JNN=LSTABL(NORBJ,LTYPJ)
      N=N+1
      NPIJX5(N)=N15*NPWRX(NORBJ)+IX
      NPIJY5(N)=N15*NPWRY(NORBJ)+IY
      NPIJZ5(N)=N15*NPWRZ(NORBJ)+IZ
      NADIJ5(N)=NIP+JNN
   50 CONTINUE
      N=0
      DO 55 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NJIKL*(LN-1)
      IF(KANDL) NK0=LN
      DO 55 KN=1,NK0
      NORBK=MINK+KN-1
      N=N+1
      NPKLX5(N)=N3*NPWRX(NORBK)+LX
      NPKLY5(N)=N3*NPWRY(NORBK)+LY
      NPKLZ5(N)=N3*NPWRZ(NORBK)+LZ
      NADKL5(N)=NJIK*(KN-1)+NLP
   55 CONTINUE
C
   56 CONTINUE
C
C     ----- INTEGRAL TYPE ; (IJ/K''L)                  -----
C     ----- IN AN ACTUAL ADDRESS CALCULATION           -----
C     ----- (K''L/IJ) TYPE                             -----
C
      IF(NSKIP6) GO TO 66
      NKL=22
      NKLI=NKL*NL0
      NKLIJ=NKLI*NI0
      N=0
      DO 60 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NKL*(LN-1)
      DO 60 KN=1,NK2
      NORBK=NSTABL(KN,NTYPK)
      KNN=LSTABL(NORBK,LTYPK)
      N=N+1
      NPKLX6(N)=N3*NPWRX(NORBK)+LX
      NPKLY6(N)=N3*NPWRY(NORBK)+LY
      NPKLZ6(N)=N3*NPWRZ(NORBK)+LZ
      NADKL6(N)=NLP+KNN
   60 CONTINUE
      N=0
      DO 65 JN=1,NJ0
      NORBJ=MINJ+JN-1
      JX=N15*NPWRX(NORBJ)
      JY=N15*NPWRY(NORBJ)
      JZ=N15*NPWRZ(NORBJ)
      NJP=NKLIJ*(JN-1)
      IF(IANDJ) NI0=JN
      DO 65 IN=1,NI0
      NORBI=MINI+IN-1
      N=N+1
      NPIJX6(N)=N75*NPWRX(NORBI)+JX
      NPIJY6(N)=N75*NPWRY(NORBI)+JY
      NPIJZ6(N)=N75*NPWRZ(NORBI)+JZ
      NADIJ6(N)=NKLI*(IN-1)+NJP
   65 CONTINUE
C
   66 CONTINUE
C
C     ----- INTEGRAL TYPE (I'J'/KL)         -----
C
      IF(NSKIP7) GO TO 76
      NIJ=13
      NIJK=169
      NIJKL=NIJK*NK0
      N=0
      DO 70 JN=1,NJ1
      NORBJ=NFTABL(JN,NTYPJ)
      JNN=LFTABL(NORBJ,LTYPJ)
      JX=N15*NPWRX(NORBJ)
      JY=N15*NPWRY(NORBJ)
      JZ=N15*NPWRZ(NORBJ)
      NJP=NIJ*(JNN-1)
      DO 70 IN=1,NI1
      NORBI=NFTABL(IN,NTYPI)
      INN=LFTABL(NORBI,LTYPI)
      N=N+1
      NPIJX7(N)=N75*NPWRX(NORBI)+JX
      NPIJY7(N)=N75*NPWRY(NORBI)+JY
      NPIJZ7(N)=N75*NPWRZ(NORBI)+JZ
      NADIJ7(N)=NJP+INN
   70 CONTINUE
      N=0
      DO 75 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NIJKL*(LN-1)
      IF(KANDL) NK0=LN
      DO 75 KN=1,NK0
      NORBK=MINK+KN-1
      N=N+1
      NPKLX7(N)=N3*NPWRX(NORBK)+LX
      NPKLY7(N)=N3*NPWRY(NORBK)+LY
      NPKLZ7(N)=N3*NPWRZ(NORBK)+LZ
      NADKL7(N)=NIJK*(KN-1)+NLP
   75 CONTINUE
C
   76 CONTINUE
C
C     ----- INTEGRAL TYPE (I'J/K'L) -----
C
      IF(NSKIP8) GO TO 86
      NIJK=13
      NIJ=169
      NIJKL=NIJ*NJ0
      N=0
      DO 80 JN=1,NJ0
      NORBJ=MINJ+JN-1
      JX=N15*NPWRX(NORBJ)
      JY=N15*NPWRY(NORBJ)
      JZ=N15*NPWRZ(NORBJ)
      NJP=NIJ*(JN-1)
      DO 80 IN=1,NI1
      NORBI=NFTABL(IN,NTYPI)
      INN=LFTABL(NORBI,LTYPI)
      N=N+1
      NPIJX8(N)=N75*NPWRX(NORBI)+JX
      NPIJY8(N)=N75*NPWRY(NORBI)+JY
      NPIJZ8(N)=N75*NPWRZ(NORBI)+JZ
      NADIJ8(N)=NJP+INN
   80 CONTINUE
      N=0
      DO 85 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NIJKL*(LN-1)
      DO 85 KN=1,NK1
      NORBK=NFTABL(KN,NTYPK)
      KNN=LFTABL(NORBK,LTYPK)
      N=N+1
      NPKLX8(N)=N3*NPWRX(NORBK)+LX
      NPKLY8(N)=N3*NPWRY(NORBK)+LY
      NPKLZ8(N)=N3*NPWRZ(NORBK)+LZ
      NADKL8(N)=NIJK*(KNN-1)+NLP
   85 CONTINUE
C
   86 CONTINUE
C
C     ----- INTEGRAL TYPE ; (IJ'/K'L) -----
C
      IF(NSKIP9) GO TO 96
      NJIK=13
      NJI=169
      NJIKL=NJI*NI0
      N=0
      DO 90 IN=1,NI0
      NORBI=MINI+IN-1
      IX=N75*NPWRX(NORBI)
      IY=N75*NPWRY(NORBI)
      IZ=N75*NPWRZ(NORBI)
      NIP=NJI*(IN-1)
      DO 90 JN=1,NJ1
      NORBJ=NFTABL(JN,NTYPJ)
      JNN=LFTABL(NORBJ,LTYPJ)
      N=N+1
      NPIJX9(N)=N15*NPWRX(NORBJ)+IX
      NPIJY9(N)=N15*NPWRY(NORBJ)+IY
      NPIJZ9(N)=N15*NPWRZ(NORBJ)+IZ
      NADIJ9(N)=NIP+JNN
   90 CONTINUE
      N=0
      DO 95 LN=1,NL0
      NORBL=MINL+LN-1
      LX=N1*NPWRX(NORBL)+1
      LY=N1*NPWRY(NORBL)+1
      LZ=N1*NPWRZ(NORBL)+1
      NLP=NJIKL*(LN-1)
      DO 95 KN=1,NK1
      NORBK=NFTABL(KN,NTYPK)
      KNN=LFTABL(NORBK,LTYPK)
      N=N+1
      NPKLX9(N)=N3*NPWRX(NORBK)+LX
      NPKLY9(N)=N3*NPWRY(NORBK)+LY
      NPKLZ9(N)=N3*NPWRZ(NORBK)+LZ
      NADKL9(N)=NJIK*(KNN-1)+NLP
   95 CONTINUE
C
   96 CONTINUE
      RETURN
      END
C*MODULE HSS2A   *DECK JDDSHL
      SUBROUTINE JDDSHL(ISH,JSH,KSH,LSH)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME
      LOGICAL FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF
C
      PARAMETER (MXGTOT=20000, MXSH=5000, MXGSH=30, MXATM=2000)
C
      COMMON /EQUJDD/ IANDJ,KANDL,SAME
      COMMON /HSSPAR/ FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF
      COMMON /INFJDD/ GA(MXGSH),CSA(MXGSH),CPA(MXGSH),CDA(MXGSH),
     *                GB(MXGSH),CSB(MXGSH),CPB(MXGSH),CDB(MXGSH),
     *                GC(MXGSH),CSC(MXGSH),CPC(MXGSH),CDC(MXGSH),
     *                GD(MXGSH),CSD(MXGSH),CPD(MXGSH),CDD(MXGSH),
     *                AX,AY,AZ,BX,BY,BZ,RAB,CX,CY,CZ,DX,DY,DZ,RCD,
     *                NGA,NGB,NGC,NGD
      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 /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /SHLJDD/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
C
      IF( MFIRST ) NRD = 1
      IF( MSECND ) NRD = 2
      IANDJ = ISH .EQ. JSH
C
C     ----- I SHELL -----
C
      I = KATOM(ISH)
      AX = C(1,I)
      AY = C(2,I)
      AZ = C(3,I)
      I1 = KSTART(ISH)
      I2 = I1+KNG(ISH)-1
      LIT = KTYPE(ISH)
      MINI = KMIN(ISH)
      MAXI = KMAX(ISH)
      LOCI = KLOC(ISH)-MINI
      NGA = 0
      DO 100 I = I1,I2
      NGA = NGA+1
      GA(NGA) = EX(I)
      CSA(NGA) = CS(I)
      CPA(NGA) = CP(I)
      CDA(NGA) = CD(I)
  100 CONTINUE
C
C     ----- J SHELL -----
C
      J = KATOM(JSH)
      BX = C(1,J)
      BY = C(2,J)
      BZ = C(3,J)
      J1 = KSTART(JSH)
      J2 = J1+KNG(JSH)-1
      LJT = KTYPE(JSH)
      MINJ = KMIN(JSH)
      MAXJ = KMAX(JSH)
      LOCJ = KLOC(JSH)-MINJ
      NGB = 0
      DO 120 J = J1,J2
      NGB = NGB+1
      GB(NGB) = EX(J)
      CSB(NGB) = CS(J)
      CPB(NGB) = CP(J)
      CDB(NGB) = CD(J)
  120 CONTINUE
      RAB = ((AX-BX)**2+(AY-BY)**2+(AZ-BZ)**2)
      KANDL = KSH .EQ. LSH
      SAME = ISH .EQ. KSH .AND. JSH .EQ. LSH
C
C     ----- K SHELL -----
C
      K = KATOM(KSH)
      CX = C(1,K)
      CY = C(2,K)
      CZ = C(3,K)
      K1 = KSTART(KSH)
      K2 = K1+KNG(KSH)-1
      LKT = KTYPE(KSH)
      MINK = KMIN(KSH)
      MAXK = KMAX(KSH)
      LOCK = KLOC(KSH)-MINK
      NGC = 0
      DO 140 K = K1,K2
      NGC = NGC+1
      GC(NGC) = EX(K)
      CSC(NGC) = CS(K)
      CPC(NGC) = CP(K)
      CDC(NGC) = CD(K)
  140 CONTINUE
C
C     ----- L SHELL -----
C
      L = KATOM(LSH)
      DX = C(1,L)
      DY = C(2,L)
      DZ = C(3,L)
      L1 = KSTART(LSH)
      L2 = L1+KNG(LSH)-1
      LLT = KTYPE(LSH)
      MINL = KMIN(LSH)
      MAXL = KMAX(LSH)
      LOCL = KLOC(LSH)-MINL
      NGD = 0
      DO 160 L = L1,L2
      NGD = NGD+1
      GD(NGD) = EX(L)
      CSD(NGD) = CS(L)
      CPD(NGD) = CP(L)
      CDD(NGD) = CD(L)
  160 CONTINUE
      NROOTS = (LIT+LJT+LKT+LLT-4+NRD)/2 + 1
      RCD = ((CX-DX)**2+(CY-DY)**2+(CZ-DZ)**2)
      RETURN
      END
