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