1      SUBROUTINE DERI23 (F,FD,E,FCI,CMO,EMO,NORBS)
2      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3      INCLUDE 'SIZES'
4      DIMENSION F(*), FD(*), E(*), FCI(*), CMO(NORBS,*), EMO(*)
5***********************************************************************
6*  1) UNPACK THE C.I-ACTIVE M.O. DERIVATIVES IN M.O. BASIS,
7*     DIAGONAL BLOCKS INCLUDED.
8*  2) EXTRACT THE FOCK EIGENVALUES RELAXATION OVER C.I-ACTIVE M.O.
9*   INPUT
10*     F           : UNSCALED SOLUTIONS VECTOR IN M.O. BASIS,
11*                   OFF-DIAGONAL BLOCKS PACKED AS DEFINED IN 'DERI21'.
12*     FD          : DIAGONAL BLOCKS OF NON-RELAXED FOCK MATRIX
13*                   AS DEFINED IN 'DERI1'.
14*     E(NORBS)    : FOCK EIGENVALUES.
15*     FCI         : DIAGONAL BLOCKS OF RELAXATION OF THE FOCK MATRIX.
16*     NORBS       : NUMBER OF M.O
17*     NELEC,NMOS  : # OF LAST FROZEN CORE M.O , C.I-ACTIVE BAND LENGTH.
18*   OUTPUT
19*     CMO(N,NELEC+1,...,NELEC+NMOS): C.I-ACTIVE M.O DERIVATIVES
20*                                  IN M.O BASIS.
21*     EMO(  NELEC+1,...,NELEC+NMOS): C.I-ACTIVE FOCK EIGENVALUE RELAXATI
22*
23***********************************************************************
24      COMMON /FOKMAT/ FDUMY(MPACK), SCALAR(MPACK)
25      COMMON /NVOMAT/ DIAG(MPACK/2)
26      COMMON /CIBITS/ NMOS,LAB,NELEC,NBO(3)
27     1       /MOLKST/ NDUMY(4*NUMATM+8),FRACT
28C
29      NOPEN  =NBO(1)+NBO(2)
30      CONST=1.D-3
31C
32C     PART 1.
33C     -------
34C     COMPUTE AND UNPACK DIAGONAL BLOCKS, DIAGONAL TERMS INCLUDED,
35C     ACCORDING TO CMO(I,J) = (FD(I,J)-FCI(I,J))/(E(I)-E(J))
36C     AND TAKING   CMO(I,J)=0 IF E(I)=E(J) (THRESHOLD 1D-4 EV),
37C                             I.E WHEN M.O. DEGENERACY OCCURS.
38      L=1
39      NEND=0
40      DO 30 LOOP=1,3
41         NINIT=NEND+1
42         NEND =NEND+NBO(LOOP)
43         N1=MAX(NINIT,NELEC+1   )
44         N2=MIN(NEND ,NELEC+NMOS)
45         IF(N2.LT.N1) GO TO 30
46         DO 20 I=N1,N2
47            IF(I.GT.NINIT) THEN
48               DO 10 J=NINIT,I-1
49                  DIFFE=E(I)-E(J)
50                  IF(ABS(DIFFE).GT.1.D-4) THEN
51                     COM=(FD(L)-FCI(L))/DIFFE
52                  ELSE
53                     COM=0.D0
54                  ENDIF
55                  CMO(I,J)=-COM
56                  CMO(J,I)= COM
57   10          L=L+1
58            ENDIF
59   20    CMO(I,I)= 0.D0
60   30 CONTINUE
61C
62C     C.I-ACTIVE EIGENVALUES RELAXATION.
63      CALL SCOPY(NMOS,FCI(L),1,EMO(NELEC+1),1)
64C
65C     PART 2.
66C     -------
67C     UNPACK THE ANTISYMMETRIC MATRIX F IN CMO, (OFF-DIAGONAL BLOCKS).
68C
69      L=1
70      IF(NBO(2).GT.0 .AND. NBO(1).GT.0) THEN
71C        OPEN-CLOSED
72         SCAL=1.D0/(2.D0-FRACT+CONST)
73         DO 40 J=1       ,NBO(1)
74            DO 40 I=NBO(1)+1,NOPEN
75               COM=F(L)*SCAL
76               CMO(I,J)=-COM
77               CMO(J,I)= COM
78   40    L=L+1
79      ENDIF
80      IF(NBO(3).GT.0 .AND. NBO(1).GT.0) THEN
81C	 VIRTUAL-CLOSED
82         SCAL=0.5D0
83         DO 50 J=1     ,NBO(1)
84            DO 50 I=NOPEN+1,NORBS
85               COM=F(L)*SCAL
86               CMO(I,J)=-COM
87               CMO(J,I)= COM
88   50    L=L+1
89      ENDIF
90      IF(NBO(3).NE.0 .AND. NBO(2).NE.0) THEN
91C        VIRTUAL-OPEN
92         SCAL=1.D0/(FRACT+CONST)
93         DO 60 J=NBO(1)+1,NOPEN
94            DO 60 I=NOPEN+1  ,NORBS
95               COM=F(L)*SCAL
96               CMO(I,J)=-COM
97               CMO(J,I)= COM
98   60    L=L+1
99      ENDIF
100      RETURN
101      END
102