SUBROUTINE DERI22 (C,B,WORK,NORBS,FOC2,AB,MINEAR,FCI)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION C(NORBS,NORBS), B(*), WORK(NORBS,NORBS), FOC2(*),
     1AB(*), FCI(*)
************************************************************************
*  1) BUILD THE 2-ELECTRON FOCK MATRIX DEPENDING ON B AS FOLLOWS :
*     DP = C * SCALE*B * C' ...  DP DENSITY MATRIX 'DERIVATIVE',
*     FOC2 = 0.5 * TRACE ( DP * (2<J>-<K>) ) DONE IN FOCK2 & FOCK1.
*  2) HALF-TRANSFORM ONTO M.O. BASIS : DPT =  FOC2 * C
*     AND COMPUTE DIAGONAL BLOCKS ELEMENTS OF C' * FOC2, EXTRACTING
*     IN FCI ELEMENTS OVER C.I-ACTIVE M.O ONLY.
*  3) COMPUTE SUPERVECTOR AB = (DIAG + A) * B DEFINED BY THE MATRIX :
*     AB(I,J)= ( DIAG(I,J)*B(I,J)+DPT(I,J) )*SCALAR(I,J)  WITH I.GT.J,
*     DIAG(I,J)=(EIGS(I)-EIGS(J))/(O(J)-O(I)) >0, O OCCUPANCY NUMBERS,
*     EIGS EIGENVALUES OF FOCK OPERATOR WITH EIGENVECTORS C IN A.O.
*
*   INPUT
* C(NORBS,NORBS)   : M.O. EIGENVECTORS (COLUMNWISE).
* B(*)             : B SUPERVECTOR PACKED BY OFF-DIAGONAL BLOCKS, SCALED
* WORK(*)          : WORK AREA OF SIZE N*N.
* NORBS            : NUMBER OF M.O.S
* NELEC,NMOS       : LAST FROZEN CORE M.O. , C.I-ACTIVE BAND LENGTH.
*           IN COMMON
* DIAG,SCALAR AS DEFINED IN 'DERI0'.
*   OUTPUT
* FOC2(*)       : 2-ELECTRON FOCK MATRIX, PACKED CANONICAL.
* AB(*)         : ANTISYMMETRIC MATRIX PACKED IN SUPERVECTOR FORM WITH
*                 THE CONSECUTIVE FOLLOWING BLOCKS:
*              1) OPEN-CLOSED  I.E. B(IJ)=B(I,J) WITH I OPEN & J CLOSED
*                 AND I RUNNING FASTER THAN J,
*              2) VIRTUAL-CLOSED SAME RULE OF ORDERING,
*              3) VIRTUAL-OPEN   SAME RULE OF ORDERING.
* FCI(*)        : FOCK DIAGONAL BLOCKS ELEMENTS OVER C.I-ACTIVE M.O.
*            FOC2 CAN BE EQUIVALENCED WITH WORK IN THE CALLING SEQUENCE.
************************************************************************
C
C  NOTE: NORBS AND NORD ARE THE SAME ADDRESS.  THE NAME NORBD IS NOT
C        USED HERE.
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM)
     1               ,NLAST(NUMATM),NORBD,NELECS,NALPHA,NBETA
     2               ,NCLOSE,NOPEN,NDUMY,FRACT
     3       /WMATRX/ WJ(N2ELEC),WK(N2ELEC)
      COMMON /DENSTY/ PDUMY(MPACK*2), DPA(MPACK)
      COMMON /FOKMAT/ FDUMY(MPACK), SCALAR(MPACK)
      COMMON /NVOMAT/ DIAG(MPACK/2)
      COMMON /WORK1 / FDUMY2(15*MPACK), DP(7*MPACK)
      COMMON /CIBITS/ NMOS,LAB,NELEC,NBO(3)
      DIMENSION W(N2ELEC)
      EQUIVALENCE (W,WJ)
C
      LINEAR=(NORBS*(NORBS+1))/2
C
C     DERIVATIVE OF THE DENSITY MATRIX IN DP (PACKED,CANONICAL).
C     ----------------------------------------------------------
C     DP = C * B * C' .
C
C     STEP 0 : UNSCALE VECTOR B.
      DO 10 I=1,MINEAR
   10 B(I)=B(I)*SCALAR(I)
C
C     STEP 1 : WORK = C * B    .  DP TEMPORARY ARRAY.
      L=1
      IF(NBO(2).NE.0 .AND. NBO(1).NE.0) THEN
C        OPEN-CLOSED
         CALL MXM(C(1,NBO(1)+1),NORBS,B(L),NBO(2),WORK,NBO(1))
C	 CLOSED-OPEN
         CALL MXMT  (C,NORBS,B(L),NBO(1),WORK(1,NBO(1)+1),NBO(2))
         L=L+NBO(2)*NBO(1)
      ENDIF
      IF(NBO(3).NE.0 .AND. NBO(1).NE.0) THEN
C	 VIRTUAL-CLOSED
         IF(L.GT.1) THEN
            CALL MXM(C(1,NOPEN+1),NORBS,B(L),NBO(3),DP,NBO(1))
            DO 20 I=1,NORBS*NBO(1)
   20       WORK(I,1)=WORK(I,1)+DP(I)
         ELSE
            CALL MXM(C(1,NOPEN+1),NORBS,B(L),NBO(3),WORK,NBO(1))
         ENDIF
C	 CLOSED-VIRTUAL
         CALL MXMT(C,NORBS,B(L),NBO(1),WORK(1,NOPEN+1),NBO(3))
         L=L+NBO(3)*NBO(1)
      ENDIF
      IF(NBO(3).NE.0 .AND. NBO(2).NE.0) THEN
C	 VIRTUAL-OPEN
         CALL MXM(C(1,NOPEN+1),NORBS,B(L),NBO(3),DP,NBO(2))
         J=NORBS*NBO(1)
         DO 30 I=1,NORBS*NBO(2)
   30    WORK(J+I,1)=WORK(J+I,1)+DP(I)
C	 OPEN-VIRTUAL
         CALL MXMT  (C(1,NBO(1)+1),NORBS,B(L),NBO(2),DP,NBO(3))
         J=NORBS*NOPEN
         DO 40 I=1,NORBS*NBO(3)
   40    WORK(J+I,1)=WORK(J+I,1)+DP(I)
      ENDIF
C
C     STEP 2 : DP= WORK * C'   WITH DP PACKED,CANONICAL.
      L=0
      DO 50 I=1,NORBS
         DO 50 J=1,I
            L=L+1
   50 DP(L)=SDOT(NORBS,WORK(I,1),NORBS,C(J,1),NORBS)
C
C     2-ELECTRON FOCK MATRIX BUILD WITH THE DENSITY MATRIX DERIVATIVE.
C     ----------------------------------------------------------------
C     RETURNED IN FOC2 (PACKED CANONICAL).
      DO 60 I=1,LINEAR
         FOC2(I)=0.D0
   60 DPA(I)=0.5D0*DP(I)
      CALL FOCK2 (FOC2,DP,DPA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST)
      CALL FOCK1 (FOC2,DP,DPA,DPA)
C
C     BUILD DP AND EXTRACT FCI.
C     --------------------------
C
C     DP(NORBS,NEND) = FOC2(NORBS,NORBS) * C(NORBS,NEND).
      NEND=MAX(NOPEN,NELEC+NMOS)
      L=1
      DO 70 I=1,NOPEN
         CALL SUPDOT (DP(L),FOC2,C(1,I),NORBS,1)
   70 L=L+NORBS
C     EXTRACT FCI
      L=1
      NEND=0
      DO 90 LOOP=1,3
         NINIT=NEND+1
         NEND =NEND+NBO(LOOP)
         N1=MAX(NINIT,NELEC+1   )
         N2=MIN(NEND ,NELEC+NMOS)
         IF(N2.LT.N1) GO TO 90
         DO 80 I=N1,N2
            IF(I.GT.NINIT) THEN
               CALL MXM (C(1,I),1,DP(NORBS*(NINIT-1)+1),NORBS,FCI(L),I-N
     1INIT)
               L=L+I-NINIT
            ENDIF
   80    CONTINUE
   90 CONTINUE
      DO 100 I=NELEC+1,NELEC+NMOS
         FCI(L)=-DOT(C(1,I),DP(NORBS*(I-1)+1),NORBS)
  100 L=L+1
C
C     NEW SUPERVECTOR AB = (DIAG + C'* FOC2 * C) * B , SCALED.
C     --------------------------------------------------------
C
C     PART 1 : AB(I,J) = (C' * DP)(I,J) DONE BY BLOCKS.
      L=1
      IF(NBO(2).NE.0 .AND. NBO(1).NE.0) THEN
         CALL MTXM (C(1,NBO(1)+1),NBO(2),DP,NORBS,AB(L),NBO(1))
         L=L+NBO(2)*NBO(1)
      ENDIF
      IF(NBO(3).NE.0 .AND. NBO(1).NE.0) THEN
         CALL MTXM (C(1,NOPEN+1),NBO(3),DP,NORBS,AB(L),NBO(1))
         L=L+NBO(3)*NBO(1)
      ENDIF
      IF(NBO(3).NE.0 .AND. NBO(2).NE.0)
     1CALL MTXM(C(1,NOPEN+1),NBO(3),DP(NORBS*NBO(1)+1),
     2NORBS,AB(L),NBO(2))
C
C     PART 2 : AB = SCALE * (D * B + AB) AND RESCALE BASIS VECTOR B.
      DO 110 I=1,MINEAR
         AB(I)=(DIAG(I)*B(I)+AB(I))*SCALAR(I)
  110 B(I)=B(I)/SCALAR(I)
      RETURN
      END