1C  /* Deck cc_freeze_exci */
2      SUBROUTINE CC_FREEZE_core(CAM,ISYMTR,
3     &           MAXCORE,
4     &           NRHFCORE,IRHFCORE)
5C
6C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
7C     09-7-2015 Sonia Coriani
8!     Specular to CVS separation - could be replaced by CC_CORE()
9C
10C     Purpose: Project out specific CORE excitations
11C              from a trial vector (by zeroing
12C              specific elements)
13C     Ex1: zero all ai and aibj elements where i and j
14C     are CORE orbitals
15C
16C Based on cc_pram()
17! CAM is the vector analyzed, of symmetry ISYMTR
18! Control is passed via argument list, not via common block
19C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
20C
21      Implicit none
22
23#include "ccsdsym.h"
24      Double precision CAM(*)
25      Integer MAXCORE, NRHFCORE(8),IRHFCORE(MAXCORE,8)
26      integer ISYMTR,ISYMAI,ISYMI,ISYMA,ISYMJ,ISYMB,ISYMBJ
27      Double precision TWO, THR1, THR2, zero
28      PARAMETER (TWO = 2.0D0,zero=0.0d0)
29      Logical LOCDBG, ikeep, LBOTH
30      Parameter (Locdbg = .false.)
31      Integer AA, II, MA, MI, JJ, BB, NBJ, NAI, MJ, MB
32      Integer KAIBJ, NAIBJ, INDEX
33C
34C
35#include "ccorb.h"
36#include "ccsdinp.h"
37#include "priunit.h"
38Cholesky
39#include "maxorb.h"
40#include "ccdeco.h"
41C
42      LOGICAL CCSEFF
43C
44      INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J
45C
46      CCSEFF = CCS .OR. (CHOINT.AND.CC2)
47C
48      THR1 = 1.0D-9
49      THR2 = 1.0D-9
50C
51C------------------------------------------
52C     Loop through single excitation part.
53C------------------------------------------
54C
55      if (locdbg) then
56      WRITE(LUPRI,'(//A)')
57     *     ' +=============================================='
58     *    //'===============================+'
59      WRITE(LUPRI,'(1X,A)')
60     *     '| symmetry|  orbital index  |   Excitation Numbers'
61     *     //'             |   Amplitude  |'
62      WRITE(LUPRI,'(1X,A)')
63     *     '|  Index  |   a   b   i   j |      NAI      NBJ |'
64     *     //'     NAIBJ    |              |'
65      WRITE(LUPRI,'(A)')
66     *     ' +=============================================='
67     *    //'===============================+'
68      end if
69C
70      ISYMAI = MULD2H(ISYMTR,ISYMOP)
71C
72      DO 100 ISYMA = 1,NSYM
73         ISYMI = MULD2H(ISYMAI,ISYMA)
74         DO 110 I = 1,NRHF(ISYMI)
75            MI = IORB(ISYMI) + I
76            DO 120 A=1,NVIR(ISYMA)
77               NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A
78               MA = IORB(ISYMA) + NRHF(ISYMA) +  A
79                 do ii = 1, NRHFCORE(ISYMI)
80                   IF (I==IRHFCORE(II,ISYMI)) THEN
81                      CAM(NAI) = zero
82                   end if
83                 end do
84  120       CONTINUE
85  110    CONTINUE
86  100 CONTINUE
87C
88      CALL FLSHFO(LUPRI)
89C
90C--------------------------------------------
91C     Loop through double excitation vector.
92C     If not ccs or ccp2
93C--------------------------------------------
94C
95      IF (.NOT. ( CCSEFF .OR. CCP2 )) THEN
96C
97      if (locdbg) then
98      WRITE(LUPRI,'(A)')
99     *     ' +----------------------------------------------'
100     *    //'-------------------------------+'
101      end if
102C
103      DO 200 ISYMAI = 1,NSYM
104         ISYMBJ = MULD2H(ISYMAI,ISYMTR)
105         IF (ISYMAI.lt.ISYMBJ) GO TO 200
106         DO 210 ISYMJ = 1,NSYM
107            ISYMB = MULD2H(ISYMJ,ISYMBJ)
108            DO 220 ISYMI = 1,NSYM
109               ISYMA = MULD2H(ISYMI,ISYMAI)
110               DO 230 J = 1,NRHF(ISYMJ)
111                  MJ = IORB(ISYMJ) + J
112                  DO 240 B = 1,NVIR(ISYMB)
113                     NBJ = IT1AM(ISYMB,ISYMJ)
114     *                   + NVIR(ISYMB)*(J - 1) + B
115                     MB = IORB(ISYMB) + NRHF(ISYMB) + B
116                     DO 250 I = 1,NRHF(ISYMI)
117                        MI = IORB(ISYMI) + I
118                        DO 260 A = 1,NVIR(ISYMA)
119                           NAI = IT1AM(ISYMA,ISYMI)
120     *                         + NVIR(ISYMA)*(I - 1) + A
121                           MA = IORB(ISYMA) + NRHF(ISYMA) +  A
122                           IF ((ISYMAI.EQ.ISYMBJ).AND.
123     *                         (NAI .LT. NBJ))
124     *                          GOTO 260
125                           IF (ISYMAI.EQ.ISYMBJ) THEN
126                              NAIBJ = IT2AM(ISYMAI,ISYMBJ)
127     *                              + INDEX(NAI,NBJ)
128                           ELSE
129                               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
130     *                           + NT1AM(ISYMBJ)*(NAI-1)+NBJ
131
132                           ENDIF
133                           KAIBJ = NAIBJ + NT1AM(ISYMTR)  !same vector contains singles and doubles
134                                                          !skip the singles
135                             do ii = 1, nrhfcore(isymi)
136                              if (i==IRHFCORE(II,ISYMI)) then
137                                 CAM(KAIBJ) = zero
138                              end if
139                             end do
140                             do jj = 1, nrhfcore(isymj)
141                              if (j==IRHFCORE(JJ,ISYMJ)) then
142                                 CAM(KAIBJ) = zero
143                              end if
144                             end do
145!========================================
146  260                   CONTINUE
147  250                CONTINUE
148  240             CONTINUE
149  230          CONTINUE
150  220       CONTINUE
151  210    CONTINUE
152  200 CONTINUE
153C
154      ENDIF
155C
156 9990 FORMAT(1X,'| ',I1,3X,I1,2X,' | ',I3,5X,I3,4X,' | ',I8,9x,
157     *       ' | ',12x,' | ',1x, F15.9,'  |')
158 9991 FORMAT(1X,'| ',I1,1X,I1,1X,I1,1X,I1,' | ',
159     *       I3,1X,I3,1X,I3,1X,I3,' | ',
160     *       I8,1x,I8,' | ',I12,' | ',1x,F15.9,'  |')
161
162      RETURN
163      END
164C  /* Deck cc_cvs_interface */
165      SUBROUTINE CC_cvs_INTERFACE(MSYM)
166C
167C PURPOSE:
168C  interface for transfer of CVS info module
169C  Sonia, 2015
170#include "implicit.h"
171#include "priunit.h"
172#include "ccexcicvs.h"
173#include "ccxscvs.h"
174C
175      integer MSYM
176
177      NRHFCORE = NXCORE
178      IRHFCORE = IXCORE
179      LCVSEXCI = LXSCVS
180      LRMCORE  = LXRMCORE
181
182      RETURN
183      END
184
185