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