1*. A note on GICCI expansions 2* 3* |0> = C_0 |ref> + O_1|ref> + O_2 O_1|ref> + ... + 4* O_N .... O_1|ref> 5* 6* The C_0 coefficient is saved as the last element in the 7* collected vector 8* Each O operators consists of a excitation operator and a 9* projection operator 10* O_I = P_I T_I 11* The projection operator is pt just projecting a single space out. 12*.There is an indirect projection also as O_I ... I_1|ref> is/should be 13* evaluated in CI-space I, but this is not pt included. 14* 15* When a given operator O_I is optimized, this corresponds to 16* optimizing the linear expansion 17* 18* |O_new> = Delta_0(C_0 |ref> + O_1|ref> + ... O_{I-1} ... O_1|ref> 19* + sum_mu delta_{mu I} (O_{I+1} + .... O_N ... O_{I+1}) 20* tau_{mu I} O_{I-1} ... O_1 |ref> 21* 22* an optimization consists this of determining Delta_0 and delta_{mu I}. 23*. Note that the vector to be multiplied by Delta_0 depends upon I. 24* 25* In practice: in the optimization of a given vector, Delta_0 is stored 26* in the element corresponding to the unit-operator. 27* 28* The GICCI vector corresponding to a set of elements (delta_{mu I}, 29* delta_0) = (delta, delta_0) is obtained as 30* 31* I = 1: 32* ----- 33* C_0(new) = delta_0 C_0 34* T_1(new) = delta 35* T_J(new) = T_J for J> 1 36* 37* I > 1: 38* ------ 39* C_0(new) = delta_0 C_0 40* T_1(new) = T_1*delta_0 41* T_I(new) = delta/delta_0 42* T_J(new) = T_J for J neq 1,I 43* 44* The optimization of a given GICCI operator, corresponds to a 45* linear variational space spanned by the basisvectors 46* (C_0 |ref> + O_1|ref> + ... O_{I-1} ... O_1|ref> 47* and 48* (O_{I+1} + .... O_N ... O_{I+1}) tau_{mu I} O_{I-1} ... O_1 |ref> 49* 50* These vectors are fixed and do not depend on the expansion of O(I) 51* 52 53 SUBROUTINE LUCIA_GIC(ICTYP,EREF,EFINAL,CONVER,VNFINAL) 54* 55* 56* Master routine for General internally contracted CI calculations, 57* Sprin 10 version 58* 59* 60* Jeppe Olsen, March 2010 looking into contracted CI with several 61* operators 62* 63* Assumed spaces 64* Space 1: Reference HF or CAS 65* Space 2: Space where standard CI is performed 66* Space 3,4..: Spaces where internal contracted CI will be performed 67* 68 INCLUDE 'wrkspc.inc' 69 REAL*8 70 &INPROD 71 INCLUDE 'crun.inc' 72 INCLUDE 'cstate.inc' 73 INCLUDE 'cgas.inc' 74 INCLUDE 'ctcc.inc' 75 INCLUDE 'gasstr.inc' 76 INCLUDE 'strinp.inc' 77 INCLUDE 'orbinp.inc' 78 INCLUDE 'cprnt.inc' 79 INCLUDE 'corbex.inc' 80 INCLUDE 'csm.inc' 81 INCLUDE 'cicisp.inc' 82 INCLUDE 'cecore.inc' 83 INCLUDE 'glbbas.inc' 84 INCLUDE 'clunit.inc' 85*. Transfer common block for communicating with H_EFF * vector routines 86 COMMON/COM_H_S_EFF_ICCI_TV/ 87 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 88 & IUNIOPX,NSPAX,IPROJSPCX 89*. A bit of local scratch 90 DIMENSION ICASCR(MXPNGAS) 91 CHARACTER*6 ICTYP 92 LOGICAL CONVER 93* 94 EXTERNAL MTV_FUSK, STV_FUSK 95 EXTERNAL H_S_EFF_ICCI_TV,H_S_EXT_ICCI_TV 96 EXTERNAL HOME_SD_INV_T_ICCI 97* 98 IDUM = 0 99 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICCI ') 100*. I will play with spinadaptation in this routine so 101 I_SPIN_ADAPT = 1 102* 103 NTEST = 10 104 IF(NTEST.GE.5) THEN 105 WRITE(6,*) 106 WRITE(6,*) ' Generalized Internal contracted section entered ' 107 WRITE(6,*) ' =============================================== ' 108 WRITE(6,*) 109 WRITE(6,'(A,A)') ' Form of calculation ', ICTYP 110 WRITE(6,*) ' Symmetri of reference vector ' , IREFSM 111 WRITE(6,*) 112 WRITE(6,*) ' Number of external operators ', NTEXC_G 113 WRITE(6,*) ' Parameters defining internal contraction ' 114* 115 WRITE(6,*) ' Form of External operators: ' 116 WRITE(6,*) 117 & ' Op., Min. and Max exc. rank, int-exc, Proj. and Final space' 118 WRITE(6,*) 119 & ' ------------------------------------------------------------' 120 DO IEXC_G = 1, NTEXC_G 121 IF(ICEXC_INT_G(IEXC_G).EQ.1) THEN 122 WRITE(6,'(1H ,1X,I2,4X,I2,7X,I2,14X,A,3X,I2,8X,I2)') 123 & IEXC_G, ICEXC_RANK_MIN_G(IEXC_G),ICEXC_RANK_MAX_G(IEXC_G), 124 & ' + ', IPTCSPC_G(IEXC_G),ITCSPC_G(IEXC_G) 125 ELSE 126 WRITE(6,'(1H ,1X,I2,4X,I2,7X,I2,14X,A,3X,I2,8X,I2)') 127 & IEXC_G, ICEXC_RANK_MIN_G(IEXC_G),ICEXC_RANK_MAX_G(IEXC_G), 128 & ' - ', IPTCSPC_G(IEXC_G),ITCSPC_G(IEXC_G) 129 END IF 130 END DO 131* 132C IF(ICEXC_INT.EQ.1) THEN 133C WRITE(6,*) 134C & ' Internal (ina->ina, sec->sec) excitations allowed' 135C ELSE 136C WRITE(6,*) 137C & ' Internal (ina->ina, sec->sec) excitations not allowed' 138C END IF 139 WRITE(6,*) 140 & ' Largest number of vectors in iterative supspace ', MXCIV 141 WRITE(6,*) 142 & ' Largest initial number of vectors in iterative supspace ', 143 & MXVC_I 144 IF(IRESTRT_IC.EQ.1) THEN 145 WRITE(6,*) ' Restarted calculation : ' 146 WRITE(6,*) ' IC coefficients read from LUSC54' 147 WRITE(6,*) ' CI for reference read from LUSC54 ' 148 END IF 149 END IF 150* 151 IDUM = 0 152*. Divide orbital spaces into inactive, active, secondary using 153*. space 1 154 CALL CC_AC_SPACES(1,IREFTYP) 155* 156 MX_ST_TSOSO_MX = 0 157 MX_ST_TSOSO_BLK_MX = 0 158 MX_TBLK_MX = 0 159 MX_TBLK_AS_MX = 0 160 MAXLEN_I1_MX = 0 161* 162* Generate information about T-operators 163* 164 DO IEX_G = 1, NTEXC_G 165 IF(NTEST.GE.10) WRITE(6,*) ' T-excitation type = ', IEX_G 166* 167 ICEXC_RANK_MIN = ICEXC_RANK_MIN_G(IEX_G) 168 ICEXC_RANK_MAX = ICEXC_RANK_MAX_G(IEX_G) 169 ICEXC_INT = ICEXC_INT_G(IEX_G) 170*. these are transferred through CRUN 171 IF(IEX_G.EQ.1) THEN 172*. Initial reference space is first space by assumption 173 IREFSPC = 1 174 ELSE 175 IREFSPC = ITREFSPC 176 END IF 177 ITREFSPC = ITCSPC_G(IEX_G) 178C GET_TEX_INFO(ICEXC_RANK_MIN,ICEXC_RANK_MAX,ICEXC_INT, 179C IREFSPC,ITREFSPC, 180C & MX_ST_TSOSO, MX_ST_TSOSO_BLK, MX_TBLK, MX_TBLK_AS) 181 CALL GET_TEX_INFO(IREFSPC,ITREFSPC, 182 & MX_ST_TSOSO, MX_ST_TSOSO_BLK, MX_TBLK, MX_TBLK_AS) 183* 184 MX_ST_TSOSO_MX = MAX(MX_ST_TSOSO_MX,MX_ST_TSOSO) 185 MX_ST_TSOSO_BLK_MX = MAX(MX_ST_TSOSO_BLK_MX,MX_ST_TSOSO_BLK) 186 MX_TBLK_MX = MAX(MX_TBLK_MX,MX_TBLK) 187 MX_TBLK_AS_MX = MAX(MX_TBLK_AS_MX,MX_TBLK_AS) 188 MAXLEN_I1_MX = MAX(MAXLEN_I1_MX,MAXLEN_I1) 189* 190 I_FT_GLOBAL = 2 191 CALL TRANSFER_T_OFFSETS(I_FT_GLOBAL,IEX_G) 192 END DO 193 MAXLEN_I1 = MAXLEN_I1_MX 194* 195 IF(I_SPIN_ADAPT.EQ.1) THEN 196*. A bit of general info on prototype spin combinations 197 CALL PROTO_SPIN_MAT 198*. Set up information about partial spin adaptation 199 DO IEX_G = 1, NTEXC_G 200*. Put information about excitations in place 201 I_FT_GLOBAL = 1 202 CALL TRANSFER_T_OFFSETS(I_FT_GLOBAL,IEX_G) 203*. Information about partial spin adaptation for this T excitation type 204 CALL GET_SP_INFO 205*. And save offsets and arrays 206 I_FT_GLOBAL = 2 207 CALL TRANSFER_SPIN_OFFSETS(I_FT_GLOBAL,IEX_G) 208 END DO 209 END IF 210*. Prepare calculation with first T-operator 211 I_FT_GLOBAL = 1 212 CALL TRANSFER_T_OFFSETS(I_FT_GLOBAL,1) 213 CALL TRANSFER_SPIN_OFFSETS(I_FT_GLOBAL,1) 214*. Initial space is first space by assumption ( of Jeppe) 215 IREFSPC = 1 216 ITREFSPC = ITCSPC_G(1) 217 WRITE(6,*) ' IREFSPC, ITREFSPC = ', IREFSPC, ITREFSPC 218* 219 IF(ICTYP(1:4).EQ.'ICCI') THEN 220* 221* ============================== 222* Internal contracted CI section 223* ============================== 224* 225* Solve Internal contracted CI problem 226 CALL LUCIA_ICCI(IREFSPC,ITREFSPC,ICTYP,EREF, 227 & EFINAL,CONVER,VNFINAL) 228* 229 ELSE IF(ICTYP(1:5).EQ.'GICCI') THEN 230*. Generalized intetnal contraction CI 231 CALL LUCIA_GICCI(ICTYP,EREF, 232 & EFINAL,CONVER,VNFINAL) 233 234 ELSE IF(ICTYP(1:4).EQ.'ICPT') THEN 235* 236* ========================================== 237* Internal contracted Perturbation expansion 238* ========================================== 239* 240 CALL LUCIA_ICPT(IREFSPC,ITREFSPC,ICTYP,EREF, 241 & EFINAL,CONVER,VNFINAL) 242* 243 ELSE IF(ICTYP(1:4).EQ.'ICCC') THEN 244* Internal contracted coupled cluster 245* 246* ====================================== 247* Internal contracted Coupled Cluster 248* ======================================= 249* 250 CALL LUCIA_ICCC(IREFSPC,ITREFSPC,ICTYP,EREF,EFINAL, 251 & CONVER,VNFINAL) 252 END IF 253* 254*. 255 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ICCI ') 256* 257 RETURN 258 END 259 SUBROUTINE GEN_IC_IN_ORBSPC(IWAY,NIC_ORBOP,IC_ORBOP,MX_OP_NUM, 260 & IORBSPC) 261* 262* Generate orbitalexcitations for a given orbital space with 263* the restriction that the number of creation- or annihilationoperators 264* is less or equal to MX_OP_NUM. No check are performed to see 265* whether operators are non-vanishing for given space. 266* 267* Jeppe Olsen, For generating cumulants in a given orbitalsubspace 268* 269* IWAY = 1 : Number of orbital excitations for internal contraction 270* IWAY = 2 : Generate also the actual orbital excitations 271* 272 273 INCLUDE 'implicit.inc' 274 INCLUDE 'mxpdim.inc' 275 INCLUDE 'cgas.inc' 276*. Output ( if IWAY .ne. 1 ) 277 INTEGER IC_ORBOP(2*NGAS,*) 278*. Local scratch 279 INTEGER IOP(2*MXPNGAS) 280* 281 NTEST = 05 282 IZERO = 0 283* 284 NIC_ORBOP = 0 285 DO NOP = 1, MX_OP_NUM 286 CALL ISETVC(IOP,IZERO,2*NGAS) 287 IOP(IORBSPC) = NOP 288 IOP(NGAS+IORBSPC) = NOP 289 IF(NTEST.GE.100) THEN 290 WRITE(6,*) ' Next Orbital excitation ' 291 CALL IWRTMA(IOP,NGAS,2,NGAS,2) 292 END IF 293 NIC_ORBOP = NIC_ORBOP + 1 294 IF(IWAY.NE.1) CALL ICOPVE(IOP,IC_ORBOP(1,NIC_ORBOP),2*NGAS) 295 END DO 296* 297 IF(NTEST.GE.5) THEN 298 WRITE(6,*) ' Number of orbitalexcitation types generated ', 299 & NIC_ORBOP 300 IF(IWAY.NE.1) THEN 301 WRITE(6,*) ' And the actual orbitalexcitation types : ' 302 DO JC = 1, NIC_ORBOP 303 WRITE(6,*) ' Orbital excitation type ', JC 304 CALL IWRTMA(IC_ORBOP(1,JC),NGAS,2,NGAS,2) 305 END DO 306 END IF 307 END IF 308* 309 RETURN 310 END 311 SUBROUTINE GEN_IC_ORBOP(IWAY,NIC_ORBOP,IC_ORBOP,MX_OP_RANK, 312 & MN_OP_RANK,IONLY_EXCOP,IREFSPC,ITREFSPC, 313 & IADD_UNI,IPRNT) 314* 315* Generate single and double 316* orbital excitation types corresponding to internal contraction 317* The orbital excitations working on IREFSPC should contain 318* an component in space ITREFSPC. 319* 320* If IADD_UNI = 1, the unit operator ( containing zero operators) 321* is added at the end 322* 323* Jeppe Olsen, August 2002 324* 325* 326* IWAY = 1 : Number of orbital excitations for internal contraction 327* IWAY = 2 : Generate also the actual orbital excitations 328* 329* IONLY_EXCOP = 1 => only excitation operators ( no annihilation in particle 330* space, no creation in inactive space ) 331* 332*. Rank is defined as # crea of particles + # anni of holes 333* -# crea of holes - # anni of particles 334 335 INCLUDE 'implicit.inc' 336 INCLUDE 'mxpdim.inc' 337 INCLUDE 'cgas.inc' 338*. Local scratch 339 INTEGER ITREFOCC(MXPNGAS,2) 340*. Output ( if IWAY .ne. 1 ) 341 INTEGER IC_ORBOP(2*NGAS,*) 342*. Local scratch 343 INTEGER IOP(2*MXPNGAS) 344* 345 NTEST = 0 346 NTEST = MAX(NTEST,IPRNT) 347 IZERO = 0 348* 349 IF(NTEST.GE.100) THEN 350 WRITE(6,*) 351 WRITE(6,*) ' ------------------------------' 352 WRITE(6,*) ' Information from GEN_IC_ORBOP ' 353 WRITE(6,*) ' ------------------------------' 354 WRITE(6,*) 355 WRITE(6,*) ' IREFSPC, ITREFSPC = ', IREFSPC, ITREFSPC 356 END IF 357* 358 NIC_ORBOP = 0 359 I_INCLUDE_SX = 1 360 IF(I_INCLUDE_SX.EQ.0) THEN 361 DO I = 1, 200 362 WRITE(6,*) ' Excitation operators are excluded ' 363 END DO 364 ELSE 365*. Include single excitations 366*. Single excitations a+i a j 367 DO IGAS = 1, NGAS 368 DO JGAS = 1, NGAS 369 CALL ISETVC(IOP,IZERO,2*NGAS) 370 IOP(IGAS) = 1 371 IOP(NGAS+JGAS) = 1 372 IF(NTEST.GE.100) THEN 373 WRITE(6,*) ' Next Orbital excitation ' 374 CALL IWRTMA(IOP,NGAS,2,NGAS,2) 375 END IF 376C IRANK_ORBOP(IOP,NEX,NDEEX) 377C COMPARE_OPDIM_ORBDIM(IOP,IOKAY) 378 CALL COMPARE_OPDIM_ORBDIM(IOP,IOKAY) 379 IF(NTEST.GE.100) WRITE(6,*) ' IOKAY from COMPARE..', IOKAY 380*. Is the action of this operator on IREFSPC included in ITREFSPC 381 CALL ORBOP_ACCOCC(IOP,IGSOCCX(1,1,IREFSPC),ITREFOCC,NGAS,MXPNGAS) 382 CALL OVLAP_ACC_MINMAX(ITREFOCC,IGSOCCX(1,1,ITREFSPC),NGAS,MXPNGAS, 383 & IOVERLAP) 384 IF(NTEST.GE.100) WRITE(6,*) ' IOVERLAP from OVLAP..',IOVERLAP 385 IF(IOVERLAP.EQ.0) IOKAY = 0 386C ORBOP_ACCOCC(IORBOP,IACC_IN,IACC_OUT,NGAS,MXPNGAS) 387C OVLAP_ACC_MINMAX(IACC1,IACC2,NGAS,MXPNGAS,IOVERLAP) 388*. is there any operators in spaces that are frozen or deleted in ITREFSPC 389C CHECK_EXC_FR_OR_DE(IOP,IOCC,NGAS,IOKAY) 390 CALL CHECK_EXC_FR_OR_DE(IOP,IGSOCCX(1,1,ITREFSPC),NGAS,IOKAY2) 391 IF(NTEST.GE.100) WRITE(6,*) ' IOKAY2 from CHECK ... ', IOKAY2 392 IF(IOKAY2.EQ.0) IOKAY = 0 393 IF(IOKAY.EQ.1) THEN 394 CALL IRANK_ORBOP(IOP,NEX,NDEEX) 395 IOKAY2 = 1 396 IF(IONLY_EXCOP.EQ.1.AND.NDEEX.NE.0) IOKAY2 = 0 397 IRANK = NEX - NDEEX 398 IF(NTEST.GE.100) WRITE(6,*) ' IRANK = ', IRANK 399 IF(MN_OP_RANK.LE.IRANK.AND.IRANK.LE.MX_OP_RANK 400 & .AND.IOKAY2.EQ.1)THEN 401 NIC_ORBOP = NIC_ORBOP + 1 402 IF(NTEST.GE.100) WRITE(6,*) ' Operator included ' 403 IF(IWAY.NE.1) 404 & CALL ICOPVE(IOP,IC_ORBOP(1,NIC_ORBOP),2*NGAS) 405 END IF 406 END IF 407 END DO 408 END DO 409 END IF 410*. Double excitations a+i a+j a k a l 411 DO IGAS = 1, NGAS 412 DO JGAS = 1, IGAS 413 DO KGAS = 1, NGAS 414 DO LGAS = 1, KGAS 415 CALL ISETVC(IOP,IZERO,2*NGAS) 416 IOP(IGAS) = 1 417 IOP(JGAS) = IOP(JGAS) + 1 418 IOP(NGAS+KGAS) = 1 419 IOP(NGAS+LGAS) = IOP(NGAS+LGAS) + 1 420 CALL COMPARE_OPDIM_ORBDIM(IOP,IOKAY) 421*. Is the action of this operator on IREFSPC included in ITREFSPC 422 CALL ORBOP_ACCOCC(IOP,IGSOCCX(1,1,IREFSPC),ITREFOCC,NGAS,MXPNGAS) 423 CALL OVLAP_ACC_MINMAX(ITREFOCC,IGSOCCX(1,1,ITREFSPC),NGAS, 424 & MXPNGAS,IOVERLAP) 425 IF(IOVERLAP.EQ.0) IOKAY = 0 426 CALL CHECK_EXC_FR_OR_DE(IOP,IGSOCCX(1,1,ITREFSPC),NGAS,IOKAY2) 427 IF(IOKAY2.EQ.0) IOKAY = 0 428 IF(IOKAY.EQ.1) THEN 429 CALL IRANK_ORBOP(IOP,NEX,NDEEX) 430 IRANK = NEX - NDEEX 431 IOKAY2 = 1 432 IF(IONLY_EXCOP.EQ.1.AND.NDEEX.NE.0) IOKAY2 = 0 433 IF(MN_OP_RANK.LE.IRANK.AND.IRANK.LE.MX_OP_RANK.AND. 434 & IOKAY2.EQ.1) THEN 435 IF(NTEST.GE.100) WRITE(6,*) ' Operator included ' 436 NIC_ORBOP = NIC_ORBOP + 1 437 IF(IWAY.NE.1) 438 & CALL ICOPVE(IOP,IC_ORBOP(1,NIC_ORBOP),2*NGAS) 439 END IF 440 END IF 441 END DO 442 END DO 443 END DO 444 END DO 445 IF(IADD_UNI.EQ.1) THEN 446 NIC_ORBOP = NIC_ORBOP + 1 447 IF(IWAY.NE.1) THEN 448 IZERO = 0 449 CALL ISETVC(IC_ORBOP(1,NIC_ORBOP),IZERO,2*NGAS) 450 END IF 451 END IF 452* 453 IF(NTEST.GE.2) THEN 454 WRITE(6,*) ' Number of orbitalexcitation types generated ', 455 & NIC_ORBOP 456 IF(IWAY.NE.1) THEN 457 WRITE(6,*) ' And the actual orbitalexcitation types : ' 458 DO JC = 1, NIC_ORBOP 459 WRITE(6,*) ' Orbital excitation type ', JC 460 CALL IWRTMA(IC_ORBOP(1,JC),NGAS,2,NGAS,2) 461 END DO 462 END IF 463 END IF 464* 465 RETURN 466 END 467 SUBROUTINE IRANK_ORBOP(IOP,NEX,NDEEX) 468* 469* An orbital operator is given in IOP 470* Find RANK of the operator 471* 472* Find number of excitation ops (# crea of particles + # anni of holes ) 473* deexcitation ops (# crea of holes + # anni of particles) 474* IHPVGAS in CGAS is used to determine types of orbitals 475* 476* Jeppe Olsen, August 2002 477 INCLUDE 'implicit.inc' 478 INCLUDE 'mxpdim.inc' 479 INCLUDE 'cgas.inc' 480*. Specific input 481 INTEGER IOP(NGAS,2) 482* 483 NEX = 0 484 NDEEX = 0 485* 486 DO IGAS = 1, NGAS 487 IF(IHPVGAS(IGAS).EQ.1) THEN 488 NDEEX = NDEEX + IOP(IGAS,1) 489 NEX = NEX + IOP(IGAS,2) 490 ELSE IF (IHPVGAS(IGAS).EQ.2) THEN 491 NEX = NEX + IOP(IGAS,1) 492 NDEEX = NDEEX + IOP(IGAS,2) 493 END IF 494* 495 END DO 496* 497 NTEST = 00 498 IF(NTEST.GE.100) THEN 499* 500 WRITE(6,*) ' Orbital excitation operator ' 501 WRITE(6,*) ' =========================== ' 502 CALL IWRTMA(IOP,NGAS,2,NGAS,2) 503 WRITE(6,*) 504 WRITE(6,*) ' Number of excitation operators ', NEX 505 WRITE(6,*) ' Number of deexcitation operators ', NDEEX 506 END IF 507* 508 RETURN 509 END 510 SUBROUTINE COMPARE_OPDIM_ORBDIM(IOP,IOKAY) 511* 512* Compare dimensions of orbitaloperator in CA form and 513* orbitals, and check that number of crea- or anni-operators 514* is smaller than number of orbitals in each gas space 515* 516* Jeppe Olsen, August 2002 517* 518 INCLUDE 'implicit.inc' 519 INCLUDE 'mxpdim.inc' 520 INCLUDE 'orbinp.inc' 521 INCLUDE 'cgas.inc' 522*. Integer 523 INTEGER IOP(NGAS,2) 524* 525 IOKAY = 1 526 DO ICA = 1, 2 527 DO IGAS = 1, NGAS 528 IF(IOP(IGAS,ICA).GT.2*NOBPT(IGAS)) IOKAY = 0 529 END DO 530 END DO 531* 532 NTEST = 00 533 IF(NTEST.GE.100) THEN 534 WRITE(6,*) ' Orbital operator ' 535 CALL IWRTMA(IOP,NGAS,2,NGAS,2) 536 IF(IOKAY.EQ.1) THEN 537 WRITE(6,*) ' Operator is nonvanishing ' 538 ELSE 539 WRITE(6,*) ' Operator is vanishing ' 540 END IF 541 END IF 542* 543 RETURN 544 END 545 SUBROUTINE GET_NCA_FOR_ORBOP(NORBEX,IORBEX,NC_FOR_OBEX, 546 & NA_FOR_OBEX,NGAS) 547* 548* Find number of creation and annihilation operators for set 549* of orbital excitation operators 550* 551* Jeppe Olsen, September 2002 552* 553 INCLUDE 'implicit.inc' 554*. Input 555 INTEGER IORBEX(NGAS,2,NORBEX) 556*. Output 557 INTEGER NC_FOR_OBEX(NORBEX),NA_FOR_OBEX(NORBEX) 558* 559 DO I = 1, NORBEX 560 NC_FOR_OBEX(I) = IELSUM(IORBEX(1,1,I),NGAS) 561 NA_FOR_OBEX(I) = IELSUM(IORBEX(1,2,I),NGAS) 562 END DO 563* 564 NTEST = 00 565 IF(NTEST.GE.100) THEN 566 WRITE(6,*) ' Number of creations per orbital operator ' 567 CALL IWRTMA(NC_FOR_OBEX,1,NORBEX,1,NORBEX) 568 WRITE(6,*) ' Number of annihilations per orbital operator ' 569 CALL IWRTMA(NA_FOR_OBEX,1,NORBEX,1,NORBEX) 570 END IF 571* 572 RETURN 573 END 574 SUBROUTINE ORBOP_ACCOCC(IORBOP,IACC_IN,IACC_OUT,NGAS,MXPNGAS) 575* 576* An orbital excitation CA form and an CI space in the form of 577* an accumulated occupation are given. Find accumulated occupation 578* of product 579* 580* Jeppe Olsen, September 2002 581* 582 INCLUDE 'implicit.inc' 583*. Input 584 INTEGER IORBOP(NGAS,2), IACC_IN(MXPNGAS,2) 585*. Output 586 INTEGER IACC_OUT(MXPNGAS,2) 587* 588 IDEL = 0 589 DO IGAS = 1, NGAS 590 IDEL = IDEL + IORBOP(IGAS,1) - IORBOP(IGAS,2) 591 IACC_OUT(IGAS,1) = MAX(0,IACC_IN(IGAS,1) + IDEL) 592 IACC_OUT(IGAS,2) = MAX(0,IACC_IN(IGAS,2) + IDEL) 593 END DO 594* 595 NTEST = 00 596 IF(NTEST.GE.100) THEN 597 WRITE(6,*) ' Input ORBOP in CA form ' 598 CALL IWRTMA(IORBOP,NGAS,2,NGAS,2) 599 WRITE(6,*) ' Input OCC in acc min/max form ' 600 CALL IWRTMA(IACC_IN,NGAS,2,MXPNGAS,2) 601 WRITE(6,*) ' Output OCC in acc min/max form ' 602 CALL IWRTMA(IACC_OUT,NGAS,2,MXPNGAS,2) 603 END IF 604* 605 RETURN 606 END 607 SUBROUTINE OVLAP_ACC_MINMAX(IACC1,IACC2,NGAS,MXPNGAS,IOVERLAP) 608* 609* Two spaces are given in the form of accumulated MAX/MIN 610* occupations. Check if the two spaces overlap, ie. there is 611* a nonvanishing space that is contained in both. 612* 613* Jeppe Olsen, Sept 2002 614* 615 INCLUDE 'implicit.inc' 616*. Input 617 INTEGER IACC1(MXPNGAS,2), IACC2(MXPNGAS,2) 618* 619 IOVERLAP = 1 620 DO IGAS = 1, NGAS 621*. Find common Min being the Max of the individual Mins 622 IMIN_12 = MAX(IACC1(IGAS,1),IACC2(IGAS,1)) 623*. Find common Max being the Min of the individual Maxs 624 IMAX_12 = MIN(IACC1(IGAS,2),IACC2(IGAS,2)) 625 IF(IMIN_12.GT.IMAX_12) IOVERLAP = 0 626CE IF(.NOT.( (IACC2(IGAS,1).GE.IACC1(IGAS,1).AND. 627CE & IACC2(IGAS,1).LE.IACC1(IGAS,2) ) .OR. 628CE & (IACC2(IGAS,2).GE.IACC1(IGAS,1).AND. 629CE & IACC2(IGAS,2).LE.IACC1(IGAS,2)) ) ) THEN 630CE IOVERLAP = 0 631CE END IF 632 END DO 633* 634 NTEST = 00 635 IF(NTEST.GE.100) THEN 636 WRITE(6,*) ' Two accumulated min/max occupations ' 637 CALL IWRTMA(IACC1,NGAS,2,MXPNGAS,2) 638 CALL IWRTMA(IACC2,NGAS,2,MXPNGAS,2) 639 IF(IOVERLAP.EQ.1) THEN 640 WRITE(6,*) ' The occupations overlap ' 641 ELSE 642 WRITE(6,*) ' The occupations do not overlap ' 643 END IF 644 END IF 645* 646 RETURN 647 END 648 SUBROUTINE CHECK_EXC_FR_OR_DE(IOP,IOCC,NGAS,IOKAY) 649* 650* An orbital operator IOP in CA form and and occupation space 651* IOCC in accumulated min/max form is given. Ensure that there 652* are no operators in frozen, ie. completely occupied spaces 653* spaces and that no operators are in deleted orbspaces, 654*.that is spaces with zero electrons 655* IOKAY = 1 => No such operators 656* = 0 0> such operators occurs in IOP 657* 658* Jeppe Olsen, Sept 2002 659* 660 INCLUDE 'implicit.inc' 661 INCLUDE 'mxpdim.inc' 662 INCLUDE 'orbinp.inc' 663*. Input 664 INTEGER IOCC(MXPNGAS,2),IOP(NGAS,2) 665* 666 IOKAYL = 1 667 DO IGAS = 1, NGAS 668 IF(IGAS.EQ.1) THEN 669 NELMIN = IOCC(1,1) 670 ELSE 671 NELMIN = IOCC(IGAS,1)-IOCC(IGAS-1,2) 672 END IF 673 NOP = IOP(IGAS,1) + IOP(IGAS,2) 674*. Check to see if orbital space is deleted, i.e. 675*. contains no electrons 676 IDELETED = 0 677 IF(IGAS.EQ.1) THEN 678 IF(IOCC(1,2).EQ.0) IDELETED = 1 679 ELSE 680 IF(IOCC(IGAS,2).EQ.IOCC(IGAS-1,1)) IDELETED = 1 681 END IF 682 683 IF(NOP.NE.0.AND.IDELETED.EQ.1) IOKAYL = 0 684 IF(NOP.NE.0.AND.NELMIN.EQ.2*NOBPT(IGAS)) IOKAYL = 0 685 END DO 686* 687 IF(IOKAYL.EQ.1) THEN 688 IOKAY = 1 689 ELSE 690 IOKAY = 0 691 END IF 692* 693 NTEST = 00 694 IF(NTEST.GE.100) THEN 695 WRITE(6,*) ' Orbital operator in CA form ' 696 CALL IWRTMA(IOP,NGAS,2,NGAS,2) 697 IF(IOKAY.EQ.1) THEN 698 WRITE(6,*) ' No operators in frozen or deleted spaces ' 699 ELSE 700 WRITE(6,*) ' Operators in frozen or deleted spaces ' 701 END IF 702 END IF 703* 704 RETURN 705 END 706 SUBROUTINE CHECK_EXC_FR(IOP,IOCC,NGAS,IOKAY) 707* 708* An orbital operator IOP in CA form and and occupation space 709* IOCC in accumulated min/max form is given. Ensure that there 710* are no operators in frozen, ie. completely occupied spaces 711* spaces 712* IOKAY = 1 => No such operators 713* = 0 0> such operators occurs in IOP 714* 715* Jeppe Olsen, Sept 2002 716* 717 INCLUDE 'implicit.inc' 718 INCLUDE 'mxpdim.inc' 719 INCLUDE 'orbinp.inc' 720*. Input 721 INTEGER IOCC(MXPNGAS,2),IOP(NGAS,2) 722* 723 IOKAYL = 1 724 DO IGAS = 1, NGAS 725 IF(IGAS.EQ.1) THEN 726 NELMIN = IOCC(1,1) 727 ELSE 728 NELMIN = IOCC(IGAS,1)-IOCC(IGAS-1,2) 729 END IF 730 NOP = IOP(IGAS,1) + IOP(IGAS,2) 731 IF(NOP.NE.0.AND.NELMIN.EQ.2*NOBPT(IGAS)) IOKAYL = 0 732 END DO 733* 734 IF(IOKAYL.EQ.1) THEN 735 IOKAY = 1 736 ELSE 737 IOKAY = 0 738 END IF 739* 740 NTEST = 00 741 IF(NTEST.GE.100) THEN 742 WRITE(6,*) ' Orbital operator in CA form ' 743 CALL IWRTMA(IOP,NGAS,2,NGAS,2) 744 IF(IOKAY.EQ.1) THEN 745 WRITE(6,*) ' No operators in frozen or deleted spaces ' 746 ELSE 747 WRITE(6,*) ' Operators in frozen or deleted spaces ' 748 END IF 749 END IF 750* 751 RETURN 752 END 753 SUBROUTINE ICCI_COMPLETE_MAT(IREFSPC,ITREFSPC,I_SPIN_ADAPT) 754* 755* Master routine for Internal contraction with complete incore 756* construction of all matrices 757* 758* Jeppe Olsen, Sept 2002 759* 760 INCLUDE 'wrkspc.inc' 761 INCLUDE 'ctcc.inc' 762 INCLUDE 'glbbas.inc' 763 INCLUDE 'crun.inc' 764 INCLUDE 'clunit.inc' 765 INCLUDE 'cecore.inc' 766*. Scratch for CI 767* 768 NTEST = 10 769 WRITE(6,*) 770 WRITE(6,*) ' Complete H and S matrices will be constructed ' 771 WRITE(6,*) ' ==============================================' 772 WRITE(6,*) 773 WRITE(6,*) ' Reference space is ', IREFSPC 774 WRITE(6,*) ' Space of Operators times reference space ', ITREFSPC 775 WRITE(6,*) 776 WRITE(6,*) ' Number of parameters in spinuncoupled basis ', 777 & N_CC_AMP 778* 779 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'IC_CMP ') 780*. Space for old fashioned CI behind the curtain 781 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 782 KVEC1P = KVEC1 783 KVEC2P = KVEC2 784* 785* Space for complete H and S matrices 786* 787 LEN = N_CC_AMP ** 2 788 CALL MEMMAN(KLSMAT,LEN,'ADDL ',2,'SMAT ') 789 CALL MEMMAN(KLHMAT,LEN,'ADDL ',2,'HMAT ') 790 CALL MEMMAN(KLSCR1,LEN,'ADDL ',2,'SCR1_C') 791 CALL MEMMAN(KLSCR2,LEN,'ADDL ',2,'SCR2_C') 792*. Add an extra matrix to allow for backtransformation to 793*. original basis as a test 794 CALL MEMMAN(KLXORT,LEN,'ADDL ', 2,'XORT ') 795 796*. And a few working vectors 797 CALL MEMMAN(KLVCC1,N_CC_AMP,'ADDL ',2,'VCC1 ') 798 CALL MEMMAN(KLVCC2,N_CC_AMP,'ADDL ',2,'VCC2 ') 799 CALL MEMMAN(KLVCC3,N_CC_AMP,'ADDL ',2,'VCC3 ') 800*. Identify the unit operator i.e. the operator with 801*. zero creation and annihilation operators 802 IDOPROJ = 1 803 IF(IDOPROJ.EQ.1) THEN 804 CALL GET_SPOBTP_FOR_EXC_LEVEL(0,WORK(KLCOBEX_TP),NSPOBEX_TP, 805 & NUNIOP,IUNITP,WORK(KLSOX_TO_OX)) 806*. And the position of the unitoperator in the list of SPOBEX operators 807 WRITE(6,*) ' NUNIOP, IUNITP = ', NUNIOP,IUNITP 808 IF(NUNIOP.EQ.0) THEN 809 WRITE(6,*) ' Unitoperator not found in exc space ' 810 WRITE(6,*) ' I will proceed without projection ' 811 IDOPROJ = 0 812 ELSE 813C IFRMR(WORK,IROFF,IELMNT) 814 IUNIOP = IFRMR(WORK(KLIBSOBEX),1,IUNITP) 815 WRITE(6,*) ' IUNIOP = ', IUNIOP 816 END IF 817 END IF 818* 819C COM_SH(S,H,VCC1,VCC2,VCC3,VEC1,VEC2, 820C & N_CC_AMP,IREFSPC,ITREFSPC, 821C & LUC,LUHC,LUSCR,LUSCR2,IDOPROJ,IUNIOP) 822 CALL COM_SH(WORK(KLSMAT),WORK(KLHMAT),WORK(KLVCC1),WORK(KLVCC2), 823 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 824 & N_CC_AMP,IREFSPC, ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 825 & IDOPROJ,IUNIOP,1,1,0,0,0,0,0) 826*. Obtain singularities on S 827C CHK_S_FOR_SING(S,NDIM,NSING,X,SCR) 828 CALL CHK_S_FOR_SING(WORK(KLSMAT),N_CC_AMP,NSING, 829 & WORK(KLSCR1),WORK(KLSCR2),WORK(KLVCC2)) 830*. On output the eigenvalues are residing in WORK(KLSCR2) and 831*. the corresponding eigenvectors in WORK(KLSCR1). 832*. The singular subspace is defined by the first NSING eigenvectors 833 NNONSING = N_CC_AMP - NSING 834 WRITE(6,*) ' Number of nonsingular eigenvalues of S ', NNONSING 835 KLNONSING = KLSCR1 + NSING*N_CC_AMP 836*. For saving transformation matrix 837 CALL COPVEC(WORK(KLNONSING),WORK(KLXORT),NNONSING*N_CC_AMP) 838*. Transform H to a nonsigular - and orthogonal basis 839*. I use the transformation matrix 840* X = U sigma^{-1/2}, where U are the nonsingular 841*. eigenvectors of S and sigma are the corresponding 842*. eigenvectors 843*. This transformation matrix turns the nonsingular part of S into 844*. a unitmatrix 845C? WRITE(6,*) ' Unscaled transformation matrix ' 846C? CALL WRTMAT(WORK(KLNONSING),N_CC_AMP,NNONSING, 847C? & N_CC_AMP,NNONSING) 848 DO I = 1, NNONSING 849 SCALE = 1/SQRT(WORK(KLSCR2-1+NSING+I)) 850 CALL SCALVE(WORK(KLNONSING+(I-1)*N_CC_AMP),SCALE,N_CC_AMP) 851 END DO 852C? WRITE(6,*) ' Scaled transformation matrix ' 853C? CALL WRTMAT(WORK(KLNONSING),N_CC_AMP,NNONSING, 854C? & N_CC_AMP,NNONSING) 855*. Transform 856*. H Xin SCR2 857 FACTORC = 0.0D0 858 FACTORAB = 1.0D0 859C? WRITE(6,*) ' H before transformation ' 860C? CALL WRTMAT(WORK(KLHMAT),N_CC_AMP,N_CC_AMP,N_CC_AMP,N_CC_AMP) 861 CALL MATML7(WORK(KLSCR2),WORK(KLHMAT),WORK(KLNONSING), 862 & N_CC_AMP,NNONSING,N_CC_AMP,N_CC_AMP, 863 & N_CC_AMP,NNONSING,FACTORC,FACTORAB,0) 864C? WRITE(6,*) ' H halftransformed ' 865C? CALL WRTMAT(WORK(KLSCR2),N_CC_AMP,N_CC_AMP,N_CC_AMP,N_CC_AMP) 866*. X(T) H X in HMAT 867 CALL MATML7(WORK(KLHMAT),WORK(KLNONSING),WORK(KLSCR2), 868 & NNONSING,NNONSING,N_CC_AMP,NNONSING, 869 & N_CC_AMP,NNONSING,FACTORC,FACTORAB,1) 870* 871 IF(NTEST.GE.100) THEN 872 WRITE(6,*) ' Transformed Hamiltonian matrix ' 873 CALL WRTMAT(WORK(KLHMAT),NNONSING,NNONSING,NNONSING,NNONSING) 874 END IF 875* 876*. Diagonalize transformed Hamiltonian 877* 878C DIAG_SYM_MAT(A,X,SCR,NDIM,ISYM) 879 880 IOLD = 1 881 IF(IOLD.EQ.0) THEN 882 CALL DIAG_SYM_MAT(WORK(KLHMAT),WORK(KLSCR1),WORK(KLSCR2), 883 & NNONSING,0) 884 ELSE 885 ZERO = 0.0D0 886 ONE = 1.0D0 887 CALL TRIPAK(WORK(KLHMAT),WORK(KLSCR1),1,NNONSING,NNONSING) 888 CALL COPVEC(WORK(KLSCR1),WORK(KLHMAT),NNONSING*(NNONSING+1)/2) 889 CALL SETVEC(WORK(KLSCR1),ZERO,NNONSING*NNONSING) 890 CALL SETDIA(WORK(KLSCR1),ONE,NNONSING,0) 891C SETDIA(MATRIX,VALUE,NDIM,IPACK) 892 CALL JACOBI(WORK(KLHMAT),WORK(KLSCR1),NNONSING,NNONSING) 893C JACOBI(F,V,NB,NMAX) 894 CALL COPDIA(WORK(KLHMAT),WORK(KLSCR2),NNONSING,1) 895 END IF 896 897* 898 WRITE(6,*) ' Ecore in ICCI_COMPLETE.. ', ECORE 899 DO I = 1, NNONSING 900 WORK(KLSCR2-1+I) = WORK(KLSCR2-1+I) + ECORE 901 END DO 902* 903 WRITE(6,*) ' Eigenvalues of H matrix in IC basis ' 904 WRITE(6,*) ' ====================================' 905 CALL WRTMAT_EP(WORK(KLSCR2),1,NNONSING,1,NNONSING) 906* 907 IF(I_SPIN_ADAPT.EQ.1) THEN 908*. First back transform first eigenvector to original basis 909 CALL MATML7(WORK(KLVCC2),WORK(KLXORT),WORK(KLSCR1), 910 & N_CC_AMP,1,N_CC_AMP,NNONSING,NNONSING,1, 911 & FACTORC,FACTORAB,0) 912 WRITE(6,*) ' First eigenvector in CAAB basis ' 913 CALL WRTMAT(WORK(KLVCC2),1,N_CC_AMP,1,N_CC_AMP) 914*. Reform to CSF basis 915 CALL REF_CCV_CAAB_SP(WORK(KLVCC2),WORK(KLVCC1), 916 & WORK(KLVCC3),1) 917*, And reform back to CAAB basis 918 ZERO = 0.0D0 919 CALL SETVEC(WORK(KLVCC2),ZERO,N_CC_AMP) 920 CALL REF_CCV_CAAB_SP(WORK(KLVCC2),WORK(KLVCC1), 921 & WORK(KLVCC3),2) 922C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 923*. Play a bit around with spin adaptation 924*. Reorder from CAAB to CONF order ICONF(I) = ICAAB(IREO(I)) 925*. corresponding to a gathering 926C (VECO,VECI,INDEX,NDIM) 927C CALL GATVEC(WORK(KLVCC1),WORK(KLVCC2),WORK(KLREORDER_CAAB), 928C & N_CC_AMP) 929C WRITE(6,*) ' First eigenvector in conf order ' 930C CALL WRTMAT(WORK(KLVCC1),1,N_CC_AMP,1,N_CC_AMP) 931 END IF 932 933 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'IC_CMP ') 934 RETURN 935 END 936 SUBROUTINE COM_SH(S,H,VCC1,VCC2,VCC3,VEC1,VEC2, 937 & N_CC_AMP,IREFSPC,ITREFSPC, 938 & LUC,LUHC,LUSCR,LUSCR2,IDOPROJ,IUNIOP, 939 & IDO_S,IDO_H,IDO_SPA,I_DO_EI,NSPA,IDOSUB, 940 & ISUB,NSUB) 941* 942* Construct complete S and M matrices for 943* Excitations defined in CC_TCC and 944* reference space on LUC 945* 946* If IDOPROJ = 1, then the reference space is projected out 947* for all operators except the unitoperator 948* 949* IF IDOSUB.NE.0, the matrix is constructed in the space 950* defined by the NSUB elements in ISUB 951* 952* IDO_S = 1 => S is constructed 953* IDO_H = 1 => H is constructed 954* 955* If IDO_SPA = 1, the matrices are constructed in the spinadapted basis 956* If I_DO_EI = 1, the matrices are constructed in the orthonormal EI 957* basis 958* 959* Jeppe Olsen, Sept 2002 960* 961* For IDOPROJ = 1 , we are interested in calculating the matrix 962* 963* ( <0!H!0> <0!H!P Q_j!0> ) 964* ( <0!Q+(i)P!H!O> <0!Q+(I)PH PQ(J)!0>) 965* 966* The projection operators in front of evrything but !0> 967* induces some assymmetry that is organized by at the end calculating 968* explicitly 969* <0!H!0> and <0!Q+(I)P!H0> and overwriting the corresponding column 970* and row 971* 972 INCLUDE 'implicit.inc' 973 REAL*8 INPRDD 974* 975 INCLUDE 'cands.inc' 976 INCLUDE 'cstate.inc' 977*. Input 978 INTEGER ISUB(*) 979*. Output 980 DIMENSION S(*),H(*) 981*. Scratch 982 DIMENSION VCC1(*),VCC2(*),VCC3(*) 983 DIMENSION VEC1(*),VEC2(*) 984* 985 IDUM = 0 986 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'COM_SH') 987 IF(IDO_SPA.EQ.1.OR.I_DO_EI.EQ.1) THEN 988 IUNIOP = NSPA 989C? WRITE(6,*) ' Unit operator is set to last operator ' 990 END IF 991* 992 NTEST = 1005 993 IF(NTEST.GE.10) THEN 994 WRITE(6,*) ' COM_SH speaking ' 995 WRITE(6,*) ' IDOPROJ, IUNIOP = ', IDOPROJ,IUNIOP 996 WRITE(6,*) ' IDO_SPA, NSPA = ', IDO_SPA,NSPA 997 WRITE(6,*) ' IDO_S, IDO_H, = ', IDO_S, IDO_H 998 WRITE(6,*) ' IREFSPC, ITREFSPC = ', IREFSPC,ITREFSPC 999 WRITE(6,*) ' LUC, LUHC, LUSCR = ', LUC, LUHC, LUSCR 1000 END IF 1001*. Number of excitations in calculation 1002 NVAR = NSPA 1003*. Dimension of space in which S or H is constructed 1004 IF(IDOSUB.EQ.0) THEN 1005 NSBVAR = NVAR 1006 ELSE 1007 NSBVAR = NSUB 1008 END IF 1009* 1010 IUNIOP_EFF = 0 1011 IF(IDOSUB.NE.0.AND.IUNIOP.NE.0) THEN 1012*. Check if unitoperator is included in list 1013 CALL FIND_INTEGER_IN_VEC(IUNIOP,ISUB,NSUB,IUNIOP_EFF) 1014 ELSE IF(IUNIOP.NE.0) THEN 1015 IUNIOP_EFF = IUNIOP 1016 END IF 1017 WRITE(6,*) ' IUNIOP_EFF = ', IUNIOP_EFF 1018 1019 1020 LEN = NSBVAR**2 1021 1022 ZERO = 0.0D0 1023 IF(IDO_S.EQ.1) CALL SETVEC(S,ZERO,LEN) 1024 IF(IDO_H.EQ.1) CALL SETVEC(H,ZERO,LEN) 1025* 1026* 1027*. Use new approach based on H,S times vector routines 1028*. It has not been checked with subspaces 1029*. 1030 WRITE(6,*) ' NEW route used to construct ICCI matrices ' 1031 DO I = 1, NSBVAR 1032 IF(NTEST.GE.5) WRITE(6,*) 'Constructing row of S,H for I = ',I 1033 ZERO = 0.0D0 1034 CALL SETVEC(VCC1,ZERO,NVAR) 1035 IF(IDOSUB.EQ.0) THEN 1036 VCC1(I) = 1.0D0 1037 ELSE 1038 VCC1(ISUB(I)) = 1.0D0 1039 END IF 1040* 1041*. Overlap terms 1042* 1043 IF(IDO_S.EQ.1) THEN 1044 CALL H_S_EXT_ICCI_TV(VCC1,XDUM,VCC2,0,1) 1045 IF(IDOSUB.EQ.0) THEN 1046 CALL COPVEC(VCC2,S(1+(I-1)*NSBVAR),NSBVAR) 1047 ELSE 1048 CALL GATVEC(S(1+(I-1)*NSBVAR),VCC2,ISUB,NSBVAR) 1049 END IF 1050 END IF 1051* 1052*. Hamilton terms 1053* 1054 IF(IDO_H.EQ.1) THEN 1055 CALL H_S_EXT_ICCI_TV(VCC1,VCC2,XDUM,1,0) 1056 IF(IDOSUB.EQ.0) THEN 1057 CALL COPVEC(VCC2,H(1+(I-1)*NSBVAR),NSBVAR) 1058 ELSE 1059 CALL GATVEC(H(1+(I-1)*NSBVAR),VCC2,ISUB,NSBVAR) 1060 END IF 1061 END IF 1062* 1063 END DO 1064* 1065 IF(NTEST.GE.100) THEN 1066 IF(IDO_S.EQ.1) THEN 1067 WRITE(6,*) ' Constructed S matrix ' 1068 WRITE(6,*) ' ==================== ' 1069 CALL WRTMAT(S,NSBVAR,NSBVAR,NSBVAR,NSBVAR) 1070 END IF 1071 IF(IDO_H.EQ.1) THEN 1072 WRITE(6,*) ' Constructed H matrix ' 1073 WRITE(6,*) ' ======================' 1074 CALL WRTMAT(H,NSBVAR,NSBVAR,NSBVAR,NSBVAR) 1075 END IF 1076 END IF 1077* 1078 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'COM_SH') 1079* 1080 RETURN 1081 END 1082 SUBROUTINE EXTR_CIV(ISM,ISPCIN,LUIN, 1083 & ISPCX,IEX_OR_DE,LUUT,LBLK, 1084 & LUSCR,NROOT,ICOPY,IDC,NTESTG) 1085* A vector of sym ISM and space ISPCIN is given in LUIN 1086* Extract(IEX_OR_DE=1) or delete (IEX_OR_DE = 2) the 1087* parts of the CI vector that is in space ISPCX 1088* 1089* The output form is the same as the input form, only 1090* some blocks are zeroed. 1091* 1092* Jeppe Olsen, September 2002 from EXP_CIV 1093* 1094 INCLUDE 'wrkspc.inc' 1095C IMPLICIT REAL*8(A-H,O-Z) 1096C INCLUDE 'mxpdim.inc' 1097 INCLUDE 'cicisp.inc' 1098 INCLUDE 'crun.inc' 1099 INCLUDE 'strbas.inc' 1100 INCLUDE 'stinf.inc' 1101 INCLUDE 'csm.inc' 1102 INCLUDE 'cgas.inc' 1103 INCLUDE 'gasstr.inc' 1104 1105* 1106 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'EXTR_C') 1107* 1108 NTESTL = 00 1109C NTEST = MAX(NTESTG,NTESTL) 1110 NTEST = 00 1111 IF(NTEST.GE.10) THEN 1112 WRITE(6,*) ' EXTR_CIV: Subspace to be modified ', ISPCX 1113 END IF 1114* 1115 IATP = 1 1116 IBTP = 2 1117* 1118 NOCTPA = NOCTYP(IATP) 1119 NOCTPB = NOCTYP(IBTP) 1120* 1121 IOCTPA = IBSPGPFTP(IATP) 1122 IOCTPB = IBSPGPFTP(IBTP) 1123* 1124* 1125*. Allowed combinations of strings types for input and ISPCX 1126*. spaces 1127* 1128 CALL MEMMAN(KLIABI,NOCTPA*NOCTPB,'ADDL ',1,'KLIABI') 1129 CALL MEMMAN(KLIABX,NOCTPA*NOCTPB,'ADDL ',1,'KLIABU') 1130 CALL IAIBCM(ISPCIN,WORK(KLIABI)) 1131 CALL IAIBCM(ISPCX,WORK(KLIABX)) 1132* 1133* type of each symmetry block ( full, lower diagonal, absent ) 1134* 1135 CALL MEMMAN(KLBLIN,NSMST,'ADDL ',1,'KLBLIN') 1136 CALL ZBLTP(ISMOST(1,ISM),NSMST,IDC,WORK(KLBLIN),IDUMMY) 1137*. A scratch block 1138 LENGTH = MXSOOB 1139 CALL MEMMAN(KLVEC,LENGTH,'ADDL ',2,'LVEC ') 1140* 1141 IF(NTEST.GE.1000) THEN 1142 CALL REWINO(LUIN) 1143 WRITE(6,*) ' Initial vectors in EXTR_CIV ' 1144 DO IROOT = 1, NROOT 1145 WRITE(6,*) ' Root number ', IROOT 1146 CALL WRTVCD(WORK(KLVEC),LUIN,0,-1) 1147 END DO 1148 END IF 1149* ^ End of test 1150* 1151 CALL REWINO(LUIN) 1152 CALL REWINO(LUUT) 1153 DO IROOT = 1, NROOT 1154*. Input vector should be first vector on file so 1155 IF(IROOT.EQ.1) THEN 1156 LLUIN = LUIN 1157 ELSE 1158*. With the elegance of an elephant 1159 CALL REWINO(LUSCR) 1160 CALL REWINO(LUIN) 1161 DO JROOT = 1, IROOT 1162 CALL REWINO(LUSCR) 1163 CALL COPVCD(LUIN,LUSCR,WORK(KLVEC),0,-1) 1164 END DO 1165 CALL REWINO(LUSCR) 1166 LLUIN = LUSCR 1167 END IF 1168*. Expcivs may need the IAMPACK parameter ( in case it must write 1169* a zero block before any blocks have been read in. 1170* Use IDIAG to decide 1171 IF(IDIAG.EQ.1) THEN 1172 IAMPACK = 0 1173 ELSE 1174 IAMPACK = 1 1175 END IF 1176C WRITE(6,*) ' IAMPACK in EXPCIV ', IAMPACK 1177* 1178 CALL EXTRCIVS(LLUIN,WORK(KLVEC),WORK(KLIABI), 1179 & NOCTPA,NOCTPB,WORK(KLBLIN), 1180 & LUUT,WORK(KLIABX),IEX_OR_DE, 1181 & IDC,NSMST,LBLK,IAMPACK,ISMOST(1,ISM), 1182 & WORK(KNSTSO(IATP)),WORK(KNSTSO(IBTP))) 1183* 1184 END DO 1185* 1186 IF(ICOPY.NE.0) THEN 1187*. Copy expanded vectors to LUIN 1188 CALL REWINO(LUIN) 1189 CALL REWINO(LUUT) 1190 DO IROOT = 1, NROOT 1191 CALL COPVCD(LUUT,LUIN,WORK(KLVEC),0,-1) 1192 END DO 1193 END IF 1194* 1195 IF(NTEST.GE.1000) THEN 1196 WRITE(6,*) ' Output vectors in EXTR_CIV ' 1197* 1198 CALL REWINO(LUUT) 1199 DO IROOT = 1, NROOT 1200C? WRITE(6,*) ' Root number ', IROOT 1201 CALL WRTVCD(WORK(KLVEC),LUUT,0,-1) 1202 END DO 1203 END IF 1204* 1205 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'EXTR_C') 1206* 1207 RETURN 1208 END 1209C CALL EXTRCIVS(LLUIN,WORK(KLBLI),WORK(KLIABIN), 1210C & NOCTPA,NOCTPB,WORK(KLBLIN), 1211C & LUUT,WORK(KLIABX),IEX_OR_DE, 1212C & IDC,NSMST,LBLK,IAMPACK,ISMOST(1,ISM), 1213C & WORK(KNSTSO(IATP)),WORK(KNSTSO(IBTP))) 1214 SUBROUTINE EXTRCIVS(LUIN,VEC,IABIN, 1215 & NOCTPA,NOCTPB,IBLTPIN, 1216 & LUUT,IABX,IEX_OR_DE, 1217 & IDC,NSMST,LBLK,IAMPACKED_IN, 1218 & ISMOST,NSSOA,NSSOB) 1219* 1220* IEX_OR_DE = 1 : Copy those blocks of LUIN that are allowed according 1221* to IABX, set remaining blocks to 0 1222* IEX_OR_DE = 2 : Copy blocks of LUIN that are not allowed according 1223* to IABX, set remaining blocks to 0 1224* 1225* Input vector on LUIN, Output vector in LUUT 1226* Output vector is supposed on start of vector 1227* 1228* LUIN is assumed to be single vector file, 1229* so rewinding will place vector on start of vector 1230* 1231* Note that the form of the two files will be identical, 1232* just that LUUT will contain some zero blocks 1233* 1234* ALL ICISTR = 1 code has been removed 1235* 1236* Jeppe Olsen, September 2002 from EXPCIVS 1237* 1238 IMPLICIT REAL*8 (A-H,O-Z) 1239*. Input 1240 INTEGER IABIN(NOCTPA,NOCTPB),IABX(NOCTPA,NOCTPB) 1241 INTEGER IBLTPIN(NSMST) 1242*, Symmetry of other string, given total symmetry 1243 INTEGER ISMOST(NSMST) 1244 INTEGER NSSOA(NSMST,*),NSSOB(NSMST,*) 1245*. Scratch 1246 DIMENSION VEC(*) 1247* 1248*. Loop over TTS blocks of output vector 1249 IATP = 1 1250 IBTP = 1 1251 IASM = 0 1252 1000 CONTINUE 1253*. Next block 1254 CALL NXTBLK(IATP,IBTP,IASM,NOCTPA,NOCTPB,NSMST, 1255 & IBLTPIN,IDC,NONEW,IABIN,ISMOST, 1256 & NSSOA,NSSOB,LBLOCK,LBLOCKP) 1257 IF(IABX(IATP,IBTP).EQ.0) THEN 1258 IF(IEX_OR_DE.EQ.1) THEN 1259 ICOPY = 0 1260 ELSE 1261 ICOPY = 1 1262 END IF 1263 ELSE 1264 IF(IEX_OR_DE.EQ.1) THEN 1265 ICOPY = 1 1266 ELSE 1267 ICOPY = 0 1268 END IF 1269 END IF 1270* 1271 IF(NONEW.EQ.0) THEN 1272 CALL IFRMDS(LENGTH,1,-1,LUIN) 1273 CALL FRMDSC(VEC,LENGTH,-1,LUIN,IMZERO,IAMPACK) 1274* 1275 CALL ITODS(LENGTH,1,-1,LUUT) 1276 IF(ICOPY.EQ.0) THEN 1277 CALL ZERORC(-1,LUUT,IAMPACKED_IN) 1278 ELSE 1279 IF(IAMPACK.EQ.0) THEN 1280 CALL TODSC(VEC,LENGTH,-1,LUUT) 1281 ELSE 1282 CALL TODSCP(VEC,LENGTH,-1,LUUT) 1283 END IF 1284 END IF 1285 GOTO 1000 1286 END IF 1287*. End of file on output vector 1288 CALL ITODS(-1,1,-1,LUUT) 1289* 1290 NTEST = 00 1291 IF(NTEST.NE.0) THEN 1292 WRITE(6,*) ' EXPTRCIVS Speaking ' 1293 WRITE(6,*) ' =================' 1294 WRITE(6,*) 1295 WRITE(6,*) ' ============ ' 1296 WRITE(6,*) ' Input Vector ' 1297 WRITE(6,*) ' ============ ' 1298 WRITE(6,*) 1299 CALL WRTVCD(VEC,LUIN,1,LBLK) 1300 WRITE(6,*) 1301 WRITE(6,*) ' =============== ' 1302 WRITE(6,*) ' Output Vector ' 1303 WRITE(6,*) ' =============== ' 1304 WRITE(6,*) 1305 CALL WRTVCD(VEC,LUUT,1,LBLK) 1306 END IF 1307* 1308 RETURN 1309 END 1310 SUBROUTINE GET_CONF_FOR_ORBEX(NCOC_FSM,NAOC_FSM,ICOC,IAOC, 1311 & NOP_C,NOP_A, IBCOC_FSM,IBAOC_FSM,NSMST,IOPSM, 1312 & ICAOC) 1313*. Obtain the configurations for given C and A occupations 1314* 1315*. Jeppe Olsen, Sept. 2002 1316* 1317 INCLUDE 'implicit.inc' 1318 INCLUDE 'multd2h.inc' 1319* 1320* ====== 1321*. Input 1322* ====== 1323* 1324*. Number of C and A occupations per symmetry 1325 INTEGER NCOC_FSM(NSMST), NAOC_FSM(NSMST) 1326*. Offset for C and A occupations of given sym 1327 INTEGER IBCOC_FSM(NSMST), IBAOC_FSM(NSMST) 1328*. And the actual C and A orbital configurations 1329 INTEGER ICOC(NOP_C,*), IAOC(NOP_A,*) 1330* 1331* ======= 1332*. Output 1333* ======= 1334* 1335 INTEGER ICAOC(NOP_C+NOP_A,*) 1336* 1337 NTEST = 10 1338 IF(NTEST.GE.1000) THEN 1339 WRITE(6,*) ' C and A strings of sym 1 ' 1340 CALL IWRTMA(ICOC,NOP_C,NCOC_FSM(1),NOP_C,NCOC_FSM(1)) 1341 CALL IWRTMA(IAOC,NOP_A,NAOC_FSM(1),NOP_A,NAOC_FSM(1)) 1342 END IF 1343 JCONF = 0 1344 DO ICSM = 1, NSMST 1345 IASM = MULTD2H(IOPSM,ICSM) 1346 NC = NCOC_FSM(ICSM) 1347 NA = NAOC_FSM(IASM) 1348 DO IA = 1, NA 1349 DO IC = 1, NC 1350 IC_ABS = IBCOC_FSM(ICSM) - 1 + IC 1351 IA_ABS = IBAOC_FSM(IASM) - 1 + IA 1352 JCONF = JCONF + 1 1353 CALL ICOPVE(ICOC(1,IC_ABS),ICAOC(1,JCONF),NOP_C) 1354 CALL ICOPVE(IAOC(1,IA_ABS),ICAOC(1+NOP_C,JCONF),NOP_A) 1355 END DO 1356 END DO 1357* ^ End of loop over C and A 1358 END DO 1359* ^ End of loop over sym of C strings 1360 NCONF = JCONF 1361* 1362 IF(NTEST.GE.100) THEN 1363 WRITE(6,*) ' Number of operators in C and A ',NOP_C, NOP_A 1364 WRITE(6,*) ' List of CA configurations ' 1365 WRITE(6,*) ' ==========================' 1366 WRITE(6,*) 1367 WRITE(6,*) ' Creation part Annihilation part ' 1368 WRITE(6,*) ' ======================================' 1369 DO JCONF = 1, NCONF 1370 WRITE(6,'(1H , 20(1X,I3))') (ICAOC(I,JCONF),I=1,NOP_C+NOP_A) 1371 END DO 1372 END IF 1373* 1374 RETURN 1375 END 1376 SUBROUTINE GET_CA_CONF_FOR_ORBEX(ICEX_TP,IAEX_TP, 1377 & NCOC_FSM,NAOC_FSM,IBCOC_FSM,IBAOC_FSM, 1378 & KCOC,KAOC,KZC,KZA,KCREO,KAREO) 1379* 1380* Obtain the occupations, Arc weights and reordering matrices 1381* for a Creation and Annihilation types defined by ICEX_TP, IAEX_TP 1382* 1383* 1384* Jeppe Olsen, Sept 2002 1385* 1386 INCLUDE 'wrkspc.inc' 1387 INCLUDE 'cgas.inc' 1388 INCLUDE 'csm.inc' 1389 INCLUDE 'orbinp.inc' 1390*. Input 1391 INTEGER ICEX_TP(NGAS),IAEX_TP(NGAS) 1392* 1393*. Output 1394* 1395*. Number of creation and annihilation occupations per symmetry 1396 INTEGER NCOC_FSM(MXPNSMST), NAOC_FSM(MXPNSMST) 1397*. Start of creation and annihilation occupations of given symmetry 1398 INTEGER IBCOC_FSM(MXPNSMST), IBAOC_FSM(MXPNSMST) 1399* 1400* A number of terms are delivered in arrays allocated in this 1401* subroutine 1402 NTEST = 000 1403 IF(NTEST.GE.100) THEN 1404 WRITE(6,*) ' INFO from GET_CA_CONF_FOR_ORBEX ' 1405 WRITE(6,*) ' Creation excitation type ' 1406 CALL IWRTMA(ICEX_TP,1,NGAS,1,NGAS) 1407 WRITE(6,*) ' Annihilation excitation type ' 1408 CALL IWRTMA(IAEX_TP,1,NGAS,1,NGAS) 1409 END IF 1410* 1411* ================ 1412*. Creation strings 1413* ================ 1414* 1415*.Number of strings per symmetry 1416 1417 IDUMMY = 0 1418 CALL GET_CONF_FOR_OCCLS(ICEX_TP,NCOC_FSM,IBCOC_FSM,IDUMMY, 1419 & NSMST,1) 1420* 1421*. the actual occupation 1422* 1423 NCOC_TOT = IELSUM(NCOC_FSM,NSMST) 1424 NELC = IELSUM(ICEX_TP,NGAS) 1425 CALL MEMMAN(KCOC,NELC*NCOC_TOT,'ADDL ',2,'COC ') 1426 CALL GET_CONF_FOR_OCCLS(ICEX_TP,NCOC_FSM,IBCOC_FSM,WORK(KCOC), 1427 & NSMST,2) 1428* 1429* Arc weights for addressing creation occupations 1430* 1431*. Memory for arc weights 1432 CALL MEMMAN(KZC,2*NTOOB*NELC,'ADDL ',2,'ZCconf') 1433 1434*. Local scratch is needed for REO_CONFIGS, so 1435 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'REO_C1') 1436* 1437 CALL MEMMAN(KLSCR,(NTOOB+1)*(NELC+1),'ADDL ',2,'LSCR ') 1438 CALL MEMMAN(KLOCMIN,NTOOB,'ADDL ',2,'LOCMIN') 1439 CALL MEMMAN(KLOCMAX,NTOOB,'ADDL ',2,'LOCMAX') 1440*. Min/Max occupation 1441 CALL MXMNOC_OCCLS(WORK(KLOCMIN),WORK(KLOCMAX),NGAS,NOBPT, 1442 & ICEX_TP,0,0) 1443*. and the arc weights 1444 CALL CONF_GRAPH(WORK(KLOCMIN),WORK(KLOCMAX),NTOOB,NELC, 1445 & WORK(KZC),NCONFT,WORK(KLSCR)) 1446*. And remove the local memory 1447 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'REO_C1') 1448* Reorder array : Lexical to actual numbers 1449 CALL MEMMAN(KCREO,NCOC_TOT,'ADDL ',2,'COC_RE') 1450 CALL REO_CONFIGS(WORK(KCOC),NCOC_TOT,NELC,WORK(KZC), 1451 & NTOOB,WORK(KCREO),IBCOC_FSM) 1452* 1453* ====================== 1454*. Annihilation strings 1455* ====================== 1456* 1457* 1458*. Number per symmetry 1459 CALL GET_CONF_FOR_OCCLS(IAEX_TP,NAOC_FSM,IBAOC_FSM,IAOC,NSMST, 1460 & 1) 1461*. The actual occupations 1462 NAOC_TOT = IELSUM(NAOC_FSM,NSMST) 1463 NELA = IELSUM(IAEX_TP,NGAS) 1464 CALL MEMMAN(KAOC,NELA*NAOC_TOT,'ADDL ',2,'AOC ') 1465 CALL GET_CONF_FOR_OCCLS(IAEX_TP,NAOC_FSM,IBAOC_FSM,WORK(KAOC), 1466 & NSMST,2) 1467* 1468* Arc weights for addressing occupations 1469* 1470*. Memory for arc weights 1471 CALL MEMMAN(KZA,2*NTOOB*NELA,'ADDL ',2,'ZCconf') 1472 1473*. Local scratch is needed for REO_CONFIGS, so 1474 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'REO_C1') 1475* 1476 CALL MEMMAN(KLSCR,(NTOOB+1)*(NELA+1),'ADDL ',2,'LSCR ') 1477 CALL MEMMAN(KLOCMIN,NTOOB,'ADDL ',1,'LOCMIN') 1478 CALL MEMMAN(KLOCMAX,NTOOB,'ADDL ',1,'LOCMAX') 1479*. Min/Max occupation 1480 CALL MXMNOC_OCCLS(WORK(KLOCMIN),WORK(KLOCMAX),NGAS,NOBPT, 1481 & IAEX_TP,0,0) 1482*. and the arc weights 1483 CALL CONF_GRAPH(WORK(KLOCMIN),WORK(KLOCMAX),NTOOB,NELA, 1484 & WORK(KZA),NCONFT,WORK(KLSCR)) 1485*. And remove the local memory 1486 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'REO_C1') 1487* Reorder array : Lexical to actual numbers 1488 CALL MEMMAN(KAREO,NAOC_TOT,'ADDL ',2,'COC_RE') 1489 CALL REO_CONFIGS(WORK(KAOC),NAOC_TOT,NELA,WORK(KZA), 1490 & NTOOB,WORK(KAREO),IBAOC_FSM) 1491* 1492 IF(NTEST.GE.100) THEN 1493 WRITE(6,*) ' Number of C occupations per symmetry ' 1494 CALL IWRTMA(NCOC_FSM,1,NSMST,1,NSMST) 1495 WRITE(6,*) ' Number of A occupations per symmetry ' 1496 CALL IWRTMA(NAOC_FSM,1,NSMST,1,NSMST) 1497 END IF 1498* 1499 RETURN 1500 END 1501* 1502 SUBROUTINE GET_CONF_FOR_OCCLS(IOC_TP,NOC_FSM,IBOC_FSM,IOC, 1503 & NSMST,IWAY) 1504* 1505* Obtain the number of occupations and the actual occupations ( IWAY = 2) 1506* for given occupation type (IOC_TP) 1507* 1508* Jeppe Olsen, September 2002 1509* 1510 INCLUDE 'implicit.inc' 1511 INCLUDE 'mxpdim.inc' 1512 INCLUDE 'cgas.inc' 1513 INCLUDE 'orbinp.inc' 1514*. Input : Number of electrons per GAS space 1515 INTEGER IOC_TP(NGAS) 1516*. Input if IWAY = 2 , else output 1517* Offset for occupations of given sym 1518 INTEGER IBOC_FSM(NSMST) 1519*. Output : Number of occupations per symmetru 1520 INTEGER NOC_FSM(NSMST) 1521*. Output if IWAY = 2 : The actual occupations ordered by symmetry 1522 INTEGER IOC(*) 1523*. Scratch space 1524 INTEGER ICONF(MXPNEL) 1525* 1526 NEL = IELSUM(IOC_TP,NGAS) 1527* 1528 IZERO = 0 1529 CALL ISETVC(NOC_FSM,IZERO,NSMST) 1530*. Loop over configurations 1531 INI = 1 1532 NONEW = 0 1533 NCONF_TEST = 0 1534 1000 CONTINUE 1535*. Next configuration 1536C NEXT_CONF_FOR_OCCLS(ICONF,IOCCLS,NGAS,NOBPT,INI,NONEW) 1537 CALL NEXT_CONF_FOR_OCCLS(ICONF,IOC_TP,NGAS,NOBPT,INI,NONEW) 1538 INI = 0 1539 NCONF_TEST = NCONF_TEST + 1 1540C? WRITE(6,*) ' Nonew = ', NONEW 1541C? WRITE(6,*) ' Conf from NEXT_CONF = ' 1542C? CALL IWRTMA(ICONF,1,NEL,1,NEL) 1543* 1544C? IF(NCONF_TEST.GE.100) THEN 1545C? WRITE(6,*) ' Enforced stop in GET_CONF ' 1546C? STOP ' Enforced stop in GET_CONF ' 1547C? END IF 1548* 1549 IF(NONEW.EQ.0) THEN 1550*. Another configuration has been delivered 1551*. Find symmetry 1552 ISYM = ISYMST(ICONF,NEL) 1553 NOC_FSM(ISYM) = NOC_FSM(ISYM) + 1 1554 IF(IWAY.EQ.2) THEN 1555 NOC_TOT = IBOC_FSM(ISYM)-1 + NOC_FSM(ISYM) 1556 CALL ICOPVE(ICONF,IOC(1+(NOC_TOT-1)*NEL),NEL) 1557 END IF 1558 1559 GOTO 1000 1560 END IF 1561*. Total number of configurations 1562 NCONF_TOT = IELSUM(NOC_FSM,NSMST) 1563*. Offsets 1564C ZBASE(NVEC,IVEC,NCLASS) 1565 CALL ZBASE(NOC_FSM,IBOC_FSM,NSMST) 1566* 1567 NTEST = 00 1568 IF(NTEST.GE.100) THEN 1569 WRITE(6,*) ' Occupation over gas spaces : ' 1570 CALL IWRTMA(IOC_TP,1,NGAS,1,NGAS) 1571 WRITE(6,*) ' Number of configurations per symmetry ' 1572 CALL IWRTMA(NOC_FSM,1,NSMST,1,NSMST) 1573* 1574 IF(IWAY.EQ.2) THEN 1575 WRITE(6,*) ' The actual configurations ' 1576 CALL IWRTMA(IOC,NEL,NCONF_TOT,NEL,NCONF_TOT) 1577 END IF 1578 END IF 1579* 1580 RETURN 1581 END 1582 SUBROUTINE REO_CONFIGS(ICONF,NCONF,NEL,IZ,NORBT,IREO,IB_FSM) 1583* 1584* Obtain reorder array lexical order => actual order 1585* for a set of configurations 1586* 1587* Offsets are defined with respect to start of symmetry 1588* 1589* Jeppe Olsen, Sept. 2002 1590* 1591 INCLUDE 'implicit.inc' 1592 INCLUDE 'mxpdim.inc' 1593* 1594*. Input 1595* ======= 1596* 1597*. The occupation of configurations 1598 INTEGER ICONF(NEL,NCONF) 1599*. Arcweights 1600 INTEGER IZ(NORBT,NEL,2) 1601*. Offset for strings with given symmetry 1602 INTEGER IB_FSM(*) 1603* 1604*. Output 1605* ======= 1606* 1607*. Reorder array lexical => actual order 1608 DIMENSION IREO(*) 1609*. Local scratch : for configuration in truncated form 1610 DIMENSION ICONF2(MXPORB) 1611* 1612C? WRITE(6,*) ' In REO .. NORBT, NEL = ', NORBT, NEL 1613C? WRITE(6,*) ' In REO, Number of configurations=', NCONF 1614 DO I = 1, NCONF 1615*. Obtain configuration in compact form -using negative numbers 1616*. to flag double occupied orbitals 1617C REFORM_CONF_OCC(IOCC_EXP,IOCC_PCK,NEL,NOCOB,IWAY) 1618C? WRITE(6,*) ' Config to be reordered ', 1619C? & (ICONF(J,I),J=1,NEL) 1620 CALL REFORM_CONF_OCC(ICONF(1,I),ICONF2,NEL,NOCOB,1) 1621C ILEX_FOR_CONF(ICONF,NOCC_ORB,NORB,NEL,IARCW,IDOREO,IREO) 1622C? WRITE(6,*) ' NOCOB = ', NOCOB 1623*. Symmetry of this configuration 1624 ISM = ISYMST(ICONF(1,I),NEL) 1625C? WRITE(6,*) ' ISM = ', ISM 1626 ILEX = ILEX_FOR_CONF(ICONF2,NOCOB,NORBT,NEL,IZ,0,IREO) 1627 IREO(ILEX) = I - IB_FSM(ISM) + 1 1628 END DO 1629* 1630 NTEST = 00 1631 IF(NTEST.GE.100) THEN 1632 WRITE(6,*) ' Reorder array, lexical => actual address ' 1633 WRITE(6,*) ' Actual address is w.r.t. to start of block' 1634 CALL IWRTMA(IREO,1,NCONF,1,NCONF) 1635 END IF 1636* 1637 RETURN 1638 END 1639 SUBROUTINE IABS_TO_REL(IARRAY,NBLOCK,LBLOCK) 1640* 1641* An array IARRAY is given. Reform IARRAY, so each index 1642* refers to start of block 1643* 1644 INCLUDE 'implicit.inc' 1645 INTEGER IARRAY(*), LBLOCK(NBLOCK) 1646* 1647 IOFF = 1 1648 DO IBLOCK = 1, NBLOCK 1649 IF(IBLOCK.EQ.1) THEN 1650 IOFF = 1 1651 ELSE 1652 IOFF = IOFF + LBLOCK(IBLOCK-1) 1653 END IF 1654 DO I = IOFF, IOFF + LBLOCK(IBLOCK-1)-1 1655 IARRAY(I) = IARRAY(I) - IOFF + 1 1656 END DO 1657 END DO 1658 NELMNT = IOFF + LBLOCK(NBLOCK)-1 1659* 1660 NTEST = 100 1661 IF(NTEST.GE.100) THEN 1662 WRITE(6,*) ' Array with relative indexing ' 1663 WRITE(6,*) ' ============================ ' 1664 CALL IWRTMA(IARRAY,1,NELMNT,1,NELMNT) 1665 END IF 1666* 1667 RETURN 1668 END 1669 SUBROUTINE CAAB_TO_CA_OC(ISM,ISPOBEX_TP,IOBEX_TP,IOBEX_NUM, 1670 & ISOX_FOR_OX,IBSOX_FOR_OX,NSOX_FOR_OX, 1671 & IBSPOBEX, 1672 & MX_ST_TSOSO_BLK_MX,NOP_CA, 1673 & IZC, IZA, ICREO,IAREO,ICAOC, 1674 & IBCA,NCOC_FSM, 1675 & IBCAAB_FOR_CA,ICAAB_FOR_CA_OP,ICAAB_FOR_CA_NUM, 1676 & LCAAB_FOR_CA,NCAAB_FOR_CA, 1677 & NOBCONF,NSPOBOP,NCOMP_FOR_PROTO) 1678 1679 1680* 1681* Obtain the spinorbital excitations for each orbital excitation 1682* 1683* 1684* Jeppe Olsen, September 02 1685*. Modified to allow general prototypes, August 2004 1686* 1687C INCLUDE 'implicit.inc' 1688C INCLUDE 'mxpdim.inc' 1689 INCLUDE 'wrkspc.inc' 1690 INCLUDE 'glbbas.inc' 1691 INCLUDE 'clunit.inc' 1692 INCLUDE 'cintfo.inc' 1693 INCLUDE 'orbinp.inc' 1694 INCLUDE 'cgas.inc' 1695* 1696* ===== 1697*. Input 1698* ===== 1699* 1700*. The array of all spinorbital excitations 1701 INTEGER ISPOBEX_TP(4*NGAS,*) 1702*. All orbital orbital operators, the orbital excitation in action is 1703*. IOBEX_NUM 1704 INTEGER IOBEX_TP(NGAS*2,*) 1705*. The arcweights for the C and A orbital occupations 1706 INTEGER IZC(*),IZA(*) 1707*. The reorder arrays for the C and A orbital occupations 1708 INTEGER ICREO(*), IAREO(*) 1709*. The occupation of the C and A orbital occupations 1710C INTEGER ICOC(*), IAOC(*) 1711*. Offset to CA configurations with a given sym of C 1712 INTEGER IBCA(*) 1713*. Number of creation strings per symmetry 1714 INTEGER NCOC_FSM(*) 1715*. The list of orbital configurations 1716 INTEGER ICAOC(NOP_CA,NOBCONF) 1717*. The spinorbital excitation types for a given orbital excitation type 1718 INTEGER ISOX_FOR_OX(*) 1719*. The start of spinorbital excitations in ISOX_FOR_OX for 1720*. a given orbital excitations 1721 INTEGER IBSOX_FOR_OX(*) 1722*. Number of spinorbital excitations for each orbital excitation 1723 INTEGER NSOX_FOR_OX(*) 1724*.Base for coefficients for given spinorbital excitation type 1725 INTEGER IBSPOBEX(*) 1726*. Number of Components for the various prototype CA's 1727 INTEGER NCOMP_FOR_PROTO(*) 1728 1729* 1730* ======= 1731*. Output 1732* ======= 1733*. The CAAB strings for a given CA configurations 1734*. ( LCAAB is the (max) number of elementary excitations in 1735* the CAAB operators) 1736 INTEGER ICAAB_FOR_CA_OP(NOP_CA,*) 1737*. The address in the spinorbital list for the CAABS belonging to a CAAB 1738 INTEGER ICAAB_FOR_CA_NUM(NSPOBOP) 1739*. The number of CAAB operators for each CA operators 1740 INTEGER NCAAB_FOR_CA(NOBCONF) 1741*. The number of operators in each of the CA CB AA AB operators 1742 INTEGER LCAAB_FOR_CA(4,NSPOBOP) 1743*. The address of the first CAAB operator for a given CA operator 1744 INTEGER IBCAAB_FOR_CA(NOBCONF) 1745*. Offset in for the CAAB 1746 IDUM = 0 1747 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GCC_FD') 1748* 1749 NTEST = 10 1750* 1751 IF(NTEST.GE.100) THEN 1752 WRITE(6,*) 1753 WRITE(6,*) ' -------------------------------' 1754 WRITE(6,*) ' Information from CAAB_TO_CA_OC ' 1755 WRITE(6,*) ' -------------------------------' 1756 WRITE(6,*) 1757 WRITE(6,*) ' CA => CAAB map for orbital excitation ', IOBEX_NUM 1758 WRITE(6,*) ' The corresponding CA operator ' 1759 CALL IWRTMA(IOBEX_TP(1,IOBEX_NUM),NGAS,2,NGAS,2) 1760 WRITE(6,*) ' NOBCONF,NSPOBOP = ', NOBCONF,NSPOBOP 1761 WRITE(6,*) ' NCOC_FSM(1) ', NCOC_FSM(1) 1762 END IF 1763* 1764*. Set up the the array IBCAAB_FOR_CA assuming that all 1765*. spinorbital excitations belonging to a given orbital excitation 1766* are given 1767*. Number of operators in creation and annihilation part 1768 NOP_C = IELSUM(IOBEX_TP(1 ,IOBEX_NUM),NGAS) 1769 NOP_A = IELSUM(IOBEX_TP(1+NGAS,IOBEX_NUM),NGAS) 1770 NOP_CA = NOP_C + NOP_A 1771C? WRITE(6,*) ' NOP_C, NOP_A = ', NOP_C, NOP_A 1772 IOFF = 1 1773 DO JOBEX = 1, NOBCONF 1774*. Obtain prototype for this CA ex 1775 IPROTO = IPROTO_TYPE_FOR_CA(ICAOC(1,JOBEX),IOBEX_NUM, 1776 & NOP_C,NOP_A) 1777 NDET_FOR_CA = NCOMP_FOR_PROTO(IPROTO) 1778 IF(NTEST.GE.100) THEN 1779 WRITE(6,*) ' Orbital excitation ' 1780 CALL IWRTMA(ICAOC(1,JOBEX),1,NOP_CA,1,NOP_CA) 1781 WRITE(6,*) ' Prototype of orbexc ', IPROTO 1782 WRITE(6,*) ' Number of dets for conf ', NDET_FOR_CA 1783 END IF 1784 IBCAAB_FOR_CA(JOBEX) = IOFF 1785 IOFF = IOFF + NDET_FOR_CA 1786 END DO 1787 IF(NTEST.GE.100) THEN 1788 WRITE(6,*) ' IBCAAB_FOR_CA : ' 1789 CALL IWRTMA(IBCAAB_FOR_CA,1, NOBCONF,1, NOBCONF) 1790 END IF 1791* 1792 IZERO = 0 1793 CALL ISETVC(NCAAB_FOR_CA,IZERO,NOBCONF) 1794*. Four blocks of string occupations 1795 CALL MEMMAN(KLSTR1_OCC,MX_ST_TSOSO_BLK_MX,'ADDL ',1,'STOCC1') 1796 CALL MEMMAN(KLSTR2_OCC,MX_ST_TSOSO_BLK_MX,'ADDL ',1,'STOCC2') 1797 CALL MEMMAN(KLSTR3_OCC,MX_ST_TSOSO_BLK_MX,'ADDL ',1,'STOCC3') 1798 CALL MEMMAN(KLSTR4_OCC,MX_ST_TSOSO_BLK_MX,'ADDL ',1,'STOCC4') 1799* 1800*. Loop over spinorbitaltypes for the given orbital excitations 1801 JSTART = IBSOX_FOR_OX(IOBEX_NUM) 1802 JSTOP = JSTART + NSOX_FOR_OX(IOBEX_NUM) - 1 1803 DO JJSPOBEX = JSTART, JSTOP 1804 JSPOBEX = ISOX_FOR_OX(JJSPOBEX) 1805C WRITE(6,*) ' .. OCS will be called for JSPOBEX = ', 1806C & JSPOBEX 1807 JOFF = IBSPOBEX(JSPOBEX) 1808 CALL CAAB_TO_CA_OCS(ISPOBEX_TP(1,JSPOBEX),JOFF,1,NOP_CA, 1809 & IZC,IZA,ICREO,IAREO, 1810 & WORK(KLSTR1_OCC),WORK(KLSTR2_OCC), 1811 & WORK(KLSTR3_OCC),WORK(KLSTR4_OCC),IBCA, 1812 & NCOC_FSM,IBCAAB_FOR_CA,ICAAB_FOR_CA_OP,ICAAB_FOR_CA_NUM, 1813 & NCAAB_FOR_CA,LCAAB_FOR_CA) 1814 END DO 1815* 1816 IF(NTEST.GE.100) THEN 1817 WRITE(6,*) ' Info on CAAB => CA relations ' 1818 WRITE(6,*) ' =============================' 1819 WRITE(6,*) 1820 DO JOBCONF = 1, NOBCONF 1821 WRITE(6,*) ' CA conf ', JOBCONF, ' has ', 1822 & NCAAB_FOR_CA(JOBCONF), ' CAAB contributions ' 1823 WRITE(6,*) ' Original order of the contributions ' 1824 IOFF = IBCAAB_FOR_CA(JOBCONF) 1825 N = NCAAB_FOR_CA(JOBCONF) 1826 CALL IWRTMA(ICAAB_FOR_CA_NUM(IOFF),1,N,1,N) 1827 END DO 1828 END IF 1829 1830* 1831 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GCC_FD') 1832* 1833 RETURN 1834 END 1835 SUBROUTINE CAAB_TO_CA_OCS(ITSS_TP,ITOFF,ISM,NOP_CA, 1836 & IZC, IZA, ICREO,IAREO, 1837 & IOCC_CA,IOCC_CB,IOCC_AA,IOCC_AB,IBCA,NCOC_FSM, 1838 & IBCAAB_FOR_CA,ICAAB_FOR_CA_OP,ICAAB_FOR_CA_NUM, 1839 & NCAAB_FOR_CA,LCAAB_FOR_CA) 1840* 1841* An spin-orbital excitation type belonging to 1842* a given orbital excitation type is given. 1843* 1844* ITOFF is offset for this type of spinorbital excitation 1845* 1846* Obtain mapping Orbital excitation => spinorbital excitation 1847* 1848* Jeppe Olsen, September 2002 1849* 1850 INCLUDE 'implicit.inc' 1851 INCLUDE 'mxpdim.inc' 1852 INCLUDE 'cgas.inc' 1853 INCLUDE 'multd2h.inc' 1854 INCLUDE 'csm.inc' 1855 INCLUDE 'orbinp.inc' 1856 INCLUDE 'cc_exc.inc' 1857*. Specific input 1858 INTEGER ITSS_TP(4*NGAS) 1859*. Arc weights for creation and annihilation occupations 1860 INTEGER IZC(*), IZA(*) 1861*. Reorder arrays for creation and annihilation occupations 1862 INTEGER ICREO(*),IAREO(*) 1863*, Number of creation occupations per symmetry 1864 INTEGER NCOC_FSM(*) 1865*. Offset of CA occupation with given symmetry of C string 1866 INTEGER IBCA(*) 1867*. First CAAB determinant for each CA operator 1868 INTEGER IBCAAB_FOR_CA(*) 1869*. Scratch 1870 INTEGER IOCC_CA(*),IOCC_CB(*),IOCC_AA(*),IOCC_AB(*) 1871*. Local scratch 1872 INTEGER IGRP_CA(MXPNGAS),IGRP_CB(MXPNGAS) 1873 INTEGER IGRP_AA(MXPNGAS),IGRP_AB(MXPNGAS) 1874* 1875 INTEGER IOCC_C(MXPNEL),IOCC_A(MXPNEL), IOCCX(MXPNEL) 1876 INTEGER IMS_C(MXPNEL),IMS_A(MXPNEL) 1877*. Output 1878*. Updated number of CAAB's for each CA 1879 INTEGER NCAAB_FOR_CA(*) 1880*. Length of CA CB AA AB for each CAAB 1881 INTEGER LCAAB_FOR_CA(4,*) 1882*. The CA CB AA AB strings 1883 INTEGER ICAAB_FOR_CA_OP(NOP_CA,*) 1884*. configuration => standard order of each SPOBEX 1885 INTEGER ICAAB_FOR_CA_NUM(*) 1886* 1887 NTEST = 000 1888 IF(NTEST.GE.100) THEN 1889 WRITE(6,*) ' ----------------------------' 1890 WRITE(6,*) ' Output from CAAB_TO_CA_OCS ' 1891 WRITE(6,*) ' ----------------------------' 1892 END IF 1893C? WRITE(6,*) ' The first two elements of IZC and IZA in CA_OCS' 1894C? CALL IWRTMA(IZC,2,1,2,1) 1895C? CALL IWRTMA(IZA,2,1,2,1) 1896 IT = ITOFF - 1 1897*. Transform from occupations to groups 1898 CALL OCC_TO_GRP(ITSS_TP(1+0*NGAS),IGRP_CA,1 ) 1899 CALL OCC_TO_GRP(ITSS_TP(1+1*NGAS),IGRP_CB,1 ) 1900 CALL OCC_TO_GRP(ITSS_TP(1+2*NGAS),IGRP_AA,1 ) 1901 CALL OCC_TO_GRP(ITSS_TP(1+3*NGAS),IGRP_AB,1 ) 1902* 1903 NEL_CA = IELSUM(ITSS_TP(1+0*NGAS),NGAS) 1904 NEL_CB = IELSUM(ITSS_TP(1+1*NGAS),NGAS) 1905 NEL_AA = IELSUM(ITSS_TP(1+2*NGAS),NGAS) 1906 NEL_AB = IELSUM(ITSS_TP(1+3*NGAS),NGAS) 1907 IF(NTEST.GE.100) THEN 1908 WRITE(6,'(A,4I4)') ' NEL_CA, NEL_CB, NEL_AA, NEL_AB = ', 1909 & NEL_CA, NEL_CB, NEL_AA, NEL_AB 1910 END IF 1911 DO ISM_C = 1, NSMST 1912 ISM_A = MULTD2H(ISM,ISM_C) 1913 DO ISM_CA = 1, NSMST 1914 ISM_CB = MULTD2H(ISM_C,ISM_CA) 1915 DO ISM_AA = 1, NSMST 1916 ISM_AB = MULTD2H(ISM_A,ISM_AA) 1917 IF(NTEST.GE.100) THEN 1918 WRITE(6,'(A,4I5)') ' ISM_CA, ISM_CB, ISM_AA, ISM_AB', 1919 & ISM_CA, ISM_CB, ISM_AA, ISM_AB 1920 END IF 1921*. obtain strings 1922 CALL GETSTR2_TOTSM_SPGP(IGRP_CA,NGAS,ISM_CA,NEL_CA,NSTR_CA, 1923 & IOCC_CA, NORBT,0,IDUM,IDUM) 1924 CALL GETSTR2_TOTSM_SPGP(IGRP_CB,NGAS,ISM_CB,NEL_CB,NSTR_CB, 1925 & IOCC_CB, NORBT,0,IDUM,IDUM) 1926 CALL GETSTR2_TOTSM_SPGP(IGRP_AA,NGAS,ISM_AA,NEL_AA,NSTR_AA, 1927 & IOCC_AA, NORBT,0,IDUM,IDUM) 1928 CALL GETSTR2_TOTSM_SPGP(IGRP_AB,NGAS,ISM_AB,NEL_AB,NSTR_AB, 1929 & IOCC_AB, NORBT,0,IDUM,IDUM) 1930C GETSTR2_TOTSM_SPGP(IGRP,NIGRP,ISPGRPSM,NEL,NSTR,ISTR, 1931C & NORBT,IDOREO,IZ,IREO) 1932*. Loop over T elements as matric T(I_CA, I_CB, IAA, I_AB) 1933 DO I_AB = 1, NSTR_AB 1934 DO I_AA = 1, NSTR_AA 1935 DO I_CB = 1, NSTR_CB 1936 DO I_CA = 1, NSTR_CA 1937 IT = IT + 1 1938 IF(NTEST.GE.100) THEN 1939 WRITE(6,*) ' CA CB strings ' 1940 CALL IWRTMA(IOCC_CA(1+(I_CA-1)*NEL_CA), 1941 & 1,NEL_CA,1,NEL_CA) 1942 CALL IWRTMA(IOCC_CB(1+(I_CB-1)*NEL_CB), 1943 & 1, NEL_CB,1,NEL_CB) 1944 END IF 1945* 1946 1947* Adress of Combined creation string in list of creation occupations 1948* 1949*. Obtain the AB occuption in IOCC_C 1950C ABSTR_TO_ORDSTR(IA_OC,IB_OC,NAEL,NBEL,IDET_OC,IDET_SP,ISIGN) 1951 CALL ABSTR_TO_ORDSTR( 1952 & IOCC_CA(1+(I_CA-1)*NEL_CA),IOCC_CB(1+(I_CB-1)*NEL_CB), 1953 & NEL_CA, NEL_CB, IOCC_C,IMS_C,ISIGN_C) 1954*. Reform Occupation to compressed form 1955 NEL_C = NEL_CA + NEL_CB 1956C REFORM_CONF_OCC(IOCC_EXP,IOCC_PCK,NEL,NOCOB,IWAY) 1957 CALL REFORM_CONF_OCC(IOCC_C,IOCCX,NEL_C,NOCOBX,1) 1958*. Address of C string 1959C ILEX_FOR_CONF(ICONF,NOCC_ORB,NORB,NEL,IARCW, 1960C IDOREO,IREO) 1961C? WRITE(6,*) ' Lexical adress for C ' 1962 IC_NUM = ILEX_FOR_CONF(IOCCX,NOCOBX,NTOOB,NEL_C,IZC, 1963 & 1, ICREO) 1964* 1965* Adress of Combined annihilation string in list of creation occupations 1966* 1967*. Obtain the AB occuption in IOCC_A 1968C ABSTR_TO_ORDSTR(IA_OC,IB_OC,NAEL,NBEL,IDET_OC,IDET_SP,ISIGN) 1969 CALL ABSTR_TO_ORDSTR( 1970 & IOCC_AA(1+(I_AA-1)*NEL_AA),IOCC_AB(1+(I_AB-1)*NEL_AB), 1971 & NEL_AA, NEL_AB, IOCC_A,IMS_A,ISIGN_A) 1972*. Reform Occupation to compressed form 1973 NEL_A = NEL_AA + NEL_AB 1974C REFORM_CONF_OCC(IOCC_EXP,IOCC_PCK,NEL,NOCOB,IWAY) 1975 CALL REFORM_CONF_OCC(IOCC_A,IOCCX,NEL_A,NOCOBX,1) 1976*. Address of A occupation 1977C ILEX_FOR_CONF(ICONF,NOCC_ORB,NORB,NEL,IARCW, 1978C IDOREO,IREO) 1979C? WRITE(6,*) ' Lexical adress for A ' 1980 IA_NUM = ILEX_FOR_CONF(IOCCX,NOCOBX,NTOOB,NEL_A,IZA, 1981 & 1, IAREO) 1982 IF(NTEST.GE.100) THEN 1983 WRITE(6,'(A,4I4)') ' I_AB, I_AA, I_CB, I_CA', 1984 & I_AB, I_AA, I_CB, I_CA 1985 END IF 1986*. And adress of the corresponding CA string 1987 ICA_ADR = IBCA(ISM_C) - 1 1988 & + (IA_NUM-1)*NCOC_FSM(ISM_C) + IC_NUM 1989 IF(NTEST.GE.100) THEN 1990 WRITE(6,*) ' IBCA(ISM_C) = ', IBCA(ISM_C) 1991 WRITE(6,*) ' NCOC_FSM(ISM_C) = ',NCOC_FSM(ISM_C) 1992 WRITE(6,*) ' IA_NUM, IC_NUM, ISM_C, ICA_ADR = ', 1993 & IA_NUM, IC_NUM, ISM_C, ICA_ADR 1994 END IF 1995C STOP ' Jeppe Stop ' 1996*. And enroll this spinorbital excitation in the list for orbital 1997*. excitation ICA_ADR 1998 NCAAB_FOR_CA(ICA_ADR) = NCAAB_FOR_CA(ICA_ADR) + 1 1999 ICAAB_ADR = IBCAAB_FOR_CA(ICA_ADR)-1 2000 & + NCAAB_FOR_CA(ICA_ADR) 2001 IF(NTEST.GE.100) THEN 2002 WRITE(6,*) ' IBCAAB_FOR_CA(ICA_ADR) = ', 2003 & IBCAAB_FOR_CA(ICA_ADR) 2004 WRITE(6,*) ' NCAAB_FOR_CA(ICA_ADR) ', 2005 & NCAAB_FOR_CA(ICA_ADR) 2006 WRITE(6,*) ' ICAAB_ADR = ', ICAAB_ADR 2007 END IF 2008 ICAAB_FOR_CA_NUM(ICAAB_ADR) = IT 2009 IPLACE = 1 2010 CALL ICOPVE(IOCC_CA(1+(I_CA-1)*NEL_CA), 2011 & ICAAB_FOR_CA_OP(IPLACE,ICAAB_ADR),NEL_CA) 2012 IPLACE = IPLACE + NEL_CA 2013 CALL ICOPVE(IOCC_CB(1+(I_CB-1)*NEL_CB), 2014 & ICAAB_FOR_CA_OP(IPLACE,ICAAB_ADR),NEL_CB) 2015 IPLACE = IPLACE + NEL_CB 2016 CALL ICOPVE(IOCC_AA(1+(I_AA-1)*NEL_AA), 2017 & ICAAB_FOR_CA_OP(IPLACE,ICAAB_ADR),NEL_AA) 2018 IPLACE = IPLACE + NEL_AA 2019 CALL ICOPVE(IOCC_AB(1+(I_AB-1)*NEL_AB), 2020 & ICAAB_FOR_CA_OP(IPLACE,ICAAB_ADR),NEL_AB) 2021* 2022 LCAAB_FOR_CA(1,ICAAB_ADR) = NEL_CA 2023 LCAAB_FOR_CA(2,ICAAB_ADR) = NEL_CB 2024 LCAAB_FOR_CA(3,ICAAB_ADR) = NEL_AA 2025 LCAAB_FOR_CA(4,ICAAB_ADR) = NEL_AB 2026 END DO 2027 END DO 2028 END DO 2029 END DO 2030* ^ End of loop over elements of block 2031 END DO 2032* ^ End of loop over ISM_AA 2033 END DO 2034* ^ End of loop over ISM_CA 2035 END DO 2036* ^ End of loop over ISM_C 2037* 2038 IF(NTEST.GE.3) THEN 2039 WRITE(6,*) ' Number of elements ', IT-ITOFF + 1 2040 END IF 2041* 2042 RETURN 2043 END 2044 FUNCTION IGATSUM(IVEC,IGAT,IOFF,NELMNT) 2045* 2046* IGATSUM = SUM(I=IOFF,IOFF-1+NELMNT) IVEC(IGAT(I)) 2047* 2048 INCLUDE 'implicit.inc' 2049* 2050 INTEGER IVEC(*),IGAT(*) 2051* 2052 ISUM = 0 2053 DO I = IOFF, IOFF-1+NELMNT 2054 ISUM = ISUM + IVEC(IGAT(I)) 2055 END DO 2056* 2057 IGATSUM = ISUM 2058* 2059 RETURN 2060 END 2061 SUBROUTINE WRITE_CAAB_CONFM 2062* 2063* Print the spinorbital excitations as obtained from configurations 2064* order 2065* 2066* 2067* Jeppe Olsen, September 2002 2068* 2069C INCLUDE 'implicit.inc' 2070C INCLUDE 'mxpdim.inc' 2071 INCLUDE 'wrkspc.inc' 2072 INCLUDE 'corbex.inc' 2073 INCLUDE 'ctcc.inc' 2074* 2075*. Loop over the various types of orbital excitations 2076 DO IOBEX_TP = 1, NOBEX_TP 2077*. And let another routine do the work for a given 2078*. orbital excitation type 2079 CALL WRITE_CAAB_CONF( 2080 & NCAOC(IOBEX_TP),WORK(KIBCAAB_FOR_CA(IOBEX_TP)), 2081 & WORK(KICAAB_FOR_CA_OP(IOBEX_TP)), 2082 & WORK(KICAAB_FOR_CA_NUM(IOBEX_TP)), 2083 & WORK(KLCAAB_FOR_CA(IOBEX_TP)), 2084 & WORK(KNCAAB_FOR_CA(IOBEX_TP)) ) 2085 END DO 2086* 2087 RETURN 2088 END 2089 SUBROUTINE WRITE_CAAB_CONF(NCAOC, 2090 & IBCAAB_FOR_CA,ICAAB_FOR_CA_OP,ICAAB_FOR_CA_NUM, 2091 & LCAAB_FOR_CA,NCAAB_FOR_CA) 2092* 2093* Print spinorbital excitations from configuration information 2094* 2095* 2096* Jeppe Olsen, September 02 2097* 2098C INCLUDE 'implicit.inc' 2099C INCLUDE 'mxpdim.inc' 2100 INCLUDE 'wrkspc.inc' 2101 INCLUDE 'glbbas.inc' 2102 INCLUDE 'clunit.inc' 2103 INCLUDE 'cintfo.inc' 2104 INCLUDE 'orbinp.inc' 2105 INCLUDE 'cgas.inc' 2106* 2107* ===== 2108*. Input 2109* ===== 2110* 2111*. The spinorbital excitations (CAABS) belonging to a CA 2112 INTEGER ICAAB_FOR_CA_OP(*) 2113*. The address in the spinorbital list for the CAABS belonging to a CA 2114 INTEGER ICAAB_FOR_CA_NUM(*) 2115*. The number of CAAB operators for each CA operators 2116 INTEGER NCAAB_FOR_CA(*) 2117*. The number of operators in each of the CA CB AA AB operators 2118 INTEGER LCAAB_FOR_CA(4,*) 2119*. The address of the first CAAB operator for a given CA operator 2120 INTEGER IBCAAB_FOR_CA(*) 2121 IDUM = 0 2122 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'WCAABC') 2123* 2124 WRITE(6,*) ' Number of configurations for orbex-type', NCAOC 2125* 2126 DO ICA = 1, NCAOC 2127 IBCA = IBCAAB_FOR_CA(ICA) 2128 NCAAB = NCAAB_FOR_CA(ICA) 2129* 2130 DO ICAAB = 1, NCAAB 2131 LCA = LCAAB_FOR_CA(1,IBCA-1+ICAAB) 2132 LCB = LCAAB_FOR_CA(2,IBCA-1+ICAAB) 2133 LAA = LCAAB_FOR_CA(3,IBCA-1+ICAAB) 2134 LAB = LCAAB_FOR_CA(4,IBCA-1+ICAAB) 2135 LCAAB = LCA + LCB + LAA + LAB 2136 ICAAB_ABS = IBCA-1+ICAAB 2137* 2138 WRITE(6,*) ' Info for CA configuration and component = ', 2139 & ICA, ICAAB 2140 WRITE(6,*) ' LCA LCB LAA LAB = ', LCA, LCB, LAA, LAB 2141 WRITE(6,*) ' The corresponding CA CB AA AB strings ' 2142 CALL IWRTMA(ICAAB_FOR_CA_OP(1+(ICAAB_ABS-1)*LCAAB), 2143 & 1,LCAAB,1,LCAAB) 2144 END DO 2145 END DO 2146* 2147 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'WCAABC') 2148 RETURN 2149 END 2150 SUBROUTINE GEN_REORDER_CAABM(ICAAB_REO) 2151* 2152* Outer routine for 2153* Generating reorder array going from configuration order of 2154* CAAB to standard CAAB order. The array is delivered in 2155* ICAAB_REO, which should be located outside 2156* 2157* This routine exploits that ICAAB_FOR_CA_NUM gives reordering 2158* within a given CA type 2159* 2160* Jeppe Olsen, September 2002 ( 20 hours to take off to UTRECHT) 2161* 2162* This routine collects the informations stored 2163* seperately for each occupation type in a single array 2164* 2165C INCLUDE 'implicit.inc' 2166C INCLUDE 'mxpdim.inc' 2167 INCLUDE 'wrkspc.inc' 2168 INCLUDE 'corbex.inc' 2169 INCLUDE 'ctcc.inc' 2170 INCLUDE 'crun.inc' 2171*. Output 2172 INTEGER ICAAB_REO(*) 2173* 2174 NTEST = 00 2175 IONEM = -1 2176 CALL ISETVC(ICAAB_REO,IONEM,N_CC_AMP) 2177*. Loop over the various types of orbital excitations 2178 IBCONF = 1 2179 DO IOBEX_TP = 1, NOBEX_TP 2180*. The number of CAABs for a given Orbital excitation 2181 NSOX = IFRMR(WORK(KNSOX_FOR_OX),1,IOBEX_TP) 2182 IBSOX = IFRMR(WORK(KIBSOX_FOR_OX),1,IOBEX_TP) 2183 NCAAB = IGATSUM(WORK(KLLSOBEX),WORK(KISOX_FOR_OX), 2184 & IBSOX,NSOX) 2185 IF(NTEST.GE.1000) THEN 2186 WRITE(6,*) ' IOBEX_TP, NSOX, IBSOX, NCAAB, IBCONF = ', 2187 & IOBEX_TP, NSOX, IBSOX, NCAAB, IBCONF 2188 END IF 2189 CALL ICOPVE(WORK(KICAAB_FOR_CA_NUM(IOBEX_TP)),ICAAB_REO(IBCONF), 2190 & NCAAB) 2191* 2192 IBCONF = IBCONF + NCAAB 2193 END DO 2194* 2195 I_DO_CHECK = 0 2196 IF( I_DO_CHECK.EQ.1) THEN 2197*. Check that the sum of all reorder elements = N_CC_AMP*(N_CC_AMP+1)/2 2198 ICHECKSUM = IELSUM(ICAAB_REO,N_CC_AMP) 2199 IF(ICHECKSUM.NE.N_CC_AMP*(N_CC_AMP+1)/2) THEN 2200 WRITE(6,*) ' CHECKSUM in REO failed ... ' 2201 WRITE(6,*) ' Reorder array for CAAB, CONF => CAAB order ' 2202 WRITE(6,*) ' =========================================== ' 2203 CALL IWRTMA(ICAAB_REO,1,N_CC_AMP,1,N_CC_AMP) 2204 STOP ' CHECKSUM in REO failed ... ' 2205 ELSE 2206 WRITE(6,*) ' Check sum passed ' 2207 END IF 2208 END IF 2209 2210* 2211 IF(NTEST.GE.100) THEN 2212 WRITE(6,*) ' Reorder array for CAAB, CONF => CAAB order ' 2213 WRITE(6,*) ' =========================================== ' 2214 CALL IWRTMA(ICAAB_REO,1,N_CC_AMP,1,N_CC_AMP) 2215 END IF 2216* 2217 RETURN 2218 END 2219 SUBROUTINE PROTO_SPIN_MAT 2220* 2221* Set up matrices transforming between CAAB and spinadapted operator 2222* basis. Quick fix for results for the utrecht meeting 2223* 2224*. Jeppe Olsen, September 2002 2225*. 2226*. Modified to include 4 det case, August 2004 2227* 2228 INCLUDE 'wrkspc.inc' 2229*. Output 2230 COMMON/PROTO_SP_MAT/NSPA_FOP(6),NCAAB_FOP(6),IB_FOP(6),XTRA(100), 2231 & NSPA_FOP_G(6,MXPCYC),NCAAB_FOP_G(6,MXPCYC), 2232 & IB_FOP_G(6,MXPCYC) 2233* 2234 FACTOR = 1.0D0/DSQRT(2.0D0) 2235* 2236* For one component : Type 1 2237 NSPA_FOP(1) = 1 2238 NCAAB_FOP(1) = 1 2239 IB_FOP(1) = 1 2240 XTRA(1) = 1.0D0 2241* 2242*. For two components : type 2 2243* 2244 2245 NSPA_FOP(2) = 1 2246 NCAAB_FOP(2) = 2 2247 IB_FOP(2) = 2 2248 XTRA(2) = FACTOR 2249 XTRA(3) = FACTOR 2250* 2251* for four components : type 4 2252* 2253 NSPA_FOP(4) = 2 2254 NCAAB_FOP(4) = 4 2255 IB_FOP(4) = 4 2256 ZERO = 0.0D0 2257 CALL SETVEC(XTRA(IB_FOP(4)),ZERO, NSPA_FOP(4)* NCAAB_FOP(4)) 2258*. CAAB's related by time reversal are ( I hope ...) 2259*. 1 and 4 2260*. 2 and 3 2261*.. 1 : 1 + 4 2262 XTRA(IB_FOP(4)-1+1+(1-1)*4 ) = FACTOR 2263 XTRA(IB_FOP(4)-1+4+(1-1)*4 ) = FACTOR 2264*.. 2 : 2 + 3 2265 XTRA(IB_FOP(4)-1+2+(2-1)*4 ) = FACTOR 2266 XTRA(IB_FOP(4)-1+3+(2-1)*4 ) = FACTOR 2267* 2268* For six components : type 6 2269* 2270 NSPA_FOP(6) = 3 2271 NCAAB_FOP(6) = 6 2272 IB_FOP(6) = 12 2273 ZERO = 0.0D0 2274 CALL SETVEC(XTRA(IB_FOP(6)),ZERO, NSPA_FOP(6)* NCAAB_FOP(6)) 2275*. CAAB's related by time reversal are ( I hope ...) 2276*. 1 and 4 2277*. 2 and 3 2278*. 5 and 6 2279*.. 1 : 1 + 4 2280 XTRA(IB_FOP(6)-1+1+(1-1)*6 ) = FACTOR 2281 XTRA(IB_FOP(6)-1+4+(1-1)*6 ) = FACTOR 2282*.. 2 : 2 + 3 2283 XTRA(IB_FOP(6)-1+2+(2-1)*6 ) = FACTOR 2284 XTRA(IB_FOP(6)-1+3+(2-1)*6 ) = FACTOR 2285*.. 3 : 5 + 6 2286 XTRA(IB_FOP(6)-1+5+(3-1)*6 ) = FACTOR 2287 XTRA(IB_FOP(6)-1+6+(3-1)*6 ) = FACTOR 2288* 2289 RETURN 2290 END 2291 SUBROUTINE REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 2292* 2293* Transform vector between CAAB form and spinadapted form 2294* 2295* IWAY = 1 : CAAB => Spin adapted form 2296* IWAY = 2 : Spin adapted form => CAAB 2297* 2298* Jeppe Olsen, September 2002 2299* 2300C INCLUDE 'implicit.inc' 2301C INCLUDE 'mxpdim.inc' 2302 INCLUDE 'wrkspc.inc' 2303 INCLUDE 'ctcc.inc' 2304 INCLUDE 'corbex.inc' 2305 INCLUDE 'crun.inc' 2306*. Input and output 2307 DIMENSION VEC_CAAB(*),VEC_SP(*) 2308*. and a scratch vector 2309 DIMENSION VEC_SCR(*) 2310* 2311 NTEST = 000 2312 IF(NTEST.GE.1000) THEN 2313 WRITE(6,*) 2314 WRITE(6,*) ' REF_CCV_CCAB speaking' 2315 WRITE(6,*) ' ---------------------' 2316 WRITE(6,*) 2317 IF(IWAY.EQ.1) THEN 2318 WRITE(6,*) ' CAAB => spinadapted basis transformation ' 2319 ELSE 2320 WRITE(6,*) ' spinadapted basis => CAABtransformation ' 2321 END IF 2322 END IF 2323* 2324 IF(IWAY.EQ.1) THEN 2325* CAAB => Spin adapted : Reorder to conf and then transform 2326 CALL GATVEC(VEC_SCR,VEC_CAAB,WORK(KLREORDER_CAAB), 2327 & N_CC_AMP) 2328* 2329* 2330 IF(NTEST.GE.1000) THEN 2331 WRITE(6,*) ' Result from GATVEC ' 2332 CALL WRTMAT(VEC_SCR,1,N_CC_AMP,1,N_CC_AMP) 2333 END IF 2334*. Offsets for CAAB and Spin adapted form will be updated in the process 2335 IB_CAAB = 1 2336 IB_SP = 1 2337 DO JOBTP = 1, NOBEX_TP 2338 CALL CAAB_SP_FOR_OCTP(VEC_SCR(IB_CAAB),VEC_SP(IB_SP), 2339 & WORK(KNCAAB_FOR_CA(JOBTP)),NCAOC(JOBTP), 2340 & N_SP,N_CAAB,1) 2341 IB_CAAB = IB_CAAB + N_CAAB 2342 IB_SP = IB_SP + N_SP 2343 END DO 2344 ELSE 2345*. Spin-adapted => CAAB transformation 2346 IB_CAAB = 1 2347 IB_SP = 1 2348 DO JOBTP = 1, NOBEX_TP 2349C? WRITE(6,*) ' REF_CCV : JOBTP = ', JOBTP 2350 CALL CAAB_SP_FOR_OCTP(VEC_SCR(IB_CAAB),VEC_SP(IB_SP), 2351 & WORK(KNCAAB_FOR_CA(JOBTP)),NCAOC(JOBTP), 2352 & N_SP,N_CAAB,2) 2353 IB_CAAB = IB_CAAB + N_CAAB 2354 IB_SP = IB_SP + N_SP 2355 END DO 2356C SCAVEC(VECO,VECI,INDEX,NDIM) 2357 CALL SCAVEC(VEC_CAAB,VEC_SCR,WORK(KLREORDER_CAAB),N_CC_AMP) 2358 END IF 2359 N_CAAB_TOT = IB_CAAB - 1 2360 N_SP_TOT = IB_SP - 1 2361* 2362 IF(NTEST.GE.100) THEN 2363 WRITE(6,*) ' Test, N_CAAB_TOT, N_SP_TOT = ', 2364 & N_CAAB_TOT, N_SP_TOT 2365 END IF 2366* 2367 IF(NTEST.GE.100) THEN 2368 WRITE(6,*) ' Vector in spinadapted basis ' 2369 CALL WRTMAT(VEC_SP,1,N_SP_TOT,1,N_SP_TOT) 2370 WRITE(6,*) ' Vector in CAAB basis ' 2371 CALL WRTMAT(VEC_CAAB,1,N_CAAB_TOT,1,N_CAAB_TOT) 2372 END IF 2373* 2374 RETURN 2375 END 2376 SUBROUTINE CAAB_SP_FOR_OCTP(VEC_CAAB,VEC_SP,NCAAB_FOR_CA, 2377 & NCONF,N_SP,N_CAAB,IWAY ) 2378* 2379* Transforming between spinadapted and CAAB form of 2380* vector for given OCTP 2381* 2382* IWAY = 1 : CAAB => Spin 2383* IWAY = 2 : Spin => CAAB 2384* 2385* Jeppe Olsen, September 2002 2386* 2387 INCLUDE 'implicit.inc' 2388 INCLUDE 'proto_sp_mat.inc' 2389*, Input or output 2390 DIMENSION VEC_CAAB(*),VEC_SP(*) 2391*. Number of dets per configuration 2392 INTEGER NCAAB_FOR_CA(NCONF) 2393 2394* 2395 NTEST = 00 2396* 2397 IB_SP = 1 2398 IB_CAAB = 1 2399* 2400 IF(NTEST.GE.100) THEN 2401 WRITE(6,*) ' NCONF, IWAY = ', NCONF, IWAY 2402 END IF 2403 DO ICONF = 1, NCONF 2404*. Use number of determinants is used to decide the type of open shells 2405*. ( Yes dirty initial version) 2406 NDET = NCAAB_FOR_CA(ICONF) 2407 NCSF = NSPA_FOP(NDET) 2408 IB = IB_FOP(NDET) 2409 IF(NTEST.GE.100) THEN 2410 WRITE(6,*) ' ICONF, NDET ,NCSF = ',ICONF, NDET ,NCSF 2411 END IF 2412 IF(IWAY.EQ.1) THEN 2413*VEC_CSF(I) = SUM(J) XTRA(J,I) VEC_DET(J) 2414C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS 2415C? WRITE(6,*) ' IB, IB_CAAB, IB_SP = ', IB,IB_CAAB,IB_SP 2416 CALL MATVCC(XTRA(IB),VEC_CAAB(IB_CAAB),VEC_SP(IB_SP), 2417 & NDET,NCSF,1) 2418C? WRITE(6,*) ' XTRA, VEC_CAAB, VEC_SP : ' 2419C? CALL WRTMAT(XTRA(IB),NDET,NCSF,NDET,NCSF) 2420C? CALL WRTMAT(VEC_CAAB(IB_CAAB),1,NDET,1,NDET) 2421C? CALL WRTMAT(VEC_SP(IB_SP),1,NCSF,1,NCSF) 2422 ELSE 2423* VEC_DET(J) = SUM(I) XTRA(J,I) VEC_CSF(I) 2424 CALL MATVCC(XTRA(IB),VEC_SP(IB_SP),VEC_CAAB(IB_CAAB), 2425 & NDET,NCSF,0) 2426 END IF 2427 IB_SP = IB_SP + NCSF 2428 IB_CAAB = IB_CAAB + NDET 2429 END DO 2430*. Length of SP and CAAB expansions should be returned so 2431 N_SP = IB_SP - 1 2432 N_CAAB =IB_CAAB-1 2433* 2434 RETURN 2435 END 2436 SUBROUTINE NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 2437* 2438* Number of CSF's in current expansion obtained by reading 2439* number of CAABs in the CA expansion 2440* 2441* Jeppe Olsen, Amsterdam airport Sept 20, 2002 2442* 2443C INCLUDE 'implicit.inc' 2444C INCLUDE 'mxpdim.inc' 2445 INCLUDE 'wrkspc.inc' 2446 INCLUDE 'crun.inc' 2447 INCLUDE 'ctcc.inc' 2448 INCLUDE 'corbex.inc' 2449 INCLUDE 'cprnt.inc' 2450*. Local scratch 2451 INTEGER NCNF_FOP(MXPNEL), ISCR(MXPNEL) 2452*. Find number of configurations with the various number of open shells 2453*. at the moment I am here assuming atmost 4 open shells.. 2454*. At the moment I assume only combinations so 3 csfs for 4 open shells.. 2455* 2456 NTEST = 00 2457 NTEST = MAX(NTEST,IPRCSF) 2458 MAXNDET = 6 2459 IZERO = 0 2460 CALL ISETVC(ISCR,IZERO,MAXNDET) 2461 CALL ISETVC(NCNF_FOP,IZERO,MAXNDET) 2462* 2463C? WRITE(6,*) ' Number of orbitalexcitationtypes ', NOBEX_TP 2464 DO IOBEX_TP = 1, NOBEX_TP 2465*. Count the number of times the various number of dets for 2466*. a given CA occurs 2467* COUNT_OCCURENCE(IVEC,IOCC,NELMNT,MAXVAL) 2468 NCA = NCAOC(IOBEX_TP) 2469C? WRITE(6,*) ' IOBEX_TP, NCA ', IOBEX_TP, NCA 2470C? WRITE(6,*) ' And the types ' 2471C? CALL IWRTMA(WORK(KNCAAB_FOR_CA(IOBEX_TP)),1,NCA,1,NCA) 2472 CALL COUNT_OCCURENCE(WORK(KNCAAB_FOR_CA(IOBEX_TP)),ISCR,NCA, 2473 & MAXNDET) 2474 IONE = 1 2475 CALL IVCSUM(NCNF_FOP,NCNF_FOP,ISCR,IONE,IONE,MAXNDET) 2476 END DO 2477* 2478 NSPA = NCNF_FOP(1)*1 + NCNF_FOP(2)*1 + NCNF_FOP(4)*2 2479 & + NCNF_FOP(6)*3 2480 NCAAB= NCNF_FOP(1)*1 + NCNF_FOP(2)*2 + NCNF_FOP(4)*4 2481 & + NCNF_FOP(6)*6 2482* 2483 IF(NTEST.GE.5) THEN 2484 WRITE(6,*) ' Number of CA ops with 1 comp = ', 2485 & NCNF_FOP(1) 2486 WRITE(6,*) ' Number of CA ops with two comps = ', 2487 & NCNF_FOP(2) 2488 WRITE(6,*) ' Number of CA ops with four comps = ', 2489 & NCNF_FOP(4) 2490 WRITE(6,*) ' Number of CA ops with six comps = ', 2491 & NCNF_FOP(6) 2492 WRITE(6,*) ' Number of spinadapted operators = ', NSPA 2493 WRITE(6,*) ' Number of CAAB = ', NCAAB 2494 END IF 2495* 2496 RETURN 2497 END 2498 SUBROUTINE ICCC_COMPLETE_MAT( 2499 & IREFSPC,ITREFSPC,I_SPIN_ADAPT, 2500 & IROOT,T_EXT,C_0,INI_IT,IFIN_IT,VEC1,VEC2,IDIIS) 2501 2502* 2503* Master routine for Internal Contraction Coupled Cluster 2504* with complete incore * construction of all matrices. 2505* 2506* It is assumed that the excitation manifold produces 2507* states that are orthogonal to the reference so 2508* no projection is carried out 2509* 2510* Routine is allowed to leave without turning the lights off, 2511* i.e. leave routine with all allocations and marks intact. 2512*: Thus : Allocations are only done if INI_IT = 1 2513* Deallocations are only done if IFIN_IT = 1 2514* 2515* IF IDIIS.NE.0, DIIS is used to accelerate convergence 2516* 2517* Jeppe Olsen, Aug. 2005 2518* 2519*. for DIIS units LUSC35 and LUSC36 will be used for storing vectors 2520 INCLUDE 'wrkspc.inc' 2521 INCLUDE 'ctcc.inc' 2522 INCLUDE 'glbbas.inc' 2523 INCLUDE 'crun.inc' 2524 INCLUDE 'clunit.inc' 2525 INCLUDE 'cecore.inc' 2526* 2527 REAL*8 2528 &INPROD 2529*. Output : Coefficients of external correlation 2530 DIMENSION T_EXT(*) 2531 COMMON/COM_H_S_EFF_ICCI_TV/ 2532 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 2533 & IUNIOPX,NSPAX,IPROJSPCX 2534 COMMON/CLOCAL/KVEC1,KVEC2,MXCJ, 2535 & KLVCC1,KLVCC2,KLVCC3,KLVCC4,KLVCC5,KLSMAT,KLXMAT,KLJMAT,KLU,KLL, 2536 & NSING,NNONSING,KLCDIIS,KLDIA 2537*. Scratch for CI behind the curtain 2538 DIMENSION VEC1(*),VEC2(*) 2539 WRITE(6,*) ' Code has should be modified to new MRCC vecfnc ' 2540 STOP ' Code has should be modified to new MRCC vecfnc ' 2541 2542*. Number of Spin adapted functions ( and NCAAB for a check) 2543 CALL NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 2544*. We will not include the unit-operator so 2545 NSPAM1 = NSPA - 1 2546* 2547 NTEST = 10 2548 WRITE(6,*) 2549 WRITE(6,*) ' Complete J matrix will be used ' 2550 WRITE(6,*) ' ===============================' 2551 WRITE(6,*) 2552 WRITE(6,*) ' Reference space is ', IREFSPC 2553 WRITE(6,*) ' Space of Operators times reference space ', ITREFSPC 2554 WRITE(6,*) 2555 WRITE(6,*) ' Number of parameters in spinuncoupled basis ', 2556 & N_CC_AMP 2557 WRITE(6,*) ' Number of parameters in spincoupled basis ', 2558 & NSPA 2559 WRITE(6,*) ' INI_IT, IFIN_IT = ', INI_IT, IFIN_IT 2560* 2561 IF(NTEST.GE.1000) THEN 2562 WRITE(6,*) ' Initial T-amplitudes ' 2563 CALL WRTMAT(T_EXT,1,N_CC_AMP,1,N_CC_AMP) 2564 END IF 2565*. Allowed number of iterations 2566 NNEW_MAX = 15 2567 MAXITL = NNEW_MAX 2568* 2569 IF(INI_IT.EQ.1) 2570 &CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICC_CMP') 2571* 2572* Space for complete J matrices 2573* 2574*. And a few working vectors 2575 IF(INI_IT.EQ.1) THEN 2576*. Space for old fashioned CI behind the curtain 2577COLD CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 2578COLD KVEC1P = KVEC1 2579COLD KVEC2P = KVEC2 2580 CALL MEMMAN(KLVCC1,N_CC_AMP,'ADDL ',2,'VCC1 ') 2581 CALL MEMMAN(KLVCC2,N_CC_AMP,'ADDL ',2,'VCC2 ') 2582 CALL MEMMAN(KLVCC3,N_CC_AMP,'ADDL ',2,'VCC3 ') 2583 CALL MEMMAN(KLVCC4,N_CC_AMP,'ADDL ',2,'VCC4 ') 2584 CALL MEMMAN(KLVCC5,N_CC_AMP,'ADDL ',2,'VCC5 ') 2585 CALL MEMMAN(KLVCC6,N_CC_AMP,'ADDL ',2,'VCC6 ') 2586*. For complete matrices, three used pt 2587 LEN = NSPA**2 2588 CALL MEMMAN(KLSMAT,LEN,'ADDL ',2,'SMAT ') 2589 CALL MEMMAN(KLXMAT,LEN,'ADDL ',2,'XMAT ') 2590 CALL MEMMAN(KLJMAT,LEN,'ADDL ',2,'JMAT ') 2591*. Storage for LU decomposition of J 2592 LEN = NSPA*(NSPA+1)/2 2593 CALL MEMMAN(KLL,LEN,'ADDL ',2,'L ') 2594 CALL MEMMAN(KLU,LEN,'ADDL ',2,'U ') 2595*. Space for DIIS 2596 CALL MEMMAN(KLCDIIS,MAXITL,'ADDL ',2,'CDIIS ') 2597 END IF 2598* 2599*. Identify the unit operator i.e. the operator with 2600*. zero creation and annihilation operators 2601 IDOPROJ = 0 2602*. Construct metric (once again ..) 2603*. Prepare the routines used in COM_SH 2604*. Not used here 2605 C_0X = 0.0D0 2606 KLTOPX = -1 2607*. Used 2608 NREFX = N_REF 2609 IREFSPCX = IREFSPC 2610 ITREFSPCX = ITREFSPC 2611 NCAABX = N_CC_AMP 2612 NSPAX = NSPA 2613 IPROJSPCX = IREFSPC 2614*. Unitoperator in SPA order ... Please check .. 2615 IUNIOPX = 0 2616*. Metric only evaluated in first macro-it 2617 IF(INI_IT.EQ.1) THEN 2618 CALL COM_SH(WORK(KLSMAT),WORK(KLSMAT),WORK(KLVCC1),WORK(KLVCC2), 2619 & WORK(KLVCC3),VEC1,VEC2, 2620 & N_CC_AMP,IREFSPC,ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 2621 & IDOPROJ,IUNIOP,1,0,1,I_DO_EI,NSPA,0,0,0) 2622*. ELiminate part referring to unit operator 2623 CALL TRUNC_MAT(WORK(KLSMAT),NSPA,NSPA,NSPAM1,NSPAM1) 2624C GET_ON_BASIS(S,NVEC,NSING,X,SCRVEC1,SCRVEC2) 2625 CALL GET_ON_BASIS(WORK(KLSMAT),NSPAM1,NSING, 2626 & WORK(KLXMAT),WORK(KLVCC1),WORK(KLVCC2) ) 2627 WRITE(6,*) ' Number of singularities in S ', NSING 2628 NNONSING = NSPAM1 - NSING 2629 IF(NTEST.GE.1000) THEN 2630 WRITE(6,*) ' Transformation matrix to nonsingular basis ' 2631 CALL WRTMAT(WORK(KLXMAT),NSPAM1,NNONSING,NSPAM1, 2632 & NNONSING) 2633 END IF 2634 END IF 2635* ^ End if it was initial iteration 2636 IF(IDIIS.NE.0) THEN 2637 CALL REWINO(LUSC35) 2638 CALL REWINO(LUSC36) 2639 END IF 2640*. Loop over Newton iterations 2641 DO IT = 1, NNEW_MAX 2642*. Construct CC vector function in VCC5 2643C? WRITE(6,*) ' MRCC vector function at current point ' 2644 CALL MRCC_VECFNC(WORK(KLVCC5),T_EXT,NCOMMU_V,I_APPROX_HCOM_V, 2645 & IREFSPC,ITREFSPC) 2646*. The energy is returned as first element in CAAB basis, so 2647 E = WORK(KLVCC5) 2648*. And set energy term to zero 2649 WORK(KLVCC5) = 0.0D0 2650 VCFNORM = SQRT(INPROD(WORK(KLVCC5+1),WORK(KLVCC5+1),NCAAB-1)) 2651 WRITE(6,'(A,1X,I4,2E22.15)') 2652 & ' It, vecfnc : energy and norm ', IT, E, VCFNORM 2653* 2654C MRCC_VECFNC(CCVECFNC,T,NCOMMU,IREFSPC,ITREFSPC) 2655*. Vectors are stored in CAAB basis - not the smartest.. 2656 IF(IDIIS.EQ.1) THEN 2657*. It is assumed that DIIS leaved the file at end of file 2658*. T_ext on LUSC35, VECFNC on LUSC36 2659 CALL VEC_TO_DISC(T_EXT,NCAAB,0,-1,LUSC35) 2660 CALL VEC_TO_DISC(WORK(KLVCC5),NCAAB,0,-1,LUSC36) 2661*. We have now IT vectors in LUSC36, find combination with lowest 2662*. Norm 2663C DIIS_SIMPLE(LUEVEC,NVEC,NDIM,C) 2664 CALL DIIS_SIMPLE(LUSC36,IT,NCAAB,WORK(KLCDIIS)) 2665*. Obtain combination as given in CDIIS 2666C MVCSMD(LUIN,FAC,LUOUT,LUSCR,VEC1,VEC2,NVEC,IREW,LBLK) 2667 CALL MVCSMD(LUSC35,WORK(KLCDIIS),LUSC37,LUSC38, 2668 & WORK(KLVCC1),WORK(KLVCC2),IT,1,-1) 2669 CALL VEC_FROM_DISC(T_EXT,NCAAB,1,-1,LUSC37) 2670*. Calculate new vectorfunction for T or use sum 2671 I_NEW_OR_SUM = 1 2672 IF(I_NEW_OR_SUM.EQ.1) THEN 2673 WRITE(6,*) ' CC vector-function recalculated after DIIS ' 2674 CALL MRCC_VECFNC(WORK(KLVCC5),T_EXT,NCOMMU_V,IREFSPC, 2675 & ITREFSPC) 2676*. Note : I am not storing new vectors in DIIS queue - 2677* to have symmetry between case where vecfunc is 2678* obtained from sum. 2679 E = WORK(KLVCC5) 2680 VCFNORM = SQRT(INPROD(WORK(KLVCC5+1),WORK(KLVCC5+1), 2681 & NCAAB-1)) 2682 WRITE(6,'(A,I4,2E22.15)') 2683 & ' From DIIS : It, vecfnc : energy and norm ', 2684 & IT, E, VCFNORM 2685 ELSE 2686 CALL MVCSMD(LUSC36,WORK(KLCDIIS),LUSC37,LUSC38, 2687 & WORK(KLVCC1),WORK(KLVCC2),IT,1,-1) 2688 CALL VEC_FROM_DISC(WORK(KLVCC5),NCAAB,1,-1,LUSC37) 2689 VCFNORM = SQRT(INPROD(WORK(KLVCC5+1),WORK(KLVCC5+1), 2690 & NCAAB-1)) 2691 WRITE(6,'(A,I4,2E22.15)') 2692 & ' From DIIS : It, norm of approx vecfnc ', 2693 & IT, VCFNORM 2694 END IF 2695*. ^ End if VECFNC should be recalculated or obtained as sum 2696 END IF 2697*. Transform to SPA basis 2698 CALL REF_CCV_CAAB_SP(WORK(KLVCC5),WORK(KLVCC1),WORK(KLVCC2),1) 2699C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 2700*. and to orthonormal basis, save in VCC5 2701C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 2702 CALL MATVCC(WORK(KLXMAT),WORK(KLVCC1),WORK(KLVCC5),NSPAM1, 2703 & NNONSING,1) 2704*. Transform to Nonsigular basis 2705*. Construct Jacobian matrix in nonsingular basis 2706*. Here : Evaluate Jacobian in first IT, and use fewer commutators 2707* 2708* A further simplification is possible. If - As pt only one 2709* commutator is used, one can restrict the space to be the MRSD space 2710* instead of the presently used MRSDTQ space. To accomplish this 2711* add the MRSD space as third space after the refspc and ITREFSPC 2712 IF(INI_IT.EQ.1.AND.IT.EQ.1) THEN 2713 IF(NCOMMU_J.EQ.1) THEN 2714*. I assume that the third space has been defined 2715 ITREFSPC_L = 3 2716 WRITE(6,*) ' NOTE : Space 3 is used for COM_JMRCC ' 2717 WRITE(6,*) ' NOTE : Space 3 is used for COM_JMRCC ' 2718 WRITE(6,*) ' NOTE : Space 3 is used for COM_JMRCC ' 2719 WRITE(6,*) ' NOTE : Space 3 is used for COM_JMRCC ' 2720 WRITE(6,*) ' NOTE : Space 3 is used for COM_JMRCC ' 2721 WRITE(6,*) ' NOTE : Space 3 is used for COM_JMRCC ' 2722 WRITE(6,*) ' NOTE : Space 3 is used for COM_JMRCC ' 2723 WRITE(6,*) ' NOTE : Space 3 is used for COM_JMRCC ' 2724*. Jacobian independent of T, so use T = 0 for simplicity 2725 ZERO = 0.0D0 2726 CALL SETVEC(WORK(KLVCC6),ZERO,N_CC_AMP) 2727 CALL COM_JMRCC(WORK(KLVCC6),NCOMMU_J,WORK(KLJMAT),WORK(KLVCC1), 2728 & WORK(KLVCC2), WORK(KLVCC3), WORK(KLVCC4), 2729 & N_CC_AMP,NSPAM1,NNONSING,IREFSPC,ITREFSPC_L, 2730 & WORK(KLXMAT) ) 2731 ELSE 2732*. More than one commutator, so J depends on T 2733 CALL COM_JMRCC(T_EXT,NCOMMU_J,WORK(KLJMAT),WORK(KLVCC1), 2734 & WORK(KLVCC2), WORK(KLVCC3), WORK(KLVCC4), 2735 & N_CC_AMP,NSPAM1,NNONSING,IREFSPC,ITREFSPC_L, 2736 & WORK(KLXMAT) ) 2737 END IF 2738*. Obtain LU-Decomposition of Jacobian 2739 CALL LULU(WORK(KLJMAT),WORK(KLL),WORK(KLU),NNONSING) 2740 END IF 2741*. Solve Linear equations J Delta = - Vecfnc, store solution in VCC1 2742 ONEM = -1.0D0 2743 CALL SCALVE(WORK(KLVCC5),ONEM,NNONSING) 2744 CALL MEMCHK2('AFTSCA') 2745 CALL LINSOL_FROM_LUCOMP(WORK(KLL),WORK(KLU),WORK(KLVCC5), 2746 & WORK(KLVCC1),NNONSING,WORK(KLVCC2)) 2747C LINSOL_FROM_LUCOMP(XL,XU,RHS,X,NDIM,SCR1) 2748*. Transform solution to SPA basis and store in VCC2 2749C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 2750 CALL MATVCC(WORK(KLXMAT),WORK(KLVCC1),WORK(KLVCC2), 2751 & NSPAM1,NNONSING,0) 2752 CALL MEMCHK2('AFTVC2') 2753 WORK(KLVCC2-1+NSPA) = 0.0D0 2754 IF(NTEST.GE.1000) THEN 2755 WRITE(6,*) ' Solution in SPA basis ' 2756 CALL WRTMAT(WORK(KLVCC2),1,NSPA,1,NSPA) 2757 END IF 2758*. And transform to CAAB basis and save in VCC1 2759C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 2760 CALL REF_CCV_CAAB_SP(WORK(KLVCC1),WORK(KLVCC2),WORK(KLVCC3),2) 2761 CALL MEMCHK2('AFTRF2') 2762*. Norm of change 2763 XNORM = SQRT(INPROD(WORK(KLVCC1),WORK(KLVCC1),N_CC_AMP)) 2764 WRITE(6,*) ' Norm of correction ', XNORM 2765*. And update the T-coefficients 2766 ONE = 1.0D0 2767 CALL VECSUM(T_EXT,T_EXT,WORK(KLVCC1),ONE,ONE,N_CC_AMP) 2768 CALL MEMCHK2('AFTSUM') 2769 END DO 2770* ^ End of loop over Newton iterations 2771 IF(NTEST.GE.100) THEN 2772 WRITE(6,*) ' Info from T optimization ', IROOT 2773 WRITE(6,*) ' Updated amplitudes ' 2774 CALL WRTMAT(T_EXT,1,NCAAB,1,NCAAB) 2775 END IF 2776* 2777 IF(IFIN_IT.EQ.1) 2778 &CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ICC_CMP') 2779 RETURN 2780 END 2781 SUBROUTINE ICCI_COMPLETE_MAT2(IREFSPC,ITREFSPC,I_SPIN_ADAPT, 2782 & IROOT,T_EXT,C_0,E_IROOT) 2783 2784* 2785* Master routine for Internal contraction with complete incore 2786* construction of all matrices. 2787* 2788* Version using spin adapted basis functions or EI basis functions 2789* 2790* Jeppe Olsen, Sept 2002 2791* 2792 INCLUDE 'wrkspc.inc' 2793 INCLUDE 'ctcc.inc' 2794 INCLUDE 'glbbas.inc' 2795 INCLUDE 'crun.inc' 2796 INCLUDE 'clunit.inc' 2797 INCLUDE 'cecore.inc' 2798 INCLUDE 'cei.inc' 2799*. Output : Coefficients of external correlation 2800 DIMENSION T_EXT(*) 2801*. Number of Spin adapted functions ( and NCAAB for a check) 2802 IF(I_DO_EI.EQ.0) THEN 2803 CALL NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 2804 ELSE 2805 NSPA = N_ZERO_EI 2806 NCAAB = NDIM_EI 2807 END IF 2808 NTEST = 100 2809 WRITE(6,*) 2810 WRITE(6,*) ' Complete H and S matrices will be constructed ' 2811 WRITE(6,*) ' ==============================================' 2812 WRITE(6,*) 2813 WRITE(6,*) ' Reference space is ', IREFSPC 2814 WRITE(6,*) ' Space of Operators times reference space ', ITREFSPC 2815 WRITE(6,*) 2816 WRITE(6,*) 2817 &' Number of parameters in spinuncoupled/original basis ', 2818 & NCAAB 2819 WRITE(6,*) 2820 &' Number of parameters in spincoupled/zero-order basis ', 2821 & NSPA 2822* 2823 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'IC_CMP ') 2824*. Space for old fashioned CI behind the curtain 2825 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 2826 KVEC1P = KVEC1 2827 KVEC2P = KVEC2 2828* 2829* Space for complete H and S matrices 2830* 2831*. And a few working vectors 2832 CALL MEMMAN(KLVCC1,NCAAB,'ADDL ',2,'VCC1 ') 2833 CALL MEMMAN(KLVCC2,NCAAB,'ADDL ',2,'VCC2 ') 2834 CALL MEMMAN(KLVCC3,NCAAB,'ADDL ',2,'VCC3 ') 2835 CALL MEMMAN(KLVCC4,NCAAB,'ADDL ',2,'VCC4 ') 2836 LEN = NSPA**2 2837 CALL MEMMAN(KLSHMAT,LEN,'ADDL ',2,'SHMAT ') 2838 CALL MEMMAN(KLXMAT,LEN,'ADDL ',2,'XMAT ') 2839*. Identify the unit operator i.e. the operator with 2840*. zero creation and annihilation operators 2841 IDOPROJ = 1 2842 IF(IDOPROJ.EQ.1) THEN 2843 CALL GET_SPOBTP_FOR_EXC_LEVEL(0,WORK(KLCOBEX_TP),NSPOBEX_TP+1, 2844 & NUNIOP,IUNITP,WORK(KLSOX_TO_OX)) 2845*. And the position of the unitoperator in the list of SPOBEX operators 2846 WRITE(6,*) ' NUNIOP, IUNITP = ', NUNIOP,IUNITP 2847 IF(NUNIOP.EQ.0) THEN 2848 WRITE(6,*) ' Unitoperator not found in exc space ' 2849 WRITE(6,*) ' I will proceed without projection ' 2850 IDOPROJ = 0 2851 ELSE 2852 IUNIOP = IFRMR(WORK(KLIBSOBEX),1,IUNITP) 2853 WRITE(6,*) ' IUNIOP = ', IUNIOP 2854 END IF 2855 END IF 2856*. Construct metric 2857 CALL COM_SH(WORK(KLSHMAT),WORK(KLSHMAT),WORK(KLVCC1),WORK(KLVCC2), 2858 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 2859 & N_CC_AMP,IREFSPC, ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 2860 & IDOPROJ,IUNIOP,1,0,1,I_DO_EI,NSPA,0,0,0) 2861*. Obtain singularities on S 2862 CALL CHK_S_FOR_SING(WORK(KLSHMAT),NSPA,NSING, 2863 & WORK(KLXMAT),WORK(KLVCC1),WORK(KLVCC2)) 2864*. On output the eigenvalues are residing in WORK(KLVCC1) and 2865*. the corresponding eigenvectors in WORK(KLXMAT). 2866*. The singular subspace is defined by the first NSING eigenvectors 2867 NNONSING = NSPA - NSING 2868 WRITE(6,*) ' Number of nonsingular eigenvalues of S ', NNONSING 2869 KLNONSING = KLXMAT + NSING*NSPA 2870* 2871 I_ANALYZE_SUM_SING = 0 2872 IF(I_ANALYZE_SUM_SING.EQ.1) THEN 2873*. Analyze sum of singularities : Print out Sum(i:sing) C(j,i)**2, 2874*. where C(J,I) is in the original basis 2875 ZERO = 0.0D0 2876 CALL SETVEC(WORK(KLVCC3),ZERO,N_CC_AMP) 2877 DO JSING = 1, NSING 2878*. Transform to Standard basis 2879C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 2880 CALL REF_CCV_CAAB_SP(WORK(KLVCC4), 2881 & WORK(KLXMAT-1+(JSING-1)*NSPA),WORK(KLVCC2),2) 2882*. Square Vector in CAAB basis and add to VCC3) 2883 CALL VVTOV(WORK(KLVCC4),WORK(KLVCC4),WORK(KLVCC2),N_CC_AMP) 2884 ONE = 1.0D0 2885 CALL VECSUM(WORK(KLVCC3),WORK(KLVCC3),WORK(KLVCC2),ONE,ONE, 2886 & N_CC_AMP) 2887 END DO 2888*. Change so summed sqareed elements add up to one 2889 FACTOR = 1.0D0/SQRT(DBLE(NSING)) 2890 DO I = 1, N_CC_AMP 2891 WORK(KLVCC3-1+I) = SQRT(WORK(KLVCC3-1+I))*FACTOR 2892 END DO 2893*. And analyze vector 2894 CALL ANA_GENCC(WORK(KLVCC3),1) 2895 END IF 2896* ^ End if sum of singularities should be analyzed 2897* 2898*. Obtain transformation to orthonormal basis 2899* X = U sigma^{-1/2}, where U are the nonsingular 2900*. eigenvectors of S and sigma are the corresponding 2901*. eigenvectors 2902 DO I = 1, NNONSING 2903 SCALE = 1/SQRT(WORK(KLVCC1-1+NSING+I)) 2904 CALL SCALVE(WORK(KLNONSING+(I-1)*NSPA),SCALE,NSPA) 2905 END DO 2906*. Construct H matrix 2907 CALL COM_SH(WORK(KLSHMAT),WORK(KLSHMAT),WORK(KLVCC1),WORK(KLVCC2), 2908 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 2909 & N_CC_AMP,IREFSPC, ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 2910 & IDOPROJ,IUNIOP,0,1,1,I_DO_EI,NSPA,0,0,0) 2911*. To save space we now need to play a bit around: First we 2912*. write H and the needed part of X on disc -they will be 2913*. destroyed during transformation 2914 LUSCR = 36 2915 CALL REWINO(LUSCR) 2916C TODSC(A,NDIM,MBLOCK,IFIL) 2917 CALL TODSC(WORK(KLNONSING),NSPA*NNONSING,-1,LUSCR) 2918 CALL ITODS(-1,1,-1,LUSCR) 2919 CALL TODSC(WORK(KLSHMAT),NSPA*NSPA,-1,LUSCR) 2920 CALL ITODS(-1,1,-1,LUSCR) 2921*. Use low memory routine overwriting the input matrices 2922C TRNMA_LM(XTAX,A,X,NRA,NCA,NRX,NCX,SCRVEC) 2923 CALL TRNMA_LM(WORK(KLNONSING),WORK(KLSHMAT),WORK(KLNONSING), 2924 & NSPA,NSPA,NSPA,NNONSING,WORK(KLVCC1)) 2925 CALL COPVEC(WORK(KLNONSING),WORK(KLSHMAT),NNONSING*NNONSING) 2926* 2927 IF(NTEST.GE.100) THEN 2928 WRITE(6,*) ' Transformed Hamiltonian matrix ' 2929 CALL WRTMAT(WORK(KLSHMAT),NNONSING,NNONSING,NNONSING,NNONSING) 2930 END IF 2931C STOP ' Enforced stop after TRANMA_LM' 2932* 2933*. Diagonalize transformed Hamiltonian 2934* 2935*. using EISPACK TRED2-TQL2 2936 IOLD = 0 2937 IF(IOLD.EQ.0) THEN 2938 CALL DIAG_SYMMAT_EISPACK(WORK(KLSHMAT),WORK(KLVCC1), 2939 & WORK(KLVCC2),NNONSING,IEIG_RETURN) 2940 ELSE 2941 ZERO = 0.0D0 2942 ONE = 1.0D0 2943 CALL TRIPAK(WORK(KLSHMAT),WORK(KLXMAT),1,NNONSING,NNONSING) 2944 CALL COPVEC(WORK(KLXMAT),WORK(KLSHMAT),NNONSING*(NNONSING+1)/2) 2945 CALL SETVEC(WORK(KLXMAT),ZERO,NNONSING*NNONSING) 2946 CALL SETDIA(WORK(KLXMAT),ONE,NNONSING,0) 2947C SETDIA(MATRIX,VALUE,NDIM,IPACK) 2948 CALL JACOBI(WORK(KLSHMAT),WORK(KLXMAT),NNONSING,NNONSING) 2949C JACOBI(F,V,NB,NMAX) 2950 CALL COPDIA(WORK(KLSHMAT),WORK(KLVCC1),NNONSING,1) 2951 WRITE(6,*) ' Diagonalize JACOBI was used ' 2952 WRITE(6,*) ' This does not order eigenvalues so STOP ' 2953 STOP ' Will not proceed after call to JACOBI ' 2954 END IF 2955* 2956 WRITE(6,*) ' Ecore in ICCI_COMPLETE.. ', ECORE 2957 DO I = 1, NNONSING 2958 WORK(KLVCC1-1+I) = WORK(KLVCC1-1+I) + ECORE 2959 END DO 2960* 2961 IF(NTEST.GE.100) THEN 2962 WRITE(6,*) ' Eigenvalues of H matrix in IC basis ' 2963 WRITE(6,*) ' ====================================' 2964 CALL WRTMAT_EP(WORK(KLVCC1),1,NNONSING,1,NNONSING) 2965 END IF 2966 E_IROOT = WORK(KLVCC1-1+IROOT) 2967 IF(NTEST.GE.10) THEN 2968 WRITE(6,*) ' Energy after reoptimization of external',E_IROOT 2969 END IF 2970* 2971 IF(IOLD.NE.0) THEN 2972 WRITE(6,*) ' Warning : Information for specific root ' 2973 WRITE(6,*) ' can not be obtained as IOLD = 0 does not give ' 2974 WRITE(6,*) ' ordered roots ' 2975 END IF 2976*. Transform root IROOT to original spin-adapted basis 2977 CALL COPVEC(WORK(KLSHMAT+(IROOT-1)*NNONSING),WORK(KLVCC2), 2978 & NNONSING) 2979 CALL REWINO(LUSCR) 2980C FRMDSC(ARRAY,NDIM,MBLOCK,IFILE,IMZERO,I_AM_PACKED) 2981 CALL FRMDSC(WORK(KLNONSING),NSPA*NNONSING,-1,LUSCR,IMZERO, 2982 / I_AM_PACKED) 2983C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 2984 CALL MATVCC(WORK(KLNONSING),WORK(KLVCC2),WORK(KLVCC4), 2985 & NSPA,NNONSING,0) 2986 C_0 = 0.0D0 2987 IF(NTEST.GE.100) 2988 &WRITE(6,*) ' NUNIOP, IUNIOP = ', NUNIOP, IUNIOP 2989 IF(NUNIOP.NE.0) C_0 = WORK(KLVCC4-1+IUNIOP) 2990 IF(NTEST.GE.100) 2991 &WRITE(6,*) ' C_0 = ', C_0 2992*. And transform to CAAB basis 2993 IF(I_DO_EI.EQ.0) THEN 2994 CALL REF_CCV_CAAB_SP(T_EXT,WORK(KLVCC4),WORK(KLVCC2),2) 2995C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 2996 ELSE 2997*. EI in VCC4 to CAAB in T_EXT 2998 CALL TRANS_CAAB_ORTN(T_EXT,WORK(KLVCC4),1,2,2,WORK(KLVCC2),2) 2999 END IF 3000* 3001 IF(NTEST.GE.100) THEN 3002 WRITE(6,*) ' Info from IC root nr ', IROOT 3003 WRITE(6,*) ' Energy is ', WORK(KLVCC1-1+IROOT) 3004 WRITE(6,*) ' Coefficient of zero-order state ', C_0 3005 END IF 3006 IF(NTEST.GE.1000) THEN 3007 WRITE(6,*) ' eigenvector from ICCI eigenequations ' 3008 CALL WRTMAT(T_EXT,1,NCAAB,1,NCAAB) 3009 END IF 3010* 3011 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'IC_CMP ') 3012 RETURN 3013 END 3014 SUBROUTINE JACOBI(F,V,NB,NMAX) 00015000 3015 IMPLICIT REAL*8 (A-H,O-Z) 3016 DIMENSION F(*),V(NMAX,NB) 00016000 3017C 00017000 3018C PURPOSE: TO DIAGONALIZE AN NB*NB-SIZED SUBSPACE OF THE 00018000 3019C MATRIX F, AND TO TRANSFORM THE NB VECTORS V OF LENGTH 00019000 3020C NMAX BY THE SAME UNITARY MATRIX THAT DIAGONALIZED F. 00020000 3021C (NORMAL USAGE: NB=NMAX, AND V IS A UNIT MATRIX WHEN CALLED, 00021000 3022C SO THAT V CONTAINS THE EIGENVECTORS ON EXIT.) 00022000 3023C F IS STORED AS UNDER-TRIANGULAR ROWS, AND ON EXIT HAS 00023000 3024C BEEN REPLACED BY A NEAR-DIAGONAL MATRIX. THE OUT-OF 00024000 3025C DIAGONAL ELEMENTS ARE SMALLER IN SIZE THAN THE PARAMETER 00025000 3026C EPS. 00026000 3027C (MALMQUIST 85-02-05) 00027000 3028 PARAMETER (EPS=1.E-12,EPS2=EPS*EPS) 00028000 3029 1 FMAX=0.0 00029000 3030 II0=1 00030000 3031C --- SCAN ALL NON-DIAGONAL ELEMENTS. THIS IS JUST AS EFFICIENT AS 00031000 3032C --- TO ROTATE SELECTED PAIRS ONLY. 00032000 3033 DO 60 I=2,NB 00033000 3034 II=II0+I 00034000 3035 JJ0=0 00035000 3036 DO 50 J=1,I-1 00036000 3037 FII=F(II) 00037000 3038C --- NOTE: FII CANNOT BE SET OUTSIDE THIS LOOP. 00038000 3039 IJ=II0+J 00039000 3040 FIJ=F(IJ) 00040000 3041 JJ=JJ0+J 00041000 3042 FJJ=F(JJ) 00042000 3043 FSQ=FIJ**2 00043000 3044 FMAX=MAX(FMAX,FSQ) 00044000 3045 IF(FSQ.LT.EPS2) GOTO 40 00045000 3046 DIFFR=FII-FJJ 00046000 3047 SIGN=1.0 00047000 3048 IF(DIFFR.LT.0) THEN 00048000 3049 DIFFR=-DIFFR 00049000 3050 SIGN=-SIGN 00050000 3051 END IF 00051000 3052 DUM=DIFFR+SQRT(DIFFR**2+4*FSQ) 00052000 3053 T=2*SIGN*FIJ/DUM 00053000 3054 C=1.0/SQRT(1+T**2) 00054000 3055 S=C*T 00055000 3056C --- T,C,S=TAN,COS AND SIN OF ROTATION ANGLE. 00056000 3057C --- ROTATE VECTORS: 00057000 3058 DO 10 K=1,NMAX 00058000 3059 DUM=C*V(K,J)-S*V(K,I) 00059000 3060 V(K,I)=S*V(K,J)+C*V(K,I) 00060000 3061 V(K,J)=DUM 00061000 3062 10 CONTINUE 00062000 3063C --- ROTATE F MATRIX COMPONENTS WITH ONE INDEX=I OR J: 00063000 3064 DO 31 K=1,J-1 00064000 3065 KI=II0+K 00065000 3066 KJ=JJ0+K 00066000 3067 DUM=C*F(KJ)-S*F(KI) 00067000 3068 F(KI)=S*F(KJ)+C*F(KI) 00068000 3069 F(KJ)=DUM 00069000 3070 31 CONTINUE 00070000 3071 KK0=JJ0+J 00071000 3072 DO 32 K=J+1,I-1 00072000 3073 KI=II0+K 00073000 3074 KJ=KK0+J 00074000 3075 DUM=C*F(KJ)-S*F(KI) 00075000 3076 F(KI)=S*F(KJ)+C*F(KI) 00076000 3077 F(KJ)=DUM 00077000 3078 KK0=KK0+K 00078000 3079 32 CONTINUE 00079000 3080 KK0=II0+I 00080000 3081 DO 33 K=I+1,NB 00081000 3082 KI=KK0+I 00082000 3083 KJ=KK0+J 00083000 3084 DUM=C*F(KJ)-S*F(KI) 00084000 3085 F(KI)=S*F(KJ)+C*F(KI) 00085000 3086 F(KJ)=DUM 00086000 3087 KK0=KK0+K 00087000 3088 33 CONTINUE 00088000 3089C--- ROTATE THE II,IJ, AND JJ COMPONENTS: 00089000 3090 C2=C**2 00090000 3091 S2=S**2 00091000 3092 CIJ=2*C*S*FIJ 00092000 3093 F(II)=C2*FII+S2*FJJ+CIJ 00093000 3094 F(JJ)=S2*FII+C2*FJJ-CIJ 00094000 3095 F(IJ)=0.0 00095000 3096 40 JJ0=JJ0+J 00096000 3097 50 CONTINUE 00097000 3098 II0=II0+I 00098000 3099 60 CONTINUE 00099000 3100C --- CHECK IF CONVERGED: 00100000 3101 IF(FMAX.GT.EPS2) GOTO 1 00101000 3102 RETURN 00102000 3103 END 00103000 3104 SUBROUTINE DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 3105* 3106* Diagonalize symmetric matrix using eispack routines 3107* TRED2 and TQL2 3108* 3109* Jeppe Olsen, September 2002 3110* 3111*. Arguments 3112* =========== 3113* 3114* A : On input : The matrix in full form 3115* On output: The eigenvectors 3116* EIGVAL : Contains eigenvalues on output 3117* SCRVEC : Scratch vector 3118* NDIM : Dimension of matrices 3119* IRETURN : ne 0 => Diagonalization was not complete ... 3120* 3121 INCLUDE 'implicit.inc' 3122*. Input and output 3123 DIMENSION A(NDIM*NDIM) 3124*. Output 3125 DIMENSION EIGVAL(*) 3126*. Scratch 3127 DIMENSION SCRVEC(*) 3128* 3129 CALL LUCIAQENTER('EIS_D') 3130* 3131* 1 : Bring matrix to tridiagonal form 3132* 3133 CALL TRED2L(NDIM,NDIM,A,EIGVAL,SCRVEC,A) 3134* 3135* 2 : Obtain eigenvalues from tridiagonal form 3136* 3137C TQL2(NM,N,D,E,Z,IERR) 3138 CALL TQL2L(NDIM,NDIM,EIGVAL,SCRVEC,A,IRETURN) 3139* 3140 IF(IRETURN.NE.0) THEN 3141 WRITE(6,*) ' Problem in TQL2 diagonalization, IRETURN = ', 3142 & IRETURN 3143 STOP ' Problem in TQL2 diagonalization ' 3144 END IF 3145* 3146 CALL LUCIAQEXIT('EIS_D') 3147 RETURN 3148 END 3149 SUBROUTINE GET_SXLIKE_CAABM(NSXLIKE,ISXLIKE,IWAY,I_SPIN_ADAPT) 3150* 3151* Obtain spinorbital excitations CAAB that may contain a part of 3152* a single excitation 3153* 3154* a+ a a i 3155* a+ a a+x ax ai, where x refers to some orbital index 3156* 3157* 3158* IWAY = 1 : Just the number of SXlike CAABS 3159* IWAY = 2 : Number and the actual SXLIKE CAABS 3160* 3161* 3162* Jeppe Olsen, September 2002, for understanding and isolating 3163* singularities 3164*. Modified a bit to allow more general prototypes, aug. 2004 3165* 3166C INCLUDE 'implicit.inc' 3167C INCLUDE 'mxpdim.inc' 3168 INCLUDE 'wrkspc.inc' 3169 INCLUDE 'corbex.inc' 3170 INCLUDE 'ctcc.inc' 3171 INCLUDE 'cgas.inc' 3172 INCLUDE 'glbbas.inc' 3173*. Output ( IF IWAY.NE.1) 3174 INTEGER ISXLIKE(*) 3175*. Local scratch 3176 INTEGER ICASCR(2*MXPNGAS) 3177*. Loop over the various types of orbital excitations 3178 IBSXLIKE = 1 3179 IBCOMP = 1 3180 DO IOBEX_TP = 1, NOBEX_TP 3181*. Integer arrays for creation and annihilation part 3182 CALL ICOPVE2(WORK(KOBEX_TP),1+(IOBEX_TP-1)*2*NGAS,2*NGAS, 3183 & ICASCR) 3184 NOP_C = IELSUM(ICASCR,NGAS) 3185 NOP_A = IELSUM(ICASCR(1+NGAS),NGAS) 3186 NOP_CA = NOP_C + NOP_A 3187 3188*. And let another routine do the work for a given 3189*. orbital excitation type 3190*. Effective operator rank of this type of operator 3191 CALL GET_SXLIKE_CAAB(IWAY,IBSXLIKE,ISXLIKE, 3192 & NCAOC(IOBEX_TP),WORK(KCAOC(IOBEX_TP)),NOP_C,NOP_A, 3193 & I_SPIN_ADAPT,IBCOMP,WORK(KNCAAB_FOR_CA(IOBEX_TP)) ) 3194 END DO 3195* 3196 NSXLIKE = IBSXLIKE -1 3197 NTEST = 100 3198 IF(NTEST.GE.100) THEN 3199 WRITE(6,*) ' Number of SX like operators = ', NSXLIKE 3200 IF(IWAY.NE.1) THEN 3201 WRITE(6,*) ' The SX like operators ' 3202 CALL IWRTMA(ISXLIKE,1,NSXLIKE,1,NSXLIKE) 3203 END IF 3204 END IF 3205* 3206 RETURN 3207 END 3208 SUBROUTINE GET_SXLIKE_CAAB(IWAY,IBSXLIKE,ISXLIKE, 3209 & NCA_FOR_TP,ICA_FOR_TP,NOP_C,NOP_A, 3210 & I_SPIN_ADAPT,IBCOMP,NCOMP_FOR_CA) 3211* 3212* Obtain -for a given occupation type - the configurations 3213* that are effectively single excitations 3214* 3215* It is assumed that no operators are purely internal 3216* 3217* Jeppe Olsen, Sept. 2002 3218*. Modified a bit to allow more general prototypes, aug. 2004 3219* 3220 INCLUDE 'implicit.inc' 3221 INCLUDE 'mxpdim.inc' 3222 INCLUDE 'cgas.inc' 3223 INCLUDE 'proto_sp_mat.inc' 3224* 3225*. Input 3226*. The occupation of the configations 3227 INTEGER ICA_FOR_TP(NOP_C+NOP_A,NCA_FOR_TP) 3228*. Number of components for each CA excs 3229 INTEGER NCOMP_FOR_CA(*) 3230*. Output (IWAY = 2) 3231 INTEGER ISXLIKE(*) 3232* 3233 NTEST = 10 3234 IF(NTEST.GE.100) THEN 3235 WRITE(6,*) ' Info from GET_SXLIKE_CAAB ' 3236 WRITE(6,*) 'NOP_C, NOP_A, NCA_FOR_TP = ', 3237 & NOP_C, NOP_A, NCA_FOR_TP 3238 END IF 3239 3240 DO ICA = 1, NCA_FOR_TP 3241 IF(NTEST.GE.1000) THEN 3242 WRITE(6,*) ' Next CA configuration ' 3243 CALL IWRTMA(ICA_FOR_TP(1,ICA),1,NOP_C+NOP_A,1,NOP_C+NOP_A) 3244 END IF 3245 NCOMP_CAAB = NCOMP_FOR_CA(ICA) 3246 NCOMP_SPA = NSPA_FOP(NCOMP_CAAB) 3247 IF(I_SPIN_ADAPT.EQ.1) THEN 3248 NCOMP = NCOMP_SPA 3249 ELSE 3250 NCOMP = NCOMP_CAAB 3251 END IF 3252 LSX = 0 3253 IF(NOP_C.EQ.1) THEN 3254*. Single excitation 3255 LSX = 1 3256 ELSE IF (NOP_C.EQ.2) THEN 3257*. Twobody excitation a+ a+ a a, 3258 IF(ICA_FOR_TP(1,ICA).EQ.ICA_FOR_TP(3,ICA).OR. 3259 & ICA_FOR_TP(1,ICA).EQ.ICA_FOR_TP(4,ICA).OR. 3260 & ICA_FOR_TP(2,ICA).EQ.ICA_FOR_TP(3,ICA).OR. 3261 & ICA_FOR_TP(2,ICA).EQ.ICA_FOR_TP(4,ICA)) LSX = 1 3262* 3263 END IF 3264 IF(NTEST.GE.1000) THEN 3265 IF(LSX.EQ.1) THEN 3266 WRITE(6,*) ' Excitation is single like ' 3267 ELSE 3268 WRITE(6,*) ' Excitation is not single-like' 3269 END IF 3270 END IF 3271 IF(NTEST.GE.1000) WRITE(6,*) ' NCOMP = ', NCOMP 3272* 3273 IF(LSX.EQ.1) THEN 3274 IF(IWAY.NE.1) THEN 3275 DO J = 1, NCOMP 3276 ISXLIKE(IBSXLIKE-1+J) = IBCOMP-1+J 3277 END DO 3278 IF(NTEST.GE.1000) THEN 3279 WRITE(6,*) ' Corresponding added operators ' 3280 CALL IWRTMA(ISXLIKE(IBSXLIKE),1,NCOMP,1,NCOMP) 3281 END IF 3282 END IF 3283 IBSXLIKE = IBSXLIKE + NCOMP 3284 END IF 3285 IBCOMP = IBCOMP + NCOMP 3286 END DO 3287* 3288 RETURN 3289 END 3290 SUBROUTINE SXLIKE_SING(IREFSPC,ITREFSPC,NSXLIKE,I_SPIN_ADAPT) 3291* 3292* Study the space of single-excitation like operators 3293* and determine singularities in this space 3294* 3295* 3296* Jeppe Olsen, Oct 1, 2002 3297* 3298C INCLUDE 'implicit.inc' 3299C INCLUDE 'mxpdim.inc' 3300 INCLUDE 'wrkspc.inc' 3301 INCLUDE 'corbex.inc' 3302 INCLUDE 'clunit.inc' 3303 INCLUDE 'glbbas.inc' 3304 INCLUDE 'crun.inc' 3305* 3306 IDUM = 0 3307 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'SXLIKE') 3308*. Dimension of the space of SXLIKE operators 3309C GET_SXLIKE_CAABM(NSXLIKE,ISXLIKE,IWAY,I_SPIN_ADAPT) 3310 CALL GET_SXLIKE_CAABM(NSXLIKE,IDUM,1,I_SPIN_ADAPT) 3311*. And the actual operators 3312 CALL MEMMAN(KLSXLIKE,NSXLIKE,'ADDL ',2,'SXLIKE') 3313 CALL GET_SXLIKE_CAABM(NSXLIKE,WORK(KLSXLIKE),2,I_SPIN_ADAPT) 3314*. Construct the overlap over the SXLIKE operators 3315 3316 CALL MEMMAN(KLSMAT,NSXLIKE**2,'ADDL ',2,'SMAT ') 3317 CALL MEMMAN(KLX ,NSXLIKE**2,'ADDL ',2,'SMAT ') 3318 CALL MEMMAN(KLVCC1,N_CC_AMP,'ADDL ',2,'VCC1 ') 3319 CALL MEMMAN(KLVCC2,N_CC_AMP,'ADDL ',2,'VCC2 ') 3320 CALL MEMMAN(KLVCC3,N_CC_AMP,'ADDL ',2,'VCC3 ') 3321*. Space for old fashioned CI behind the curtain 3322 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 3323 KVEC1P = KVEC1 3324 KVEC2P = KVEC2 3325 IDOPROJ = 1 3326 IUNIOP = 0 3327 IF(I_SPIN_ADAPT.EQ.0) THEN 3328 NSPA = 0 3329 ELSE 3330 CALL NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 3331 END IF 3332C COM_SH(S,H,VCC1,VCC2,VCC3,VEC1,VEC2, 3333C & N_CC_AMP,IREFSPC,ITREFSPC, 3334C & LUC,LUHC,LUSCR,LUSCR2,IDOPROJ,IUNIOP, 3335C & IDO_S,IDO_H,IDO_SPA,NSPA,IDOSUB,ISUB,NSUB) 3336 CALL COM_SH(WORK(KLSMAT),WORK(KLSMAT),WORK(KLVCC1),WORK(KLVCC2), 3337 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 3338 & N_CC_AMP,IREFSPC, ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 3339 & IDOPROJ,IUNIOP,1,0,I_SPIN_ADAPT,I_DO_EI,NSPA,1, 3340 & WORK(KLSXLIKE),NSXLIKE) 3341* 3342C? WRITE(6,*) ' The first 5 rows of S ' 3343C? CALL WRTMAT(WORK(KLSMAT),5,NSXLIKE,NSXLIKE,NSXLIKE) 3344C? WRITE(6,*) ' And the last column ' 3345C? CALL WRTMAT(WORK(KLSMAT+(NSXLIKE-1)*NSXLIKE),1,NSXLIKE,1,NSXLIKE) 3346*. Diagonalize metric and count singularities 3347C CHK_S_FOR_SING(S,NDIM,NSING,X,SCR,SCR2) 3348 CALL CHK_S_FOR_SING(WORK(KLSMAT),NSXLIKE,NSXSING,WORK(KLX), 3349 & WORK(KLVCC2),WORK(KLVCC3)) 3350 WRITE(6,*) ' Number of singularities in SX like space = ', 3351 & NSXSING 3352* 3353 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'SXLIKE') 3354 RETURN 3355 END 3356 SUBROUTINE FIND_INTEGER_IN_VEC(IVAL,IVEC,NELMNT,IELMNT) 3357* 3358* A vector of NELMNT elements is given in IVEC. 3359* Find the element IELMNT in IVEC with value IVAL. 3360* If there are several elements with this value, the last element 3361* with correct value is returned. 3362* If an element with the value IELMNT is not obtained, IELMNT is 3363* returned as zero 3364* 3365* Jeppe Olsen, Oct. 2002 3366* 3367 INCLUDE 'implicit.inc' 3368* 3369 INTEGER IVEC(NELMNT) 3370* 3371 IELMNT = 0 3372 DO JELMNT = 1, NELMNT 3373 IF(IVEC(JELMNT).EQ.IVAL) IELMNT = JELMNT 3374 END DO 3375* 3376 RETURN 3377 END 3378 SUBROUTINE GET_ADR_FOR_OCCLS(IOCCLS_SEL,NOCCLS_SEL,NOP,IOP) 3379* 3380* Find the number and addresses (in configuration order) of spinadapted 3381* operators for the 3382* NOCCLS_SEL occupation classes given in IOCCLS_SEL 3383* 3384* The operators are returned in IOP 3385* 3386* Jeppe Olsen, Oct 2002, Milano Airport ( Malpensa to be more exact) 3387* 3388*. General Input 3389C INCLUDE 'implicit.inc' 3390C INCLUDE 'mxpdim.inc' 3391 INCLUDE 'wrkspc.inc' 3392 INCLUDE 'glbbas.inc' 3393 INCLUDE 'ctcc.inc' 3394 INCLUDE 'corbex.inc' 3395*. Specific Input 3396 INTEGER IOCCLS_SEL(NOCCLS_SEL) 3397*. Output 3398 INTEGER IOP(*) 3399 IBOP = 1 3400 DO JJOCCLS = 1, NOCCLS_SEL 3401 JOCCLS = IOCCLS_SEL(JJOCCLS) 3402 DO JOP = 1, NSPA_FOR_OCCLS(JOCCLS) 3403 IOP(IBOP) = IBSPA_FOR_OCCLS(JOCCLS)-1+JOP 3404 IBOP = IBOP + 1 3405 END DO 3406 END DO 3407 NOP = IBOP - 1 3408* 3409 NTEST = 10 3410 IF(NTEST.GE.10) THEN 3411 WRITE(6,*) ' SPA operators for the Excitation types ', 3412 & (IOCCLS_SEL(I),I=1, NOCCLS_SEL),' : ' 3413 WRITE(6,*) ' Dimension = ', NOP 3414 IF(NTEST.GE.100) CALL IWRTMA(IOP,1,NOP,1,NOP) 3415 END IF 3416* 3417 RETURN 3418 END 3419 SUBROUTINE DIM_FOR_OBEXTP 3420* 3421* Number of CSF's per ocupation class and number of 3422* CAAB's per orbital excitation type. 3423* 3424* At the moment the code is adapted to ICCI, so only single 3425* and double excitations are considered ( giving atmost 6 dets for 3426* a given CONF) 3427* 3428* The output is delivered in NSPA_FOR_OCCLS,NCAAB_FOR_OCCLS 3429* given in CORBEX 3430* 3431* Jeppe Olsen, Milano Airport, Oct 2002 3432* 3433C INCLUDE 'implicit.inc' 3434C INCLUDE 'mxpdim.inc' 3435 INCLUDE 'wrkspc.inc' 3436 INCLUDE 'crun.inc' 3437 INCLUDE 'ctcc.inc' 3438 INCLUDE 'corbex.inc' 3439 INCLUDE 'cprnt.inc' 3440 COMMON/PROTO_SP_MAT/NSPA_FOP(6),NCAAB_FOP(6),IB_FOP(6),XTRA(100), 3441 & NSPA_FOP_G(6,MXPCYC),NCAAB_FOP_G(6,MXPCYC), 3442 & IB_FOP_G(6,MXPCYC) 3443*. Local scratch 3444 INTEGER ISCR(MXPNEL) 3445*. Output is given in CORBEX 3446* 3447 NTEST = 0 3448 NTEST = MAX(NTEST,IPRCSF) 3449 MAXNDET = 6 3450 IZERO = 0 3451* 3452 DO IOBEX_TP = 1, NOBEX_TP 3453*. Count the number of times the various number of dets for 3454*. a given CA occurs 3455 CALL ISETVC(ISCR,IZERO,MAXNDET) 3456 NCA = NCAOC(IOBEX_TP) 3457 CALL COUNT_OCCURENCE(WORK(KNCAAB_FOR_CA(IOBEX_TP)),ISCR,NCA, 3458 & MAXNDET) 3459* 3460 NSPA = ISCR(1)*NSPA_FOP(1) + ISCR(2)*NSPA_FOP(2) 3461 & + ISCR(4)*NSPA_FOP(4) + ISCR(6)*NSPA_FOP(6) 3462 NCAAB= ISCR(1)*NCAAB_FOP(1) + ISCR(2)*NCAAB_FOP(2) 3463 & + ISCR(4)*NCAAB_FOP(4) + ISCR(6)*NCAAB_FOP(6) 3464* 3465 NSPA_FOR_OCCLS(IOBEX_TP) = NSPA 3466 NCAAB_FOR_OCCLS(IOBEX_TP) = NCAAB 3467 END DO 3468*. Offsets for SPA operators belonging to a given occlass 3469C ZBASE(NVEC,IVEC,NCLASS) 3470 CALL ZBASE(NSPA_FOR_OCCLS,IBSPA_FOR_OCCLS,NOBEX_TP) 3471C IBSPA_FOR_OCCLS 3472* 3473 IF(NTEST.GE.100) THEN 3474 WRITE(6,*) ' Information about operators per orb. exc. type ' 3475 WRITE(6,*) '==================================================' 3476 WRITE(6,*) 3477 WRITE(6,*) 3478 & ' Orb. exc. type Configurations Spin-adapted CAAB ' 3479 WRITE(6,*) 3480 & ' =====================================================' 3481 DO IOBEX_TP = 1, NOBEX_TP 3482 WRITE(6,'(6X,I3,6X,I9,6X,I9,4X,I9)') 3483 & IOBEX_TP, NCAOC(IOBEX_TP),NSPA_FOR_OCCLS(IOBEX_TP), 3484 & NCAAB_FOR_OCCLS(IOBEX_TP) 3485 END DO 3486 END IF 3487* 3488 RETURN 3489 END 3490 SUBROUTINE SING_IN_OCCLS(IREFSPC,ITREFSPC,IOCCLS_SEL,NOCCLS_SEL) 3491* 3492* Analyze singularities in the space of the SPA operators of the 3493* NOCCLS_SEL occupation classes given in IOCCLS_SEL' 3494* 3495* 3496* Jeppe Olsen, Oct 4, 2002 3497* 3498C INCLUDE 'implicit.inc' 3499C INCLUDE 'mxpdim.inc' 3500 INCLUDE 'wrkspc.inc' 3501 INCLUDE 'corbex.inc' 3502 INCLUDE 'clunit.inc' 3503 INCLUDE 'glbbas.inc' 3504 INCLUDE 'crun.inc' 3505 INCLUDE 'ctcc.inc' 3506*. Specific input 3507 INTEGER IOCCLS_SEL(NOCCLS_SEL) 3508* 3509 IDUM = 0 3510 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'SING_I') 3511*. Allocate a vector that can contain addresses of all operators 3512 NSPA_TOT = IELSUM(NSPA_FOR_OCCLS,NOBEX_TP) 3513C? WRITE(6,*) ' NSPA_TOT = ', NSPA_TOT 3514 CALL MEMMAN(KLSPAOP,NSPA_TOT,'ADDL ',1,'SPAOP ') 3515*. The operators of the specified occupation classes 3516C GET_ADR_FOR_OCCLS(IOCCLS_SEL,NOCCLS_SEL,NOP,IOP) 3517 CALL GET_ADR_FOR_OCCLS(IOCCLS_SEL,NOCCLS_SEL,NOP, 3518 & WORK(KLSPAOP)) 3519*. Construct the overlap matrix over the these operators 3520 CALL MEMMAN(KLSMAT,NOP**2,'ADDL ',2,'SMAT ') 3521 CALL MEMMAN(KLX ,NOP**2,'ADDL ',2,'XMAT ') 3522 CALL MEMMAN(KLVCC1,N_CC_AMP,'ADDL ',2,'VCC1 ') 3523 CALL MEMMAN(KLVCC2,N_CC_AMP,'ADDL ',2,'VCC2 ') 3524 CALL MEMMAN(KLVCC3,N_CC_AMP,'ADDL ',2,'VCC3 ') 3525*. Space for old fashioned CI behind the curtain 3526 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 3527 KVEC1P = KVEC1 3528 KVEC2P = KVEC2 3529 IDOPROJ = 1 3530 IUNIOP = 0 3531C COM_SH(S,H,VCC1,VCC2,VCC3,VEC1,VEC2, 3532C & N_CC_AMP,IREFSPC,ITREFSPC, 3533C & LUC,LUHC,LUSCR,LUSCR2,IDOPROJ,IUNIOP, 3534C & IDO_S,IDO_H,IDO_SPA,NSPA_TOT,IDOSUB,ISUB,NSUB) 3535 CALL COM_SH(WORK(KLSMAT),WORK(KLSMAT),WORK(KLVCC1),WORK(KLVCC2), 3536 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 3537 & N_CC_AMP,IREFSPC, ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 3538 & IDOPROJ,IUNIOP,1,0,1,I_DO_EI,NSPA_TOT,1,WORK(KLSPAOP), 3539 & NOP) 3540* 3541*. Diagonalize metric and count singularities 3542 CALL CHK_S_FOR_SING(WORK(KLSMAT),NOP,NSING,WORK(KLX), 3543 & WORK(KLVCC2),WORK(KLVCC3)) 3544 WRITE(6,*) ' Number of singularities in choosen space ', 3545 & NSING 3546* 3547 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'SING_I') 3548 RETURN 3549 END 3550 SUBROUTINE TRNMA_LM(XTAX,A,X,NRA,NCA,NRX,NCX,SCRVEC) 3551* 3552* XTAX = X(T) * A * X 3553* Low memory version where XTAX may be identical to X, 3554* and X and A are overwritten. This works only if the 3555* number of columns in X is less than or equal to the 3556* number of columns in A 3557* 3558* SCRVEC is a scratch vector of the max dimension as A and X 3559* 3560* Jeppe Olsen, October 4, 2002 3561* 3562 INCLUDE 'implicit.inc' 3563 REAL*8 INPROD 3564*. Input 3565 DIMENSION A(*),X(*) 3566*. Output - which may be identical to X 3567 DIMENSION XTAX(*) 3568*. Scratch vector 3569 DIMENSION SCRVEC(*) 3570* 3571 NTEST = 00 3572 IF(NTEST.GE.100) THEN 3573 WRITE(6,*) ' Input matrices X and A to TRNMA_LM ' 3574 CALL WRTMAT(X,NRX,NCX,NRX,NCX) 3575 CALL WRTMAT(A,NRA,NCA,NRA,NCA) 3576 WRITE(6,*) ' NRX, NCX, NRA, NCA = ', NRX, NCX, NRA, NCA 3577 END IF 3578* 3579 IF(NCX.GT.NCA) THEN 3580 WRITE(6,*) ' TRNMA_LM: NCX gt NCA: ', NCX,NCA 3581 STOP 'TRNMA_LM: NCX gt NCA' 3582 END IF 3583* 3584 3585*.1 : X(T) A in A 3586 DO L = 1, NCA 3587*. To avoid compiler warnings 3588 IB_AKL = 0 3589 DO I = 1, NCX 3590 IB_XKI = (I-1)*NRX + 1 3591 IB_AKL = (L-1)*NRA + 1 3592 SCRVEC(I) = INPROD(X(IB_XKI),A(IB_AKL),NRA) 3593 END DO 3594*. Address of (1,L) in XTA 3595 IB_AKL = (L-1)*NCX + 1 3596 IF(NCX.NE.0) THEN 3597 CALL COPVEC(SCRVEC,A(IB_AKL),NCX) 3598 ELSE 3599 ZERO = 0.0D0 3600 CALL SETVEC(A(IB_AKL),ZERO,NCX) 3601 END IF 3602 END DO 3603* X(T) A X in XTAX 3604 DO J = 1, NCX 3605 ZERO = 0.0D0 3606 CALL SETVEC(SCRVEC,ZERO,NCX) 3607 DO L = 1, NRX 3608 XLJ = X((J-1)*NRX+L) 3609 IB_XTA_IL = (L-1)*NCX + 1 3610 ONE = 1.0D0 3611 CALL VECSUM(SCRVEC,SCRVEC,A(IB_XTA_IL),ONE,XLJ,NCX) 3612 END DO 3613 CALL COPVEC(SCRVEC,XTAX((J-1)*NCX+1),NCX) 3614 END DO 3615* 3616 IF(NTEST.GE.100) THEN 3617 WRITE(6,*) ' Outputmatrix from TRANMA_LM ' 3618 CALL WRTMAT(XTAX,NCX,NCX,NCX,NCX) 3619 END IF 3620* 3621 RETURN 3622 END 3623 subroutine tranma_lm_test 3624* 3625* Test new low memory transformation of matrix 3626* 3627* Jeppe Olsen 3628* 3629 INCLUDE 'implicit.inc' 3630 PARAMETER(MXPDIM = 100) 3631 DIMENSION A(MXPDIM*MXPDIM),X(MXPDIM*MXPDIM) 3632 DIMENSION VEC(MXPDIM) 3633* 3634 A(1) = 1.0D0 3635 A(2) = 2.0D0 3636 A(3) = 3.0D0 3637 A(4) = 4.0D0 3638 X(1) = 1.0D0 3639 X(2) = 2.0D0 3640 X(3) = 2.0D0 3641 X(4) = 1.0D0 3642C TRNMA_LM(XTAX,A,X,NRA,NCA,NRX,NCX,SCRVEC) 3643 CALL TRNMA_LM(X,A,X,2,2,2,2,VEC) 3644* 3645 RETURN 3646 END 3647 SUBROUTINE SXLIKE_SING2(IREFSPC,ITREFSPC,NSXLIKE,I_SPIN_ADAPT) 3648* 3649* 1 : Obtain the single like excitation by diagonalizing in the space 3650* single-like configurations 3651* 3652* 2 : Diagonalize complete metric in space othogonal to SX like 3653* excitations and analyze remaining singulatities 3654* 3655* Jeppe Olsen, Oct 7, 2002 - a night session in Palermo 3656* 3657C INCLUDE 'implicit.inc' 3658C INCLUDE 'mxpdim.inc' 3659 INCLUDE 'wrkspc.inc' 3660 INCLUDE 'corbex.inc' 3661 INCLUDE 'clunit.inc' 3662 INCLUDE 'glbbas.inc' 3663 INCLUDE 'crun.inc' 3664 INCLUDE 'ctcc.inc' 3665* 3666 IDUM = 0 3667 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'SXLIKA') 3668*. Dimension of the space of SXLIKE operators 3669C GET_SXLIKE_CAABM(NSXLIKE,ISXLIKE,IWAY,I_SPIN_ADAPT) 3670 CALL GET_SXLIKE_CAABM(NSXLIKE,IDUM,1,I_SPIN_ADAPT) 3671*. And the actual operators 3672 CALL MEMMAN(KLSXLIKE,NSXLIKE,'ADDL ',2,'SXLIKE') 3673 CALL GET_SXLIKE_CAABM(NSXLIKE,WORK(KLSXLIKE),2,I_SPIN_ADAPT) 3674*. Construct the overlap over the SXLIKE operators 3675 3676 CALL MEMMAN(KLSMAT,NSXLIKE**2,'ADDL ',2,'SMAT ') 3677 CALL MEMMAN(KLX ,NSXLIKE**2,'ADDL ',2,'SMAT ') 3678 CALL MEMMAN(KLVCC1,N_CC_AMP,'ADDL ',2,'VCC1 ') 3679 CALL MEMMAN(KLVCC2,N_CC_AMP,'ADDL ',2,'VCC2 ') 3680 CALL MEMMAN(KLVCC3,N_CC_AMP,'ADDL ',2,'VCC3 ') 3681*. Space for old fashioned CI behind the curtain 3682 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 3683 KVEC1P = KVEC1 3684 KVEC2P = KVEC2 3685 IDOPROJ = 1 3686 IUNIOP = 0 3687 IF(I_SPIN_ADAPT.EQ.0) THEN 3688 NSPA = 0 3689 ELSE 3690 CALL NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 3691 END IF 3692C COM_SH(S,H,VCC1,VCC2,VCC3,VEC1,VEC2, 3693C & N_CC_AMP,IREFSPC,ITREFSPC, 3694C & LUC,LUHC,LUSCR,LUSCR2,IDOPROJ,IUNIOP, 3695C & IDO_S,IDO_H,IDO_SPA,NSPA,IDOSUB,ISUB,NSUB) 3696 CALL COM_SH(WORK(KLSMAT),WORK(KLSMAT),WORK(KLVCC1),WORK(KLVCC2), 3697 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 3698 & N_CC_AMP,IREFSPC, ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 3699 & IDOPROJ,IUNIOP,1,0,I_SPIN_ADAPT,I_DO_EI,NSPA,1, 3700 & WORK(KLSXLIKE),NSXLIKE) 3701* 3702*. Diagonalize metric and count singularities 3703 CALL CHK_S_FOR_SING(WORK(KLSMAT),NSXLIKE,NSXSING,WORK(KLX), 3704 & WORK(KLVCC2),WORK(KLVCC3)) 3705 WRITE(6,*) ' Number of singularities in SX like space = ', 3706 & NSXSING 3707*. On output we have the singularities as the first NSXSING singularities 3708*. Write these to disc and remove current local allocation 3709 CALL REWINO(LUSC1) 3710 CALL TODSC(WORK(KLX),NSXLIKE*NSXLIKE,-1,LUSC1) 3711 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'SXLIKA') 3712* 3713* Part 2 : Construct complete metric and orthogonalize to 3714* SX like singularitues 3715 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'SXLIKB') 3716*. Memory for metrix and a eigenvector basis 3717 NSPA_T = IELSUM(NSPA_FOR_OCCLS,NOBEX_TP) 3718 CALL MEMMAN(KLSMAT,NSPA_T**2,'ADDL ',2,'SMAT ') 3719 CALL MEMMAN(KLX ,NSPA_T**2,'ADDL ',2,'XMAT ') 3720 CALL MEMMAN(KLVCC1,N_CC_AMP,'ADDL ',2,'VCC1 ') 3721 CALL MEMMAN(KLVCC2,N_CC_AMP,'ADDL ',2,'VCC2 ') 3722 CALL MEMMAN(KLVCC3,N_CC_AMP,'ADDL ',2,'VCC3 ') 3723*. Space for old fashioned CI behind the curtain 3724 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 3725 KVEC1P = KVEC1 3726 KVEC2P = KVEC2 3727 IDOPROJ = 1 3728 IUNIOP = 0 3729C COM_SH(S,H,VCC1,VCC2,VCC3,VEC1,VEC2, 3730C & N_CC_AMP,IREFSPC,ITREFSPC, 3731C & LUC,LUHC,LUSCR,LUSCR2,IDOPROJ,IUNIOP, 3732C & IDO_S,IDO_H,IDO_SPA,NSPA,IDOSUB,ISUB,NSUB) 3733 CALL COM_SH(WORK(KLSMAT),WORK(KLSMAT),WORK(KLVCC1),WORK(KLVCC2), 3734 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 3735 & N_CC_AMP,IREFSPC, ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 3736 & IDOPROJ,IUNIOP,1,0,I_SPIN_ADAPT,I_DO_EI, 3737 & NSPA_T,0,IDUM,IDUM) 3738*. Recreate the SX like singularities (NSXLIKE is known) 3739 CALL MEMMAN(KLSXORD,NSPA_T,'ADDL ',2,'SXORD ') 3740 CALL GET_SXLIKE_CAABM(NSXLIKE,WORK(KLSXORD),2,I_SPIN_ADAPT) 3741*. Add terms that are not SX at end of list 3742 CALL COMPL_LIST(WORK(KLSXORD),NSXLIKE,NSPA_T) 3743*. Find the configurations that not are single excitations 3744 3745* 3746 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'SXLIKB') 3747 RETURN 3748 END 3749C COMPL_LIST(WORK(KLSXORD),NSXLIKE,NSPA_T) 3750 SUBROUTINE COMPL_LIST(ILIST,NIN,NTOT) 3751* A list is given with NIN elements in 3752* ascending order. Complete list so all integers 3753* between 1 and NTOT occurs 3754* 3755* Jeppe Olsen, Palermo Oct 8 2002, a few hours before liftof 3756* 3757 INCLUDE 'implicit.inc' 3758*. Input and output 3759 INTEGER ILIST(NTOT) 3760*. Loop over intergers to be in list 3761 KPIN = 1 3762 KTOT = NIN 3763 DO I = 1, NTOT 3764*. Is this integer next element included list ? 3765 IF(KPIN.GT.NIN.OR.I.NE.ILIST(KPIN)) THEN 3766* I is not in list 3767 KTOT = KTOT + 1 3768 ILIST(KTOT) = I 3769 ELSE 3770*. I is in list already 3771 KPIN = KPIN + 1 3772 END IF 3773 END DO 3774* 3775 NTEST = 100 3776 IF(NTEST.GE.100) THEN 3777 WRITE(6,*) ' completed list from COMPL_LIST ' 3778 WRITE(6,*) ' NIN, NTOT = ', NIN, NTOT 3779 CALL IWRTMA(ILIST,1,NTOT,1,NTOT) 3780 END IF 3781* 3782 RETURN 3783 END 3784 SUBROUTINE ICCI_RELAX_REFCOEFS_COM(T_EXT,N_EXT,H_REF,S_REF,N_REF, 3785 & VEC1,VEC2,IDO_SPA,IREFSPC,ITREFSPC, 3786 & C_0,ECORE,C_REF_OUT,IREFROOT,NCAAB, 3787 & E_RELAX) 3788*. Relax internal coefficients in the presence of external 3789*. correlation function 3790* 3791* Initial version generating complete matrices 3792* 3793* NCAAB is number of operators including unitoperator, all in elementary 3794* form 3795* 3796* 3797* Redetermine coefficients in reference wavefunction for 3798* a given Set of external coefficients given by T_EXT. 3799* 3800* The wave-function is given as 3801* 3802* |ICCI > = (C_0 + P \sum_{\mu}T_EXT_{\mu} \hat 0_{\mu} |0 > 3803* 3804* where |0> is the reference wave function that we will 3805* reoptimize 3806* 3807* |0> = \sum_i d_i |i> 3808* 3809* P is an projection operator projecting on the orthogonal 3810* complement space of the reference space 3811* 3812* T_EXT is required to be in the CAAB basis 3813* 3814* The equations to be solved are 3815* 3816* H_REF C = E S_REF C with 3817* 3818* H_REF_ij = <0_i!H!0_j> 3819* S_REF_ij = <0_i ! 0_j> 3820* 3821* |0_i> = (C_0 + P T) |i > 3822*. Jeppe Olsen, July 2004, new way of calculating matrix added aug. 04 3823* 3824C INCLUDE 'implicit.inc' 3825 INCLUDE 'wrkspc.inc' 3826 REAL*8 INPRDD, INPROD 3827* 3828C INCLUDE 'mxpdim.inc' 3829 INCLUDE 'clunit.inc' 3830 INCLUDE 'crun.inc' 3831 INCLUDE 'cands.inc' 3832 INCLUDE 'cstate.inc' 3833*. Transfer common block - all parameters have an X here - dirty 3834*. and naughty ( in the boring way ) 3835 COMMON/COM_H_S_EFF_ICCI_TV/ 3836 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 3837 & IUNIOPX,NSPAX,IPROJSPCX 3838*. Input 3839 DIMENSION T_EXT(N_EXT) 3840*. Output 3841 DIMENSION H_REF(N_REF,N_REF),S_REF(N_REF,N_REF) 3842 DIMENSION C_REF_OUT(*) 3843*. Scratch 3844 DIMENSION VEC1(*),VEC2(*) 3845* 3846 IDUM = 0 3847 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'IC_REL') 3848* 3849 NTEST = 100 3850 WRITE(6,*) 'ICC_RELAX...: NCAAB= ', NCAAB 3851* 3852 ICSPC = IREFSPC 3853 ISSPC = ITREFSPC 3854* 3855* 3856*. Scratch : 3 vectors that can hold T_EXT in expanded form 3857* 3858*. Construct/copy T_EXT in CAAB form in VCC1 3859 CALL MEMMAN(KLVCC1,NCAAB,'ADDL ',2,'VCC1 ') 3860 CALL MEMMAN(KLVCC2,NCAAB,'ADDL ',2,'VCC2 ') 3861 CALL MEMMAN(KLREF1,N_REF ,'ADDL ',2,'REF1 ') 3862* 3863 CALL COPVEC(T_EXT,WORK(KLVCC1),NCAAB) 3864* 3865*. Prepare the transfer common block 3866C & C_0X,KLTOPX,NREFX,IREFSPX,ITREFSPCX,NCAABX 3867 C_0X = C_0 3868 KLTOPX = KLVCC1 3869 NREFX = N_REF 3870 IREFSPCX = IREFSPC 3871 ITREFSPCX = ITREFSPC 3872 NCAABX = NCAAB 3873* 3874 ZERO = 0.0D0 3875 ONE = 1.0D0 3876 DO I = 1, N_REF 3877 CALL SETVEC(WORK(KLREF1),ZERO,N_REF) 3878 WORK(KLREF1-1+I) = ONE 3879 CALL H_S_EFF_ICCI_TV(WORK(KLREF1),H_REF(1,I),S_REF(1,I),1,1) 3880C H_S_EFF_ICCI_TV(VECIN,VECOUT_H,VECOUT_S) 3881 END DO 3882* 3883 IF(NTEST.GE.100) THEN 3884 WRITE(6,*) ' The Effective S-matrix in reference space ' 3885 CALL WRTMAT(S_REF,N_REF,N_REF,N_REF,N_REF) 3886 WRITE(6,*) ' The Effective H-matrix in reference space ' 3887 CALL WRTMAT(H_REF,N_REF,N_REF,N_REF,N_REF) 3888 END IF 3889* 3890** And diagonalize 3891* 3892C GENEIG_WITH_SING_CHECK(A,S,EIGVEC,EIGVAL,NVAR,NSING, 3893C & WORK) 3894 LWORK = 5*N_REF**2 + 2*N_REF 3895 CALL MEMMAN(KLSCR_FOR_GENEIG,LWORK,'ADDL ',2,'SC_GEI') 3896 CALL MEMMAN(KLEIGVC,N_REF**2,'ADDL ',2,'EIGVC ') 3897 CALL MEMMAN(KLEIGVA,N_REF ,'ADDL ',2,'EIGVA ') 3898 CALL GENEIG_WITH_SING_CHECK(H_REF,S_REF,WORK(KLEIGVC), 3899 & WORK(KLEIGVA),N_REF,NSING,WORK(KLSCR_FOR_GENEIG),0) 3900* 3901 IF(NSING.NE.0) THEN 3902 WRITE(6,*) ' Warning : Singularities in Reference CI ' 3903 WRITE(6,*) ' Warning : Singularities in Reference CI ' 3904 WRITE(6,*) ' Warning : Singularities in Reference CI ' 3905 WRITE(6,*) ' Number of singularities = ', NSING 3906 END IF 3907* 3908 NNONSING = N_REF - NSING 3909 DO I = 1, NNONSING 3910 WORK(KLEIGVA-1+I) = WORK(KLEIGVA-1+I) + ECORE 3911 END DO 3912*. Energy of root IREFROOT 3913 E_RELAX = WORK(KLEIGVA-1+IREFROOT) 3914*. Copy the coefficients of root IROOT to C_REF_OUT 3915 CALL COPVEC(WORK(KLEIGVC+(IREFROOT-1)*N_REF),C_REF_OUT,N_REF) 3916*. The eigenvector is normalized with the general metric, 3917*. but we want standard normalization so 3918 XNORM = INPROD(C_REF_OUT,C_REF_OUT,N_REF) 3919 SCALE = 1.0D0/SQRT(XNORM) 3920 WRITE(6,*) ' NORM in ..RELAX.. ', XNORM 3921 CALL SCALVE(C_REF_OUT,SCALE,N_REF) 3922* 3923 WRITE(6,*) ' Eigenvalues of H_EFF matrix ' 3924 WRITE(6,*) ' ============================' 3925 CALL WRTMAT_EP(WORK(KLEIGVA),1,NNONSING,1,NNONSING) 3926* 3927 IF(NTEST.GE.100) THEN 3928 WRITE(6,*) ' Updated coefficients of reference state' 3929 CALL WRTMAT(C_REF_OUT,1,N_REF,1,N_REF) 3930 END IF 3931* 3932 CALL MEMMAN(IDUM,IDUM,'FLUSM',IDUM,'IC_REL') 3933* 3934 RETURN 3935 END 3936 SUBROUTINE GENEIG_WITH_SING_CHECK(A,S,EIGVEC,EIGVAL,NVAR,NSING, 3937 & WORK,IASPACK) 3938* 3939* A generalized eigenvalue problem A X = Lambda S X is 3940* given for S positive semidefinite. 3941* 3942* Check for singularities, and find eigensolutions in nonsingular subspace 3943* Intended as subspace diagonalizer for iterative solver, therefore 3944* not extremely space conserving. 3945* 3946* If IASPACK = 1 the input matrices are packed in lower half form 3947* = 0 the input matrices are in complete quadratic form 3948* 3949* Jeppe Olsen, Palermo, Oct. 2002 3950* 3951 INCLUDE 'implicit.inc' 3952*. Input - matrices are supposed to be given in symmetry packed form 3953 DIMENSION A(*),S(*) 3954*. Output 3955*. Eigenvectors in input basis 3956 DIMENSION EIGVEC(*) 3957*. And the eigenvalues 3958 DIMENSION EIGVAL(*) 3959*. Scratch : should atleast be 5*NVAR**2 + 2*NVAR 3960 DIMENSION WORK(*) 3961* 3962 NTEST = 100 3963 IF(NTEST.GE.100) THEN 3964 WRITE(6,*) ' Wellcome to GENEIG_WITH_SING_CHECK ' 3965 WRITE(6,*) ' Dimension of problem = ', NVAR 3966 END IF 3967 IF(NTEST.GE.1000) THEN 3968 WRITE(6,*) ' Input A and S matrices ' 3969 IF(IASPACK.EQ.0) THEN 3970 CALL WRTMAT(A,NVAR,NVAR,NVAR,NVAR) 3971 CALL WRTMAT(S,NVAR,NVAR,NVAR,NVAR) 3972 ELSE 3973 CALL PRSYM(A,NVAR) 3974 CALL PRSYM(S,NVAR) 3975 END IF 3976 END IF 3977C STOP ' Jeppe forced me to stop ' 3978*. Partition WORK 3979* 3980 KFREE = 1 3981* 3982 KSSUB = 1 3983 KFREE = KFREE + NVAR**2 3984* 3985 KMSUB = KFREE 3986 KFREE = KFREE + NVAR**2 3987* 3988 KXORTN = KFREE 3989 KFREE = KFREE + NVAR**2 3990* 3991 KSCRMAT = KFREE 3992 KFREE = KFREE + NVAR**2 3993* 3994 KSCRMAT2 = KFREE 3995 KFREE = KFREE + NVAR**2 3996* 3997 KVEC1 = KFREE 3998 KFREE = KFREE+ NVAR 3999* 4000 KVEC2 = KFREE 4001 KFREE = KFREE+ NVAR 4002*. Outpack S matrix to full form 4003 ONE = 1.0D0 4004C TRIPK3(AUTPAK,APAK,IWAY,MATDIM,NDIM,SIGN) 4005 IF(IASPACK.EQ.1) THEN 4006 CALL TRIPK3(WORK(KSSUB),S,2,NVAR,NVAR,ONE) 4007 ELSE 4008 CALL COPVEC(S,WORK(KSSUB),NVAR**2) 4009 END IF 4010C GET_ON_BASIS(S,NVEC,NSING,X,SCRVEC1,SCRVEC2) 4011 CALL GET_ON_BASIS(WORK(KSSUB),NVAR,NSING,WORK(KXORTN), 4012 & WORK(KVEC1),WORK(KVEC2)) 4013 NNONSING = NVAR - NSING 4014*. Transform A to orthonormal basis 4015 IF(IASPACK.EQ.1) THEN 4016 CALL TRIPK3(WORK(KMSUB),A,2,NVAR,NVAR,ONE) 4017 ELSE 4018 CALL COPVEC(A,WORK(KMSUB),NVAR**2) 4019 END IF 4020C TRNMA_LM(XTAX,A,X,NRA,NCA,NRX,NCX,SCRVEC) 4021 CALL TRNMA_LM(WORK(KSCRMAT),WORK(KMSUB),WORK(KXORTN), 4022 & NVAR,NVAR,NVAR,NNONSING,WORK(KVEC1)) 4023 IF(NTEST.GE.1000) THEN 4024 WRITE(6,*) ' Matrix in orthonormal nonsingular basis ' 4025 CALL WRTMAT(WORK(KSCRMAT),NNONSING,NNONSING,NNONSING,NNONSING) 4026 END IF 4027*. Transformed matrix is returved in KSCRMAT 4028*. Diagonalize transformed matrix 4029* 4030C DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 4031 CALL DIAG_SYMMAT_EISPACK(WORK(KSCRMAT),WORK(KVEC1), 4032 & WORK(KVEC2),NNONSING,IRETURN) 4033 CALL COPVEC(WORK(KVEC1),EIGVAL,NNONSING) 4034*. Obtain the eigenvectors in the original basis 4035 FACTORC = 0.0D0 4036 FACTORAB = 1.0D0 4037 CALL MATML7(EIGVEC,WORK(KXORTN),WORK(KSCRMAT),NVAR,NNONSING, 4038 & NVAR,NNONSING,NNONSING,NNONSING,FACTORC,FACTORAB,0) 4039 IF(NTEST.GE.100) THEN 4040 WRITE(6,*) ' Eigenvalues ' 4041 CALL WRTMAT(WORK(KVEC1),1,NNONSING,1,NNONSING) 4042 WRITE(6,*) ' Lowest eigenvector ' 4043 CALL WRTMAT(EIGVEC(1),1,NVAR,1,NVAR) 4044 END IF 4045 IF(NTEST.GE.1000) THEN 4046 WRITE(6,*) ' Eigenvectors in original basis ' 4047 CALL WRTMAT(EIGVEC,NVAR,NNONSING,NVAR,NNONSING) 4048 END IF 4049 & 4050* 4051 RETURN 4052 END 4053 SUBROUTINE GET_ON_BASIS(S,NVEC,NSING,X,SCRVEC1,SCRVEC2) 4054* 4055* NVEC vectors with overlap matrix S are given. 4056* Obtain transformation matrix to orthonormal basis 4057* 4058* NSING is the number of singularities obtained 4059* If there are singularities, the nonsingular transformation 4060* os obtained as a NVEC x (NVEC-NSING) matrix in X 4061* First vectors. The eigenvectors corresponding to the 4062* singular eigenvectors are lost. 4063* 4064* 4065* Jeppe Olsen, Palermo, oct 2002 4066* 4067 INCLUDE 'implicit.inc' 4068*. Input 4069 DIMENSION S(NVEC*NVEC) 4070*. Output 4071 DIMENSION X(NVEC*NVEC) 4072*. Local scratch 4073 DIMENSION SCRVEC1(*), SCRVEC2(*) 4074* 4075 NTEST = 00 4076 IF(NTEST.GE.100) THEN 4077 WRITE(6,*) ' GET_ON_BASIS speaking ' 4078 WRITE(6,*) ' Input overlap matrix ' 4079 CALL WRTMAT(S,NVEC,NVEC,NVEC,NVEC) 4080 END IF 4081*1 : Diagonalize S and save eigenvalues in SCRVEC1 4082 CALL COPVEC(S,X,NVEC*NVEC) 4083C DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 4084 CALL DIAG_SYMMAT_EISPACK(X,SCRVEC1,SCRVEC2,NVEC,IRETURN) 4085 IF(NTEST.GE.100) THEN 4086 WRITE(6,*) ' Eigenvalues of metric ' 4087 CALL WRTMAT(SCRVEC1,1,NVEC,1,NVEC) 4088 END IF 4089*2 : Count number of nonsingularities 4090 NNONSING = 0 4091 THRES = 1.0D-14 4092 DO I = 1, NVEC 4093 IF(ABS(SCRVEC1(I)).GT.THRES) THEN 4094 NNONSING = NNONSING + 1 4095 IF(I.NE.NNONSING) THEN 4096 SCRVEC1(NNONSING) = SCRVEC1(I) 4097 CALL COPVEC(X((I-1)*NVEC+1), X((NNONSING-1)*NVEC+1),NVEC) 4098 END IF 4099 END IF 4100 END DO 4101 NSING = NVEC - NNONSING 4102*2 : Rearrange so the nonsingular 4103* eigenvectors and eigenvalues are the first parts of X and 4104* SCRVEC1 4105CE ISING = 0 4106CE INONSING = 0 4107CE DO I = 1, NVEC 4108CE IF(ABS(SCRVEC1(I)) .GT. THRES) THEN 4109*. A nonsingular eigenpair 4110CE INONSING = INONSING + 1 4111CE ITO = INONSING 4112CE ELSE 4113*. A singular eigenpair 4114CE ISING = ISING + 1 4115CE ITO = ISING + NNONSING 4116CE END IF 4117CE IF(ITO.NE.I) THEN 4118CE SCRVEC1(ITO) = SCRVEC1(I) 4119CE CALL COPVEC(X((I-1)*NVEC+1), X((ITO-1)*NVEC+1),NVEC) 4120CE END IF 4121CE END DO 4122* 4123 IF(NTEST.GE.100) THEN 4124 WRITE(6,*) ' Nonsingular eigenvalues of metric ' 4125 CALL WRTMAT(SCRVEC1,1,NNONSING,1,NNONSING) 4126 END IF 4127*3 : Construct orthonormal basis using 4128* X = U sigma^{-1/2}, 4129* where U are the nonsingular 4130*. eigenvectors of S and sigma are the corresponding eigenvalues 4131 DO I = 1, NNONSING 4132 SCALE = 1/SQRT(SCRVEC1(I)) 4133 IBX = (I-1)*NVEC+1 4134 CALL SCALVE(X(IBX),SCALE,NVEC) 4135 END DO 4136* 4137 IF(NTEST.GE.100) THEN 4138 WRITE(6,*) ' Transformation matrix to nonsingular basis ' 4139 CALL WRTMAT(X,NVEC,NNONSING,NVEC,NNONSING) 4140 END IF 4141* 4142 RETURN 4143 END 4144 SUBROUTINE INFO2_FOR_PROTO_CA( 4145 & NOBEX_TP,IOBEX_TP,ISOX_FOR_OX,NSOX_FOR_OX,IBSOX_FOR_OX, 4146 & ISPOBEX_TP,NGAS, 4147 & IB_PROTO_CA, MX_DBL_C_CA, MX_DBL_A_CA, 4148 & NCOMP_FOR_PROTO_CA,NPROTO_CA) 4149* 4150* Info on the number of CAAB excitations for a CA operator 4151* with due respect given to the number of double occupied orbitals 4152* in the CA operators 4153* 4154* To obtain the number of CAAB components belonging to a given 4155* CA excitations two things must be taken into account 4156* 1) the types of spin-orbital excitations belonging to this type 4157* 2) the number of doubly occuring indeces in the C and in the A 4158* part of the orbextp 4159* 4160* 4161* So a prototype spin-orbital excitation is defined by three 4162* numbers 4163* 1) the orbital excitation type (JOBEX_TP) 4164* 2) the number of doubly occupied orbital in the C part (NDBL_C) 4165* 3) the number of double occupied orbitals in the A part (NDLB_A) 4166* 4167*. A prototype CA will thus be given the number/adress 4168* IB_PROTO_CA(JOBEX_TP) + NDBL_A*(MAX_DBL_C+1) + NDBL_C 4169* 4170*. Thus, presently a prototype does not distinguish 4171*. between CA operators having doubly occupied orbitals 4172*. in different orbital subspaces. THis may be a problem 4173* when more than 2 e ex operators must be included. 4174* Jeppe Olsen, August 2004 4175* 4176 INCLUDE 'implicit.inc' 4177 INCLUDE 'cprnt.inc' 4178*. IPRCSF is printflag in charge 4179*. Input 4180*. ====== 4181*. The CA operators 4182 INTEGER IOBEX_TP(2*NGAS,NOBEX_TP) 4183*. Number of spin-orbital excitations for each orbital excitations 4184 INTEGER NSOX_FOR_OX(NOBEX_TP) 4185*. And the number/address of the spinorbital excitations for each orbexc 4186*. the adress refers to ISPOBEX_TP 4187 INTEGER ISOX_FOR_OX(NOBEX_TP) 4188*. Start in ISOX_FOR_OC for spinorbital exc belonging to given orbexc 4189 INTEGER IBSOX_FOR_OX(NOBEX_TP) 4190*. and the actual spin-orbital excitations 4191 INTEGER ISPOBEX_TP(4*NGAS,*) 4192*.======== 4193*. Output 4194*.======== 4195* 4196*. Offset for prototypes CA belonging to a given CA 4197 INTEGER IB_PROTO_CA(NOBEX_TP) 4198*. max number of double occupied orbital in C part for given CA type 4199 INTEGER MX_DBL_C_CA(NOBEX_TP) 4200*. max number of double occupied orbital in A part for given CA type 4201 INTEGER MX_DBL_A_CA(NOBEX_TP) 4202*. Number of CAAB components for given prototype of CA 4203 INTEGER NCOMP_FOR_PROTO_CA(NPROTO_CA) 4204* 4205 NTEST = 00 4206 NTEST = MAX(NTEST,IPRCSF) 4207* 4208*. Number and offset for prototypes for given CA type 4209* 4210 IOFF = 1 4211 DO JOBEX_TP = 1, NOBEX_TP 4212 IB_PROTO_CA(JOBEX_TP) = IOFF 4213 DO ICA = 1, 2 4214 MXDBL = 0 4215 DO IGAS = 1, NGAS 4216 MXDBL = MXDBL + IOBEX_TP((ICA-1)*NGAS+IGAS,JOBEX_TP)/2 4217 END DO 4218 IF(ICA.EQ.1) THEN 4219 MX_DBL_C_CA(JOBEX_TP) = MXDBL 4220 ELSE 4221 MX_DBL_A_CA(JOBEX_TP) = MXDBL 4222 END IF 4223 END DO 4224 IOFF = IOFF + 4225 & (MX_DBL_C_CA(JOBEX_TP)+1)*(MX_DBL_A_CA(JOBEX_TP)+1) 4226 END DO 4227* 4228 IF(NTEST.GE.10) THEN 4229 WRITE(6,*) ' Max number of double occ orbs in C part ' 4230 CALL IWRTMA(MX_DBL_C_CA,1,NOBEX_TP,1,NOBEX_TP) 4231 WRITE(6,*) ' Max number of double occ orbs in A part ' 4232 CALL IWRTMA(MX_DBL_A_CA,1,NOBEX_TP,1,NOBEX_TP) 4233 WRITE(6,*) ' Offset for proto CA types ' 4234 CALL IWRTMA(IB_PROTO_CA,1,NOBEX_TP,1,NOBEX_TP) 4235 END IF 4236* 4237*. Number of CAAB components per prototype CA 4238* 4239 DO JOBEX_TP = 1, NOBEX_TP 4240 DO NDBL_C = 0, MX_DBL_C_CA(JOBEX_TP) 4241 DO NDBL_A = 0, MX_DBL_A_CA(JOBEX_TP) 4242 IPROTO = IB_PROTO_CA(JOBEX_TP) 4243 & + (MX_DBL_C_CA(JOBEX_TP)+1)*NDBL_A + NDBL_C 4244C? WRITE(6,*) ' Info for IPROTO = ', IPROTO 4245*. Loop over spin-components of this excitation 4246 ISPOX_START = IBSOX_FOR_OX(JOBEX_TP) 4247 ISPOX_STOP = ISPOX_START + NSOX_FOR_OX(JOBEX_TP)-1 4248C? WRITE(6,*) ' JOBEX_TP, START, STOP ', 4249C? & JOBEX_TP , ISPOX_START, ISPOX_STOP 4250 NCOMP_PROTO = 0 4251 DO JJSPOBEX_TP = ISPOX_START,ISPOX_STOP 4252 NDBL_C_LEFT = NDBL_C 4253 NDBL_A_LEFT = NDBL_A 4254 JSPOBEX_TP = ISOX_FOR_OX(JJSPOBEX_TP) 4255C? WRITE(6,*) ' INFO2, JJSPOBEX_TP, JSPOBEX_TP ', 4256C? & JJSPOBEX_TP, JSPOBEX_TP 4257 NCOMP = 1 4258 DO JGAS = 1, NGAS 4259*. Number CA,CB operators in this SPOX 4260C? WRITE(6,*) ' in INFO2.. ', JGAS, JSPOBEX_TP, 4261C? & JGAS, JSPOBEX_TP 4262 NCA = ISPOBEX_TP(JGAS+0*NGAS,JSPOBEX_TP) 4263 NCB = ISPOBEX_TP(JGAS+1*NGAS,JSPOBEX_TP) 4264*. Put as many double occupied orbitals in this space 4265 ND_C = MIN(MIN(NCA,NCB),NDBL_C_LEFT) 4266 NDBL_C_LEFT = NDBL_C_LEFT - ND_C 4267 NCA_S = NCA - ND_C 4268 NCB_S = NCB - ND_C 4269C? WRITE(6,*) ' NCA_S, NCB_S = ', NCA_S, NCB_S 4270 NC_COMP = IBION(NCA_S+NCB_S,NCB_S) 4271*. Number AA,AB operators in this SPOX 4272 NAA = ISPOBEX_TP(JGAS+2*NGAS,JSPOBEX_TP) 4273 NAB = ISPOBEX_TP(JGAS+3*NGAS,JSPOBEX_TP) 4274C? WRITE(6,*) ' NAA, NAB = ', NAA, NAB 4275*. Put as many double occupied orbitals in this space 4276 ND_A = MIN(MIN(NAA,NAB),NDBL_A_LEFT) 4277 NDBL_A_LEFT = NDBL_A_LEFT - ND_A 4278 NAA_S = NAA - ND_A 4279 NAB_S = NAB - ND_A 4280C? WRITE(6,*) ' NAA_S, NAB_S = ', NAA_S, NAB_S 4281 NA_COMP = IBION(NAA_S+NAB_S,NAB_S) 4282 NCOMP = NCOMP*NC_COMP*NA_COMP 4283C? WRITE(6,*) ' JGAS, NA_COMP,NC_COMP =', 4284C? & JGAS,NA_COMP,NC_COMP 4285 END DO 4286* ^ End of loop over GAS spaces 4287C? WRITE(6,*) ' Number of comps for this spox', NCOMP 4288 IF(NDBL_C_LEFT.EQ.0.AND.NDBL_A_LEFT.EQ.0) 4289 & NCOMP_PROTO = NCOMP_PROTO + NCOMP 4290 END DO 4291* ^ End of loop over spinorbitalexcitations 4292 NCOMP_FOR_PROTO_CA(IPROTO) = NCOMP_PROTO 4293 END DO 4294 END DO 4295* ^ End of loop over number of doubly occ C and A operators 4296 END DO 4297* ^ End of loop over orbital excitations 4298 IF(NTEST.GE.100) THEN 4299 WRITE(6,*) ' Number of CAAB components per prototype ' 4300 CALL IWRTMA(NCOMP_FOR_PROTO_CA,1,NPROTO_CA,1,NPROTO_CA) 4301 END IF 4302* 4303 IF(NTEST.GE.5) THEN 4304 WRITE(6,*) 4305 WRITE(6,*) ' Information about prototype CA excitations ' 4306 WRITE(6,*) ' ===========================================' 4307 WRITE(6,*) 4308 WRITE(6,*) ' Number Obextp ndbl_c ndbl_a ncomp ' 4309 WRITE(6,*) ' ==========================================' 4310 IPROTO = 0 4311 DO JOBEX_TP = 1, NOBEX_TP 4312 DO NDBL_A = 0, MX_DBL_A_CA(JOBEX_TP) 4313 DO NDBL_C = 0, MX_DBL_C_CA(JOBEX_TP) 4314 IPROTO = IPROTO + 1 4315 NCOMP = NCOMP_FOR_PROTO_CA(IPROTO) 4316 WRITE(6,'(5(3X,I5))') 4317 & IPROTO, JOBEX_TP, NDBL_C, NDBL_A, NCOMP 4318 END DO 4319 END DO 4320 END DO 4321 END IF 4322* 4323 RETURN 4324 END 4325 FUNCTION NPROTO_CA(NOBEX_TP,IOBEX_TP,NGAS) 4326* 4327* Find the number of prototype CA operators 4328* A prototype CA is ( at least today, aug 5, 2004) 4329* defined by orbital excitation, and the number of 4330* orbitals occuring twice in the C and A parts. 4331*. Thus, presently a prototype does not distinguish 4332*. between CA operators having doubly occupied orbitals 4333*. in different orbital subspaces. THis may be a problem 4334* when more than 2 e ex operators must be included. 4335* 4336* Jeppe Olsen, Aug 2005 4337* 4338 INCLUDE 'implicit.inc' 4339* 4340*. Input 4341 INTEGER IOBEX_TP(2*NGAS,NOBEX_TP) 4342* 4343 NTEST = 00 4344 IF(NTEST.GE.100) THEN 4345 WRITE(6,*) ' Input to NPROTO_CA ' 4346 WRITE(6,*) ' NOBEX_TP, NGAS = ', NOBEX_TP, NGAS 4347 WRITE(6,*) ' IOBEX:' 4348 CALL IWRTMA(IOBEX_TP,2*NGAS,NOBEX_TP,2*NGAS,NOBEX_TP) 4349 END IF 4350* 4351*. Compiler warnings ... 4352 MXDBL_C = -2810 4353 MXDBL_A = -2810 4354* 4355 NPROTO = 0 4356 DO JOBEX_TP = 1, NOBEX_TP 4357 DO ICA = 1, 2 4358 MXDBL = 0 4359 DO IGAS = 1, NGAS 4360 MXDBL = MXDBL + IOBEX_TP((ICA-1)*NGAS+IGAS,JOBEX_TP)/2 4361 END DO 4362 IF(ICA.EQ.1) THEN 4363 MXDBL_C = MXDBL 4364 ELSE 4365 MXDBL_A = MXDBL 4366 END IF 4367 END DO 4368 NPROTO = NPROTO + (MXDBL_C+1)*(MXDBL_A+1) 4369 END DO 4370* 4371 NPROTO_CA = NPROTO 4372 NTEST = 00 4373 IF(NTEST.GE.100) THEN 4374 WRITE(6,*) ' Number of prototype CA''s ', NPROTO_CA 4375 END IF 4376* 4377 RETURN 4378 END 4379 FUNCTION IPROTO_TYPE_FOR_CA(ICAEX,IOBEX_TP,NOP_C,NOP_A) 4380* 4381*. Obtain prototype number for a given CAEX. 4382* 4383*. Jeppe Olsen, August 2004 4384* 4385C INCLUDE 'implicit.inc' 4386*. General input 4387C INCLUDE 'mxpdim.inc' 4388 INCLUDE 'wrkspc.inc' 4389 INCLUDE 'glbbas.inc' 4390*. Specific input 4391 DIMENSION ICAEX(*) 4392C K_MX_DLB_C,K_MX_DLB_A,K_IB_PROTO,K_NCOMP_FOR_PROTO 4393*. Number of double occupied orbital indeces in C and A part 4394 NCL_C = NCL_FOR_CONF(ICAEX(1),NOP_C) 4395 NCL_A = NCL_FOR_CONF(ICAEX(1+NOP_C),NOP_A) 4396*. Obtain MAX number of CL orbitals in C and A parts for this type 4397 MX_CL_C = IFRMR(WORK(K_MX_DLB_C),1,IOBEX_TP) 4398 MX_CL_A = IFRMR(WORK(K_MX_DLB_A),1,IOBEX_TP) 4399*. And offset to prototypes for this obextp 4400 IB = IFRMR(WORK(K_IB_PROTO),1,IOBEX_TP) 4401* 4402 IPROTO = IB + (MX_CL_C+1)*NCL_A + NCL_C 4403* 4404 IPROTO_TYPE_FOR_CA = IPROTO 4405* 4406 NTEST = 000 4407 IF(NTEST.GE.100) THEN 4408 WRITE(6,*) ' C and A parts of CA operator ' 4409 CALL IWRTMA(ICAEX,1,NOP_C,1,NOP_C) 4410 CALL IWRTMA(ICAEX(1+NOP_C),1,NOP_A,1,NOP_A) 4411 WRITE(6,*) ' NCL_C and NCL_A ', NCL_C, NCL_A 4412 WRITE(6,*) ' CAex corresponds to protoype ', IPROTO 4413 END IF 4414* 4415 RETURN 4416 END 4417 SUBROUTINE LUCIA_ICPT(IREFSPC,ITREFSPC,ICTYP,EREF, 4418 & EFINAL,CONVER,VFINAL) 4419* 4420* Master routine for Internal Contraction perturbation theory 4421* 4422* LUCIA_IC is assumed to have been called to do the 4423* prepatory work for working with internal contraction 4424* 4425* It is assumed that spin-adaptation is used ( no flag anymore..) 4426* 4427* It is standard that the unitoperator is included in 4428* the operator manifold, but in PT theory this should be 4429* excluded. This is easily done as the unitoperator is the 4430* last operator in CA order. 4431* 4432* Jeppe Olsen, August 2004 4433* 4434C INCLUDE 'implicit.inc' 4435 INCLUDE 'wrkspc.inc' 4436 REAL*8 INPROD 4437 LOGICAL CONVER 4438C INCLUDE 'mxpdim.inc' 4439 INCLUDE 'crun.inc' 4440 INCLUDE 'cstate.inc' 4441 INCLUDE 'cgas.inc' 4442 INCLUDE 'ctcc.inc' 4443 INCLUDE 'gasstr.inc' 4444 INCLUDE 'strinp.inc' 4445 INCLUDE 'orbinp.inc' 4446 INCLUDE 'cprnt.inc' 4447 INCLUDE 'corbex.inc' 4448 INCLUDE 'csm.inc' 4449 INCLUDE 'cicisp.inc' 4450 INCLUDE 'cecore.inc' 4451 INCLUDE 'glbbas.inc' 4452 INCLUDE 'clunit.inc' 4453 INCLUDE 'lucinp.inc' 4454 INCLUDE 'oper.inc' 4455 INCLUDE 'cintfo.inc' 4456 INCLUDE 'cei.inc' 4457*. Transfer common block for communicating with H_EFF * vector routines 4458 COMMON/COM_H_S_EFF_ICCI_TV/ 4459 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 4460 & IUNIOPX,NSPAX,IPROJSPCX 4461*. Transfer block for communicating zero order energy to 4462*. routien for performing H0-E0 * vector 4463 include 'cshift.inc' 4464* 4465 CHARACTER*6 ICTYP 4466 EXTERNAL H0ME0TV_EXT_IC 4467* 4468 IDUM = 0 4469 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICPT ') 4470 NTEST = 1001 4471 WRITE(6,*) 4472 WRITE(6,*) ' ====================' 4473 WRITE(6,*) ' ICPT section entered ' 4474 WRITE(6,*) ' ====================' 4475 WRITE(6,*) 4476* 4477*. Form of ICPT calculation 4478* 4479 IF(ICTYP(1:5).EQ.'ICPT2') THEN 4480 WRITE(6,*) ' Second-order calculation ' 4481 ELSE IF (ICTYP(1:5).EQ.'ICPT3') THEN 4482 WRITE(6,*) ' Third-order calculation ' 4483 ELSE 4484 WRITE(6,'(A,A)') ' Unknown ICPT form : ', ICTYP 4485 STOP ' Unknown ICPT form ' 4486 END IF 4487* 4488 IF(I_DO_EI.EQ.1) THEN 4489 WRITE(6,*) ' EI approach in use' 4490 ELSE 4491 WRITE(6,*) ' Partial spin-adaptation in use' 4492 END IF 4493* 4494 4495 WRITE(6,*) ' Energy of reference state ', EREF 4496*. Number of parameters with and without spinadaptation 4497 IF(I_DO_EI.EQ.0) THEN 4498 CALL NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 4499 ELSE 4500*. zero-particle operator is included in N_ZERO_EI 4501 NSPA = N_ZERO_EI 4502*. Note: NCAAB includes unitop 4503 NCAAB = NDIM_EI 4504 END IF 4505 IF(I_DO_EI.EQ.0) THEN 4506 WRITE(6,*) ' Number of spin-adapted operators ', NSPA 4507 ELSE 4508 WRITE(6,*) ' Number of orthonormal zero-order states', 4509 & N_ZERO_EI 4510 END IF 4511 WRITE(6,*) ' Number of CAAB operators ', NCAAB 4512*. Number of spin adapted operators without the unitoperator 4513 I_DIR_OR_IT = 2 4514 IF(I_DIR_OR_IT.EQ.1) THEN 4515 WRITE(6,*) ' Explicit construction of all matrices' 4516 ELSE 4517 WRITE(6,*) ' Iterative solution of equations' 4518 END IF 4519* 4520 NSPAM1 = NSPA - 1 4521* 4522* ================================================== 4523* 1 : Set up zero-order Hamiltonian in WORK(KFIFA) 4524* ================================================== 4525* 4526*. It is assumed that one-body density over reference resides 4527* in WORK(KRHO1) 4528*. Calculate zero-order Hamiltonian: use either actual or Hartree-Fock density 4529 I_ACT_OR_HF = 1 4530*. Zero-offdiagonal elements ? 4531 I_ZERO_OFF = 0 4532 IF(I_ACT_OR_HF.EQ.1) THEN 4533 WRITE(6,*) ' Zero-order Hamiltonian with actual density ' 4534*. Inactive Fock matrix and core-energy- with original def. of 4535* inactive terms 4536 CALL COPVEC(WORK(KH),WORK(KHINA),NINT1) 4537 CALL FISM(WORK(KHINA),ECC) 4538 IF(NTEST.GE.1000) THEN 4539 WRITE(6,*) ' The (standard) inactive Fock matrix ' 4540 CALL APRBLM2(WORK(KHINA),NTOOBS,NTOOBS,NSMOB,1) 4541 END IF 4542 CALL FAM(WORK(KFIFA)) 4543*. and add active and inactive fock matrix 4544 ONE = 1.0D0 4545 CALL VECSUM(WORK(KFIFA),WORK(KFIFA),WORK(KHINA), 4546 & ONE,ONE,NINT1) 4547 4548 IF(NTEST.GE.1000) THEN 4549 WRITE(6,*) ' FI + FA matrix ' 4550 CALL APRBLM2(WORK(KFIFA),NTOOBS,NTOOBS,NSMOB,1) 4551 END IF 4552 ELSE 4553 WRITE(6,*) ' Zero-order Hamiltonian with zero-order density ' 4554 STOP ' I doubt this route is working says Jeppe ' 4555*. IPHGAS1 should be used to divide into H,P,V, but IPHGAS is used, so swap 4556 IF(NTEST.GE.100) THEN 4557 WRITE(6,*) ' IPHGAS1 : ' 4558 CALL IWRTMA(IPHGAS1(1),1,NGAS,1,NGAS) 4559 END IF 4560 CALL ISWPVE(IPHGAS(1),IPHGAS1(1),NGAS) 4561 IF(NTEST.GE.100) THEN 4562 WRITE(6,*) ' IHPGAS in use ' 4563 CALL IWRTMA(IPHGAS(1),1,NGAS,1,NGAS) 4564 END IF 4565* 4566 CALL COPVEC(WORK(KINT1O),WORK(KFIFA),NINT1) 4567 CALL FI(WORK(KFIFA),ECC,1) 4568 IF(NTEST.GE.100)THEN 4569 WRITE(6,*) ' FI before zeroing : ' 4570 CALL APRBLM2(WORK(KFIFA),NTOOBS,NTOOBS,NSMOB,1) 4571 END IF 4572*. And clean up 4573 CALL ISWPVE(IPHGAS,IPHGAS1,NGAS) 4574*. zero offdiagonal elements 4575C ZERO_OFFDIAG_BLM(A,NBLOCK,LBLOCK,IPACK) 4576 IF(I_ZERO_OFF.EQ.1) 4577 & CALL ZERO_OFFDIAG_BLM(WORK(KFIFA),NSMOB,NTOOBS,1) 4578 END IF 4579* ^ End if we should use actual or Hartree-Fock density 4580* 4581 IF(NTEST.GE.100) THEN 4582 WRITE(6,*) ' One-body zero-order Hamiltonian ' 4583 CALL APRBLM2(WORK(KFIFA),NTOOBS,NTOOBS,NSMOB,1) 4584 END IF 4585*. Obtain zero-order energy 4586 CALL COPVEC(WORK(KFIFA),WORK(KINT1),NINT1) 4587*. Contributions from inactive orbitals 4588 E0INA = EXP_ONEEL_INACT(WORK(KFIFA),1) 4589*. Contributions from active orbitals 4590 CALL EN_FROM_DENS(E0ACT,1,0) 4591*. And the synthesis 4592 E0FIFA = ECORE_EXT + E0INA + E0ACT 4593 WRITE(6,'(A,4E15.8)') ' E0FIFA,ECORE_EXT,E0INA,E0ACT =', 4594 & E0FIFA,ECORE_EXT,E0INA,E0ACT 4595 E0 = E0FIFA 4596*. Scratch space for CI 4597 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 4598 KVEC1P = KVEC1 4599 KVEC2P = KVEC2 4600* 4601* 4602* ===================================================================== 4603* Obtain metric matrix and nonsingular set of operators in WORK(KLXMAT) 4604* ===================================================================== 4605* 4606*. Some additional scratch, dominated by two complete matrices !! 4607*. And a few working vectors 4608 CALL MEMMAN(KLVCC1,NCAAB,'ADDL ',2,'VCC1 ') 4609 CALL MEMMAN(KLVCC2,NCAAB,'ADDL ',2,'VCC2 ') 4610 CALL MEMMAN(KLVCC3,NCAAB,'ADDL ',2,'VCC3 ') 4611 CALL MEMMAN(KLVCC4,NCAAB,'ADDL ',2,'VCC4 ') 4612 CALL MEMMAN(KLRHS ,NCAAB,'ADDL ',2,'RHS ') 4613 CALL MEMMAN(KLC1 ,NCAAB,'ADDL ',2,'C1 ') 4614 CALL MEMMAN(KLC1O ,NCAAB,'ADDL ',2,'C1 ') 4615*. Identify the unit operator i.e. the operator with 4616*. zero creation and annihilation operators 4617 IDOPROJ = 1 4618 IF(IDOPROJ.EQ.1) THEN 4619 CALL GET_SPOBTP_FOR_EXC_LEVEL(0,WORK(KLCOBEX_TP),NSPOBEX_TP, 4620 & NUNIOP,IUNITP,WORK(KLSOX_TO_OX)) 4621*. And the position of the unitoperator in the list of SPOBEX operators 4622*. that is, in the CAAB representation 4623 WRITE(6,*) ' NUNIOP, IUNITP = ', NUNIOP,IUNITP 4624 IF(NUNIOP.EQ.0) THEN 4625 WRITE(6,*) ' Unitoperator not found in exc space ' 4626 WRITE(6,*) ' I will proceed without projection ' 4627 IDOPROJ = 0 4628 ELSE 4629 IUNIOP = IFRMR(WORK(KLIBSOBEX),1,IUNITP) 4630 IF(NTEST.GE.100) WRITE(6,*) ' IUNIOP = ', IUNIOP 4631 END IF 4632 END IF 4633*. 4634*. Prepare transfer common block used for H(ICCI) * v, S(ICCI) * v 4635* ( also used for constructing H,S) 4636*. The First three entries below are not used 4637 C_0X = 0.0D0 4638 KLTOPX = -1 4639 NREFX = -1 4640*. Used 4641 IREFSPCX = IREFSPC 4642 ITREFSPCX = ITREFSPC 4643 IPROJSPCX = IREFSPC 4644 NCAABX = N_CC_AMP 4645 NSPAX = NSPA 4646*. Unitoperator in SPA format 4647 IUNIOPX = NSPA 4648* 4649* 4650 IF(I_DIR_OR_IT.EQ.1) THEN 4651* 4652* Approach based on construction of all matrices. 4653* Matrices are constructed in the partial spin-adapted or 4654* in the zero-order basis 4655* 4656*. Construct complete matrices in the SPA representation 4657 LEN = NSPA**2 4658 CALL MEMMAN(KLSHMAT,LEN,'ADDL ',2,'SHMAT ') 4659 CALL MEMMAN(KLXMAT ,LEN,'ADDL ',2,'XMAT ') 4660 IF(I_DO_EI.EQ.1) THEN 4661 I_DO_SPA = 0 4662 ELSE 4663 I_DO_SPA = 1 4664 END IF 4665*. The metric 4666 CALL COM_SH(WORK(KLSHMAT),WORK(KLSHMAT),WORK(KLVCC1), 4667 & WORK(KLVCC2), 4668 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 4669 & N_CC_AMP,IREFSPC,ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 4670 & IDOPROJ,IUNIOP,1,0,I_DO_SPA,I_DO_EI,NSPA,0,0,0) 4671 IREFSPCX = IREFSPC 4672*. ELiminate part referring to unit operator 4673 CALL TRUNC_MAT(WORK(KLSHMAT),NSPA,NSPA,NSPAM1,NSPAM1) 4674C TRUNC_MAT(A,NRI,NCI,NRO,NCO) 4675*. Obtain orthonormal basis for nonsingular part of S 4676C GET_ON_BASIS(S,NVEC,NSING,X,SCRVEC1,SCRVEC2) 4677 CALL GET_ON_BASIS(WORK(KLSHMAT),NSPAM1,NSING, 4678 & WORK(KLXMAT),WORK(KLVCC1),WORK(KLVCC2) ) 4679 WRITE(6,*) ' Number of singularities in S ', NSING 4680 NNONSING = NSPAM1 - NSING 4681 IF(NTEST.GE.1000) THEN 4682 WRITE(6,*) ' Transformation matrix to nonsingular basis ' 4683 CALL WRTMAT(WORK(KLXMAT),NSPAM1,NNONSING,NSPAM1, 4684 & NNONSING) 4685 END IF 4686*. Save transformation to orthonormal basis - WORK(KLXMAT) will be overwritten 4687 LU28 = IGETUNIT(28) 4688 CALL REWINO(LU28) 4689 CALL VEC_TO_DISC(WORK(KLXMAT),NSPAM1*NNONSING,1,-1,LU28) 4690* 4691* ======================================================= 4692* Set up RHS of first-order equations = <0!H P T_{\mu}!0> 4693* ======================================================= 4694* 4695 I12 = 2 4696 CALL GET_ICPT_RHS1(WORK(KLRHS),IREFSPC,ITREFSPC, 4697 & NSPA,NCAAB,I_DO_EI, 4698 & WORK(KVEC1),WORK(KVEC2), 4699 & WORK(KLVCC1),WORK(KLVCC2) ) 4700C GET_ICPT_RHS1(RHS,IREFSPC,ITREFSPC, 4701C & NSPA,NCAAB, 4702C & VEC1,VEC2,VIC1,VIC2) 4703*. Transform RHS to orthonormal basis 4704C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 4705 CALL MATVCC(WORK(KLXMAT),WORK(KLRHS),WORK(KLVCC1),NSPAM1, 4706 & NNONSING,1) 4707 CALL COPVEC(WORK(KLVCC1),WORK(KLRHS),NNONSING) 4708 IF(NTEST.GE.100) THEN 4709 WRITE(6,*) ' RHS in orthonormal basis ' 4710 CALL WRTMAT(WORK(KLRHS),1,NNONSING,1,NNONSING) 4711 END IF 4712* 4713* 4714* ======================================================= 4715* Set up Zero-order Hamiltonian in WORK(KLSHMAT) 4716* ======================================================= 4717* 4718*. Complete matrix including unitop 4719* 4720*. Make KINT1 the zero-order-hamiltonian 4721 CALL SWAPVE(WORK(KINT1),WORK(KFIFA),NINT1) 4722*. And tell CI only to work with one-electron operator 4723 I12 = 1 4724 CALL COM_SH(WORK(KLSHMAT),WORK(KLSHMAT),WORK(KLVCC1), 4725 & WORK(KLVCC2), 4726 & WORK(KLVCC3),WORK(KVEC1),WORK(KVEC2), 4727 & N_CC_AMP,IREFSPC, ITREFSPC,LUC,LUHC,LUSC1,LUSC2, 4728 & IDOPROJ,IUNIOP,0,1,I_DO_SPA,I_DO_EI,NSPA,0,0,0) 4729 IF(NTEST.GE.100) THEN 4730 WRITE(6,*) ' The zero-order Hamiltonian in SPA basis ' 4731 CALL WRTMAT(WORK(KLSHMAT),NSPA,NSPA,NSPA,NSPA) 4732 END IF 4733*E0 is the last element of H so 4734 E0 = WORK(KLSHMAT-1+(NSPA-1)*NSPA+NSPA) 4735 WRITE(6,*) ' The zero-order energy ', E0 4736*. Eliminate the unit-operator from H0 4737 CALL TRUNC_MAT(WORK(KLSHMAT),NSPA,NSPA,NSPAM1,NSPAM1) 4738*. Transform H to orthonormal basis 4739C TRNMA_LM(XTAX,A,X,NRA,NCA,NRX,NCX,SCRVEC) 4740 CALL TRNMA_LM(WORK(KLXMAT),WORK(KLSHMAT),WORK(KLXMAT), 4741 & NSPAM1,NSPAM1,NSPAM1,NNONSING,WORK(KLVCC1) ) 4742 CALL COPVEC(WORK(KLXMAT),WORK(KLSHMAT),NNONSING*NNONSING) 4743 IF(NTEST.GE.100) THEN 4744 WRITE(6,*) ' The zero-order Hamiltonian in orthonormal basis ' 4745 CALL WRTMAT(WORK(KLSHMAT),NNONSING,NNONSING,NNONSING,NNONSING) 4746 END IF 4747* 4748* 4749* ===================================== 4750* Obtain First order correction to wf 4751* ===================================== 4752* 4753*. H0 - E0*1 4754* 4755 FACTOR = - E0 4756 CALL ADDDIA(WORK(KLSHMAT),FACTOR,NNONSING,0) 4757*. Diagonalixe H0-E0 , eigenvectors are returned in WORK(KLSHMAT), 4758*. eigenvalues in WORK(KLVCC1) 4759C DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 4760 CALL DIAG_SYMMAT_EISPACK(WORK(KLSHMAT),WORK(KLVCC1), 4761 & WORK(KLVCC2),NNONSING,IRETURN) 4762C IF(NTEST.GE.100) THEN 4763 WRITE(6,*) ' Eigenvalues of H0 - E0*1 ' 4764 CALL WRTMAT(WORK(KLVCC1),1,NNONSING,1,NNONSING) 4765C END IF 4766*. Transform RHS to eigenvector basis and store in WORK(KLVCC2) 4767C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 4768 CALL MATVCC(WORK(KLSHMAT),WORK(KLRHS),WORK(KLVCC2),NNONSING, 4769 & NNONSING,1) 4770*. And divide with eigenvalues - with check for singularities 4771 THRES = 1.0D-10 4772 NSING = 0 4773 DO I = 1, NNONSING 4774 IF(ABS(WORK(KLVCC1)).GT.THRES) THEN 4775 WORK(KLVCC3-1+I) = WORK(KLVCC2-1+I)/WORK(KLVCC1-1+I) 4776 ELSE 4777 NSING = NSING + 1 4778 WORK(KLVCC3-1+I) = 0.0D0 4779 END IF 4780 END DO 4781*. and remember the - : !1> = -(H0-E0)**-1 V |0> 4782 ONEM = -1.0D0 4783 CALL SCALVE(WORK(KLVCC3),ONEM,NNONSING) 4784 IF(NTEST.GE.100) THEN 4785 WRITE(6,*) ' First order correction in eigenvector basis ' 4786 CALL WRTMAT(WORK(KLVCC3),1,NNONSING,1,NNONSING) 4787 END IF 4788 WRITE(6,*) ' Number of encountered singularities ', NSING 4789*. And transform to orthonormal basis 4790 CALL MATVCC(WORK(KLSHMAT),WORK(KLVCC3),WORK(KLC1),NNONSING, 4791 & NNONSING,0) 4792 IF(NTEST.GE.100) THEN 4793 WRITE(6,*) ' First-order correction in orthonormal basis ' 4794 CALL WRTMAT(WORK(KLC1),1,NNONSING,1,NNONSING) 4795 END IF 4796*. And obtain energy corrections 4797*. E2 = <0!V!1> = <0!H|1> 4798 E2 = INPROD(WORK(KLVCC2),WORK(KLVCC3),NNONSING) 4799 WRITE(6,*) ' Second order energy correction ', E2 4800 WRITE(6,*) ' Second order approximation to energy ', 4801 & EREF+E2+ECORE 4802 E2TOT = EREF + E2 + ECORE 4803 EFINAL = E2TOT 4804* 4805 IF(ICTYP(1:5).EQ.'ICPT3') THEN 4806* Obtain also 3'rd order energy = <1!V-E1!1> = <1!H-F-E1!1> 4807*. transform first order correction to original SPA basis 4808 CALL VEC_FROM_DISC(WORK(KLXMAT),NSPAM1*NNONSING,1,-1,LU28) 4809 CALL MATVCC(WORK(KLXMAT),WORK(KLC1),WORK(KLVCC1), 4810 & NSPAM1,NNONSING,0) 4811*. Insert a zero at the place of the unit-operator 4812 WORK(KLVCC1-1+NSPA) = 0.0D0 4813*. And transform first order correction to CAAB basis 4814 IF(I_DO_SPA.EQ.1) THEN 4815*. From SPA basis to CAAB basis 4816 CALL REF_CCV_CAAB_SP(WORK(KLC1O),WORK(KLVCC1),WORK(KLVCC3),2) 4817 ELSE 4818*. From zero-order to CAAB basis 4819C TRANS_CAAB_ORTN(T_CAAB,T_ORTN,ITSYM,ICO,ILR,SCR,ICOCON) 4820 CALL TRANS_CAAB_ORTN(WORK(KLC1O),WORK(KLVCC1),1,2,2, 4821 & WORK(KLVCC3),2) 4822 END IF 4823 IF(NTEST.GE.100) THEN 4824 WRITE(6,*) ' First order correction in CAAB basis ' 4825 CALL WRTMAT(WORK(KLC1O),1,NCAAB,1,NCAAB) 4826 END IF 4827*. Modify one-electron integrals to h - f 4828*. (remember that f is in KINT1 and h is in KFIFA ... 4829 ONE = 1.0D0 4830 CALL VECSUM(WORK(KINT1),WORK(KFIFA),WORK(KINT1), 4831 & ONE,ONEM,NINT1) 4832 IF(NTEST.GE.1000) THEN 4833 WRITE(6,*) ' h - f 1-e operator ' 4834 CALL APRBLM2(WORK(KINT1),NTOOBS,NTOOBS,NSMOB,1) 4835 END IF 4836 I12 = 2 4837*. And calculate <1|V|1> and <1!1> 4838C GET_IC_EXPECT(EXPVAL,IREFSPC,ITREFSPC, 4839C & OP1,OP2,VEC1,VEC2) 4840*. 4841 ECORE_SAVE = ECORE 4842 ECORE = 0.0D0 4843 CALL GET_IC_EXPECT(EXPVAL,OVLAP,IREFSPC,ITREFSPC,WORK(KLC1O), 4844 & WORK(KLC1O),WORK(KVEC1),WORK(KVEC2), 4845 & WORK(KLVCC1)) 4846 ECORE = ECORE_SAVE 4847 E1 = EREF - E0 4848 E3 = EXPVAL - E1*OVLAP 4849 E3TOT = EREF + E2 + E3 + ECORE 4850 EFINAL = E3TOT 4851 WRITE(6,*) ' <1!V!1> = ', EXPVAL 4852 WRITE(6,*) ' <1|1> = ', OVLAP 4853 WRITE(6,*) ' Third order energy correction ', E3 4854 WRITE(6,*) ' Third order approximation to energy ', 4855 & EREF+E2+E3+ECORE 4856 END IF 4857*. Report back to LUCIA 4858*. No iterative procedure, so 4859 CONVER = .TRUE. 4860 VFINAL = 0.0D0 4861 ELSE 4862* 4863*. Use iterative method to solve first order equations 4864* 4865* 4866* ======================================================= 4867* Set up RHS of first-order equations = <0!H P T_{\mu}!0> 4868* ======================================================= 4869* 4870 I12 = 2 4871 IPERTOP = 0 4872*. Use one-electron operator with inactive and ph contributions 4873 CALL COPVEC(WORK(KFI),WORK(KINT1),NINT1) 4874 CALL GET_ICPT_RHS1(WORK(KLRHS),IREFSPC,ITREFSPC, 4875 & NSPA,NCAAB,I_DO_EI, 4876 & WORK(KVEC1),WORK(KVEC2), 4877 & WORK(KLVCC1),WORK(KLVCC2) ) 4878*. Make FIFA the one-body-hamiltonian 4879 CALL COPVEC(WORK(KFIFA),WORK(KINT1),NINT1) 4880*. And tell CI only to work with one-electron operator 4881 I12 = 1 4882*. Prepare for solution of first-order eqs by iterative techniques 4883* 4884*. The statement below is dirty, and I hope it will 4885* not give me trouble in the future. The deal is that 4886* the last operator ( in spinadapted order !!) is the 4887* unit operator, and this is excluded from the 4888* first order operator manifold, so... 4889 NVAR = NSPA - 1 4890*. Diagonal preconditioner, unit vector or diagonal of H0 4891 I_CALC_DIAG = 1 4892 IF(I_CALC_DIAG.EQ.1) THEN 4893 IF(I_DO_EI.EQ.1) THEN 4894C GET_DIAG_H0_EI(DIAG,I_IN_TP) 4895 CALL GET_DIAG_H0_EI(WORK(KLVCC1)) 4896*. The last element in KLDIA is the zero-order energy(without core) 4897 E0_FROMDIAG = WORK(KLVCC1-1+N_ZERO_EI) 4898 IF(NTEST.GE.10) 4899 & WRITE(6,*) ' Zero-order energy from diag (with ecore)', 4900 & E0_FROMDIAG 4901 DO I = 1, NVAR 4902 WORK(KLVCC1-1+I) = WORK(KLVCC1-1+I) - E0_FROMDIAG 4903 END DO 4904 ELSE 4905 STOP ' Diagonal only programmed for EI-approach' 4906 END IF 4907 ELSE 4908 ONE = 1.0D0 4909 CALL SETVEC(WORK(KLVCC1),ONE,NVAR) 4910 END IF 4911 CALL VEC_TO_DISC(WORK(KLVCC1),NVAR,1,-1,LUSC53) 4912*. Initial guess - zero - to LUSC54 4913 ZERO = 0.0D0 4914 CALL SETVEC(WORK(KLVCC1),ZERO,NVAR) 4915 CALL VEC_TO_DISC(WORK(KLVCC1),NVAR,1,-1,LUSC54) 4916*. And right hand side to LUSC37 4917C WRITE(6,*) ' RHS before written to DISC ' 4918C CALL WRTMAT(WORK(KLRHS),1,NVAR,1,NVAR) 4919 CALL VEC_TO_DISC(WORK(KLRHS),NVAR,1,-1,LUSC37) 4920* 4921 THRESH = 1.0D-8 4922 MAXITL = MAXIT 4923 MAXIT_MACRO = MAXITM 4924 WRITE(6,*) ' MAXITL, MAXIT_MACRO =', MAXITL, MAXIT_MACRO 4925* 4926 CALL MEMMAN(KLERROR,MAXITL+1,'ADDL ',2,'ERROR ') 4927* The 0's in H0ME0TV are zeros ... 4928 NTESTL = 10 4929*. For communicating zero-order energy to routine for 4930*. H0 - E0 * v 4931C SHIFT = -E0 4932 SHIFT = -E0_FROMDIAG 4933* 4934 NTESTL = 3 4935 DO IMIC = 1, MAXIT_MACRO 4936*. Put RHS back on file 4937 IF(IMIC.NE.1) CALL VEC_TO_DISC(WORK(KLRHS),NVAR,1,-1,LUSC37) 4938 CALL MICGCG(H0ME0TV_EXT_IC,LUSC54,LUSC37,LUSC38,LUSC39,LUSC40, 4939 & LUSC53,WORK(KLVCC1),WORK(KLVCC2),MAXITL,CONVER, 4940 & THRESH,ZERO,WORK(KLERROR),NVAR,0,0,VFINAL,NTESTL) 4941C MICGCG(MV8,LU1,LU2,LU3,LU4,LU5,LUDIA,VEC1,VEC2, 4942C & MAXIT,CONVER,TEST,W,ERROR,NVAR, 4943C & LUPROJ,LUPROJ2,VFINAL,IPRT) 4944 IF(CONVER) GOTO 1001 4945 END DO 4946 1001 CONTINUE 4947*. The solution to the first-order eqs, without a minus, is now 4948*. on LUSC54 4949 CALL VEC_FROM_DISC(WORK(KLVCC1),NVAR,1,-1,LUSC54) 4950*. and add a minus to obtain the first-order corrections 4951 ONEM = -1.0D0 4952 CALL SCALVE(WORK(KLVCC1),ONEM,NVAR) 4953*. E2 = <0!V!1> = <0!H|1> 4954 E2 = INPROD(WORK(KLVCC1),WORK(KLRHS),NVAR) 4955 WRITE(6,*) ' Second order energy correction ', E2 4956 WRITE(6,*) ' Second order approximation to energy ', 4957 & EREF+E2 4958 EFINAL = EREF+E2 4959 IF(ICTYP(1:5).EQ.'ICPT3') THEN 4960* Obtain also 3'rd order energy = <1!V-E1!1> = <1!H-F-E1!1> 4961*. Insert a zero at the place of the unit-operator 4962 WORK(KLVCC1-1+NSPA) = 0.0D0 4963*. And transform first order correction to CAAB basis 4964C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 4965 IF(I_DO_EI.EQ.0) THEN 4966 CALL REF_CCV_CAAB_SP(WORK(KLC1O),WORK(KLVCC1),WORK(KLVCC3),2) 4967 ELSE 4968 CALL TRANS_CAAB_ORTN(WORK(KLC1O),WORK(KLVCC1),1,2,2, 4969 & WORK(KLVCC3),2) 4970 END IF 4971 4972 IF(NTEST.GE.100) THEN 4973 WRITE(6,*) ' First order correction in CAAB basis ' 4974 CALL WRTMAT(WORK(KLC1O),1,NCAAB,1,NCAAB) 4975 END IF 4976C IF(NTEST.GE.2) THEN 4977C WRITE(6,*) ' Analysis of first-order correction' 4978C CALL ANA_GENCC(WORK(KLC1O),1) 4979C END IF 4980*. Modify one-electron integrals to h - f 4981*. (remember that f is in KINT1 and h is in KFIFA ... 4982 ONE = 1.0D0 4983 CALL VECSUM(WORK(KINT1),WORK(KFIFA),WORK(KINT1), 4984 & ONE,ONEM,NINT1) 4985 IF(NTEST.GE.1000) THEN 4986 WRITE(6,*) ' h - f 1-e operator ' 4987 CALL APRBLM2(WORK(KINT1),NTOOBS,NTOOBS,NSMOB,1) 4988 END IF 4989 I12 = 2 4990*. And calculate <1|V|1> and <1!1> 4991C GET_IC_EXPECT(EXPVAL,IREFSPC,ITREFSPC, 4992C & OP1,OP2,VEC1,VEC2) 4993 ECORE_SAVE = ECORE 4994 ECORE = 0.0D0 4995 CALL GET_IC_EXPECT(EXPVAL,OVLAP,IREFSPC,ITREFSPC,WORK(KLC1O), 4996 & WORK(KLC1O),WORK(KVEC1),WORK(KVEC2), 4997 & WORK(KLVCC1)) 4998 ECORE = ECORE_SAVE 4999 E1 = EREF -ECORE - E0 5000 E3 = EXPVAL - E1*OVLAP 5001 WRITE(6,*) ' <1!V!1> = ', EXPVAL 5002 WRITE(6,*) ' <1|1> = ', OVLAP 5003 WRITE(6,*) ' Third order energy correction ', E3 5004 WRITE(6,*) ' Third order approximation to energy ', 5005 & EREF+E2+E3 5006 EFINAL = EREF+E2+E3 5007* 5008 IF(NTEST.GE.2) THEN 5009 WRITE(6,*) ' Analysis of first-order correction' 5010 CALL ANA_GENCC(WORK(KLC1O),1) 5011 END IF 5012 END IF 5013 END IF 5014* ^ End of swith between direct and iterative method for solving 5015* first order eqs. 5016 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ICPT ') 5017 RETURN 5018 END 5019 SUBROUTINE GET_ICPT_RHS1(RHS,IREFSPC,ITREFSPC, 5020 & NSPA,NCAAB,I_DO_EI, 5021 & VEC1,VEC2,VIC1,VIC2) 5022* 5023* Obtain RHS side vector for first order ICPT equations 5024* 5025*. RHS_{\mu} = <0|T+_{\mu}PH|0> = <0!HP T_{\mu}|0> 5026* 5027* I_DO_EI = 1 => EI approach used, output vector is in zero-order basis 5028* I_DO_EI = 0 => SPA approach used, output vector is in SPA basis 5029* 5030*. Jeppe Olsen, August 2004 5031* October 2009: I_DO_EI added 5032* 5033 5034C INCLUDE 'implicit.inc' 5035*. General input 5036C INCLUDE 'mxpdim.inc' 5037 INCLUDE 'wrkspc.inc' 5038 INCLUDE 'cstate.inc' 5039 INCLUDE 'cands.inc' 5040 INCLUDE 'clunit.inc' 5041*. Scratch for CI 5042 DIMENSION VEC1(*),VEC2(*) 5043*. Scratch space for IC vectors 5044 DIMENSION VIC1(*),VIC2(*) 5045*. Output 5046 DIMENSION RHS(*) 5047* 5048 NTEST = 000 5049 IF(NTEST.GE.1000) THEN 5050 WRITE(6,*) ' Output form GET_ICPT_RHS1' 5051 WRITE(6,*) ' -------------------------' 5052 WRITE(6,*) ' I_DO_EI, NCAAB, NSPA =', I_DO_EI,NCAAB,NSPA 5053 END IF 5054* 5055* RHS will be calculated as density <L|T_{\mu}|0> 5056* with |L> = P H|0> 5057 5058*. Obtain H|0> on LUHC 5059 ICSPC = IREFSPC 5060 ISSPC = ITREFSPC 5061C? WRITE(6,*) ' Test : ICSPC, ISSPC = ', ICSPC,ISSPC 5062 CALL MV7(VEC1,VEC2,LUC,LUHC,0,0) 5063* 5064 IF(NTEST.GE.1000) THEN 5065 WRITE(6,*) ' H !Ref> as delivered in LUHC ' 5066 CALL WRTVCD(VEC1,LUHC,1,-1) 5067 END IF 5068*. P H !0> on LUHC 5069 CALL REWINO(LUHC) 5070 CALL EXTR_CIV(IREFSM,ITREFSPC,LUHC,IREFSPC,2, 5071 & LUSC1,-1,LUSC2,1,1,IDC,NTEST) 5072C EXTR_CIV(ISM,ISPCIN,LUIN, 5073C & ISPCX,IEX_OR_DE,LUUT,LBLK, 5074C & LUSCR,NROOT,ICOPY,IDC,NTESTG) 5075 IF(NTEST.GE.1000) THEN 5076 WRITE(6,*) ' P H !Ref> as delivered in LUHC ' 5077 CALL WRTVCD(VEC1,LUHC,1,-1) 5078 END IF 5079* <0!T+(I)P H !0> = <LUHC!T(I)!LUC> 5080 ICSPC = IREFSPC 5081 ISSPC = ITREFSPC 5082 ZERO = 0.0D0 5083 CALL SETVEC(VIC1,ZERO,NCAAB) 5084 CALL SIGDEN_CC(VEC1,VEC2,LUC,LUHC,VIC1,2) 5085 IF(I_DO_EI.EQ.0) THEN 5086 CALL REF_CCV_CAAB_SP(VIC1,RHS,VIC2,1) 5087 ELSE 5088C TRANS_CAAB_ORTN(T_CAAB,T_ORTN,ITSYM,ICO,ILR,SCR,ICOCON) 5089 CALL TRANS_CAAB_ORTN(VIC1,RHS,1,1,2,VIC2,1) 5090 END IF 5091* 5092 IF(NTEST.GE.100) THEN 5093 WRITE(6,*) ' RHS for first order correction ' 5094 CALL WRTMAT(RHS,1,NSPA,1,NSPA) 5095 END IF 5096* 5097 RETURN 5098 END 5099 SUBROUTINE TRUNC_MAT(A,NRI,NCI,NRO,NCO) 5100* 5101* Truncate a matrix A by deleting some of the last rows and columns 5102* 5103*. Jeppe Olsen, Aug. 2004 5104* 5105 INCLUDE 'implicit.inc' 5106*. Input and output 5107 DIMENSION A(*) 5108 IJO = 0 5109 DO ICO = 1, NCO 5110 DO IRO = 1, NRO 5111 IJO = IJO + 1 5112 IJI = (ICO-1)*NRI+IRO 5113 A(IJO) = A(IJI) 5114 END DO 5115 END DO 5116* 5117 NTEST = 00 5118 IF(NTEST.GE.100) THEN 5119 WRITE(6,*) ' truncated matrix ' 5120 CALL WRTMAT(A,NRO,NCO,NRO,NCO) 5121 END IF 5122* 5123 RETURN 5124 END 5125 SUBROUTINE GET_IC_EXPECT(EXPVAL,OVLAP,IREFSPC,ITREFSPC, 5126 & OP1,OP2,VEC1,VEC2,VIC1) 5127*. Obtain expectation value 5128* <0!O1+ H O2 |0> 5129* for two operators delivered in CAAB form 5130* Jeppe Olsen, August 2004 5131* 5132 INCLUDE 'implicit.inc' 5133 INCLUDE 'mxpdim.inc' 5134 REAL*8 INPRDD 5135*. For communicating with routines below 5136 INCLUDE 'cstate.inc' 5137 INCLUDE 'cands.inc' 5138 INCLUDE 'clunit.inc' 5139*. Input : Two operators in CAAB format 5140 DIMENSION OP1(*),OP2(*) 5141*. Scratch for CI 5142 DIMENSION VEC1(*), VEC2(*) 5143*. and a vector of the size of the IC expansion 5144 DIMENSION VIC1(*) 5145* 5146*. 1 : Obtain Op2 |0> on LUSC1 5147 ICSPC = IREFSPC 5148 ISSPC = ITREFSPC 5149 CALL SIGDEN_CC(VEC1,VEC2,LUC,LUSC1,OP2,1) 5150*. Obtain P Op2 !0> on LUSC1 5151 CALL REWINO(LUSC1) 5152 CALL EXTR_CIV(IREFSM,ITREFSPC,LUSC1,IREFSPC,2, 5153 & LUSC2,-1,LUSC3,1,1,IDC,NTEST) 5154*. Obtain H P Op2 |0> on LUHC 5155 ICSPC = ITREFSPC 5156 ISSPC = ITREFSPC 5157 CALL REWINO(LUHC) 5158 CALL MV7(VEC1,VEC2,LUSC1,LUHC,0,0) 5159* 5160* Two ways to proceed. 5161* 5162 I_NEW_OR_OLD = 1 5163 IF(I_NEW_OR_OLD.EQ.2) THEN 5164*. Obtain Op1 |0> on LUSC2 5165 ICSPC = IREFSPC 5166 ISSPC = ITREFSPC 5167 CALL SIGDEN_CC(VEC1,VEC2,LUC,LUSC2,OP1,1) 5168*. Obtain P Op1 |0> on LUSC2 5169 CALL REWINO(LUSC2) 5170 CALL EXTR_CIV(IREFSM,ITREFSPC,LUSC2,IREFSPC,2, 5171 & LUSC3,-1,LUSC34,1,1,IDC,NTEST) 5172*. Obtain <O| Op1+P H P Op 2 |0> as inner product 5173 EXPVAL = INPRDD(VEC1,VEC2,LUHC,LUSC2,1,-1) 5174*. and the overlap <O| Op1+P P Op 2 |0> 5175 OVLAP = INPRDD(VEC1,VEC2,LUSC1,LUSC2,1,-1) 5176 ELSE 5177*. Op1 => Op1+ 5178 CALL CONJ_CCAMP(OP1,1,VIC1) 5179 CALL CONJ_T 5180*. Op1+ P Op2 |0> on LUSC2 5181 ICSPC = ITREFSPC 5182 ISSPC = IREFSPC 5183 CALL REWINO(LUSC2) 5184 CALL REWINO(LUSC1) 5185 CALL SIGDEN_CC(VEC1,VEC2,LUSC1,LUSC2,VIC1,1) 5186 OVLAP = INPRDD(VEC1,VEC2,LUC,LUSC2,1,-1) 5187*. H P Op2 |0> => P H P Op 2|0> on LUHC 5188 CALL REWINO(LUHC) 5189 CALL EXTR_CIV(IREFSM,ITREFSPC,LUHC,IREFSPC,2, 5190 & LUSC3,-1,LUSC34,1,1,IDC,NTEST) 5191* P H P Op 2|0> => Op1+ P H P Op 2|0> on LUSC1 5192 CALL SIGDEN_CC(VEC1,VEC2,LUHC,LUSC1,VIC1,1) 5193 EXPVAL = INPRDD(VEC1,VEC2,LUSC1,LUC,1,-1) 5194*. And clean up 5195 CALL CONJ_T 5196 END IF 5197* 5198 NTEST = 100 5199 IF(NTEST.GE.100) THEN 5200 WRITE(6,*) ' Expectation value <0|Op1+ P H P Op2 |0> = ', EXPVAL 5201 WRITE(6,*) ' Overlap <0|Op1+ P P Op2 |0> = ', OVLAP 5202 END IF 5203 5204* 5205 RETURN 5206 END 5207 SUBROUTINE H_S_EFF_ICCI_TV(VECIN,VECOUT_H,VECOUT_S, 5208 & I_DO_H,I_DO_S) 5209* 5210* Obtain effective H and S- matrices (in reference space ) 5211* times vector ( in reference space ) for given external CI 5212* vector. 5213* if (I_DO_H.EQ.1) 5214* vecout_h(i) = <i!(C_0 + T+ P) H (C_0 + P T)|in>, |in> = sum(j) vecin(j) |j> 5215* 5216* If (I_DO_S.EQ.1) 5217* vecout_s(i) = <i!(C_0 + T+ P) (C_0 + P T)|in> 5218* 5219* it is assumed that space for CI (Work(kvec1p) etc has been 5220* defined .., and that common block COM_H_S_EFF_ICCI_TV 5221* has been initialized 5222* Jeppe Olsen, Aug. 2004 5223* 5224C INCLUDE 'implicit.inc' 5225C INCLUDE 'mxpdim.inc' 5226 INCLUDE 'wrkspc.inc' 5227 INCLUDE 'glbbas.inc' 5228 INCLUDE 'clunit.inc' 5229 INCLUDE 'cstate.inc' 5230 INCLUDE 'cands.inc' 5231*. Scratch units in use : LUHC, LUSC1, LUSC2, LUSC3, LUSC34,LUSC35 5232*. Transfer common 5233 COMMON/COM_H_S_EFF_ICCI_TV/C_0,KLTOP,NREF,IREFSPC,ITREFSPC,NCAAB, 5234 & IUNIOP,NSPA,IPROJSPC 5235 & 5236* C0 : Coefficient of reference function 5237* KLTOP : Pointer to T vector in WORK 5238* T is assumed to be in CAAB form 5239* NREF : Number of parameters in reference vector 5240*. Input : Vector in refence space 5241 DIMENSION VECIN(*) 5242*. And output, also a vector in reference space 5243 DIMENSION VECOUT_H(*) 5244 DIMENSION VECOUT_S(*) 5245* 5246 NTEST = 00 5247 IDUM = 0 5248 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'HS_EFV') 5249 CALL MEMMAN(KL_REFV1,NREF,'ADDL ',2,'REFV1 ') 5250 CALL MEMMAN(KL_ICV1,NCAAB,'ADDL ',2,'ICV1 ') 5251* 5252C? WRITE(6,*) ' Start of H_S .... ' 5253* 5254* 5255*. Transfer Vecin to discfile LUSC1 using the format of LUDIA 5256* 5257*. Use VECOUT_H to write integer list 1,2,3, ... NREF ( A bit unesthetic ..) 5258 CALL ISTVC2(VECOUT_H,0,1,NREF) 5259 CALL REWINO(LUSC1) 5260 CALL REWINO(LUDIA) 5261 CALL WRSVCD(LUSC1,-1,WORK(KVEC1P),VECOUT_H,VECIN,NREF,NREF, 5262 & LUDIA,1) 5263C WRSVCD(LU,LBLK,VEC1,IPLAC,VAL,NSCAT,NDIM,LUFORM,JPACK) 5264*. Obtain T !vecin> on LUSC2 5265 ICSPC = IREFSPC 5266 ISSPC = ITREFSPC 5267 CALL REWINO(LUSC1) 5268 CALL REWINO(LUSC2) 5269 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUSC2, 5270 & WORK(KLTOP),1) 5271*. T |vecin> => P T |vecin> on LUSC2 5272 CALL REWINO(LUSC2) 5273 CALL REWINO(LUSC3) 5274 CALL EXTR_CIV(IREFSM,ITREFSPC,LUSC2,IPROJSPC,2, 5275 & LUSC3,-1,LUSCR34,1,1,IDC,NTEST) 5276C EXTR_CIV(ISM,ISPCIN,LUIN, 5277C & ISPCX,IEX_OR_DE,LUUT,LBLK, 5278C & LUSCR,NROOT,ICOPY,IDC,NTESTG) 5279*. Expand vecin from IREFSPC to ITREFSPC on LUSC34 5280 CALL REWINO(LUSC1) 5281 CALL REWINO(LUSC34) 5282 CALL EXPCIV(IREFSM,IREFSPC,LUSC1,ITREFSPC,LUSC34,-1, 5283 / LUSC35,1,0,IDC,NTEST) 5284C EXPCIV(ISM,ISPCIN,LUIN, 5285C & ISPCUT,LUUT,LBLK, 5286C & LUSCR,NROOT,ICOPY,IDC,NTESTG) 5287*. And add C_0 !vecin> to P T |Vecin>, save result on LUSC1 5288 ONE = 1.0D0 5289C? WRITE(6,*) ' The LUSC2 and LUSC34 files ' 5290C? CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 5291C? CALL WRTVCD(WORK(KVEC1P),LUSC34,1,-1) 5292 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),ONE,C_0,LUSC2,LUSC34, 5293 & LUSC1,1,-1) 5294C VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 5295*. Now we have ( C_0 + P T ) |vecin> on LUSC1 5296C? WRITE(6,*) '(C_0 + P T) |Vecin> ' 5297C? CALL WRTVCD(WORK(KVEC1P),LUSC1,1,-1) 5298* 5299* ================ 5300*. Overlap terms 5301* ================ 5302* 5303*. obtain ( C_0 + P T ) |vecin> in reference space on LUSC2, LUSC1 => LUSC2 5304C? WRITE(6,*) ' Start of overlap terms ' 5305 IF(I_DO_S.EQ.1) THEN 5306 CALL REWINO(LUSC1) 5307 CALL REWINO(LUSC2) 5308 CALL EXPCIV(IREFSM,ITREFSPC,LUSC1,IREFSPC,LUSC2,-1, 5309 / LUSC3,1,0,IDC,NTEST) 5310*. ( C_0 + P T ) |vecin> => P ( C_0 + P T ) |vecin>, LUSC1 => LUSC3 5311 CALL REWINO(LUSC1) 5312 CALL REWINO(LUSC3) 5313 CALL EXTR_CIV(IREFSM,ITREFSPC,LUSC1,IPROJSPC,2, 5314 & LUSC3,-1,LUSC34,1,0,IDC,NTEST) 5315*. P ( C_0 + P T ) |vecin> => T+ P ( C_0 + P T ) |vecin>, LUSC3 => LUSC34 5316*. Conjugate T 5317 CALL CONJ_CCAMP(WORK(KLTOP),1,WORK(KL_ICV1)) 5318 CALL CONJ_T 5319 CALL REWINO(LUSC3) 5320 CALL REWINO(LUSC34) 5321 ICSPC = ITREFSPC 5322 ISSPC = IREFSPC 5323 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC34, 5324 & WORK(KL_ICV1),1) 5325*. C_0 ( C_0 + P T ) |vecin> + T+ P ( C_0 + P T ) |vecin> on LUSC35 5326*. C_0 * LUSC2 + LUSC34 => LUSC35 5327 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),C_0,ONE,LUSC2,LUSC34, 5328 & LUSC35,1,-1) 5329*. And now read in form LUSC35 5330 CALL REWINO(LUSC35) 5331 CALL FRMDSCN(VECOUT_S,-1,-1,LUSC35) 5332 ELSE 5333*. It was assumed that T => T+ was done in connection with overlap so 5334 CALL CONJ_CCAMP(WORK(KLTOP),1,WORK(KL_ICV1)) 5335 CALL CONJ_T 5336 END IF 5337* 5338* ========== 5339* H terms 5340* ========== 5341C? WRITE(6,*) ' Start of Hamilton terms ' 5342*. (C_0 + P T ) |vecin> => H (C_0 + P T ) |vecin>, LUSC1 => LUHC 5343 IF(I_DO_H.EQ.1) THEN 5344 CALL REWINO(LUSC1) 5345 CALL REWINO(LUHC) 5346 ICSPC = ITREFSPC 5347 ISSPC = ITREFSPC 5348 CALL MV7(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUHC,0,0) 5349*. Obtain H!(C_0+PT)!vecin> in LUSC2, just in reference space 5350* (obtained by contracting from ITREFSPC to IREFSPC), LUHC => LUSC2 5351 CALL REWINO(LUHC) 5352 CALL REWINO(LUSC2) 5353 CALL EXPCIV(IREFSM,ITREFSPC,LUHC,IREFSPC,LUSC2,-1, 5354 / LUSC3,1,0,IDC,NTEST) 5355*. H (C_0 + P T) |vecin> => P H (C_0 + P T) |vecin>, LUHC = > LUHC via LUSC1 5356 CALL REWINO(LUHC) 5357 CALL REWINO(LUSC1) 5358C? WRITE(6,*) ' LUHC before call to EXTR_CIV ' 5359C? CALL WRTVCD(WORK(KVEC1P),LUHC,1,-1) 5360 CALL EXTR_CIV(IREFSM,ITREFSPC,LUHC,IPROJSPC,2, 5361 & LUSC1,-1,LUSC3,1,1,IDC,NTEST) 5362C EXTR_CIV(ISM,ISPCIN,LUIN, 5363C & ISPCX,IEX_OR_DE,LUUT,LBLK, 5364C & LUSCR,NROOT,ICOPY,IDC,NTESTG) 5365*. T => T+ operator have been done in overlap part 5366*. P H (C_0 + P T) |vecin> => T+ P H (C_0 + P T) |vecin>, LUHC => LUSC1 5367 ICSPC = ITREFSPC 5368 ISSPC = IREFSPC 5369 CALL REWINO(LUHC) 5370 CALL REWINO(LUSC1) 5371 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUHC,LUSC1, 5372 & WORK(KL_ICV1),1) 5373*. Clean up, conjugate so we get the standard T operator back 5374 CALL CONJ_T 5375*. add C_O * H!(C_0+PT)!vecin> and T+ P H (C_0 + P T) |vecin>, 5376* C_0 * LUSC2 + LUSC1 => LUSC3 5377 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),C_0,ONE,LUSC2,LUSC1, 5378 & LUSC3,1,-1) 5379C VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 5380*. And we must now just read the result from LUSC3 5381C FRMDSCN(VEC,NREC,LBLK,LU) 5382 CALL REWINO(LUSC3) 5383 CALL FRMDSCN(VECOUT_H,-1,-1,LUSC3) 5384 ELSE 5385*. It is assumed that T-ops are conjugated back in the above so 5386 CALL CONJ_T 5387 END IF 5388* 5389 IF(NTEST.GE.100) THEN 5390 WRITE(6,*) ' Vecin, Vecout_H, Vecout_S from H_S_EFF_ICCI_...' 5391 CALL WRTMAT(VECIN,1,NREF,1,NREF) 5392 IF(I_DO_H.EQ.1) THEN 5393 WRITE(6,*) ' Vecout_H ' 5394 CALL WRTMAT(VECOUT_H,1,NREF,1,NREF) 5395 END IF 5396 IF(I_DO_S.EQ.1) THEN 5397 WRITE(6,*) ' Vecout_S ' 5398 CALL WRTMAT(VECOUT_S,1,NREF,1,NREF) 5399 END IF 5400 END IF 5401* 5402 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'HS_EFV') 5403* 5404 RETURN 5405 END 5406 SUBROUTINE H_S_EXT_ICCI_TV(VECIN,VECOUT_H,VECOUT_S, 5407 & I_DO_H,I_DO_S) 5408* 5409* Obtain ICCI Hamiltonian and metric times vector, 5410* external part 5411* 5412* If(I_DO_H.eq.1) vecout_h(i) : 5413* <0! H (V_0 + P sum_j vecin(j) O(j)) |0>, V_0 = vecin(iuniop) 5414* <0!O+(i) PH (V_0 + P sum_j vecin(j) O(j))|0> 5415* if(I_DO_S.eq.1) vecout_s(i) : 5416* <0! (V_0 + P sum_j vecin(j) O(j)) |0> = V_0 5417* <0!O+(i) P (V_0 + P sum_j vecin(j) O(j))|0> 5418* 5419* <0!0> is assumed normalized 5420* 5421* Vecin is supposed to be delivered in SPA basis (if I_DO_EI = 0) 5422* or in the Zeroorder basis (if I_DO_EI = 1) 5423* 5424* Jeppe Olsen, August 2004 5425* I_DO_EI added, August 2009 5426* 5427 INCLUDE 'wrkspc.inc' 5428 REAL*8 5429 &INPRDD 5430 INCLUDE 'clunit.inc' 5431 INCLUDE 'cands.inc' 5432 INCLUDE 'glbbas.inc' 5433 INCLUDE 'cstate.inc' 5434 INCLUDE 'crun.inc' 5435 INCLUDE 'ctcc.inc' 5436*. Input 5437 DIMENSION VECIN(*) 5438*. Output 5439 DIMENSION VECOUT_H(*), VECOUT_S(*) 5440*. For transfer of data 5441 COMMON/COM_H_S_EFF_ICCI_TV/C_0,KLTOP,NREF,IREFSPC,ITREFSPC,NCAAB, 5442 & IUNIOP,NSPA,IPROJSPC 5443 NTEST = 5 5444* 5445 IF(NTEST.GE.5) THEN 5446 WRITE(6,*) ' H_S_EXT_ICCI_TV entered ' 5447 ELSE IF(NTEST.GE.10) THEN 5448 WRITE(6,*) '---------------------------------' 5449 WRITE(6,*) ' Reporting from H_S_EXT_ICCI_TV ' 5450 WRITE(6,*) '---------------------------------' 5451 WRITE(6,*) 5452 WRITE(6,*) ' NSPA, NCAAB = ', NSPA, NCAAB 5453 END IF 5454 IF(NTEST.GE.1000) THEN 5455 WRITE(6,*) ' Input vector ' 5456 CALL WRTMAT(VECIN,1,NSPA,1,NSPA) 5457 END IF 5458* 5459 IDUM = 0 5460 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'HSE_TV') 5461 CALL MEMMAN(KL_VIC1,NCAAB+1,'ADDL ',2,'VIC1 ') 5462 CALL MEMMAN(KL_VIC2,NCAAB+1,'ADDL ',2,'VIC2 ') 5463* 5464 IF(IUNIOP.NE.0) THEN 5465 V_0 = VECIN(IUNIOP) 5466 ELSE 5467 V_0 = 0.0D0 5468 END IF 5469C? WRITE(6,*) ' IUNIOP = ', IUNIOP 5470* 5471* ======================================================= 5472* 1 : Obtain (V_0 + P sum_j vecin(j) O(j)) |0> on LUSC1 5473* ======================================================= 5474* 5475*. Reform VECIN to CAAB basis and store in WORK(KL_VIC1) 5476 5477 IF(I_DO_EI.EQ.0) THEN 5478 CALL REF_CCV_CAAB_SP(WORK(KL_VIC1),VECIN,WORK(KL_VIC2),2) 5479 ELSE 5480 CALL TRANS_CAAB_ORTN(WORK(KL_VIC1),VECIN,1,2,2,WORK(KL_VIC2),2) 5481 END IF 5482 IF(NTEST.GE.1000) THEN 5483 WRITE(6,*) ' Input vector in CAAB basis ' 5484 CALL WRTMAT(WORK(KL_VIC1),1,NCAAB,1,NCAAB) 5485 END IF 5486*. Obtain T !0> on LUSC2 5487 ICSPC = IREFSPC 5488 ISSPC = ITREFSPC 5489 CALL REWINO(LUC) 5490 CALL REWINO(LUSC2) 5491 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUSC2, 5492 & WORK(KL_VIC1),1) 5493 IF(NTEST.GE.10000) THEN 5494 WRITE(6,*) ' T |0> ' 5495 CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 5496 END IF 5497*. T |0> => P T |0> on LUSC2 5498 CALL REWINO(LUSC2) 5499 CALL REWINO(LUSC3) 5500C? WRITE(6,*) ' IREFSM, ITREFSPC, IPROJSPC = ', 5501C? & IREFSM, ITREFSPC, IPROJSPC 5502 CALL EXTR_CIV(IREFSM,ITREFSPC,LUSC2,IPROJSPC,2, 5503 & LUSC3,-1,LUSCR34,1,1,IDC,NTEST) 5504 IF(NTEST.GE.10000) THEN 5505 WRITE(6,*) ' P T |0> ' 5506 CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 5507 END IF 5508*. Expand |0> from IREFSPC to ITREFSPC on LUSC34 5509 CALL REWINO(LUC) 5510 CALL REWINO(LUSC34) 5511C? WRITE(6,*) ' IREFSM, IREFSPC, ITREFSPC ', 5512C? & IREFSM, IREFSPC, ITREFSPC 5513 CALL EXPCIV(IREFSM,IREFSPC,LUC,ITREFSPC,LUSC34,-1, 5514 / LUSC35,1,0,IDC,NTEST) 5515*. And add V_0 !0> to P T |0>, save result on LUSC1 5516 ONE = 1.0D0 5517 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),ONE,V_0,LUSC2,LUSC34, 5518 & LUSC1,1,-1) 5519*. We now we have ( V_0 + P T ) |0> on LUSC1 5520 IF(NTEST.GE.1000) THEN 5521 WRITE(6,*) '(V_0 + P T) |0> ' 5522 CALL WRTVCD(WORK(KVEC1P),LUSC1,1,-1) 5523 END IF 5524CM CALL MEMCHK2('BEF_OVL') 5525* 5526* ================ 5527*. Overlap terms 5528* ================ 5529* 5530*. ( V_0 + P T ) |0> => P ( V_0 + P T ) |0>, LUSC1 => LUSC3 5531 IF(I_DO_S.EQ.1) THEN 5532 CALL REWINO(LUSC1) 5533 CALL REWINO(LUSC3) 5534 CALL EXTR_CIV(IREFSM,ITREFSPC,LUSC1,IPROJSPC,2, 5535 & LUSC3,-1,LUSC34,1,0,IDC,NTEST) 5536 IF(NTEST.GE.1000) THEN 5537 WRITE(6,*) 'P (V_0 + P T) |0> ' 5538 CALL WRTVCD(WORK(KVEC1P),LUSC1,1,-1) 5539 END IF 5540CM CALL MEMCHK2('AFT_EX') 5541*. Obtain density <0!O+(i) P ( V_0 + P T ) |0> 5542 ICSPC = IREFSPC 5543 ISSPC = ITREFSPC 5544 ZERO = 0.0D0 5545 CALL SETVEC(WORK(KL_VIC1),ZERO,NCAAB) 5546 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUSC3, 5547 & WORK(KL_VIC1),2) 5548*. Transfer to SPA or EI basis 5549 IF(I_DO_EI.EQ.1) THEN 5550C TRANS_CAAB_ORTN(T_CAAB,T_ORTN,ITSYM,ICO,ILR,SCR,ICOCON) 5551 CALL TRANS_CAAB_ORTN(WORK(KL_VIC1),VECOUT_S,1,1,2, 5552 & WORK(KL_VIC2),1) 5553 ELSE 5554 CALL REF_CCV_CAAB_SP(WORK(KL_VIC1),VECOUT_S,WORK(KL_VIC2),1) 5555 END IF 5556*. and the unit terms 5557 IF(IUNIOP.NE.0) VECOUT_S(IUNIOP) = V_0 5558 END IF 5559CM CALL MEMCHK2('AFT_OVL') 5560* 5561* ================ 5562*. Hamilton terms 5563* ================ 5564* 5565*. (V_0 + P T ) |0> => H (V_0 + P T ) |0>, LUSC1 => LUHC 5566 IF(I_DO_H.EQ.1) THEN 5567 CALL REWINO(LUSC1) 5568 CALL REWINO(LUHC) 5569 ICSPC = ITREFSPC 5570 ISSPC = ITREFSPC 5571 CALL MV7(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUHC,0,0) 5572*. Obtain H!(V_0+PT)!0> in LUSC2, just in reference space 5573* (obtained by contracting from ITREFSPC to IREFSPC), LUHC => LUSC2 5574 CALL REWINO(LUHC) 5575 CALL REWINO(LUSC2) 5576 CALL EXPCIV(IREFSM,ITREFSPC,LUHC,IREFSPC,LUSC2,-1, 5577 / LUSC3,1,0,IDC,NTEST) 5578*. Obtain <0! H!(V_0+PT)!0> 5579 H_UNI = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUC,LUSC2,1,-1) 5580*. H (V_0 + P T) |0> => P H (V_0 + P T) |0>, LUHC = > LUHC via LUSC1 5581 CALL REWINO(LUHC) 5582 CALL REWINO(LUSC1) 5583 CALL EXTR_CIV(IREFSM,ITREFSPC,LUHC,IPROJSPC,2, 5584 & LUSC1,-1,LUSC3,1,1,IDC,NTEST) 5585*. <LUHC!T(I)!LUC> 5586 ICSPC = IREFSPC 5587 ISSPC = ITREFSPC 5588 ZERO = 0.0D0 5589 CALL SETVEC(WORK(KL_VIC1),ZERO,NCAAB) 5590 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUHC, 5591 & WORK(KL_VIC1),2) 5592*. Transfer to SPA or EI basis 5593 IF(I_DO_EI.EQ.1) THEN 5594C TRANS_CAAB_ORTN(T_CAAB,T_ORTN,ITSYM,ICO,ILR,SCR,ICOCON) 5595 CALL TRANS_CAAB_ORTN(WORK(KL_VIC1),VECOUT_H,1,1,2, 5596 & WORK(KL_VIC2),1) 5597 ELSE 5598 CALL REF_CCV_CAAB_SP(WORK(KL_VIC1),VECOUT_H,WORK(KL_VIC2),1) 5599 END IF 5600 VECOUT_H(IUNIOP) = H_UNI 5601 END IF 5602* 5603 IF(NTEST.GE.100) THEN 5604 WRITE(6,*) ' Direct ICCI, external part ' 5605 WRITE(6,*) ' Input vector ' 5606 CALL WRTMAT(VECIN,1,NSPA,1,NSPA) 5607 IF(I_DO_H.EQ.1) THEN 5608 WRITE(6,*) ' H(ICCI) times input vector ' 5609 CALL WRTMAT(VECOUT_H,1,NSPA,1,NSPA) 5610 END IF 5611 IF(I_DO_S.EQ.1) THEN 5612 WRITE(6,*) ' S(ICCI) times input vector ' 5613 CALL WRTMAT(VECOUT_S,1,NSPA,1,NSPA) 5614 END IF 5615 END IF 5616* 5617 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'HSE_TV') 5618 RETURN 5619 END 5620 SUBROUTINE GET_HS_DIA(HDIA,SDIA,IDO_H,IDO_S,IFORM, 5621 & VCC1,VCC2,VEC1,VEC2, 5622 & IREFSPC,ITREFSPC, 5623 & IUNIOP,NSPA,IDOSUB,ISUB,NSUB) 5624* 5625* Obtain some form of Diagonal of H and S 5626* 5627* IFORM = 1 : Obtain diagonal of Hamiltonian 5628* IFORM = 2 : Obtain diagonal of number-conserving part of H 5629* 5630* reference space on LUC 5631* 5632* If IDOPROJ = 1, then the reference space is projected out 5633* for all operators except the unitoperator 5634* 5635* IF IDOSUB.NE.0, the matrix is constructed in the space 5636* defined by the NSUB elements in ISUB 5637* NOTE : CODE HAS NOT BEEN TESTED FOR IDOSUB = 1 !!!! 5638* 5639* IDO_S = 1 => Diagonal of S is constructed 5640* IDO_H = 1 => Diagonal of H is constructed 5641* 5642* Jeppe Olsen, August 2004 5643* 5644* 5645 INCLUDE 'implicit.inc' 5646* 5647 INCLUDE 'cands.inc' 5648 INCLUDE 'cstate.inc' 5649*. Input 5650 INTEGER ISUB(*) 5651*. Output 5652 DIMENSION HDIA(*),SDIA(*) 5653*. Scratch 5654 DIMENSION VCC1(*),VCC2(*) 5655 DIMENSION VEC1(*),VEC2(*) 5656* 5657 IDUM = 0 5658 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'HS_DIA') 5659 IUNIOP = NSPA 5660* ^ Unit operator is assumed to be last operator 5661* as it is in configuration ordered approach 5662* 5663 NTEST = 205 5664 IF(NTEST.GE.10) THEN 5665 WRITE(6,*) ' GET_HS_DIA speaking ' 5666 WRITE(6,*) ' IDO_S, IDO_H, = ', IDO_S, IDO_H 5667 WRITE(6,*) ' IREFSPC, ITREFSPC = ', IREFSPC,ITREFSPC 5668 END IF 5669*. Number of excitations in calculation 5670 NVAR = NSPA 5671*. Dimension of space in which S or H is constructed 5672 IF(IDOSUB.EQ.0) THEN 5673 NSBVAR = NVAR 5674 ELSE 5675 NSBVAR = NSUB 5676 END IF 5677* 5678 IUNIOP_EFF = 0 5679 IF(IDOSUB.NE.0.AND.IUNIOP.NE.0) THEN 5680*. Check if unitoperator is included in list 5681 CALL FIND_INTEGER_IN_VEC(IUNIOP,ISUB,NSUB,IUNIOP_EFF) 5682 ELSE IF(IUNIOP.NE.0) THEN 5683 IUNIOP_EFF = IUNIOP 5684 END IF 5685C? WRITE(6,*) ' IUNIOP_EFF = ', IUNIOP_EFF 5686*. 5687 IF(IFORM.EQ.1) THEN 5688*. Calculate Diagonal of H and S by calculating complete matrix .. 5689 WRITE(6,*) ' Complete matrix approach to obtaining diagonals' 5690 DO I = 1, NSBVAR 5691 IF(NTEST.GE.5) WRITE(6,*) 'Constructing row of S,H for I = ',I 5692 ZERO = 0.0D0 5693 CALL SETVEC(VCC1,ZERO,NVAR) 5694 IF(IDOSUB.EQ.0) THEN 5695 VCC1(I) = 1.0D0 5696 ELSE 5697 VCC1(ISUB(I)) = 1.0D0 5698 END IF 5699* 5700*. Overlap terms 5701* 5702 IF(IDO_S.EQ.1) THEN 5703 CALL H_S_EXT_ICCI_TV(VCC1,XDUM,VCC2,0,1) 5704 IF(IDOSUB.EQ.0) THEN 5705 SDIA(I) = VCC2(I) 5706 ELSE 5707 SDIA(I) = VCC2(ISUB(I)) 5708 END IF 5709 END IF 5710* 5711*. Hamilton terms 5712* 5713 IF(IDO_H.EQ.1) THEN 5714 CALL H_S_EXT_ICCI_TV(VCC1,VCC2,XDUM,1,0) 5715 IF(IDOSUB.EQ.0) THEN 5716 HDIA(I) = VCC2(I) 5717 ELSE 5718 HDIA(I) = VCC2(ISUB(I)) 5719 END IF 5720 END IF 5721* 5722 END DO 5723 END IF 5724* ^ Switch between various IFORMS 5725* 5726 IF(NTEST.GE.100) THEN 5727 IF(IDO_S.EQ.1) THEN 5728 WRITE(6,*) ' Diagonal of S ' 5729 WRITE(6,*) ' ============== ' 5730 CALL WRTMAT(SDIA,1,NSBVAR,1,NSBVAR) 5731 END IF 5732 IF(IDO_H.EQ.1) THEN 5733 WRITE(6,*) ' Diagonal of H ' 5734 WRITE(6,*) ' ==============' 5735 CALL WRTMAT(HDIA,1,NSBVAR,1,NSBVAR) 5736 END IF 5737 END IF 5738* 5739 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'HS_DIA') 5740* 5741 RETURN 5742 END 5743 SUBROUTINE HOME_SD_INV_T_ICCI(VECIN,VECOUT,E0,LUL1,LUL2) 5744* 5745* Obtain Inverted diagonal operator times ICCI vector 5746* 5747* VECOUT(I) = sum_j <0!O+i (sum_I |I><I|(H0-E0)!I><I| ) Oj |0> VECIN(J) 5748* 5749* Note that this does not correspond to the solution of the equations 5750* 5751* sum(j) <0!O+i(H0-E0)O j|0> Vecout(j) = Vecin(i) 5752* 5753* For getting better preconditioners ( without too much human labor) 5754* 5755* 5756* Vecin and Vecout are in (partial ) spinadapted basis 5757* 5758* 5759* Jeppe Olsen, Sept. 2004 5760 INCLUDE 'wrkspc.inc' 5761C INCLUDE 'implicit.inc' 5762C INCLUDE 'mxpdim.inc' 5763 INCLUDE 'glbbas.inc' 5764 INCLUDE 'cands.inc' 5765 INCLUDE 'crun.inc' 5766 INCLUDE 'clunit.inc' 5767 REAL*8 5768 &INPRDD, INPROD 5769*. Input 5770 DIMENSION VECIN(*) 5771*. Output 5772 DIMENSION VECOUT(*) 5773*. Transfer block 5774 COMMON/COM_H_S_EFF_ICCI_TV/C_0,KLTOP,NREF,IREFSPC,ITREFSPC,NCAAB, 5775 & IUNIOP,NSPA,IPROJSPC 5776* 5777 IDUM = 0 5778 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'HOMESD') 5779*. 2 vectors that should hold IC expansion in CAAB format 5780 CALL MEMMAN(KLVIC1,NCAAB,'ADDL ',2,'VIC1 ') 5781 CALL MEMMAN(KLVIC2,NCAAB,'ADDL ',2,'VIC2 ') 5782* 5783* Obtain VECIN in CAAB basis 5784* 5785C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 5786 CALL REF_CCV_CAAB_SP(WORK(KLVIC1),VECIN,WORK(KLVIC2),2) 5787* 5788*. Obtain sum_j Vecin(j) O_j !0> in SD basis and save on LUL1 5789* 5790 ICSPC = IREFSPC 5791 ISSPC = ITREFSPC 5792 CALL REWINO(LUC) 5793 CALL REWINO(LUL1) 5794 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUL1, 5795 & WORK(KLVIC1),1) 5796*. Norm of assumed residual 5797 X1NORM = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUL1,LUL1,1,-1) 5798* 5799*. And then Multiply LU1 with (H0-E0)**-1, save result on LUL2 5800* 5801 FACTOR = -1.0D0*E0 5802 CALL REWINO(LUL1) 5803 CALL REWINO(LUL2) 5804 CALL DIA0TRM_GAS(2,LUL1,LUL2,WORK(KVEC1P),WORK(KVEC2P),FACTOR) 5805*. Norm of (H0-E0)**-1 * residual 5806 X2NORM = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUL2,LUL2,1,-1) 5807 WRITE(6,*) ' Norm of residual and (H0-E0)**-1 * resid ', 5808 & X1NORM, X2NORM 5809 5810C DIATRM(ITASK,LUIN,LUOUT,VECIN,VECOUT,FACTOR) 5811*. We are interested in <0!0+i (H0-E0)**-1(SD) O_j!0> Vecin(j) = 5812*. <LUL2!O_i!LUC> 5813 ICSPC = IREFSPC 5814 ISSPC = ITREFSPC 5815 CALL REWINO(LUC) 5816 CALL REWINO(LUL2) 5817 ZERO = 0.0D0 5818 CALL SETVEC(WORK(KLVIC1),ZERO,NCAAB) 5819 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUL2,WORK(KLVIC1),2) 5820 X4NORM = INPROD(WORK(KLVIC1),WORK(KLVIC1),NCAAB) 5821 WRITE(6,*) ' Norm (H0-E0)**-1 * resid in ICCI(CAAB) basis ', 5822 & X4NORM 5823*. And reformat to SP basis 5824 CALL REF_CCV_CAAB_SP(WORK(KLVIC1),VECOUT,WORK(KLVIC2),1) 5825*. Norm of (H0-E0)**-1 * residual 5826 X3NORM = INPROD(VECOUT,VECOUT,NSPA) 5827 WRITE(6,*) ' Norm (H0-E0)**-1 * resid in ICCI(SPA) basis ', 5828 & X3NORM 5829* 5830 NTEST = 00 5831 IF(NTEST.GE.100) THEN 5832 WRITE(6,*) ' Input and output vectors from HOME_SD_INV_T_ICCI' 5833 CALL WRTMAT(VECIN ,1,NSPA,1,NSPA) 5834 CALL WRTMAT(VECOUT,1,NSPA,1,NSPA) 5835 END IF 5836* 5837 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'HOMESD') 5838* 5839 RETURN 5840 END 5841 SUBROUTINE H0ME0TV_EXT_IC(VEC1,VEC2,LU1,LU2) 5842* 5843*. Obtain H0 - E0 * vector for external part in IC formalism 5844* 5845*. Jeppe Olsen, Sept. 2004 5846* 5847C INCLUDE 'implicit.inc' 5848C INCLUDE 'mxpdim.inc' 5849 INCLUDE 'wrkspc.inc' 5850*. Scratch 5851 DIMENSION VEC1(*),VEC2(*) 5852* Info from transfer arrays 5853 COMMON/COM_H_S_EFF_ICCI_TV/ 5854 & C_0,KLTOP,NREF,IREFSPC,ITREFSPC,NCAAB, 5855 & IUNIOP,NSPA,IPROJSPC 5856 include 'cshift.inc' 5857 5858*. 1 : Read input vector in from disc : Remember that 5859* unit operator is excluded, so NVAR = NSPA - 1 5860*. Obtain H0 and S times vectors 5861 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'H0ME0 ') 5862 CALL MEMMAN(KLVEC3,NSPA,'ADDL ',2,'VEC3IC') 5863* 5864 CALL VEC_FROM_DISC(VEC1,NSPA-1,1,-1,LU1) 5865 VEC1(NSPA) = 0.0D0 5866* 5867 CALL H_S_EXT_ICCI_TV(VEC1,VEC2,WORK(KLVEC3),1,1) 5868C H_S_EXT_ICCI_TV(VECIN,VECOUT_H,VECOUT_S, 5869C & I_DO_H,I_DO_S) 5870* H0 * v, S *v => (H0-E0S)*V 5871 ONE = 1.0D0 5872 CALL VECSUM(VEC2,VEC2,WORK(KLVEC3),ONE,SHIFT,NSPA-1) 5873 CALL VEC_TO_DISC(VEC2,NSPA-1,1,-1,LU2) 5874* 5875 NTEST = 000 5876 IF(NTEST.GE.100) THEN 5877 WRITE(6,*) ' Input and output vectors from H0ME0_EXT_IC ' 5878 CALL WRTMAT(VEC1,1,NSPA-1,1,NSPA-1) 5879 CALL WRTMAT(VEC2,1,NSPA-1,1,NSPA-1) 5880 END IF 5881* 5882 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'H0ME0 ') 5883* 5884 RETURN 5885 END 5886 SUBROUTINE GET_SING_IN_SX_SPACE(IREFSPC) 5887* 5888* Analyze singularities in space of single-excitations 5889* 5890* Jeppe Olsen, Comfort Inn in Oak Ridge, Sept. 17 2004, 5 am (to be precise) 5891*.Continued Dec 2004 at Korsh�jen before Warwick meeting( 30 hours to take-off) 5892* 5893* 5894*. It is assumed that spin-densities have been calculated 5895* for reference state - although spin-densities may 5896* be recalculated here ... 5897* 5898 INCLUDE 'wrkspc.inc' 5899C INCLUDE 'implicit.inc' 5900C INCLUDE 'mxpdim.inc' 5901 INCLUDE 'glbbas.inc' 5902 INCLUDE 'orbinp.inc' 5903 INCLUDE 'clunit.inc' 5904 INCLUDE 'cstate.inc' 5905 INCLUDE 'crun.inc' 5906 INCLUDE 'csm.inc' 5907*. Local list of single excitations, atmost 100 orbitals 5908 INTEGER ISX(2,100*100) 5909* 5910 NTEST = 10 5911* 5912 IDUM = 0 5913 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GET_SI') 5914* 5915 I_CALC_DENS = 1 5916 IF(I_CALC_DENS.EQ.1) THEN 5917* 5918*. Space for CI behind the curtain 5919 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 5920 KVEC1P = KVEC1 5921 KVEC2P = KVEC2 5922*. Recalculate density matrices 5923*. Should the densities be calculated with original CI-vector 5924*. or projected density matrix ? 5925 I_DO_PROJ = 1 5926 IF(I_DO_PROJ.EQ.1) THEN 5927*. Project part of CI-vector belonging to IREFSPC - 1 5928 IPROJSPC = IREFSPC - 1 5929 WRITE(6,*) 5930 & ' Space to be projected out from reference ',IPROJSPC 5931 IF(IPROJSPC.EQ.0) THEN 5932 WRITE(6,*) ' No projection will be done ' 5933 WRITE(6,*) ' As suggested projection space is undefined' 5934 LUPROJ = LUC 5935 ELSE 5936*. Project IPROJSPC out, save on LUHC 5937*. P T(I) !Ref> back on LUSCR 5938C EXTR_CIV(ISM,ISPCIN,LUIN, 5939C & ISPCX,IEX_OR_DE,LUUT,LBLK, 5940C & LUSCR,NROOT,ICOPY,IDC,NTESTG) 5941 CALL EXTR_CIV(IREFSM,IREFSPC,LUC,IPROJSPC,2, 5942 & LUHC,-1,LUSC2,1,0,IDC,NTEST) 5943 LUPROJ = LUHC 5944 END IF 5945 ELSE 5946 LUPROJ = LUC 5947 END IF 5948*. And do the densities 5949 ISPNDEN = 2 5950 CALL COPVCD(LUPROJ,LUSC2,WORK(KVEC1),1,-1) 5951 CALL DENSI2(IDENSI,WORK(KRHO1),WORK(KRHO2), 5952 & WORK(KVEC1),WORK(KVEC2),LUPROJ,LUSC2,EXPS2,ISPNDEN, 5953 & WORK(KSRHO1),WORK(KRHO2AA),WORK(KRHO2AB),WORK(KRHO2BB),1) 5954 END IF 5955*. ^ End if densities should be recalculated .. 5956* 5957* ========================================================== 5958* Very simple first try, just diagonalize using no symmetry 5959* ========================================================== 5960* 5961*. Allocate space for two scratch matrices - each of length 2*NTOOB**2 5962* 5963 LEN = NTOOB**2 5964 LEN2 = NTOOB**4 5965 CALL MEMMAN(KLVEC1,2*LEN ,'ADDL ',2,'LVEC1 ') 5966 CALL MEMMAN(KLVEC2,2*LEN ,'ADDL ',2,'LVEC2 ') 5967 CALL MEMMAN(KLMAT1,4*LEN2,'ADDL ',2,'LMAT1 ') 5968 CALL MEMMAN(KLMAT2,4*LEN2,'ADDL ',2,'LMAT2 ') 5969 CALL MEMMAN(KLMAT3,4*LEN2,'ADDL ',2,'LMAT3 ') 5970 CALL MEMMAN(KLISX, LEN ,'ADDL ',1,'ISX ') 5971* 5972 I_DIAG_AAOP = 1 5973 IF(I_DIAG_AAOP.EQ.1) THEN 5974*. Diagonalize space of double annihilations 5975 5976* 5977* 1 : Double annihilation operators 5978* 5979 5980* 5981*. Diagonalize RHO2AB 5982* 5983*. The form of RHO2AB is <0!a+ia a+kb alb aja!0> written as 5984*. rho2(ik,lj) ik=(k-1)*NORB+i, lj=(j-1)*NORB+l. 5985*. with the addressing of ik and jl this is not 5986*. an overlap matrix !! (It took me some hours to figure this out) 5987*. 5988*. If we define operator lj ( with above def of lj) to be 5989* alb aja!0>, then the conjugated operator (lj)+ is 5990* <0!a+ja a+lb - which in rho2ab is given address jl. 5991*. so reorganize row indeces 5992* 5993 DO L = 1, NTOOB 5994 DO J = 1, NTOOB 5995 LJ_IN = (J-1)*NTOOB + L 5996 LJ_OUT = (L-1)*NTOOB + J 5997*. looping in the wrong direction, but this is not timedefining 5998 DO ICOL = 1, NTOOB**2 5999 WORK(KLMAT1-1+(ICOL-1)*LEN+LJ_OUT) = 6000 & WORK(KRHO2AB-1+(ICOL-1)*LEN+LJ_IN) 6001 END DO 6002 END DO 6003 END DO 6004C CALL COPVEC(WORK(KRHO2AB),WORK(KLMAT1),LEN2) 6005 WRITE(6,*) ' Info for diagonalization of RHO2AB ' 6006 CALL CHK_S_FOR_SING(WORK(KLMAT1),LEN,NSING,WORK(KLMAT2), 6007 & WORK(KLVEC1),WORK(KLVEC2) ) 6008 IF(NTEST.GE.100) THEN 6009 WRITE(6,*) ' The eigenvectors for zero-eigenvalues ' 6010 CALL WRTMAT(WORK(KLMAT1),LEN,NSING,LEN,NSING) 6011 END IF 6012C CHK_S_FOR_SING(S,NDIM,NSING,X,SCR,SCR2) 6013* 6014*. Diagonalize RHO2AA 6015* 6016 LENS = NTOOB*(NTOOB+1)/2 6017 LENS2 = LENS**2 6018 CALL COPVEC(WORK(KRHO2AA),WORK(KLMAT1),LENS2) 6019*. Actually RHO2SS are organized so they are minus the overlap so 6020 ONEM = -1.0D0 6021 CALL SCALVE(WORK(KLMAT1),ONEM,LENS2) 6022 WRITE(6,*) ' Info for diagonalization of RHO2AA ' 6023 CALL CHK_S_FOR_SING(WORK(KLMAT1),LENS,NSING,WORK(KLMAT2), 6024 & WORK(KLVEC1),WORK(KLVEC2) ) 6025 IF(NTEST.GE.100) THEN 6026 WRITE(6,*) ' The eigenvectors for zero-eigenvalues ' 6027 CALL WRTMAT(WORK(KLMAT1),LENS,NSING,LENS,NSING) 6028 END IF 6029* 6030*. Diagonalize RHO2BB 6031* 6032 LENS = NTOOB*(NTOOB+1)/2 6033 LENS2 = LENS**2 6034 CALL COPVEC(WORK(KRHO2BB),WORK(KLMAT1),LENS2) 6035*. Actually RHO2SS are organized so they are minus the overlap so 6036 ONEM = -1.0D0 6037 CALL SCALVE(WORK(KLMAT1),ONEM,LENS2) 6038 WRITE(6,*) ' Info for diagonalization of RHO2BB ' 6039 CALL CHK_S_FOR_SING(WORK(KLMAT1),LENS,NSING,WORK(KLMAT2), 6040 & WORK(KLVEC1),WORK(KLVEC2) ) 6041 IF(NTEST.GE.100) THEN 6042 WRITE(6,*) ' The eigenvectors for zero-eigenvalues ' 6043 CALL WRTMAT(WORK(KLMAT1),LENS,NSING,LENS,NSING) 6044 END IF 6045* 6046 END IF 6047*. ^ End if double annihilations should be diagonalized 6048* 6049 I_DIAG_FULLSX = 0 6050* 6051* 2 : And the single excitation operators 6052* 6053* a : MS = 1 operators : a+ia ajb 6054* 6055*. The overlap is S_ij,kl 6056* = <0!(a+ia ajb)^+ (a+ka alb)!0> 6057* = - <0!a+ka a+jb alb aia!0> + delta(i,k)<0!a+jb alb!0> 6058* = -RHO2AB(kj,li) + delta(i,k)(RHO1(jl)-RHO1S(jl))/2 6059* 6060 DO I = 1, NTOOB 6061 DO J = 1, NTOOB 6062 DO K = 1, NTOOB 6063 DO L = 1, NTOOB 6064 KJ = (J-1)*NTOOB + K 6065 LI = (I-1)*NTOOB + L 6066 JL = (L-1)*NTOOB + J 6067 KJLI = (KJ-1)*NTOOB**2 + LI 6068 IJKL = (L-1)*NTOOB**3 + (K-1)*NTOOB**2 + (J-1)*NTOOB + I 6069 WORK(KLMAT1-1+IJKL) = -WORK(KRHO2AB-1+KJLI) 6070 IF(I.EQ.K) WORK(KLMAT1-1+IJKL) = WORK(KLMAT1-1+IJKL) 6071 & +(WORK(KRHO1-1+JL)-WORK(KSRHO1-1+JL))/2 6072 END DO 6073 END DO 6074 END DO 6075 END DO 6076 CALL COPVEC(WORK(KLMAT1),WORK(KLMAT3),LEN*LEN) 6077 IF(NTEST.GE.1000) THEN 6078 WRITE(6,*) ' The MS=1 SX metric ' 6079 CALL WRTMAT(WORK(KLMAT1),LEN,LEN,LEN,LEN) 6080 END IF 6081 IF(I_DIAG_FULLSX.EQ.1) THEN 6082 WRITE(6,*) ' Info for diagonalization of metric of MS=1 SX ' 6083 CALL CHK_S_FOR_SING(WORK(KLMAT1),LEN,NSING,WORK(KLMAT2), 6084 & WORK(KLVEC1),WORK(KLVEC2) ) 6085 IF(NTEST.GE.100) THEN 6086 WRITE(6,*) 6087 & 'The eigenvectors of zero-eigenvalues as NORB X NORB matrices' 6088 DO I = 1, NSING 6089 ILOFF = KLMAT1 + (I-1)*LEN 6090 CALL WRTMAT(WORK(ILOFF),NTOOB,NTOOB,NTOOB,NTOOB) 6091 END DO 6092 END IF 6093 END IF 6094* ^ End if full space of SX should be diagonalized 6095*. Divide orbital excitations according to symmetry and 6096*. diagonalize subblocks 6097 DO ISYM = 1, NSMST 6098C DO IRANK = -1,1 6099 DO IRANK = 0,0 6100*. Obtain single excitations of this symmetry and rank 6101C GET_SX_FOR_SYM_AND_EXCRANK(ISYM_SX,IRANK2_SX,NSX,ISX) 6102 IRANK2 = 2*IRANK 6103 CALL GET_SX_FOR_SYM_AND_EXCRANK(ISYM,IRANK2,NSX,ISX) 6104*. Obtain matrix of excitations of this symmetry and rank 6105 DO IEX = 1, NSX 6106 DO JEX = 1, NSX 6107 IC = ISX(1,IEX) 6108 IA = ISX(2,IEX) 6109 JC = ISX(1,JEX) 6110 JA = ISX(2,JEX) 6111 IADR_IN = (JA-1)*NTOOB**3 + (JC-1)*NTOOB**2 6112 / + (IA-1)*NTOOB + IC 6113 IADR_OUT = (JEX-1)*NSX + IEX 6114 WORK(KLMAT1-1+IADR_OUT) = WORK(KLMAT3-1+IADR_IN) 6115 END DO 6116 END DO 6117 IF(NTEST.GE.100) THEN 6118 WRITE(6,*) ' Metric for MS, SYM, RANK = ', 1,ISYM,IRANK2 6119 CALL WRTMAT(WORK(KLMAT1),NSX,NSX,NSX,NSX) 6120 END IF 6121 WRITE(6,*) 6122 & ' Info for diagonalization of metric of SX for MS,SYM,RANK ', 6123 & 1,ISYM,IRANK2 6124 CALL CHK_S_FOR_SING(WORK(KLMAT1),NSX,NSING,WORK(KLMAT2), 6125 & WORK(KLVEC1),WORK(KLVEC2) ) 6126 IF(NTEST.GE.10) THEN 6127 WRITE(6,*) 6128 & ' The eigenvectors for zero-eigenvalues' 6129 CALL WRTMAT(WORK(KLMAT1),NSX,NSING,NSX,NSING) 6130 END IF 6131 END DO 6132 END DO 6133 6134* 6135* b : MS = -1 operators : a+ib aja 6136* 6137*. The overlap is S_ij,kl 6138* = <0!(a+ib aja)^+ (a+kb ala)!0> 6139* = - <0!a+ja a+kb aib ala!0> + delta(i,k)<0!a+ja ala!0> 6140* = -RHO2AB(jk,il) + delta(i,k)(RHO1(jl)+RHO1S(jl))/2 6141* 6142 DO I = 1, NTOOB 6143 DO J = 1, NTOOB 6144 DO K = 1, NTOOB 6145 DO L = 1, NTOOB 6146 JK = (K-1)*NTOOB + J 6147 IL = (L-1)*NTOOB + I 6148 JL = (L-1)*NTOOB + J 6149 JKIL = (JK-1)*NTOOB**2 + IL 6150 IJKL = (L-1)*NTOOB**3 + (K-1)*NTOOB**2 + (J-1)*NTOOB + I 6151 WORK(KLMAT1-1+IJKL) = -WORK(KRHO2AB-1+JKIL) 6152 IF(I.EQ.K) WORK(KLMAT1-1+IJKL) = WORK(KLMAT1-1+IJKL) 6153 & +(WORK(KRHO1-1+JL)+WORK(KSRHO1-1+JL))/2 6154 END DO 6155 END DO 6156 END DO 6157 END DO 6158 CALL COPVEC(WORK(KLMAT1),WORK(KLMAT3),LEN*LEN) 6159 IF(I_DIAG_FULLSX.EQ.1) THEN 6160 WRITE(6,*) ' Info for diagonalization of metric of MS=-1 SX ' 6161 CALL CHK_S_FOR_SING(WORK(KLMAT1),LEN,NSING,WORK(KLMAT2), 6162 & WORK(KLVEC1),WORK(KLVEC2) ) 6163 IF(NTEST.GE.10) THEN 6164 WRITE(6,*) 6165 & ' Eigenvectors for zero-eigenvalues as NORB X NORB matrices' 6166 DO I = 1, NSING 6167 ILOFF = KLMAT1 + (I-1)*LEN 6168 CALL WRTMAT(WORK(ILOFF),NTOOB,NTOOB,NTOOB,NTOOB) 6169 END DO 6170 END IF 6171 END IF 6172*. Divide orbital excitations according to symmetry and 6173*. diagonalize subblocks 6174 DO ISYM = 1, NSMST 6175C DO IRANK = -1,1 6176 DO IRANK = 0,0 6177*. Obtain single excitations of this symmetry and rank 6178C GET_SX_FOR_SYM_AND_EXCRANK(ISYM_SX,IRANK2_SX,NSX,ISX) 6179 IRANK2 = 2*IRANK 6180 CALL GET_SX_FOR_SYM_AND_EXCRANK(ISYM,IRANK2,NSX,ISX) 6181*. Obtain matrix of excitations of this symmetry and rank 6182 DO IEX = 1, NSX 6183 DO JEX = 1, NSX 6184 IC = ISX(1,IEX) 6185 IA = ISX(2,IEX) 6186 JC = ISX(1,JEX) 6187 JA = ISX(2,JEX) 6188 IADR_IN = (JA-1)*NTOOB**3 + (JC-1)*NTOOB**2 6189 / + (IA-1)*NTOOB + IC 6190 IADR_OUT = (JEX-1)*NSX + IEX 6191 WORK(KLMAT1-1+IADR_OUT) = WORK(KLMAT3-1+IADR_IN) 6192 END DO 6193 END DO 6194 IF(NTEST.GE.100) THEN 6195 WRITE(6,*) ' Metric for MS, SYM, RANK = ', -1,ISYM,IRANK2 6196 CALL WRTMAT(WORK(KLMAT1),NSX,NSX,NSX,NSX) 6197 END IF 6198 WRITE(6,*) 6199 & ' Info for diagonalization of metric of SX for MS,SYM,RANK ', 6200 & -1,ISYM,IRANK2 6201 CALL CHK_S_FOR_SING(WORK(KLMAT1),NSX,NSING,WORK(KLMAT2), 6202 & WORK(KLVEC1),WORK(KLVEC2) ) 6203 IF(NTEST.GE.10) THEN 6204 WRITE(6,*) 6205 & ' The eigenvectors for zero-eigenvalues' 6206 CALL WRTMAT(WORK(KLMAT1),NSX,NSING,NSX,NSING) 6207 END IF 6208 END DO 6209 END DO 6210* 6211* MS = 0 6212* 6213* There are two types of operators : a+ia aja and a+ib ajb 6214* 6215* This leads to a 2*NTOOB matrix 6216* S_ij,kl = 6217* (<0!(a+ia aja)^+ a+ka ala |0> | <0!(a+ia aja)^+ a+kb alb !0> ) 6218* ( ----------------------------| -----------------------------) 6219* (<0!(a+ib ajb)^+ a+ka ala |0> | <0!(a+ib ajb)^ a+kb alb !0> ) 6220* 6221* The aaaa part 6222* 6223* <0!(a+ia aja)^+ a+ka ala |0> 6224*=-<0!a+ja a+ka aia ala!0> + delta(i,k) <0!a+ja ala!0> 6225* 6226 LEND = 2*NTOOB**2 6227 VALUE = -1234 6228 CALL SETVEC(WORK(KLMAT1),VALUE,LEND**2) 6229 DO I = 1, NTOOB 6230 DO J = 1, NTOOB 6231 DO K = 1, NTOOB 6232 DO L = 1, NTOOB 6233 IF(J.GT.K) THEN 6234 JK = J*(J-1)/2+K 6235 SIGN_JK =-1.0D0 6236 ELSE 6237 JK = K*(K-1)/2 + J 6238 SIGN_JK = 1.0D0 6239 END IF 6240 IF(I.GT.L) THEN 6241 IL = I*(I-1)/2 + L 6242 SIGN_IL = -1.0D0 6243 ELSE 6244 IL = L*(L-1)/2 + I 6245 SIGN_IL =1.0D0 6246 END IF 6247 JKIL = (IL-1)*NTOOB*(NTOOB+1)/2 + JK 6248 IJKL = ((L-1)*NTOOB+K-1)*2*NTOOB**2 + (J-1)*NTOOB + I 6249 JL = (L-1)*NTOOB + J 6250 WORK(KLMAT1-1+IJKL) =-SIGN_JK*SIGN_IL*WORK(KRHO2AA-1+JKIL) 6251 IF(I.EQ.K) WORK(KLMAT1-1+IJKL) = WORK(KLMAT1-1+IJKL) 6252 & +(WORK(KRHO1-1+JL)+WORK(KSRHO1-1+JL))/2 6253 END DO 6254 END DO 6255 END DO 6256 END DO 6257* 6258* the bbbb part 6259* 6260* <0!(a+ib ajb)^+ a+kb alb |0> 6261*=-<0!a+jb a+kb aib alb!0> + delta(i,k) <0!a+jb alb!0> 6262* 6263 DO I = 1, NTOOB 6264 DO J = 1, NTOOB 6265 DO K = 1, NTOOB 6266 DO L = 1, NTOOB 6267 IF(J.GT.K) THEN 6268 JK = J*(J-1)/2+K 6269 SIGN_JK = 1.0D0 6270 ELSE 6271 JK = K*(K-1)/2 + J 6272 SIGN_JK = -1.0D0 6273 END IF 6274 IF(I.GT.L) THEN 6275 IL = I*(I-1)/2 + L 6276 SIGN_IL = 1.0D0 6277 ELSE 6278 IL = L*(L-1)/2 + I 6279 SIGN_IL =-1.0D0 6280 END IF 6281 JKIL = (IL-1)*NTOOB*(NTOOB+1)/2 + JK 6282 IJKL = ((L-1)*NTOOB+K-1+NTOOB**2 )*2*NTOOB**2 6283 & + (J-1)*NTOOB + I + NTOOB**2 6284 JL = (L-1)*NTOOB + J 6285 WORK(KLMAT1-1+IJKL) =-SIGN_JK*SIGN_IL*WORK(KRHO2BB-1+JKIL) 6286 IF(I.EQ.K) WORK(KLMAT1-1+IJKL) = WORK(KLMAT1-1+IJKL) 6287 & +(WORK(KRHO1-1+JL)-WORK(KSRHO1-1+JL))/2 6288 END DO 6289 END DO 6290 END DO 6291 END DO 6292* 6293* the aabb and bbaa part 6294* 6295* S_ijkl(aabb) = <0!a+ja a+kb alb aia!0> 6296* S_ijkl(bbaa) = S_klij(aabb) 6297* 6298 DO I = 1, NTOOB 6299 DO J = 1, NTOOB 6300 DO K = 1, NTOOB 6301 DO L = 1, NTOOB 6302 JKLI = (I-1)*NTOOB**3 + (L-1)*NTOOB**2 + (K-1)*NTOOB + J 6303 IJKL = ((L-1)*NTOOB+K-1+NTOOB**2)*2*NTOOB**2 6304 & + (J-1)*NTOOB + I 6305 WORK(KLMAT1-1+IJKL) = WORK(KRHO2AB-1+JKLI) 6306 KLIJ = ((J-1)*NTOOB + I-1)*2*NTOOB**2 6307 / + (L-1)*NTOOB + K + NTOOB**2 6308 WORK(KLMAT1-1+KLIJ) = WORK(KLMAT1-1+IJKL) 6309 END DO 6310 END DO 6311 END DO 6312 END DO 6313* 6314 LEND = 2*NTOOB**2 6315* 6316 IF(NTEST.GE.1000) THEN 6317 WRITE(6,*) ' The metric for MS = 0 ' 6318 CALL WRTMAT(WORK(KLMAT1),LEND,LEND,LEND,LEND) 6319 END IF 6320* 6321 CALL COPVEC(WORK(KLMAT1),WORK(KLMAT3),LEND*LEND) 6322 IF(I_DIAG_FULLSX.EQ.1) THEN 6323 WRITE(6,*) ' Info for diagonalization of metric of MS = 0 SX ' 6324 CALL CHK_S_FOR_SING(WORK(KLMAT1),LEND,NSING,WORK(KLMAT2), 6325 & WORK(KLVEC1),WORK(KLVEC2) ) 6326 IF(NTEST.GE.10) THEN 6327 WRITE(6,*) 6328 & ' Eigenvectors for zero-eigenvalues as 2 NORB X NORB matrices' 6329 DO I = 1, NSING 6330 ILOFF = KLMAT1 + (I-1)*LEND 6331 CALL WRTMAT(WORK(ILOFF),NTOOB,NTOOB,NTOOB,NTOOB) 6332 ILOFF = KLMAT1 + (I-1)*LEND + LEN 6333 CALL WRTMAT(WORK(ILOFF),NTOOB,NTOOB,NTOOB,NTOOB) 6334 END DO 6335 END IF 6336 END IF 6337* ^ End if diag should be performed in full space 6338*. Divide orbital excitations according to symmetry and 6339*. diagonalize subblocks 6340 DO ISYM = 1, NSMST 6341C DO IRANK = -1,1 6342 DO IRANK = 0,0 6343*. Obtain single excitations of this symmetry and rank 6344C GET_SX_FOR_SYM_AND_EXCRANK(ISYM_SX,IRANK2_SX,NSX,ISX) 6345 IRANK2 = 2*IRANK 6346 CALL GET_SX_FOR_SYM_AND_EXCRANK(ISYM,IRANK2,NSX,ISX) 6347*. Obtain matrix of excitations of this symmetry and rank 6348 DO IEX = 1, NSX 6349 DO JEX = 1, NSX 6350 IC = ISX(1,IEX) 6351 IA = ISX(2,IEX) 6352 JC = ISX(1,JEX) 6353 JA = ISX(2,JEX) 6354*.aaaa 6355 IADR_IN = ((JA-1)*NTOOB+JC-1)*2*NTOOB**2 6356 / + (IA-1)*NTOOB+IC 6357 IADR_OUT = (JEX-1)*2*NSX + IEX 6358 WORK(KLMAT1-1+IADR_OUT) = WORK(KLMAT3-1+IADR_IN) 6359*.aabb 6360 IADR_IN = ((JA-1)*NTOOB+JC+NTOOB**2-1)*2*NTOOB**2 6361 / + (IA-1)*NTOOB+IC 6362 IADR_OUT = (JEX+NSX-1)*2*NSX + IEX 6363 WORK(KLMAT1-1+IADR_OUT) = WORK(KLMAT3-1+IADR_IN) 6364*.bbaa 6365 IADR_IN = ((JA-1)*NTOOB+JC-1)*2*NTOOB**2 6366 / + (IA-1)*NTOOB+IC + NTOOB**2 6367 IADR_OUT = (JEX-1)*2*NSX + IEX+NSX 6368 WORK(KLMAT1-1+IADR_OUT) = WORK(KLMAT3-1+IADR_IN) 6369*.bbbb 6370 IADR_IN = ((JA-1)*NTOOB+JC+NTOOB**2-1)*2*NTOOB**2 6371 / + (IA-1)*NTOOB+IC + NTOOB**2 6372 IADR_OUT = (JEX+NSX-1)*2*NSX + IEX+NSX 6373 WORK(KLMAT1-1+IADR_OUT) = WORK(KLMAT3-1+IADR_IN) 6374 END DO 6375 END DO 6376 IF(NTEST.GE.100) THEN 6377 WRITE(6,*) ' Metric for MS, SYM, RANK = ', 0,ISYM,IRANK2 6378 CALL WRTMAT(WORK(KLMAT1),2*NSX,2*NSX,2*NSX,2*NSX) 6379 END IF 6380 WRITE(6,*) 6381 & ' Info for diagonalization of metric of SX for MS,SYM,RANK ', 6382 & 0,ISYM,IRANK2 6383 CALL CHK_S_FOR_SING(WORK(KLMAT1),2*NSX,NSING,WORK(KLMAT2), 6384 & WORK(KLVEC1),WORK(KLVEC2) ) 6385 IF(NTEST.GE.10) THEN 6386 WRITE(6,*) 6387 & ' The eigenvectors for zero-eigenvalues' 6388 CALL WRTMAT(WORK(KLMAT1),2*NSX,NSING,2*NSX,NSING) 6389 END IF 6390 END DO 6391 END DO 6392* 6393 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GET_SI') 6394* 6395 STOP ' Enforced stop in GET_SING_IN_SX_LIKE' 6396 RETURN 6397 END 6398 SUBROUTINE MINGENEIG(MSTV,PRECTV,IPREC_FORM,THRES_E,THRES_R, 6399 & I_ER_CONV, 6400 & VEC1,VEC2,VEC3,LU1,LU2,RNRM,EIG,FINEIG,MAXIT, 6401 & NVAR, 6402 & LU3,LU4,LU5,LUDIAM,LUDIAS,LUS,NROOT,MAXVEC, 6403 & NINVEC, 6404 & APROJ,AVEC,SPROJ,WORK,IPRT,EIGSHF,AVECP, 6405 & I_DO_PRECOND,CONVER,EFINAL,VFINAL) 6406* 6407* Iterative routine for generalized eigenvalue problem 6408* 6409* M X = Lambda S X 6410* 6411* Version requiring 3 vectors in core 6412* 6413* Jeppe Olsen Oct 2002 from MINDA4 6414* Finished June 2004 at Korshoejen 53 6415* 6416* Input : 6417* ======= 6418* MSTV : Name of routine performing matrix*vector calculations 6419* PRECTV : Name of precondtioner used if IPREC_FORM = 1 6420* IPREC_FORM = 1 : use simple diagonal preconditioner 6421* = 2 : Use external routine PRECTV to perform precond. 6422* THRES_E: Convergence threshold for eigenvalue 6423* THRES_R: Convergence threshold for residual norm 6424* I_ER_CONV= 1 => Change in eigenvalue is used as conv. criterium 6425* = 2 => Norm or residual is used as conv. criterium 6426* LU1 : Initial set of vectors 6427* VEC1,VEC2,VEC3 : Vectors,each must be dimensioned to hold 6428* complete vector 6429* LU2,LU3 : Scatch files 6430* LUDIAM : File containing diagonal of matrix M 6431* LUDIAS : File containing diagonal of matrix S 6432* NROOT : Number of eigenvectors to be obtained 6433* MAXVEC : Largest allowed number of vectors 6434* must atleast be 2 * NROOT 6435* NINVEC : Number of initial vectors ( atleast NROOT ) 6436* On input LU1 is supposed to hold initial guess to eigenvectors 6437* 6438 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6439 DIMENSION VEC1(*),VEC2(*), VEC3(*) 6440 REAL * 8 INPROD 6441 DIMENSION RNRM(MAXIT,NROOT),EIG(MAXIT,NROOT) 6442 DIMENSION APROJ(*),AVEC(*),SPROJ(*),WORK(*),AVECP(*) 6443*. Scratch files that may be used by matrix times vector 6444 COMMON/SCRFILES_MATVEC/LUSCR1,LUSCR2,LUSCR3, 6445 & LUCBIO_SAVE, LUHCBIO_SAVE, LUC_SAVE 6446* 6447* Dimensioning required of local vectors 6448* APROJ : MAXVEC*MAXVEC 6449* SPROJ : MAXVEC*MAXVEC 6450* AVEC : MAXVEC*MAXVEC 6451* WORK : MAXVEC*MAXVEC 6452* AVECP : MAXVEC*MAXVEC 6453* 6454 DIMENSION FINEIG(1) 6455 LOGICAL CONVER,RTCNV(10) 6456* MSTV : Routine for matrix and metric times vector 6457* PRECTV : Routine for preconditioner times vector 6458 EXTERNAL MSTV, PRECTV 6459* 6460C? WRITE(6,*) ' MINGENEIG: I_ER_CONV, THRES_E, THRES_R = ', 6461C? & I_ER_CONV, THRES_E, THRES_R 6462 ONE = 1.0D0 6463 ZERO = 0.0D0 6464*. And the scratch files 6465 LUSCR1 = LU3 6466 LUSCR2 = LU4 6467 LUSCR3 = LU5 6468 LUCBIO_SAVE = 0 6469 LUHCBIO_SAVE = 0 6470 LUC_SAVE = 0 6471* 6472*. Current code always reset to 2*NROOT so : 6473 IF( MAXVEC .LT. 3 * NROOT ) THEN 6474 WRITE(6,*) ' SORRY MINGENEIG WOUNDED , MAXVEC .LT. 3*NROOT ' 6475 STOP ' ENFORCED STOP IN MINGENEIG' 6476 END IF 6477* 6478 KFREE = 1 6479* 6480 KSSUB = 1 6481 KFREE = KFREE + MAXVEC*MAXVEC 6482* 6483 KMSUB = KFREE 6484 KFREE = KFREE + MAXVEC*MAXVEC 6485* 6486 KXORTN = KFREE 6487 KFREE = KFREE + MAXVEC*MAXVEC 6488* 6489 KSCRMAT = KFREE 6490 KFREE = KFREE + MAXVEC*MAXVEC 6491* 6492 KSCRMAT2 = KFREE 6493 KFREE = KFREE + MAXVEC*MAXVEC 6494* 6495 KVEC1 = KFREE 6496 KFREE = KFREE+ MAXVEC 6497* 6498 KVEC2 = KFREE 6499 KFREE = KFREE+ MAXVEC 6500 CONVER = .FALSE. 6501* 6502*. INITAL ITERATION 6503* 6504 ITER = 1 6505* 6506 IPRT = 10000 6507 WRITE(6,*) 6508 & ' MINGENEIG: IPRT, NVAR,MAXVEC = ' , IPRT, NVAR, MAXVEC 6509 WRITE(6,'(A,I2,2(2X,E8.3))') 6510 & ' MINGENEIG: I_ER_CONV, THRES_E, THRES_R', 6511 & I_ER_CONV, THRES_E, THRES_R 6512 IF(IPRT.GE.200) THEN 6513 WRITE(6,*) ' Initial vectors in LU1 ' 6514 CALL REWINO(LU1) 6515 DO IVEC = 1, NINVEC 6516 CALL WRTVCD(VEC1,LU1,1,-1) 6517 END DO 6518 END IF 6519 CALL GFLUSH(6) 6520* 6521 CALL REWINO(LU1) 6522 CALL REWINO(LU2) 6523 CALL REWINO(LUS) 6524 WRITE(6,*) ' NVAR at start of MINGENEIG = ', NVAR 6525 DO IVEC = 1,NINVEC 6526*. M and S times initial vector IVEC 6527 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LU1) 6528 WRITE(6,*) ' Before MSTV ' 6529 CALL MSTV(VEC1,VEC2,VEC3,1,1) 6530 WRITE(6,*) ' After MSTV ' 6531 WRITE(6,*) ' NVAR, LU2, LUS = ', NVAR, LU2,LUS 6532* 6533 CALL VEC_TO_DISC(VEC2,NVAR,0,-1,LU2) 6534 CALL VEC_TO_DISC(VEC3,NVAR,0,-1,LUS) 6535* Update projected matrix 6536 CALL REWINO(LU1) 6537 DO JVEC = 1, IVEC 6538 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LU1) 6539 IJ = IVEC*(IVEC-1)/2 + JVEC 6540 APROJ(IJ) = INPROD(VEC1,VEC2,NVAR) 6541 SPROJ(IJ) = INPROD(VEC1,VEC3,NVAR) 6542 END DO 6543 END DO 6544* 6545 IF( IPRT .GE.10 ) THEN 6546 WRITE(6,*) ' Initial matrix in subspace ' 6547 CALL PRSYM(APROJ,NINVEC) 6548 WRITE(6,*) ' Initial metric in subspace ' 6549 CALL PRSYM(SPROJ,NINVEC) 6550 END IF 6551*. Check for singularities in subspace matrix 6552C TRIPK3(AUTPAK,APAK,IWAY,MATDIM,NDIM,SIGN) 6553 CALL TRIPAK(WORK(KSSUB),SPROJ,2,NINVEC,NINVEC) 6554C GET_ON_BASIS(S,NVEC,NSING,X,SCRVEC1,SCRVEC2) 6555 CALL GET_ON_BASIS(WORK(KSSUB),NINVEC,NSING,WORK(KXORTN), 6556 & WORK(KVEC1),WORK(KVEC2)) 6557 NNONSING = NINVEC - NSING 6558*. Transform Subspace M to orthonormal basis 6559 CALL TRIPAK(WORK(KMSUB),APROJ,2,NINVEC,NINVEC) 6560 CALL COPVEC(WORK(KXORTN),WORK(KSCRMAT), 6561 & NNONSING*NINVEC) 6562C TRNMA_LM(XTAX,A,X,NRA,NCA,NRX,NCX,SCRVEC) 6563 CALL TRNMA_LM(WORK(KSCRMAT),WORK(KMSUB),WORK(KSCRMAT), 6564 & NINVEC,NINVEC,NINVEC,NNONSING,WORK(KVEC1)) 6565*. Transformed matrix is returved in KSCRMAT 6566 IF(IPRT.GE.20) THEN 6567 WRITE(6,*) ' NNONSING = ', NNONSING 6568 WRITE(6,*) ' Matrix in ON basis ' 6569 CALL WRTMAT(WORK(KSCRMAT),NINVEC,NINVEC,NINVEC,NINVEC) 6570 END IF 6571*. Diagonalize transformed matrix 6572C DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 6573 CALL DIAG_SYMMAT_EISPACK(WORK(KSCRMAT),WORK(KVEC1), 6574 & WORK(KVEC2),NNONSING,IRETURN) 6575C? WRITE(6,*) ' Eigenvalues on return from DIAG_SYM .... ' 6576C? CALL WRTMAT(WORK(KVEC1),1,NNONSING,1,NNONSING) 6577*. Obtain the eigenvectors in the original basis 6578 FACTORC = 0.0D0 6579 FACTORAB = 1.0D0 6580 CALL MATML7(AVEC,WORK(KXORTN),WORK(KSCRMAT),NINVEC,NNONSING, 6581 & NINVEC,NNONSING,NNONSING,NNONSING,FACTORC,FACTORAB,0) 6582 & 6583 DO IROOT = 1, NROOT 6584 EIG(1,IROOT) = WORK(KVEC1-1+IROOT) 6585 END DO 6586* 6587 IF( IPRT .GE. 3 ) THEN 6588 WRITE(6,'(A,I4)') ' Initial set of eigenvalues ' 6589 WRITE(6,'(5F22.13)') 6590 & ( (EIG(ITER,IROOT)+EIGSHF),IROOT=1,NNONSING) 6591 WRITE(6,*) ' Initial subspace eigenvectors ' 6592 CALL WRTMAT(AVEC,NINVEC,NROOT,NINVEC,NROOT) 6593 END IF 6594 NVEC = NINVEC 6595 NROOT_EFF = MIN(NROOT,NNONSING) 6596 IF(NNONSING.LT.NROOT) THEN 6597 WRITE(6,*) ' Linear dependencies in initial set of vectors ' 6598 WRITE(6,*) ' NROOT, NNONSING = ', NROOT, NNONSING 6599 WRITE(6,*) ' Linear dependencies in initial set of vectors ' 6600 END IF 6601* 6602 ITER_EFF = 1 6603 DO ITER = 2, MAXIT+1 6604 CALL GFLUSH(6) 6605*. In iteration MAXIT + 1, only the residuals are obtained ... 6606 IF(IPRT .GE. 10 ) 6607 & WRITE(6,*) ' INFO FORM ITERATION .... ', ITER 6608* 6609** 1 New directions to be included 6610* 6611* R = H*X - EIGAPR*S*X 6612 IADD = 0 6613 CONVER = .TRUE. 6614C? WRITE(6,*) ' NROOT_EFF = ' , NROOT_EFF 6615 DO 100 IROOT = 1, NROOT_EFF 6616*. H*X in VEC3 6617C MVCSMD(LUIN,FAC,LUOUT,LUSCR,VEC1,VEC2,NVEC,IREW,LBLK) 6618 CALL MVCSMD(LU2,AVEC((IROOT-1)*NVEC+1),LU3,LU4, 6619 & VEC1,VEC2,NVEC,1,-1) 6620 CALL VEC_FROM_DISC(VEC3,NVAR,1,-1,LU3) 6621 IF(IPRT.GE.600) THEN 6622 WRITE(6,*) ' MX ' 6623 CALL WRTMAT(VEC3,1,NVAR,1,NVAR) 6624 END IF 6625*. S*X in VEC2 6626 CALL MVCSMD(LUS,AVEC((IROOT-1)*NVEC+1),LU3,LU4, 6627 & VEC1,VEC2,NVEC,1,-1) 6628 CALL VEC_FROM_DISC(VEC2,NVAR,1,-1,LU3) 6629 IF(IPRT.GE.600) THEN 6630 WRITE(6,*) ' SX ' 6631 CALL WRTMAT(VEC2,1,NVAR,1,NVAR) 6632 END IF 6633*. MX - ESX in VEC1 6634 FACTOR = -EIG(ITER-1,IROOT) 6635 CALL VECSUM(VEC1,VEC3,VEC2,ONE,FACTOR,NVAR) 6636 IF ( IPRT .GE.600 ) THEN 6637 WRITE(6,*) ' ( MX - ESX ) ' 6638 CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 6639 END IF 6640 RNORM = SQRT( INPROD(VEC1,VEC1,NVAR) ) 6641 RNRM(ITER-1,IROOT) = RNORM 6642* STRANGE PLACE TO TEST CONVERGENCE , BUT .... 6643 RTCNV(IROOT) = .FALSE. 6644 IF(I_ER_CONV.EQ.2) THEN 6645 IF(RNORM.LT. THRES_R) THEN 6646 RTCNV(IROOT) = .TRUE. 6647 ELSE 6648 RTCNV(IROOT) = .FALSE. 6649 CONVER = .FALSE. 6650 END IF 6651 ELSE 6652 IF(ITER.EQ.2) THEN 6653 CONVER = . FALSE. 6654 ELSE 6655 IF(ABS(EIG(ITER-1,IROOT)-EIG(ITER-2,IROOT)).LT.THRES_E) 6656 & THEN 6657 RTCNV(IROOT) = .TRUE. 6658 ELSE 6659 RTCNV(IROOT) = .FALSE. 6660 CONVER = .FALSE. 6661 END IF 6662 END IF 6663 END IF 6664* 6665 IF(ITER.LE.MAXIT.AND. .NOT. RTCNV(IROOT) ) THEN 6666 IADD = IADD + 1 6667 IF(I_DO_PRECOND.EQ.1) THEN 6668 IF(IPREC_FORM.EQ.1) THEN 6669*. Just use simple diagonal preconditioner 6670*.Multiply with diag(M-eig*S) to get new direction 6671 CALL VEC_FROM_DISC(VEC2,NVAR,1,-1,LUDIAM) 6672 CALL VEC_FROM_DISC(VEC3,NVAR,1,-1,LUDIAS) 6673 FACTOR = -EIG(ITER-1,IROOT) 6674 CALL VECSUM(VEC2,VEC2,VEC3,ONE,FACTOR,NVAR) 6675 IF(IPRT.GE.600) THEN 6676 WRITE(6,*) ' Diagonal(M) - E*DIAG(S) ' 6677 CALL WRTMAT(VEC2,1,NVAR,1,NVAR) 6678 END IF 6679 CALL DIAVC2(VEC2,VEC1,VEC2,ZERO,NVAR) 6680C DIAVC2(VECOUT,VECIN,DIAG,SHIFT,NDIM) 6681 CALL COPVEC(VEC2,VEC1,NVAR) 6682 IF ( IPRT .GE. 600) THEN 6683 WRITE(6,*) ' (Diag(M)-E*Diag(S))-1 *( MX - ESX ) ' 6684 CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 6685 END IF 6686 ELSE 6687*. Perform more advanced preconditioning by using a 6688*. external preconditionings routine 6689 E = EIG(ITER-1,IROOT) + EIGSHF 6690 CALL PRECTV(VEC1,VEC2,E,LUDIAM,LUDIAS,VEC3) 6691 CALL COPVEC(VEC2,VEC1,NVAR) 6692 END IF 6693 END IF 6694*. VEC1 contains now new direction 6695*. 1.3 ORTHOGONALIZE TO ALL PREVIOUS VECTORS 6696*. Should one use the S-metric or the standard metric? 6697*. I think one can argue for both. Therefore a swith here 6698* 6699 I_USE_1_OR_S = 2 6700 IF(I_USE_1_OR_S.EQ.1) THEN 6701 CALL COPVEC(VEC1,VEC2,NVAR) 6702 ELSE 6703 WRITE(6,*) ' Before MSTV2' 6704 CALL MSTV(VEC1,VEC3,VEC2,0,1) 6705 WRITE(6,*) ' After MSTV2' 6706 END IF 6707 XNRMI = INPROD(VEC1,VEC2,NVAR) 6708 CALL REWINO( LU1 ) 6709 DO IVEC = 1,NVEC+IADD-1 6710 CALL VEC_FROM_DISC(VEC3,NVAR,0,-1,LU1) 6711 OVLAP = INPROD(VEC3,VEC2,NVAR) 6712 CALL VECSUM(VEC1,VEC1,VEC3,1.0D0,-OVLAP,NVAR) 6713 END DO 6714*. 1.4 Normalize vector and check for linear dependency 6715 IF(I_USE_1_OR_S.EQ.1) THEN 6716 CALL COPVEC(VEC1,VEC2,NVAR) 6717 ELSE 6718 WRITE(6,*) ' Before MSTV3' 6719 CALL MSTV(VEC1,VEC3,VEC2,0,1) 6720 WRITE(6,*) ' After MSTV3' 6721 END IF 6722 SCALE = INPROD(VEC1,VEC2,NVAR) 6723 IF(ABS(SCALE)/XNRMI .LT. 1.0D-10) THEN 6724*. Linear dependency 6725 IADD = IADD - 1 6726 IF ( IPRT .GE. 10 ) 6727 � WRITE(6,*) ' Trial vector linear dependent so OUT !!' 6728 ELSE 6729 FACTOR = 1.0D0/SQRT(SCALE) 6730 CALL SCALVE(VEC1,FACTOR,NVAR) 6731 CALL VEC_TO_DISC(VEC1,NVAR,0,-1,LU1) 6732 6733 IF ( IPRT .GE.600 ) THEN 6734 WRITE(6,*) 6735 & ' Orthonormalized (Diag(M)-E*Diag(S))-1 *( MX - ESX ) ' 6736 CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 6737 END IF 6738 END IF 6739* ^ End if no singularity 6740 END IF 6741* ^ End if this root was not converged 6742 100 CONTINUE 6743* 6744 IF( CONVER ) GOTO 1001 6745* 6746** 2 : OPTIMAL COMBINATION OF NEW AND OLD DIRECTION 6747* 6748 IF(.NOT.CONVER.AND.ITER.LE.MAXIT) THEN 6749 ITER_EFF = ITER_EFF + 1 6750* Augment projected matrices 6751 CALL REWINO( LU1) 6752 CALL REWINO( LU2) 6753 CALL REWINO( LUS) 6754 DO IVEC = 1, NVEC 6755 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LU1) 6756 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LU2) 6757 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LUS) 6758 END DO 6759* 6760 DO IVEC = 1, IADD 6761 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LU1) 6762 WRITE(6,*) ' Before MSTV4' 6763 CALL MSTV(VEC1,VEC2,VEC3,1,1) 6764 WRITE(6,*) ' After MSTV4' 6765 CALL VEC_TO_DISC(VEC2,NVAR,0,-1,LU2) 6766 CALL VEC_TO_DISC(VEC3,NVAR,0,-1,LUS) 6767 CALL REWINO( LU1) 6768 DO JVEC = 1, NVEC+IVEC 6769 IJ = (IVEC+NVEC)*(IVEC+NVEC-1)/2 + JVEC 6770 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LU1) 6771 APROJ(IJ) = INPROD(VEC1,VEC2,NVAR) 6772 SPROJ(IJ) = INPROD(VEC1,VEC3,NVAR) 6773 END DO 6774 END DO 6775 IF(IPRT.GE.10) THEN 6776 WRITE(6,*) ' Subspace M and S matrices ' 6777 CALL PRSYM(APROJ,NVEC+IADD) 6778 CALL PRSYM(SPROJ,NVEC+IADD) 6779 END IF 6780* 6781 I_DO_SYMTEST = 1 6782 IF(I_DO_SYMTEST.EQ.1) THEN 6783 WRITE(6,*) ' Symmetry of subspace matrices tested' 6784* Test: Construct complete subspace matrices without assuming 6785* Hermiticity 6786 CALL REWINO(LU1) 6787 NVECA = NVEC + IADD 6788 DO IVEC = 1, NVECA 6789 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LU1) 6790 CALL REWINO(LU2) 6791 CALL REWINO(LUS) 6792 DO JVEC = 1, NVECA 6793 IJ = (JVEC-1)*(NVECA) + IVEC 6794 CALL VEC_FROM_DISC(VEC2,NVAR,0,-1,LU2) 6795 WORK(KSCRMAT-1+IJ) = INPROD(VEC1,VEC2,NVAR) 6796 CALL VEC_FROM_DISC(VEC2,NVAR,0,-1,LUS) 6797 WORK(KSCRMAT2-1+IJ) = INPROD(VEC1,VEC2,NVAR) 6798 END DO 6799 END DO 6800 WRITE(6,*) ' Full A and S subspace matrices ' 6801 CALL WRTMAT(WORK(KSCRMAT),NVECA,NVECA,NVECA,NVECA) 6802 WRITE(6,*) 6803 CALL WRTMAT(WORK(KSCRMAT2),NVECA,NVECA,NVECA,NVECA) 6804 END IF ! End if hermiticity of submatrices should be tested 6805 6806 6807 6808 6809*. Save the previous set of eigenvectors in AVECP 6810C COPMT2(AIN,AOUT,NINR,NINC,NOUTR,NOUTC,IZERO) 6811 CALL COPMT2(AVEC,AVECP,NVEC,NNONSING,NVEC+IADD,NNONSING,1) 6812*. We now have new subspace matrices, so diagonalize 6813 NVEC = NVEC + IADD 6814*. Check for singularities in subspace matrix 6815 ONE = 1.0D0 6816 CALL TRIPAK(WORK(KSSUB),SPROJ,2,NVEC,NVEC) 6817C? WRITE(6,*) ' Projected S matrix in expanded form ' 6818C? CALL WRTMAT(WORK(KSSUB),NVEC,NVEC,NVEC,NVEC) 6819 CALL GET_ON_BASIS(WORK(KSSUB),NVEC,NSING,WORK(KXORTN), 6820 & WORK(KVEC1),WORK(KVEC2)) 6821 NNONSING = NVEC - NSING 6822 IF(NNONSING.LT.NROOT) THEN 6823 WRITE(6,*) ' Number of roots in nonsing problem ' 6824 WRITE(6,*) ' Is lower than the required number of roots' 6825 WRITE(6,*) NNONSING, NROOT 6826 WRITE(6,*) ' I expect trouble but will continue ' 6827 END IF 6828*. Transform Subspace M to orthonormal basis 6829 CALL TRIPAK(WORK(KMSUB),APROJ,2,NVEC,NVEC) 6830 CALL COPVEC(WORK(KXORTN),WORK(KSCRMAT), 6831 & NNONSING*NVEC) 6832C TRNMA_LM(XTAX,A,X,NRA,NCA,NRX,NCX,SCRVEC) 6833 CALL TRNMA_LM(WORK(KSCRMAT),WORK(KMSUB),WORK(KSCRMAT), 6834 & NVEC,NVEC,NVEC,NNONSING,WORK(KVEC1)) 6835*. Transformed matrix is returved in KSCRMAT 6836*. Diagonalize transformed matrix 6837C DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 6838 IF(IPRT.GE.20) THEN 6839 WRITE(6,*) ' Matrix in orthonormal basis ' 6840 CALL WRTMAT(WORK(KSCRMAT),NNONSING,NNONSING,NNONSING, 6841 & NNONSING) 6842 END IF 6843 CALL DIAG_SYMMAT_EISPACK(WORK(KSCRMAT),WORK(KVEC1), 6844 & WORK(KVEC2),NNONSING,IRETURN) 6845*. Obtain the eigenvectors in the original basis 6846 FACTORC = 0.0D0 6847 FACTORAB = 1.0D0 6848 CALL MATML7(AVEC,WORK(KXORTN),WORK(KSCRMAT),NVEC,NNONSING, 6849 & NVEC,NNONSING,NNONSING,NNONSING,FACTORC,FACTORAB,0) 6850 DO IROOT = 1, NROOT 6851 EIG(ITER,IROOT) = WORK(KVEC1-1+IROOT) 6852 END DO 6853* 6854 IF(IPRT .GE. 3 ) THEN 6855 WRITE(6,'(A,I4)') ' Eigenvalues of iteration ..', ITER 6856 WRITE(6,'(5F22.13)') 6857 & ( (EIG(ITER,IROOT)+EIGSHF) ,IROOT=1,NROOT) 6858 END IF 6859* 6860 IF( IPRT .GE. 5 ) THEN 6861 WRITE(6,*) ' Projected M-and S-matrices' 6862 CALL PRSYM(APROJ,NVEC) 6863 CALL PRSYM(SPROJ,NVEC) 6864 WRITE(6,*) ' Subspace eigen-values and -vectors' 6865 WRITE(6,'(2X,E20.13)') 6866 & (EIG(ITER,IROOT)+EIGSHF,IROOT = 1, NROOT) 6867 CALL WRTMAT(AVEC,NVEC,NROOT,MAXVEC,NROOT) 6868 END IF 6869 END IF 6870* ^ End if not converged 6871* 6872** Reset / Assemble current eigenvectors if 6873* space for another set of NROOT vectors is not possible 6874 IF(NVEC+NROOT.GT.MAXVEC.AND..NOT.CONVER) THEN 6875*. Orthogonalize previous set of eigenvectors on current 6876*. set using normal metric ! 6877 CALL COPVEC(AVECP,AVEC(NROOT*NVEC+1),NROOT*NVEC) 6878 IF(IPRT.GE.20) THEN 6879 WRITE(6,*) ' Nonorthonormal basis for reset ' 6880 CALL WRTMAT(AVEC,NVEC,2*NROOT,NVEC,2*NROOT) 6881 END IF 6882*. Overlap matrix of the 2*NROOT vectors : All vectors on file 6883* are orthonormal, so overlap matrix is simple to obtain. 6884 CALL MATML7(WORK(KSCRMAT),AVEC,AVEC,2*NROOT,2*NROOT, 6885 & NVEC,2*NROOT,NVEC,2*NROOT,ZERO,ONE,1) 6886 IF(IPRT.GE.20) THEN 6887 WRITE(6,*) ' Overlap of nonorthonormal reset vecs ' 6888 CALL WRTMAT(WORK(KSCRMAT),2*NROOT,2*NROOT, 6889 & 2*NROOT,2*NROOT) 6890 END IF 6891*. Orthogonalize vectors by forward Gram-Schmidt diagonalization 6892 CALL MGS3(WORK(KSCRMAT2),WORK(KSCRMAT),2*NROOT,WORK(KVEC1)) 6893 IF(IPRT.GE.20) THEN 6894 WRITE(6,*) ' Transformation matrix to orthonormal basis ' 6895 CALL WRTMAT(WORK(KSCRMAT2),2*NROOT,2*NROOT, 6896 & 2*NROOT,2*NROOT) 6897 END IF 6898*. In KSCRMAT2 we now have the expansion of the orthogonal 6899*. eigenvectors in terms of the new and the previous eigenvectors. 6900*. Obtain the expansion of the orthogonal eigenvectors in terms of 6901*. the vectors on disc 6902 CALL MATML7(AVECP,AVEC,WORK(KSCRMAT2),NVEC,2*NROOT, 6903 & NVEC,2*NROOT,2*NROOT,2*NROOT,ZERO,ONE,ZERO) 6904 CALL COPVEC(AVECP,AVEC,NVEC*2*NROOT) 6905 IF(IPRT.GE.20) THEN 6906 WRITE(6,*) ' Orthonormal basis for reset vectors ' 6907 CALL WRTMAT(AVEC,NVEC,2*NROOT,NVEC,2*NROOT) 6908 END IF 6909*. Obtain the corresponding Vectors on Disc 6910*. The c-Vectors 6911 CALL REWINO(LU3) 6912 DO IROOT = 1, 2*NROOT 6913 CALL MVECSUM(AVEC((IROOT-1)*NVEC+1),NVEC,NVAR,VEC1,VEC2, 6914 & LU1,1,1) 6915 CALL VEC_TO_DISC(VEC1,NVAR,0,-1,LU3) 6916 END DO 6917 CALL REWINO(LU3) 6918 CALL REWINO(LU1) 6919 DO IROOT = 1, 2*NROOT 6920 CALL COPVCD(LU3,LU1,VEC1,0,-1) 6921 END DO 6922*. and the sigma-vectors 6923 CALL REWINO(LU3) 6924 DO IROOT = 1, 2*NROOT 6925 CALL MVECSUM(AVEC((IROOT-1)*NVEC+1),NVEC,NVAR,VEC1,VEC2, 6926 & LU2,1,1) 6927 CALL VEC_TO_DISC(VEC1,NVAR,0,-1,LU3) 6928 END DO 6929 CALL REWINO(LU3) 6930 CALL REWINO(LU2) 6931 DO IROOT = 1, 2*NROOT 6932 CALL COPVCD(LU3,LU2,VEC1,0,-1) 6933 END DO 6934*. And the S-vectors 6935 CALL REWINO(LU3) 6936 DO IROOT = 1, 2*NROOT 6937 CALL MVECSUM(AVEC((IROOT-1)*NVEC+1),NVEC,NVAR,VEC1,VEC2, 6938 & LUS,1,1) 6939 CALL VEC_TO_DISC(VEC1,NVAR,0,-1,LU3) 6940 END DO 6941 CALL REWINO(LU3) 6942 CALL REWINO(LUS) 6943 DO IROOT = 1, 2*NROOT 6944 CALL COPVCD(LU3,LUS,VEC1,0,-1) 6945 END DO 6946* 6947 IF(IPRT.GE.20) THEN 6948 WRITE(6,*) ' Reset set of 2*NROOT eigenvectors ' 6949 CALL WRTMAT(AVEC,NVEC,2*NROOT,NVEC,2*NROOT) 6950 END IF 6951*. Subspace matrices for the new basis-vectors 6952C SUBSPC_MAT_FROM_VECTORS(LUV,LUAV,NVECP,NVEC,ASUB, 6953C & ISYM,VEC1,VEC2,NVAR) 6954 CALL SUBSPC_MAT_FROM_VECTORS(LU1,LU2,0,2*NROOT,APROJ, 6955 & 1,VEC1,VEC2,NVAR) 6956 CALL SUBSPC_MAT_FROM_VECTORS(LU1,LUS,0,2*NROOT,SPROJ, 6957 & 1,VEC1,VEC2,NVAR) 6958* 6959 NVEC = 2*NROOT 6960*. and reset the matrix defining the roots 6961 CALL SETVEC(AVEC,ZERO,NVEC**2) 6962 CALL SETDIA(AVEC,ONE,NVEC,0) 6963 END IF 6964* ^ End if Reset was required 6965 END DO 6966* ^ End of loop over iterations 6967 1001 CONTINUE 6968* ^ Statement to which we skip if converged 6969*. Well, the last iteration was used to to construct the residual, 6970*. and does therefore not really count so 6971 ITER = ITER_EFF 6972* 6973*. construct the first NROOT approximations to the 6974*. eigenvectors on LU1 and the corresponding sigmavectors on LU2 6975* 6976*. The c-Vectors 6977 CALL REWINO(LU3) 6978 DO IROOT = 1, NROOT 6979 CALL MVECSUM(AVEC((IROOT-1)*NVEC+1),NVEC,NVAR,VEC1,VEC2, 6980 & LU1,1,1) 6981 CALL VEC_TO_DISC(VEC1,NVAR,0,-1,LU3) 6982 END DO 6983 CALL REWINO(LU3) 6984 CALL REWINO(LU1) 6985 DO IROOT = 1, NROOT 6986 CALL COPVCD(LU3,LU1,VEC1,0,-1) 6987 END DO 6988*. and the sigma-vectors 6989 CALL REWINO(LU3) 6990 DO IROOT = 1, NROOT 6991 CALL MVECSUM(AVEC((IROOT-1)*NVEC+1),NVEC,NVAR,VEC1,VEC2, 6992 & LU2,1,1) 6993 CALL VEC_TO_DISC(VEC1,NVAR,0,-1,LU3) 6994 END DO 6995 CALL REWINO(LU3) 6996 CALL REWINO(LU2) 6997 DO IROOT = 1, NROOT 6998 CALL COPVCD(LU3,LU2,VEC1,0,-1) 6999 END DO 7000*. Obtain the Final C-vector in VEC1 7001 CALL VEC_FROM_DISC(VEC1,NVAR,1,-1,LU1) 7002* 7003 IF( .NOT. CONVER ) THEN 7004* CONVERGENCE WAS NOT OBTAINED 7005 IF(IPRT .GE. 2 ) 7006 & WRITE(6,1170) MAXIT 7007 1170 FORMAT('0 Convergence was not obtained in ',I3,' iterations') 7008 ELSE 7009* CONVERGENCE WAS OBTAINED 7010C ITER = ITER - 1 7011 IF (IPRT .GE. 2 ) 7012 & WRITE(6,1180) ITER 7013 1180 FORMAT(1H0,' Convergence was obtained in ',I3,' iterations') 7014 END IF 7015*. Final eigenvalues 7016 DO IROOT = 1, NROOT 7017 FINEIG(IROOT) = EIG(ITER,IROOT)+EIGSHF 7018 END DO 7019* 7020 EFINAL = FINEIG(NROOT) 7021 VFINAL = RNRM(ITER,NROOT) 7022* 7023 IF ( IPRT .GT. 1 ) THEN 7024 DO IROOT = 1, NROOT 7025 WRITE(6,*) 7026 WRITE(6,'(A,I3)') 7027 & ' Information about convergence for root... ' ,IROOT 7028 WRITE(6,*) 7029 & '============================================' 7030 WRITE(6,*) 7031 WRITE(6,'(A,F18.10)') 7032 & ' The final approximation to eigenvalue ', FINEIG(IROOT) 7033 IF(IPRT.GE.1000) THEN 7034 WRITE(6,*) ' The final approximation to eigenvector' 7035 CALL WRTVCD(VEC1,LU1,1,-1) 7036 END IF 7037 WRITE(6,'(A)') ' Summary of iterations ' 7038 WRITE(6,'(A)') ' ----------------------' 7039 WRITE(6,'(A)') 7040 & ' Iteration point Eigenvalue Residual ' 7041 DO I=1,ITER 7042 WRITE(6,1340) I,EIG(I,IROOT)+EIGSHF,RNRM(I,IROOT) 7043 END DO 7044 1340 FORMAT(1H ,6X,I4,8X,F20.13,2X,E12.5) 7045 END DO 7046 END IF 7047* 7048 IF(IPRT .EQ. 1 ) THEN 7049 DO IROOT = 1, NROOT 7050 WRITE(6,'(A,2I3,E13.6,2E10.3)') 7051 & ' >>> CI-OPT Iter Root E g-norm g-red', 7052 & ITER,IROOT,FINEIG(IROOT), 7053 & RNRM(ITER,IROOT), 7054 & RNRM(1,IROOT)/RNRM(ITER,IROOT) 7055 END DO 7056 END IF 7057C 7058 RETURN 7059 1030 FORMAT(1H0,2X,7F15.8,/,(1H ,2X,7F15.8)) 7060 1120 FORMAT(1H0,2X,I3,7F15.8,/,(1H ,5X,7F15.8)) 7061 END 7062 SUBROUTINE SUBSPC_MAT_FROM_VECTORS(LUV,LUAV,NVECP,NVEC,ASUB, 7063 & ISYM,VEC1,VEC2,NVAR) 7064* 7065* Obtain subspace matrix from a set of vectors (on file LUV) and matrix times 7066* vectors ( on file LUAV) 7067* 7068*. Input 7069* LUV : file containing vectors 7070* LUAV: file containing matrix times vectors 7071* NVECP : Number of vectors for which subspace matrix already 7072* have been constructed 7073* NVEC : Number of vectors 7074* ISYM : = 1 => matrix is symmetric, only lower half of ASUB 7075* is calculated 7076* =0 => matrix is not symmetric, complete SUB is obtained 7077* 7078*. Output 7079* ASUB : Updated subspace matrix 7080* 7081* Scratch 7082* ====== 7083* VEC1, VEC2, Should be able to hold vectors 7084* 7085* Jeppe Olsen, June 2004, trying to get back to work .... 7086* 7087 INCLUDE 'implicit.inc' 7088 REAL*8 INPROD 7089*. Output 7090 DIMENSION ASUB(*) 7091*. Scratch 7092 DIMENSION VEC1(NVAR),VEC2(NVAR) 7093* 7094 IF(ISYM.EQ.1) THEN 7095* Calculate A(i,j) = Vec(i)(T) A Vec(j) for i.le.j. 7096 CALL REWINO(LUV) 7097 DO I = 1, NVECP 7098 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LUV) 7099 END DO 7100 DO I = NVECP+1,NVEC 7101 CALL VEC_FROM_DISC(VEC1,NVAR,0,-1,LUV) 7102* 7103 CALL REWINO(LUAV) 7104 DO J = 1, NVECP 7105 CALL VEC_FROM_DISC(VEC2,NVAR,0,-1,LUAV) 7106 END DO 7107 DO J = NVECP+1,I 7108 CALL VEC_FROM_DISC(VEC2,NVAR,0,-1,LUAV) 7109 IJ = I*(I-1)/2 + J 7110 ASUB(IJ) = INPROD(VEC1,VEC2,NVAR) 7111 END DO 7112 END DO 7113 ELSE 7114 WRITE(6,*) ' Sorry ISYM = 0 option not yet implemented ' 7115 STOP ' SUBSPC_MAT_FROM_VECTORS : ISYM = 0 not implemented ' 7116 END IF 7117* 7118 NTEST = 00 7119 IF(NTEST.GE.100) THEN 7120 WRITE(6,*) ' Updated subspace matrix ' 7121 CALL PRSYM(ASUB,NVEC) 7122 END IF 7123* 7124 RETURN 7125 END 7126 SUBROUTINE MTV_FUSK(VECIN,VECOUT) 7127* 7128* Fusk version of vector * matrix 7129* 7130 INCLUDE 'implicit.inc' 7131* 7132 PARAMETER(NDIM_FUSK = 4) 7133 DIMENSION A(NDIM_FUSK*NDIM_FUSK) 7134* 7135 DO I = 1, NDIM_FUSK ** 2 7136 A(I) = 1.1D0 7137 END DO 7138 DO I = 1, NDIM_FUSK 7139 A((I-1)*NDIM_FUSK+I) = DBLE(I) 7140 END DO 7141C MATVCB(MATRIX,VECIN,VECOUT,MATDIM,NDIM,ITRNSP) 7142 CALL MATVCB(A,VECIN,VECOUT,NDIM_FUSK,NDIM_FUSK,0) 7143* 7144 NTEST = 00 7145 IF(NTEST.GE.100) THEN 7146 WRITE(6,*) ' Input and output form MTV_FUSK ' 7147 CALL WRTMAT(VECIN,1,NDIM_FUSK,1,NDIM_FUSK) 7148 CALL WRTMAT(VECOUT,1,NDIM_FUSK,1,NDIM_FUSK) 7149 END IF 7150* 7151 RETURN 7152 END 7153 SUBROUTINE STV_FUSK(VECIN,VECOUT) 7154* 7155* Fusk version of Metric * vector 7156* 7157 INCLUDE 'implicit.inc' 7158* 7159 PARAMETER(NDIM_FUSK = 4) 7160 DIMENSION S(NDIM_FUSK*NDIM_FUSK) 7161* 7162 DO I = 1, NDIM_FUSK ** 2 7163 S(I) = 0.0D0 7164 END DO 7165 DO I = 1, NDIM_FUSK 7166 S((I-1)*NDIM_FUSK+I) = 1.0D0 + 0.1*FLOAT(I-1) 7167 END DO 7168C MATVCB(MATRIX,VECIN,VECOUT,MATDIM,NDIM,ITRNSP) 7169 CALL MATVCB(S,VECIN,VECOUT,NDIM_FUSK,NDIM_FUSK,0) 7170* 7171 NTEST = 00 7172 IF(NTEST.GE.100) THEN 7173 WRITE(6,*) ' Input and output form STV_FUSK ' 7174 CALL WRTMAT(VECIN,1,NDIM_FUSK,1,NDIM_FUSK) 7175 CALL WRTMAT(VECOUT,1,NDIM_FUSK,1,NDIM_FUSK) 7176 END IF 7177* 7178 RETURN 7179 END 7180 SUBROUTINE GET_SX_FOR_SYM_AND_EXCRANK(ISYM_SX,IRANK2_SX,NSX,ISX) 7181* 7182* Obtain single excitations of given symmetry and excitation rank 7183* Orbital numbers are in TS order 7184* IHPVGAS is used to decide excitation rank 7185* 7186*. Jeppe Olsen, Dec. 2004 7187* 7188 INCLUDE 'implicit.inc' 7189*. Input 7190 INCLUDE 'mxpdim.inc' 7191 INCLUDE 'cgas.inc' 7192 INCLUDE 'orbinp.inc' 7193 INCLUDE 'multd2h.inc' 7194*. Output : Creation and annihilation part of SX 7195 INTEGER ISX(2,*) 7196* 7197 NSX = 0 7198 DO ICOB = 1, NTOOB 7199 DO IAOB = 1, NTOOB 7200 ISYM = MULTD2H(ISMFTO(ICOB),ISMFTO(IAOB)) 7201 IHPV_C = IHPVGAS(ITPFTO(ICOB)) 7202 IHPV_A = IHPVGAS(ITPFTO(IAOB)) 7203 IF(IHPV_C.EQ.1) THEN 7204*. Creation of hole, corresponds to deexcitaion 7205 IR_C = -1 7206 ELSE IF(IHPV_C.EQ.2) THEN 7207*. creation of particle, corresponds to excitation 7208 IR_C = 1 7209 ELSE 7210*. Valence 7211 IR_C = 0 7212 END IF 7213 IF(IHPV_A.EQ.1) THEN 7214*. Annihilation of hole, corresponds to excitation 7215 IR_A = 1 7216 ELSE IF(IHPV_A.EQ.2) THEN 7217*. Annihilation of particle, corresponds to de-excitation 7218 IR_A =-1 7219 ELSE 7220*. Valence 7221 IR_A = 0 7222 END IF 7223 IRANK2 = IR_C + IR_A 7224 IF(IRANK2.EQ.IRANK2_SX.AND.ISYM.EQ.ISYM_SX) THEN 7225 NSX = NSX + 1 7226 ISX(1,NSX) = ICOB 7227 ISX(2,NSX) = IAOB 7228 END IF 7229 END DO 7230 END DO 7231* 7232 NTEST = 100 7233 IF(NTEST.GE.100) THEN 7234 WRITE(6,*) ' SX for rank*2 and symmetry ', IRANK2_SX,ISYM_SX 7235 WRITE(6,*) ' Number of excitations obtained ', NSX 7236 CALL WRT_SXLIST(ISX,NSX) 7237 END IF 7238* 7239 RETURN 7240 END 7241 SUBROUTINE WRT_SXLIST(ISX,NSX) 7242* 7243* Write list of single excitations 7244* 7245*. Jeppe Olsen, Dec. 2004 7246* 7247 INCLUDE 'implicit.inc' 7248 INTEGER ISX(2,NSX) 7249* 7250 DO JSX = 1, NSX 7251 WRITE(6,'(A,I3,A,I3,A)') '(',ISX(1,JSX),',',ISX(2,JSX),')' 7252 END DO 7253* 7254 RETURN 7255 END 7256 SUBROUTINE REFORM_RDM_TO_CUMULANTS(CUMULANTS,ISPOBEX_TP,LSOBEX_TP) 7257* 7258* Reform density matrices to cumulants 7259* 7260* On input CUMULANTS is asumed to contain the RDM, on 7261* output it will contain the cumulants 7262* 7263*. Jeppe Olsen 7264* 7265 INCLUDE 'wrkspc.inc' 7266* 7267 INCLUDE 'glbbas.inc' 7268 INCLUDE 'ctcc.inc' 7269 INCLUDE 'cgas.inc' 7270 INCLUDE 'cprnt.inc' 7271*. Type and length of the various spinorbitalexcitationtypes 7272 INTEGER ISPOBEX_TP(4*NGAS,*), LSOBEX_TP(*) 7273* 7274 NTEST = 100 7275*. Loop over types of spinorbital excitations 7276 DO IXTP = 1, NSPOBEX_TP 7277* 7278 IF(NTEST.GE.100) THEN 7279 WRITE(6,*) ' Type of spin-orbital excitations : ' 7280 CALL WRT_SPOX_TP(ISPOBEX_TP(1,IXTP),1) 7281 END IF 7282*. Rank of type (here : just number of creation operators ) 7283 IRANK = IELSUM(ISPOBEX_TP(1,IXTP),2*NGAS) 7284 WRITE(6,*) ' Rank of operator ', IRANK 7285* 7286 IF(IRANK.EQ.1) THEN 7287*. Reduced density matrices are directly cumulants so no reforming 7288 ELSE IF(IRANK.EQ.2) THEN 7289*. Two-particle cumulant, C(ic1,ic2,ia1,ia2) = D(ic1,ic2,ia1,ia2) 7290* -D(ic1,ia1)*D(ic2,ia2) + D(ic1,ia2)D(ic2,ia1) 7291*. spinsubtype : aa, ab,bb 7292 IAOP = IELSUM(ISPOBEX_TP(1,IXTP),NGAS) 7293 IF(IAOP.EQ.2) THEN 7294*. AA type 7295 ELSE IF(IAOP.EQ.1) THEN 7296*. AB type 7297 ELSE IF(IAOP.EQ.0) THEN 7298*. AB type 7299 END IF 7300 END IF 7301 END DO 7302* 7303 NTEST = 100 7304 IF(NTEST.GE.100) THEN 7305 WRITE(6,*) ' And here comes : The cumulants ' 7306 IPRNCIV_SAVE = IPRNCIV 7307 IPRNCIV = 1 7308 CALL ANA_GENCC(CUMULANTS,1) 7309 IPRNCIV = IPRNCIV_SAVE 7310 END IF 7311* 7312 RETURN 7313 END 7314* ||||| 7315* '(' 7316* \ / 7317* CLONE: 7318 SUBROUTINE GEN_IC_ORBOP2(IWAY,NIC_ORBOP,IC_ORBOP, 7319 & INC_SING, INC_DOUB, 7320 & IONLY_EXCOP,I_IGN_OVL, 7321 & IREFSPC,ITREFSPC,IADD_UNI) 7322* 7323* Generate single and double 7324* orbital excitation types corresponding to internal contraction 7325* The orbital excitations working on IREFSPC should contain 7326* an component in space ITREFSPC. 7327* 7328* Operator-manifold is specified by the arrays 7329* 7330* inc_sing = ( <+2> , <0>, <-2> ) 7331* inc_doub = ( <+4> , <+2>, <0>, <-2>, <-4> ) 7332* 7333* the indices can be calculated as 7334* idx1 = 2 - rank/2 and idx2 = 3 - rank/2 7335* 7336* where an entry of 1 means inclusion of operators of this rank 7337* and a zero means to skip this type of operators 7338* 7339* If IADD_UNI = 1, the unit operator ( containing zero operators) 7340* is added at the end 7341* 7342* Jeppe Olsen, August 2002 7343* 7344* 7345* IWAY = 1 : Number of orbital excitations for internal contraction 7346* IWAY = 2 : Generate also the actual orbital excitations 7347* 7348* IONLY_EXCOP = 1 => only excitation operators ( no annihilation in particle 7349* space, no creation in inactive space ) 7350* 7351* I_IGN_OVL = 1 => we ignore the overlap criterion and include operators 7352* that in first order vanish, but which in higher order 7353* may contribute 7354* 7355*. Rank is defined as # crea of particles + # anni of holes 7356* -# crea of holes - # anni of particles 7357 7358 INCLUDE 'implicit.inc' 7359 INCLUDE 'mxpdim.inc' 7360 INCLUDE 'cgas.inc' 7361*. Input array 7362 INTEGER INC_SING(3), INC_DOUB(5) 7363*. Local scratch 7364 INTEGER ITREFOCC(MXPNGAS,2) 7365*. Output ( if IWAY .ne. 1 ) 7366 INTEGER IC_ORBOP(2*NGAS,*) 7367*. Local scratch 7368 INTEGER IOP(2*MXPNGAS) 7369* 7370 NTEST = 100 7371 IF(NTEST.GE.100) THEN 7372 WRITE(6,*) ' IREFSPC, ITREFSPC = ', IREFSPC, ITREFSPC 7373 WRITE(6,'(X,A,3I2)') ' INC_SING = ', INC_SING(1:3) 7374 WRITE(6,'(X,A,5I2)') ' INC_DOUB = ', INC_DOUB(1:5) 7375 END IF 7376 NIC_ORBOP = 0 7377 IF (NTEST.GE.100) WRITE(6,*) ' output for singles:' 7378*. Single excitations a+i a j 7379 DO IGAS = 1, NGAS 7380 DO JGAS = 1, NGAS 7381 IZERO = 0 7382 CALL ISETVC(IOP,IZERO,2*NGAS) 7383 IOP(IGAS) = 1 7384 IOP(NGAS+JGAS) = 1 7385 IF(NTEST.GE.100) THEN 7386 WRITE(6,*) ' Next Orbital excitation ' 7387 CALL IWRTMA(IOP,NGAS,2,NGAS,2) 7388 END IF 7389C IRANK_ORBOP(IOP,NEX,NDEEX) 7390C COMPARE_OPDIM_ORBDIM(IOP,IOKAY) 7391 CALL COMPARE_OPDIM_ORBDIM(IOP,IOKAY) 7392 IF(NTEST.GE.100) WRITE(6,*) ' IOKAY from COMPARE..', IOKAY 7393*. Is the action of this operator on IREFSPC included in ITREFSPC 7394 IF (I_IGN_OVL.NE.1) THEN 7395 CALL ORBOP_ACCOCC(IOP,IGSOCCX(1,1,IREFSPC),ITREFOCC,NGAS,MXPNGAS) 7396 CALL OVLAP_ACC_MINMAX(ITREFOCC,IGSOCCX(1,1,ITREFSPC),NGAS,MXPNGAS, 7397 & IOVERLAP) 7398 IF(NTEST.GE.100) WRITE(6,*) ' IOVERLAP from OVLAP..',IOVERLAP 7399 IF(IOVERLAP.EQ.0) IOKAY = 0 7400 ELSE 7401 IOKAY = 1 7402 END IF 7403C ORBOP_ACCOCC(IORBOP,IACC_IN,IACC_OUT,NGAS,MXPNGAS) 7404C OVLAP_ACC_MINMAX(IACC1,IACC2,NGAS,MXPNGAS,IOVERLAP) 7405*. is there any operators in spaces that are frozen or deleted in ITREFSPC 7406C CHECK_EXC_FR_OR_DE(IOP,IOCC,NGAS,IOKAY) 7407 CALL CHECK_EXC_FR(IOP,IGSOCCX(1,1,ITREFSPC),NGAS,IOKAY2) 7408 IF(NTEST.GE.100) WRITE(6,*) ' IOKAY2 from CHECK ... ', IOKAY2 7409 IF(IOKAY2.EQ.0) IOKAY = 0 7410 IF(IOKAY.EQ.1) THEN 7411 CALL IRANK_ORBOP(IOP,NEX,NDEEX) 7412 IOKAY2 = 1 7413 IF(IONLY_EXCOP.EQ.1.AND.NDEEX.NE.0) IOKAY2 = 0 7414 IRANK = NEX - NDEEX 7415 IF(NTEST.GE.100) WRITE(6,*) ' IRANK = ', IRANK 7416 IF(INC_SING(2-IRANK/2).NE.0 7417c test 7418c IF(INC_SING(2-IRANK).NE.0 7419 & .AND.IOKAY2.EQ.1)THEN 7420 NIC_ORBOP = NIC_ORBOP + 1 7421 IF(NTEST.GE.100) WRITE(6,*) ' Operator included ' 7422 IF(IWAY.NE.1) 7423 & CALL ICOPVE(IOP,IC_ORBOP(1,NIC_ORBOP),2*NGAS) 7424 END IF 7425 END IF 7426 END DO 7427 END DO 7428*. Double excitations a+i a+j a k a l 7429 IF (NTEST.GE.100) WRITE(6,*) ' output for doubles:' 7430 DO IGAS = 1, NGAS 7431 DO JGAS = 1, IGAS 7432 DO KGAS = 1, NGAS 7433 DO LGAS = 1, KGAS 7434 CALL ISETVC(IOP,IZERO,2*NGAS) 7435 IOP(IGAS) = 1 7436 IOP(JGAS) = IOP(JGAS) + 1 7437 IOP(NGAS+KGAS) = 1 7438 IOP(NGAS+LGAS) = IOP(NGAS+LGAS) + 1 7439 IF(NTEST.GE.200) THEN 7440 WRITE(6,*) ' Next Orbital excitation ' 7441 CALL IWRTMA(IOP,NGAS,2,NGAS,2) 7442 END IF 7443 CALL COMPARE_OPDIM_ORBDIM(IOP,IOKAY) 7444 IF(NTEST.GE.200) WRITE(6,*) ' IOKAY from COMPARE..', IOKAY 7445*. Is the action of this operator on IREFSPC included in ITREFSPC 7446 IF (I_IGN_OVL.NE.1) THEN 7447 CALL ORBOP_ACCOCC(IOP,IGSOCCX(1,1,IREFSPC),ITREFOCC,NGAS,MXPNGAS) 7448 CALL OVLAP_ACC_MINMAX(ITREFOCC,IGSOCCX(1,1,ITREFSPC),NGAS, 7449 & MXPNGAS,IOVERLAP) 7450 IF(NTEST.GE.200) WRITE(6,*) ' IOVERLAP from OVLAP..',IOVERLAP 7451 IF(IOVERLAP.EQ.0) IOKAY = 0 7452 ELSE 7453 IOKAY = 1 7454 END IF 7455 CALL CHECK_EXC_FR(IOP,IGSOCCX(1,1,ITREFSPC),NGAS,IOKAY2) 7456 IF(NTEST.GE.200) 7457 & WRITE(6,*) ' IOKAY2 from CHECK ... ', IOKAY2 7458 IF(IOKAY2.EQ.0) IOKAY = 0 7459 IF(IOKAY.EQ.1) THEN 7460 CALL IRANK_ORBOP(IOP,NEX,NDEEX) 7461 IOKAY2 = 1 7462 IF(IONLY_EXCOP.EQ.1.AND.NDEEX.NE.0) IOKAY2 = 0 7463 IRANK = NEX - NDEEX 7464 IF(NTEST.GE.100) WRITE(6,*) ' IRANK = ', IRANK 7465 IF(INC_DOUB(3-IRANK/2).NE.0 .AND. 7466c test 7467c IF(INC_DOUB(3-IRANK).NE.0 .AND. 7468 & IOKAY2.EQ.1) THEN 7469 IF(NTEST.GE.100) WRITE(6,*) ' Operator included ' 7470 NIC_ORBOP = NIC_ORBOP + 1 7471 IF(IWAY.NE.1) 7472 & CALL ICOPVE(IOP,IC_ORBOP(1,NIC_ORBOP),2*NGAS) 7473 END IF 7474 END IF 7475 END DO 7476 END DO 7477 END DO 7478 END DO 7479 IF(IADD_UNI.EQ.1) THEN 7480 NIC_ORBOP = NIC_ORBOP + 1 7481 IF(IWAY.NE.1) THEN 7482 IZERO = 0 7483 CALL ISETVC(IC_ORBOP(1,NIC_ORBOP),IZERO,2*NGAS) 7484 END IF 7485 END IF 7486* 7487 IF(NTEST.GE.5) THEN 7488 WRITE(6,*) ' Number of orbitalexcitation types generated ', 7489 & NIC_ORBOP 7490 IF(IWAY.NE.1) THEN 7491 WRITE(6,*) ' And the actual orbitalexcitation types : ' 7492 DO JC = 1, NIC_ORBOP 7493 WRITE(6,*) ' Orbital excitation type ', JC 7494 CALL IWRTMA(IC_ORBOP(1,JC),NGAS,2,NGAS,2) 7495 END DO 7496 END IF 7497 END IF 7498* 7499 RETURN 7500 END 7501* END OF CLONE 7502 SUBROUTINE PROJ_VEC_TO_ICSPC(LUREF,LUIN,LUOUT,VEC1_CI,VEC2_CI, 7503 & VEC1_IC,VEC2_IC,VEC3_IC,RMAT_IC, 7504 & IREFSPC,ITREFSPC,NSPA,N_IC_OP,N_NONSING,S_IC, 7505 & X_IC_NONSING,LUSCR) 7506* 7507* A vector is given in uncontracted basis (Determinant basis) 7508* on LUIN. Project this vector to the space given by the 7509* internal contracted operators O_i |ref> where |ref> is 7510* the vector on LUREF 7511* 7512* Jeppe Olsen, May 2005 for settling whether the IC triples 7513* correction is the exact second order MP triples correction 7514* 7515* The projected vector is 7516* 7517* sum_ij O_i|ref> S_{ij}^-1 <ref|O+j|LUIN> 7518* 7519* So the procedure is 7520* 1 : Calculate <ref|O+j|LUIN> as density 7521* 2 : Invert S and multiply on <ref|O+j|LUIN> 7522* 3 : Expand resulting vector in SD space 7523* 4 : And compare 7524* 7525 INCLUDE 'wrkspc.inc' 7526 REAL*8 INPRDD 7527 INCLUDE 'cands.inc' 7528* ======== 7529*. Input 7530* ======== 7531*. Metric in IC basis - unitoperator excluded IS DESTROYED IN THIS ROUTINE !!! 7532 DIMENSION S_IC((NSPA-1)**2) 7533*.Transformation basis IC=> Non-sing basis (minus unit operator) 7534 DIMENSION X_IC_NONSING(NSPA-1,N_NONSING) 7535* ========= 7536*. Scratch 7537* ========= 7538*. Scratch for CI 7539 DIMENSION VEC1_CI(*), VEC2_CI(*) 7540*. For holding IC vectors 7541 DIMENSION VEC1_IC(N_IC_OP), VEC2_IC(N_IC_OP) 7542*. and an matrix in IC basis 7543 DIMENSION RMAT_IC(N_IC_OP,N_IC_OP) 7544* 7545 NTEST = 00 7546* 7547* <REF!T+(I)P H !0> = <LUIN!T(I)!LUREF> 7548* 7549 IF(NTEST.GE.10) THEN 7550 WRITE(6,*) ' PROJ ..., LUIN, LUOUT, LUSCR = ', LUIN,LUOUT,LUSCR 7551 WRITE(6,*) ' PROJ ... N_IC_OP, NSPA, N_NONSING = ', 7552 & N_IC_OP, NSPA, N_NONSING 7553 END IF 7554 IF(NTEST.GE.100) THEN 7555 WRITE(6,*) ' Input vector in SD basis ' 7556 CALL WRTVCD(VEC1_CI,LUIN,1,-1) 7557 END IF 7558*. Both sides are in the form of the ITREFSPC so : 7559 ICSPC = ITREFSPC 7560 ISSPC = ITREFSPC 7561 ZERO = 0.0D0 7562 CALL SETVEC(VEC1_IC,ZERO,N_IC_OP) 7563 CALL SIGDEN_CC(VEC1_CI,VEC2_CI,LUREF,LUIN,VEC1_IC,2) 7564 CALL REF_CCV_CAAB_SP(VEC1_IC,VEC2_IC,VEC3_IC,1) 7565* 7566 IF(NTEST.GE.100) THEN 7567 WRITE(6,*) ' Transition density <ref|O+j|LUIN> in IC basis ' 7568 CALL WRTMAT(VEC2_IC,1,NSPA,1,NSPA) 7569 END IF 7570*. and transform to nonsingular basis 7571 CALL MATVCC(X_IC_NONSING,VEC2_IC,VEC1_IC,NSPA-1,N_NONSING,1) 7572*. Transform the metric to the nonsingular space 7573C TRNMAD(A,X,SCR,NDIMI,NDIMO) 7574 CALL TRNMAD(S_IC,X_IC_NONSING,RMAT_IC,NSPA-1,N_NONSING) 7575* Obtain inverse metric in S_IC 7576 CALL INVMAT(S_IC,RMAT_IC,N_NONSING,N_NONSING,ISING) 7577*. Multiply <ref|O+j|LUIN> with inverse metric 7578 CALL MATVCC(S_IC,VEC1_IC,VEC2_IC,N_NONSING,N_NONSING,0) 7579*. Transform back to SPA basis 7580 CALL MATVCC(X_IC_NONSING,VEC2_IC,VEC1_IC,NSPA-1,N_NONSING,0) 7581*. We have left out the coefficient corresponding to the 7582*. zero-order state. Set this to zero 7583 VEC1_IC(NSPA) = 0.0D0 7584 IF(NTEST.GE.100) THEN 7585 WRITE(6,*) ' Projected vector in IC basis ' 7586 CALL WRTMAT(VEC1_IC,1,NSPA,1,NSPA) 7587 END IF 7588*. We now have projected vector in IC basis, expand in SD 7589*. basis to allow comparison 7590C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 7591 CALL REF_CCV_CAAB_SP(VEC2_IC,VEC1_IC,VEC3_IC,2) 7592 CALL SIGDEN_CC(VEC1_CI,VEC2_CI,LUREF,LUOUT,VEC2_IC,1) 7593*. Obtain difference between the two vectors on LUSCR 7594C VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 7595 FAC1 = 1.0D0 7596 FAC2 = -1.0D0 7597 CALL VECSMD(VEC1_CI,VEC2_CI,FAC1,FAC2,LUIN,LUOUT,LUSCR,1,-1) 7598*. Norm of LUIN and of LUIN-LUOUT 7599 XNORM_IN = INPRDD(VEC1_CI,VEC2_CI,LUIN,LUIN,1,-1) 7600 XNORM_OUT = INPRDD(VEC1_CI,VEC2_CI,LUOUT,LUOUT,1,-1) 7601 XNORM_DIFF = INPRDD(VEC1_CI,VEC2_CI,LUSCR,LUSCR,1,-1) 7602*. And compare individual elements 7603 WRITE(6,*) ' Comparison of LUIN and LUOUT ' 7604 CALL CMP2VCD(VEC1_CI,VEC2_CI,LUIN,LUOUT,0.0D0,1,-1) 7605* 7606 WRITE(6,*) ' Comparing vector and vector projected to IC space ' 7607 WRITE(6,*) ' Squared norm of input vector = ', XNORM_IN 7608 WRITE(6,*) ' Squared norm of output vector = ', XNORM_OUT 7609 WRITE(6,*) ' Squared norm of difference = ', XNORM_DIFF 7610* 7611 RETURN 7612 END 7613 SUBROUTINE TRNMAD(A,X,SCR,NDIMI,NDIMO) 7614* 7615* Obtain X(T) A X and store it in A 7616* Allows different dimensions in input and output matrices 7617* 7618 INCLUDE 'implicit.inc' 7619*. Input and output 7620 DIMENSION A(*), X(NDIMI,NDIMO) 7621*. Scratch 7622 DIMENSION SCR(NDIMI*NDIMO) 7623 NTEST = 000 7624* 7625 IF(NTEST.GE.1000) THEN 7626 WRITE(6,*) ' Info from TRNMAD ' 7627 WRITE(6,*) ' NDIMI, NDIMO = ', NDIMI,NDIMO 7628 WRITE(6,*) ' Input X matrix ' 7629 CALL WRTMAT(X,NDIMI,NDIMO,NDIMI,NDIMO) 7630 WRITE(6,*) ' Input A matrix ' 7631 CALL WRTMAT(A,NDIMI,NDIMI,NDIMI,NDIMI) 7632 END IF 7633 7634* 7635*. 1 : X(T) A in SCR 7636 ZERO = 0.D0 7637 CALL SETVEC(SCR,ZERO,NDIMI*NDIMO) 7638 CALL MATML7(SCR,X,A,NDIMO,NDIMI,NDIMI,NDIMO,NDIMI,NDIMI, 7639 & 0.0D0,1.0D0,1) 7640*. X(T) A X in A 7641 CALL MATML7(A,SCR,X,NDIMO,NDIMO,NDIMO,NDIMI,NDIMI,NDIMO, 7642 & 0.0D0,1.0D0,0) 7643* 7644 NTEST = 00 7645 IF(NTEST.GE.100) THEN 7646 WRITE(6,*) ' Transformed matrix : ' 7647 CALL WRTMAT(A,NDIMO,NDIMO,NDIMO,NDIMO) 7648 END IF 7649* 7650 RETURN 7651 END 7652 SUBROUTINE EXPND_T_TO_NOSYM(XIN,XOUT,ICAAB) 7653* 7654* A matrix XIN is given in symmetry packed form XIN(CA,CB,AA,AB) 7655* Expand to form without symmetry 7656* 7657* Jeppe Olsen 7658 INCLUDE 'wrkspc.inc' 7659 INCLUDE 'crun.inc' 7660 INCLUDE 'cgas.inc' 7661 INCLUDE 'orbinp.inc' 7662* Specific input 7663 INTEGER ICAAB(NGAS,4) 7664 DIMENSION XIN(*) 7665*. Output 7666 DIMENSION XOUT(*) 7667* 7668 IDUM = -1 7669 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'EXPNOS') 7670*. 7671 NOP_CA = IELSUM(ICAAB(1,1),NGAS) 7672 NOP_CB = IELSUM(ICAAB(1,2),NGAS) 7673 NOP_AA = IELSUM(ICAAB(1,3),NGAS) 7674 NOP_AB = IELSUM(ICAAB(1,4),NGAS) 7675* 7676 NOP_MX = MAX(NOP_CA,NOP_CB,NOP_AA,NOP_AB) 7677 7678*. Set up arrays for indexing ICA, ICB, IAA, IAB without symmetry 7679 CALL MEMMAN(KLZ_CA,NOP_CA*NTOOB,'ADDL ',2,'Z_CA ') 7680 CALL MEMMAN(KLZ_CB,NOP_CB*NTOOB,'ADDL ',2,'Z_CB ') 7681 CALL MEMMAN(KLZ_AA,NOP_AA*NTOOB,'ADDL ',2,'Z_AA ') 7682 CALL MEMMAN(KLZ_AB,NOP_AB*NTOOB,'ADDL ',2,'Z_AB ') 7683 LSCR = 2*NTOOB + (NOP_MX+1)*(NTOOB+1) 7684 CALL MEMMAN(KLSCR,LSCR,'ADDL ',2,'ZLSCR') 7685C WEIGHT_SPGP(Z,NORBTP,NELFTP,NORBFTP,ISCR,NTEST) 7686 CALL WEIGHT_SPGP(WORK(KLZ_CA),NGAS,ICAAB(1,1),NOBPT,WORK(KLSCR),0) 7687 CALL WEIGHT_SPGP(WORK(KLZ_CB),NGAS,ICAAB(1,2),NOBPT,WORK(KLSCR),0) 7688 CALL WEIGHT_SPGP(WORK(KLZ_AA),NGAS,ICAAB(1,3),NOBPT,WORK(KLSCR),0) 7689 CALL WEIGHT_SPGP(WORK(KLZ_AB),NGAS,ICAAB(1,4),NOBPT,WORK(KLSCR),0) 7690*. Total number of strings per ICAAB ( is also given in last elements of Z's) 7691 NST_CA = NST_FOR_OCC(ICAAB(1,1),NOBPT,NGAS) 7692 NST_CB = NST_FOR_OCC(ICAAB(1,2),NOBPT,NGAS) 7693 NST_AA = NST_FOR_OCC(ICAAB(1,3),NOBPT,NGAS) 7694 NST_AB = NST_FOR_OCC(ICAAB(1,4),NOBPT,NGAS) 7695*. In the general form, a string is XOUT(ICA,ICB,IAA,IAB) will be adressed 7696*. as a standard fortran array 7697*. We are now ready to do the reordering 7698 ZERO = 0.0D0 7699 NELMNT = NST_CA*NST_CB*NST_AA*NST_AB 7700 CALL SETVEC(XOUT,ZERO,NELMNT) 7701*. Four scratch blocks for holding blocks of 7702 7703 CALL EXPND_T_TO_NOSYMS(XIN,XOUT,ICAAB,ISM, 7704 & WORK(KLZ_CA),WORK(KLZ_CB),WORK(KLZ_AA),WORK(KLZ_AB), 7705 & IOCC_CA, IOCC_CB, IOCC_AA, IOCC_AB,NORB,MSCOMB_CC) 7706* 7707 CALL MEMMAN(IDUM,IDUM,'FLUSM',IDUM,'EXPNOS') 7708 RETURN 7709 END 7710 SUBROUTINE EXPND_T_TO_NOSYMS(XIN,XOUT,ICAAB,ISM, 7711 & IZ_CA,IZ_CB,IZ_AA,IZ_AB, 7712 & IOCC_CA, IOCC_CB, IOCC_AA, IOCC_AB,NORB,MSCOMB_CC) 7713* 7714*. An array T(ICA,ICB,IAA,IAB) is given in symmetry-ordered form. 7715*. Unpack to form without symmetry 7716*. 7717*. Jeppe Olsen, April 2005 7718* 7719* 7720 INCLUDE 'implicit.inc' 7721 INCLUDE 'mxpdim.inc' 7722 INCLUDE 'cgas.inc' 7723 INCLUDE 'multd2h.inc' 7724 INCLUDE 'csm.inc' 7725 INCLUDE 'orbinp.inc' 7726*. Specific input 7727 INTEGER ICAAB(NGAS,4) 7728 DIMENSION XIN(*) 7729 INTEGER IZ_CA(*),IZ_CB(*),IZ_AA(*),IZ_AB(*) 7730*. Scratch 7731 INTEGER IOCC_CA(*),IOCC_CB(*),IOCC_AA(*),IOCC_AB(*) 7732*. Local scratch 7733 INTEGER IGRP_CA(MXPNGAS),IGRP_CB(MXPNGAS) 7734 INTEGER IGRP_AA(MXPNGAS),IGRP_AB(MXPNGAS) 7735*. Output 7736 DIMENSION XOUT(*) 7737*. Total number of strings for the various groups 7738 NST_CA_TOT = NST_FOR_OCC(ICAAB(1,1),NOBPT,NGAS) 7739 NST_CB_TOT = NST_FOR_OCC(ICAAB(1,2),NOBPT,NGAS) 7740 NST_AA_TOT = NST_FOR_OCC(ICAAB(1,3),NOBPT,NGAS) 7741 NST_AB_TOT = NST_FOR_OCC(ICAAB(1,4),NOBPT,NGAS) 7742 7743* 7744*. Transform from occupations to groups 7745 CALL OCC_TO_GRP(ICAAB(1,1),IGRP_CA,1) 7746 CALL OCC_TO_GRP(ICAAB(1,2),IGRP_CB,1) 7747 CALL OCC_TO_GRP(ICAAB(1,3),IGRP_AA,1) 7748 CALL OCC_TO_GRP(ICAAB(1,4),IGRP_AB,1) 7749* 7750 NEL_CA = IELSUM(ICAAB(1,1),NGAS) 7751 NEL_CB = IELSUM(ICAAB(1,2),NGAS) 7752 NEL_AA = IELSUM(ICAAB(1,3),NGAS) 7753 NEL_AB = IELSUM(ICAAB(1,4),NGAS) 7754*. It is assumed that no reduction due to spin symmetri is used. 7755 DO ISM_C = 1, NSMST 7756 ISM_A = MULTD2H(ISM,ISM_C) 7757 DO ISM_CA = 1, NSMST 7758 ISM_CB = MULTD2H(ISM_C,ISM_CA) 7759 DO ISM_AA = 1, NSMST 7760 ISM_AB = MULTD2H(ISM_A,ISM_AA) 7761 ISM_ALPHA = (ISM_AA-1)*NSMST + ISM_CA 7762 ISM_BETA = (ISM_AB-1)*NSMST + ISM_CB 7763*. obtain strings 7764 CALL GETSTR2_TOTSM_SPGP(IGRP_CA,NGAS,ISM_CA,NEL_CA,NSTR_CA, 7765 & IOCC_CA, NORB,0,IDUM,IDUM) 7766 CALL GETSTR2_TOTSM_SPGP(IGRP_CB,NGAS,ISM_CB,NEL_CB,NSTR_CB, 7767 & IOCC_CB, NORB,0,IDUM,IDUM) 7768 CALL GETSTR2_TOTSM_SPGP(IGRP_AA,NGAS,ISM_AA,NEL_AA,NSTR_AA, 7769 & IOCC_AA, NORB,0,IDUM,IDUM) 7770 CALL GETSTR2_TOTSM_SPGP(IGRP_AB,NGAS,ISM_AB,NEL_AB,NSTR_AB, 7771 & IOCC_AB, NORB,0,IDUM,IDUM) 7772*. Loop over T elements as matrix T(I_CA, I_CB, IAA, I_AB) 7773 DO I_AB = 1, NSTR_AB 7774*. Number in nonsymmetric form 7775C ISTRNM(IOCC,NORB,NEL,Z,NEWORD,IREORD) 7776 I_AB_EXP = ISTRNM(IOCC_AB(1+(I_AB-1)*NEL_AB),NORB,IZ_AB, 7777 & IDUM,0) 7778 DO I_AA = 1, NSTR_AA 7779 I_AA_EXP = ISTRNM(IOCC_AA(1+(I_AA-1)*NEL_AA),NORB,IZ_AA, 7780 & IDUM,0) 7781 DO I_CB = 1, NSTR_CB 7782 I_AB_EXP = ISTRNM(IOCC_CB(1+(I_CB-1)*NEL_CB),NORB,IZ_CB, 7783 & IDUM,0) 7784 DO I_CA = 1, NSTR_CA 7785 I_CA_EXP = ISTRNM(IOCC_CA(1+(I_CA-1)*NEL_CA),NORB,IZ_CA, 7786 & IDUM,0) 7787 IT = IT + 1 7788 IT_EXP = (IAB_EXP-1)*NST_CA_TOT*NST_CB_TOT*NST_AA_TOT 7789 & + (IAB_EXP-1)*NST_CA_TOT*NST_CB_TOT 7790 & + (ICB_EXP-1)*NST_CA_TOT 7791 & + ICA_EXP 7792 XOUT(IT_EXP) = XIN(IT) 7793 END DO 7794* ^ End of loop over alpha creation strings 7795 END DO 7796* ^ End of loop over beta creation strings 7797 END DO 7798* ^ End of loop over alpha annihilation 7799 END DO 7800* ^ End of loop over beta annihilation 7801 777 CONTINUE 7802 END DO 7803 END DO 7804 END DO 7805* ^ End of loop over symmetry blocks 7806 RETURN 7807 END 7808 SUBROUTINE LUCIA_ICCC(IREFSPC,ITREFSPC,ICTYP,EREF, 7809 & EFINAL,CONVER,VNFINAL) 7810* 7811* Master routine for Internal Contraction multireference coupled cluster theory 7812* 7813* LUCIA_IC is assumed to have been called to do the 7814* prepatory work for working with internal contraction 7815* 7816* It is assumed that spin-adaptation is used ( no flag anymore..) 7817* 7818* It is standard that the unitoperator is included in 7819* the operator manifold, but in CC ( and PT) theory this should be 7820* excluded. This is easily done as the unitoperator is the 7821* last operator in CA order. 7822* 7823* Jeppe Olsen, August 2005 7824* 7825C INCLUDE 'implicit.inc' 7826 INCLUDE 'wrkspc.inc' 7827 REAL*8 INPROD 7828 LOGICAL CONVER,CONVERL 7829C INCLUDE 'mxpdim.inc' 7830 INCLUDE 'crun.inc' 7831 INCLUDE 'cstate.inc' 7832 INCLUDE 'cgas.inc' 7833 INCLUDE 'ctcc.inc' 7834 INCLUDE 'gasstr.inc' 7835 INCLUDE 'strinp.inc' 7836 INCLUDE 'orbinp.inc' 7837 INCLUDE 'cprnt.inc' 7838 INCLUDE 'corbex.inc' 7839 INCLUDE 'csm.inc' 7840 INCLUDE 'cicisp.inc' 7841 INCLUDE 'cecore.inc' 7842 INCLUDE 'glbbas.inc' 7843 INCLUDE 'clunit.inc' 7844 INCLUDE 'lucinp.inc' 7845 INCLUDE 'oper.inc' 7846 INCLUDE 'cintfo.inc' 7847 INCLUDE 'cei.inc' 7848*. Transfer common block for communicating with H_EFF * vector routines 7849 COMMON/COM_H_S_EFF_ICCI_TV/ 7850 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 7851 & IUNIOPX,NSPAX,IPROJSPCX 7852*. Transfer block for communicating zero order energy to 7853*. routine for performing H0-E0 * vector 7854 INCLUDE 'cshift.inc' 7855* 7856 CHARACTER*6 ICTYP 7857 EXTERNAL H0ME0TV_EXT_IC 7858*. Number of commutators used in approach 7859* 7860 IDUM = 0 7861 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICCC ') 7862 NTEST = 5 7863* 7864*. a bit of dirty work before print: 7865* I will add unitoperator to the spin-orbital excitations- 7866* evrything prepared, I just need to increase number of types 7867* Is already done in old non-IE-route, add for IE-route 7868 IF(I_DO_EI.EQ.1) THEN 7869 NSPOBEX_TP = NSPOBEX_TP + 1 7870 END IF 7871 WRITE(6,*) 7872 WRITE(6,*) ' ====================' 7873 WRITE(6,*) ' ICCC section entered ' 7874 WRITE(6,*) ' ====================' 7875 WRITE(6,*) 7876* 7877*. Form of ICPT calculation 7878* 7879 WRITE(6,'(A,A)') ' Type of ICCC calculation : ', ICTYP 7880 WRITE(6,*) ' Energy of reference state ', EREF 7881 WRITE(6,*) ' Reference space ', IREFSPC 7882 WRITE(6,*) ' Extended space (ITREFSPC) ', ITREFSPC 7883 WRITE(6,*) ' Number of commutators employed : ' 7884 WRITE(6,*) ' In energy evaluation ', NCOMMU_E 7885 WRITE(6,*) ' In approximate Jacobian ', NCOMMU_J 7886 WRITE(6,*) ' In vector function ', NCOMMU_V 7887* 7888 IF(I_FIX_INTERNAL.EQ.0) THEN 7889 WRITE(6,*) ' Internal (reference) wave-function reoptimized' 7890 ELSE 7891 WRITE(6,*) ' Internal (reference) wave-function frozen' 7892 END IF 7893 IF(I_INT_HAM.EQ.1) THEN 7894 WRITE(6,*) ' One-body H0 used for internal zero-order states' 7895 ELSE 7896 WRITE(6,*) ' One-body H used for internal zero-order states' 7897 END IF 7898* 7899*. Approximate highest commutator 7900 N_APPROX_HCOM = I_APPROX_HCOM_E + I_APPROX_HCOM_V 7901 & + I_APPROX_HCOM_J 7902 IF(N_APPROX_HCOM.NE.0) THEN 7903 WRITE(6,*) ' Highest commutator approximated for ' 7904 IF(I_APPROX_HCOM_E.EQ.1) WRITE(6,*) ' energy-function' 7905 IF(I_APPROX_HCOM_V.EQ.1) WRITE(6,*) ' vector-function' 7906 IF(I_APPROX_HCOM_J.EQ.1) WRITE(6,*) ' approximate Jacobian' 7907 END IF 7908 IF(I_DO_EI.EQ.1) THEN 7909 WRITE(6,*) ' EI approach in use' 7910 ELSE 7911 WRITE(6,*) ' Partial spin-adaptation in use' 7912 END IF 7913* 7914 WRITE(6,*) ' LUCIA_ICCC: IREFSPC, ITREFSPC =', IREFSPC, ITREFSPC 7915 WRITE(6,*) ' Number of spinorbitalexctypes (inc. unit)' 7916 & , NSPOBEX_TP 7917 IF(NTEST.GE.10) THEN 7918 WRITE(6,*) ' The list of spinorbitalexcitations' 7919 CALL WRT_SPOX_TP_JEPPE(WORK(KLSOBEX),NSPOBEX_TP) 7920 END IF 7921*. Number of parameters with and without spinadaptation 7922 IF(I_DO_EI.EQ.0) THEN 7923 CALL NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 7924 ELSE 7925*. zero-particle operator is included in N_ZERO_EI 7926 NSPA = N_ZERO_EI 7927*. Note: NCAAB and N_CC_AMP below now both includes unitop 7928 NCAAB = NDIM_EI 7929 N_CC_AMP = NCAAB 7930 END IF 7931 IF(NTEST.GE.10) THEN 7932 IF(I_DO_EI.EQ.0) THEN 7933 WRITE(6,*) ' Number of spin-adapted operators ', NSPA 7934 ELSE 7935 WRITE(6,*) ' Number of orthonormal zero-order states', 7936 & N_ZERO_EI 7937 END IF 7938 WRITE(6,*) ' Number of CAAB operators ', NCAAB 7939 WRITE(6,*) ' Number of CC amplitudes ', N_CC_AMP 7940* 7941 WRITE(6,*) ' Threshold for nonsingular metric eigenvalues =', 7942 & THRES_SINGU 7943 END IF 7944*. Number of spin adapted operators without the unitoperator 7945 NSPAM1 = NSPA - 1 7946 N_REF = XISPSM(IREFSM,IREFSPC) 7947*. Size of subspace Jacobian 7948 MXVEC_SBSPJA = 15 7949 IF(I_DO_SBSPJA.EQ.1) THEN 7950 WRITE(6,*) 7951 & ' Subspace Jacobian will be constructed. Max. dim of subspace ', 7952 & MXVEC_SBSPJA 7953 END IF 7954* 7955* ============================================== 7956* 1 : Set up zero-order Hamiltonian in WORK(KFIFA) 7957* ============================================== 7958* 7959*. It is assumed that one-body density over reference resides 7960* in WORK(KRHO1) 7961* 7962 CALL COPVEC(WORK(KINT1O),WORK(KFIFA),NINT1) 7963 IF(NTEST.GE.1000) THEN 7964 WRITE(6,*) ' The original one-body hamiltonian ' 7965 CALL APRBLM2(WORK(KINT1O),NTOOBS,NTOOBS,NSMOB,1) 7966 END IF 7967*. Calculate zero-order Hamiltonian : use either actual density 7968*. or Hartree-Fock densi 7969 I_ACT_OR_HF = 1 7970 IF(I_ACT_OR_HF.EQ.1) THEN 7971 WRITE(6,*) ' Zero-order Hamiltonian with actual density ' 7972 CALL FIFAM(WORK(KFIFA)) 7973 ELSE 7974 WRITE(6,*) ' Zero-order Hamiltonian with zero-order density ' 7975*. IPHGAS1 should be used to divide into H,P,V, but IPHGAS is used, so swap 7976 CALL ISWPVE(IPHGAS(1),IPHGAS1(1),NGAS) 7977* 7978 CALL COPVEC(WORK(KINT1O),WORK(KFIFA),NINT1) 7979 CALL FI(WORK(KFIFA),ECC,1) 7980 WRITE(6,*) ' FI before zeroing : ' 7981 CALL APRBLM2(WORK(KFIFA),NTOOBS,NTOOBS,NSMOB,1) 7982*. And clean up 7983 CALL ISWPVE(IPHGAS,IPHGAS1,NGAS) 7984*. zero offdiagonal elements 7985 IF(I_DO_EI.EQ.0) THEN 7986 CALL ZERO_OFFDIAG_BLM(WORK(KFIFA),NSMOB,NTOOBS,1) 7987 END IF 7988 END IF 7989* 7990 IF(NTEST.GE.00) THEN 7991 WRITE(6,*) ' One-body zero-order Hamiltonian ' 7992 CALL APRBLM2(WORK(KFIFA),NTOOBS,NTOOBS,NSMOB,1) 7993 END IF 7994*. Scratch space for CI - has already been allocated in EI approach 7995 IF(I_DO_EI.EQ.0) THEN 7996 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 7997 KVEC1P = KVEC1 7998 KVEC2P = KVEC2 7999 END IF 8000* 8001* ===================================================================== 8002* Obtain metric matrix and nonsingular set of operators in WORK(KLXMAT) 8003* ===================================================================== 8004*. Some additional scratch, dominated by two complete matrices !! 8005*. And a few working vectors 8006 CALL MEMMAN(KLVCC1,N_CC_AMP,'ADDL ',2,'VCC1 ') 8007 CALL MEMMAN(KLVCC2,N_CC_AMP,'ADDL ',2,'VCC2 ') 8008 CALL MEMMAN(KLVCC3,N_CC_AMP,'ADDL ',2,'VCC3 ') 8009 CALL MEMMAN(KLVCC4,N_CC_AMP,'ADDL ',2,'VCC4 ') 8010 CALL MEMMAN(KLRHS ,N_CC_AMP,'ADDL ',2,'RHS ') 8011 CALL MEMMAN(KLC1 ,N_CC_AMP,'ADDL ',2,'C1 ') 8012 CALL MEMMAN(KLC1O ,N_CC_AMP,'ADDL ',2,'C1 ') 8013 CALL MEMMAN(KLC_REF,N_REF ,'ADDL ',2,'C_REF ') 8014 CALL MEMMAN(KLI_REF,N_REF ,'ADDL ',1,'I_REF ') 8015 IF(I_DO_SBSPJA.EQ.1) THEN 8016 LSBSPJA = 5*MXVEC_SBSPJA**2 + 2*MXVEC_SBSPJA 8017 CALL MEMMAN(KLSBSPJA,LSBSPJA,'ADDL ',2,'SBSPJA') 8018 ELSE 8019 LSBSPJA = 0 8020 KLSBSPJA = 1 8021 END IF 8022*. Identify the unit operator i.e. the operator with 8023*. zero creation and annihilation operators 8024 IDOPROJ = 1 8025 IF(IDOPROJ.EQ.1) THEN 8026 CALL GET_SPOBTP_FOR_EXC_LEVEL(0,WORK(KLCOBEX_TP),NSPOBEX_TP, 8027 & NUNIOP,IUNITP,WORK(KLSOX_TO_OX)) 8028*. And the position of the unitoperator in the list of SPOBEX operators 8029 WRITE(6,*) ' NUNIOP, IUNITP = ', NUNIOP,IUNITP 8030 IF(NUNIOP.EQ.0) THEN 8031 WRITE(6,*) ' Unitoperator not found in exc space ' 8032 WRITE(6,*) ' I will proceed without projection ' 8033 IDOPROJ = 0 8034 ELSE 8035 IUNIOP = IFRMR(WORK(KLIBSOBEX),1,IUNITP) 8036 IF(NTEST.GE.100) WRITE(6,*) ' IUNIOP = ', IUNIOP 8037 END IF 8038 END IF 8039* 8040* We will iterate over optimization of internal and external 8041* parts of the CC wavefunction, allowed number of iteration 8042*. 8043*. Flag for iterative calculation 8044 IF(I_DO_EI.EQ.1) THEN 8045 I_IT_OR_DIR_IN_EXT = 1 8046 ELSE 8047 I_IT_OR_DIR_IN_EXT = 1 8048 END IF 8049*. Will we allow relaxation of coefficients defining reference 8050*. state 8051 I_RELAX_INT = 1 8052*. Will direct or iterative methods be used for relaxing 8053*. reference coefficients 8054 I_IT_OR_DIR_IN_RELAX = 1 8055*. Space for external correlation vector 8056 CALL MEMMAN(KLTEXT,N_CC_AMP,'ADDL ',2,'T_EXT ') 8057* 8058*. Initial T_EXT : zero or readin 8059* 8060 IF(IRESTRT_IC.EQ.0) THEN 8061 ZERO = 0.0D0 8062 CALL SETVEC(WORK(KLTEXT),ZERO,NCAAB) 8063*. Store inital guess on unit 54 in CAAB form 8064 CALL VEC_TO_DISC(WORK(KLTEXT),NCAAB,1,-1,LUSC54) 8065 ELSE 8066 WRITE(6,*) ' T_ext restarted from LU54' 8067 CALL VEC_FROM_DISC(WORK(KLTEXT),NCAAB,1,-1,LUSC54) 8068 WRITE(6,*) 'T_EXT read in ' 8069 END IF 8070*. Allocate vectors for CI behind the curtain 8071 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 8072 KVEC1P = KVEC1 8073 KVEC2P = KVEC2 8074* 8075 IF(IRESTRT_IC.EQ.1) THEN 8076*. Copy old CI coefficients for reference space to LUC 8077 CALL REWINO(LUC) 8078 CALL COPVCD(LUSC54,LUC,WORK(KVEC1),0,-1) 8079 WRITE(6,*) ' Internal coefs copied from LUSC54' 8080 END IF 8081 8082* 8083 MAXITG = MAXITM 8084 CONVER =.FALSE. 8085 CONVERL =.FALSE. 8086*. Convergence threshold for norm of vectorfunction 8087 VTHRES = 1.0D-11 8088 DO IT_IE = 1, MAXITG 8089 IDUM = 0 8090* 8091* =============================================== 8092*. Optimize T for current internal coefficients 8093* =============================================== 8094* 8095C? WRITE(6,*) ' ITREFSPC before call to ICCC ', ITREFSPC 8096 8097 IF(IT_IE.EQ.1) THEN 8098 INI_IT = 1 8099 ELSE 8100 INI_IT = 0 8101 END IF 8102 IF(IT_IE.EQ.MAXITG) THEN 8103 IFIN_IT = 1 8104 ELSE 8105 IFIN_IT = 0 8106 END IF 8107*. use DIIS/CROP to accelerate 8108 IDIIS = 2 8109*. Use approach where internal and external parts are 8110*. optimized simultaneously. 8111 ISIMULT = 1 8112* 8113*. In the calculation of the MRCC vector function 3 spaces 8114*. will be used 8115* 1 : IREFSPC : Space of !0> 8116* 2 : IT2REFSPC : Space of T!0> 8117* 3 : ITREFSPC : Largest space needed in the calculation of e(-T) H e(T) 8118*. In the following it will be assumed that IT2REFSPC is the space BEFORE 8119*. ITREFSPC 8120 IT2REFSPC = ITREFSPC 8121 IT2REFSPC = ITREFSPC - 1 8122C? WRITE(6,*) ' After Mod: ITREFSPC, IT2REFSPC=', 8123C? & ITREFSPC, IT2REFSPC 8124C? WRITE(6,*) ' Space for T !0> : ', IT2REFSPC 8125*. Readin C_REF 8126 CALL REWINO(LUC) 8127 CALL FRMDSCN(WORK(KLC_REF),-1,-1,LUC) 8128* 8129 8130 I_DO_COMP = 0 8131 IF(I_DO_COMP.EQ.1) THEN 8132 WRITE(6,*) ' Note: Complete matrix flag activated' 8133 WRITE(6,*) ' Note: Complete matrix flag activated' 8134 WRITE(6,*) ' Note: Complete matrix flag activated' 8135 WRITE(6,*) ' Note: Complete matrix flag activated' 8136 WRITE(6,*) ' Note: Complete matrix flag activated' 8137 WRITE(6,*) ' Note: Complete matrix flag activated' 8138 WRITE(6,*) ' Note: Complete matrix flag activated' 8139 WRITE(6,*) ' Note: Complete matrix flag activated' 8140 WRITE(6,*) ' Note: Complete matrix flag activated' 8141 WRITE(6,*) ' Note: Complete matrix flag activated' 8142 WRITE(6,*) ' Note: Complete matrix flag activated' 8143 WRITE(6,*) ' Note: Complete matrix flag activated' 8144 WRITE(6,*) ' Note: Complete matrix flag activated' 8145 WRITE(6,*) ' Note: Complete matrix flag activated' 8146 WRITE(6,*) ' Note: Complete matrix flag activated' 8147 END IF 8148* 8149 I_REDO_INT = 1 8150* 8151 I_CAAB_OR_ORT = 2 8152 IF(I_CAAB_OR_ORT.EQ.1) THEN 8153 CALL ICCC_OPT_SIMULT( 8154 & IREFSPC,ITREFSPC,IT2REFSPC,I_SPIN_ADAPT, 8155 & NROOT,WORK(KLTEXT),C_0,INI_IT,IFIN_IT, 8156 & WORK(KVEC1),WORK(KVEC2),IDIIS, 8157 & WORK(KLC_REF),N_REF,I_DO_COMP,CONVERL,VTHRES, 8158 & I_REDO_INT,EFINAL,VNFINAL,CONVER, 8159 & WORK(KLSBSPJA),MXVEC_SBSPJA,I_FIX_INTERNAL) 8160 ELSE 8161 CALL ICCC_OPT_SIMULT_ONB( 8162 & IREFSPC,ITREFSPC,IT2REFSPC,I_SPIN_ADAPT, 8163 & NROOT,WORK(KLTEXT),C_0,INI_IT,IFIN_IT, 8164 & WORK(KVEC1),WORK(KVEC2),IDIIS, 8165 & WORK(KLC_REF),N_REF,I_DO_COMP,CONVERL,VTHRES, 8166 & I_REDO_INT,EFINAL,VNFINAL,CONVER, 8167 & WORK(KLSBSPJA),MXVEC_SBSPJA,I_FIX_INTERNAL) 8168 END IF 8169*. transfer new C_REF to file LUC 8170 CALL ISTVC2(WORK(KLI_REF),0,1,N_REF) 8171 CALL REWINO(LUC) 8172 CALL WRSVCD(LUC,-1,WORK(KVEC1),WORK(KLI_REF), 8173 & WORK(KLC_REF),N_REF,N_REF,LUDIA,1) 8174*. Save current T_ext in CAAB form and CI coefs on LUSC54 8175 CALL VEC_TO_DISC(WORK(KLTEXT),NCAAB,1,-1,LUSC54) 8176 CALL WRSVCD(LUSC54,-1,WORK(KVEC1),WORK(KLI_REF), 8177 & WORK(KLC_REF),N_REF,N_REF,LUDIA,1) 8178 REWIND(LUSC54) 8179 IF(CONVER) GOTO 1001 8180* 8181 IF(ISIMULT.EQ.0.AND.I_RELAX_INT.EQ.1) THEN 8182* ============================================================ 8183*. Relax coefficients of internal/reference/zero-order state 8184* ============================================================ 8185* 8186*. Three vectors are actually allocated and kept in ICCC_COMPLETE.. 8187*. so these could and should be reused 8188 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICCREL') 8189* 8190 IF(I_IT_OR_DIR_IN_RELAX.EQ.2) THEN 8191* 8192*. Construct complete matrices and diagonalize 8193* 8194*. Space for H and S in zero-order space 8195 N_REF = XISPSM(IREFSM,IREFSPC) 8196 CALL MEMMAN(KLH_REF,N_REF**2,'ADDL ',2,'H_REF ') 8197 CALL MEMMAN(KLS_REF,N_REF**2,'ADDL ',2,'S_REF ') 8198* 8199C ICCC_RELAX_REFCOEFS_COM(T_EXT,H_REF,N_REF, 8200C & NCOMMU,VEC1,VEC2,IREFSPC,ITREFSPC, 8201C & ECORE,C_REF_OUT,IREFROOT) 8202 CALL ICCC_RELAX_REFCOEFS_COM(WORK(KLTEXT), 8203 & WORK(KLH_REF),N_REF,NCOMMU_E,WORK(KVEC1), 8204 & WORK(KVEC2), 8205 & IREFSPC,ITREFSPC,ECORE,WORK(KLC_REF),NROOT) 8206*. transfer new reference vector to DISC 8207 CALL ISTVC2(WORK(KLI_REF),0,1,N_REF) 8208C WRSVCD(LU,LBLK,VEC1,IPLAC,VAL,NSCAT,NDIM,LUFORM,JPACK) 8209 CALL REWINO(LUC) 8210 CALL WRSVCD(LUC,-1,WORK(KVEC1),WORK(KLI_REF), 8211 & WORK(KLC_REF),N_REF,N_REF,LUDIA,1) 8212 ELSE 8213 WRITE(6,*) ' Iterative ICCC not working yet ' 8214 END IF 8215*. ^ End of switch direct/iterative methods for reference 8216*. relaxation 8217 CALL MEMMAN(IDUM,IDUM,'FLUSM',IDUM,'ICCREL') 8218 END IF 8219*. ^ End of reference coefs should be relaxed 8220 END DO 8221*. ^ End of loop over Internal/external correlation iterations 8222 1001 CONTINUE 8223* 8224 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ICCC ') 8225 RETURN 8226 END 8227 SUBROUTINE MRCC_VECFNC(CCVECFNC,T,NCOMMU,I_APPROX_HCOM, 8228 & IREFSPC,ITREFSPC,IT2REFSPC,CCVECFNCI) 8229* 8230* Obtain external and internal parts of the MRCC vector function 8231* 8232* External part : 8233* ================ 8234* 8235* <0!tau^{\dagger} exp(-T) H exp(T) !0>. 8236* 8237*. Internal part 8238* ================ 8239* 8240* <J! exp(-T) H exp(T) !0> 8241* 8242* Input and output vectors are in CAAB basis. 8243*. The commutator exp(-T) H exp(T) is terminated after NCOMMU commutators 8244* (initial version using CI behind the curtains) 8245* 8246* Jeppe Olsen, August 2005 8247* Latest modification : September 2005, IT2REFSPC added 8248* 8249 INCLUDE 'wrkspc.inc' 8250 INCLUDE 'crun.inc' 8251 INCLUDE 'clunit.inc' 8252 INCLUDE 'cands.inc' 8253 INCLUDE 'glbbas.inc' 8254 INCLUDE 'cstate.inc' 8255 INCLUDE 'oper.inc' 8256 INCLUDE 'cintfo.inc' 8257*. Specific input 8258 DIMENSION T(*) 8259*. Output 8260 DIMENSION CCVECFNC(*),CCVECFNCI(*) 8261* 8262 NTEST = 00 8263 IF(NTEST.GE.100) THEN 8264 WRITE(6,*) ' Output from MRCC_VECFNC' 8265 WRITE(6,*) ' -----------------------' 8266 WRITE(6,*) ' IREFSPC,ITREFSPC, IT2REFSPC =', 8267 & IREFSPC,ITREFSPC, IT2REFSPC 8268 END IF 8269* 8270 IDUM = 0 8271 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'MRCCVF') 8272* 8273* 1 : Obtain exp(-T) H exp(T) !0> and save on LUHC 8274* 8275C EMNTHETO(T,LUOUT,NCOMMU,IREFSPC,ITREFSPC) 8276 IF(I_APPROX_HCOM.EQ.0) THEN 8277 CALL EMNTHETO(T,LUC,LUHC,NCOMMU,IREFSPC,ITREFSPC,IT2REFSPC) 8278 ELSE 8279*. Exact calculation of all terms with upto NCOMMU-1 commutators 8280 CALL EMNTHETO(T,LUC,LUHC,NCOMMU-1,IREFSPC,ITREFSPC,IT2REFSPC) 8281*. and add contribution from highest commutaror 8282*. At the moment FULL Hamiltonian is used for testing 8283COLD WRITE(6,*) ' Note : Full Hamiltonian is used in highest commu' 8284*. Use zero-order Hamiltonian stored in 8285 I12 = 1 8286 CALL SWAPVE(WORK(KINT1),WORK(KFIFA),NINT1) 8287 CALL TCOM_H_N(T,LUC,LUHC,NCOMMU,IREFSPC,ITREFSPC,IT2REFSPC,1) 8288C TCOM_H_N(T,LUINI,LUUT,NCOMMU,IREFSPC,ITREFSPC,IT2REFSPC,IAC) 8289 I12 = 2 8290 CALL SWAPVE(WORK(KINT1),WORK(KFIFA),NINT1) 8291 END IF 8292* 8293* 2 : Obtain <0!tau^{\dagger} exp(-T) H exp(T) !0> = <LUC!tau^{\dagger}|LUHC> 8294* 8295 ICSPC = IREFSPC 8296 ISSPC = IT2REFSPC 8297C WRITE(6,*) ' IREFSPC, IT2REFSPC =', IREFSPC, IT2REFSPC 8298 IF(NTEST.GE.1000) THEN 8299 WRITE(6,*) ' Vector on LUC ' 8300 CALL WRTVCD(WORK(KVEC1P),LUC,1,-1) 8301 WRITE(6,*) ' Vector on LUHC ' 8302 CALL WRTVCD(WORK(KVEC1P),LUHC,1,-1) 8303 END IF 8304* 8305 ZERO = 0.0D0 8306 CALL SETVEC(CCVECFNC,ZERO,N_CC_AMP) 8307 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUHC,CCVECFNC,2) 8308 IF(NTEST.GE.1000) THEN 8309 WRITE(6,*) 'CCVECFNC right after SIGDEN_CC' 8310 CALL WRTMAT(CCVECFNC,1,N_CC_AMP,1,N_CC_AMP) 8311 END IF 8312 8313* 8314* 3 : Contract exp(-T) H exp(T) |0> to reference space and save on LUHC 8315* to obtain internal part of MRCC vector function 8316* 8317 CALL EXPCIV(IREFSM,IT2REFSPC,LUHC,IREFSPC,LUSC34,-1, 8318 / LUSC35,1,1,IDC,0) 8319 CALL REWINO(LUHC) 8320 CALL FRMDSCN(CCVECFNCI,-1,-1,LUHC) 8321* 8322 IF(NTEST.GE.100) THEN 8323 WRITE(6,*) ' Input T-coefficients ' 8324 CALL WRTMAT(T,1,N_CC_AMP,1,N_CC_AMP) 8325 WRITE(6,*) ' MRCC Vector function, external part ' 8326 CALL WRTMAT(CCVECFNC,1,N_CC_AMP,1,N_CC_AMP) 8327 WRITE(6,*) 'first element of MRCC Vector function,internal part' 8328 WRITE(6,*) ' (before subtracting E-term )' 8329 CALL WRTMAT(CCVECFNCI,1,1,1,1) 8330 END IF 8331* 8332 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'MRCCVF') 8333* 8334 8335 RETURN 8336 END 8337 SUBROUTINE EMNTHETO(T,LUINI,LUUT,NCOMMU,IREFSPC,ITREFSPC, 8338 & IT2REFSPC) 8339* 8340*. Obtain on LUOUT exp(-T) H exp(T) !0>, truncated after NCOMMU commutators 8341*. Input in CAAB basis 8342* Output on LUOT in SD basis 8343*. LUUT should differ from scratch files used below, one possible choice is LUHC 8344*. Scratch files in use : LUSC1, LUSC2, LUSC3, LUSC34 8345*. Jeppe Olsen, August 2005 8346* 8347* The three spaces : IREFSPC : Space of !0> 8348* ITREFSPC : Largest space required for the calculation of 8349* exp(-T) H exp(T) !0> 8350* IT2REFSPC : Space for T !0> 8351*. Final vector is delivered in space IT2REFSPC 8352* 8353 INCLUDE 'wrkspc.inc' 8354 INCLUDE 'crun.inc' 8355 INCLUDE 'cstate.inc' 8356 INCLUDE 'cands.inc' 8357 INCLUDE 'glbbas.inc' 8358 INCLUDE 'clunit.inc' 8359* 8360*. Specific input 8361 DIMENSION T(*) 8362*. We are after Sum(N=0,Ncommu,i=0,N)(-1)^(N-I) 1/N! T^(N-I) H T^I |0> 8363*. So realize the calculation as a double loop 8364* 8365 NTEST = 00 8366 IF(NTEST.GE.10) THEN 8367 WRITE(6,*) ' exp(-T) H Exp(T) |0> will be constructed ' 8368 WRITE(6,*) ' Input T-coefficients ' 8369 CALL WRTMAT(T,1,N_CC_AMP,1,N_CC_AMP) 8370 WRITE(6,*) ' EMNTHETO: IREFSPC, ITREFSPC, IT2REFSPC =', 8371 & IREFSPC, ITREFSPC, IT2REFSPC 8372 END IF 8373* 8374 IDUM = 0 8375 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'EMNTH ') 8376* 8377* LUINI : Initial expansion |0> 8378* LUSC1 : T^I |0> 8379* LUSC2 : H T^I |0> 8380* LUSC3 : T^N-I H T^I |0> 8381* 8382 ONE = 1.0D0 8383* 8384 DO I = 0, NCOMMU 8385 ICSPC = ITREFSPC 8386 ISSPC = ITREFSPC 8387 IF(I.EQ.0) THEN 8388*. Expand |0> in IREFSPC on LUINI to ITREFSPC on LUSC1 8389 CALL EXPCIV(IREFSM,IREFSPC,LUINI,ITREFSPC,LUSC1,-1, 8390 / LUSC34,1,0,IDC,NTEST) 8391C EXPCIV(ISM,ISPCIN,LUIN, 8392C & ISPCUT,LUUT,LBLK, 8393C & LUSCR,NROOT,ICOPY,IDC,NTESTG) 8394 ELSE 8395*T^(I-1)|0> => T^I |0> 8396 CALL REWINO(LUSC1) 8397 CALL REWINO(LUSC2) 8398 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUSC34,T,1) 8399 CALL COPVCD(LUSC34,LUSC1,WORK(KVEC1P),1,-1) 8400 END IF 8401 IF(NTEST.GE.1000) THEN 8402 WRITE(6,*) ' T^I |0> for I = ',I 8403 CALL WRTVCD(WORK(KVEC1P),LUSC1,1,-1) 8404 END IF 8405*. Calculate H T^I |0> and save on LUSC2 8406*. Space of H T^I |0> may be reduced to IT2REFSPC 8407 ICSPC = ITREFSPC 8408 ISSPC = IT2REFSPC 8409C? WRITE(6,*) ' MV7 will be called with ISSPC=IT2REFSPC' 8410 CALL MV7(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUSC2,0,0) 8411 IF(NTEST.GE.1000) THEN 8412 WRITE(6,*) ' Output from MV7' 8413 CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 8414 END IF 8415*. Compress Sigma-vector to space IT2REFSPC 8416C WRITE(6,*) ' sigma vector will be contracted to IT2REFSPC' 8417C CALL EXPCIV(1,ITREFSPC,LUSC2,IT2REFSPC,LUSC3,-1, 8418C & LUSC34,1,1,IDC,NTEST) 8419 8420*. C space may now also be restricted to IT2REFSPC 8421 ISSPC = IT2REFSPC 8422 ICSPC = IT2REFSPC 8423 IF(NTEST.GE.1000) THEN 8424 WRITE(6,*) ' H T^I |0> for I = ',I 8425 CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 8426 END IF 8427 DO NMI = 0, NCOMMU-I 8428 IF(NMI.EQ.0) THEN 8429*. Just copy H T^I |0> to LUSC3 8430 CALL COPVCD(LUSC2,LUSC3,WORK(KVEC1P),1,-1) 8431 ELSE 8432*. Calculate T^(N-I) H T^I |0> and save on LUSC3 8433 REWIND(LUSC3) 8434 REWIND(LUSC34) 8435 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC34,T,1) 8436 CALL COPVCD(LUSC34,LUSC3,WORK(KVEC1P),1,-1) 8437 END IF 8438 IF(NTEST.GE.1000) THEN 8439 WRITE(6,*) ' T^(N-I) H T^I for N-I and I ', NMI,I 8440 CALL WRTVCD(WORK(KVEC1P),LUSC3,1,-1) 8441 END IF 8442* We are now ready to add (-1)^(N-I) 1/N! T^(N-I) H T^I |0> to result vector 8443 N = NMI + I 8444 IF(NMI.EQ.0) THEN 8445 XNMIFAC = 1.0D0 8446 ELSE 8447 XNMIFAC = XFAC(NMI) 8448 END IF 8449 IF(I.EQ.0) THEN 8450 XIFAC = 1.0D0 8451 ELSE 8452 XIFAC = XFAC(I) 8453 END IF 8454 IF(MOD(NMI,2).EQ.0) THEN 8455 FACTOR = 1.0D0/(XNMIFAC*XIFAC) 8456 ELSE 8457 FACTOR = -1.0D0/(XNMIFAC*XIFAC) 8458 END IF 8459*. First contribution : Just copy (factor is 1) 8460 IF(N.EQ.0) THEN 8461 CALL COPVCD(LUSC3,LUUT,WORK(KVEC1P),1,-1) 8462 IF(NTEST.GE.1000) THEN 8463 WRITE(6,*) ' Initial vector copied to LUUT ' 8464 CALL WRTVCD(WORK(KVEC1P),LUUT,1,-1) 8465 END IF 8466 ELSE 8467* add : LUUT = LUUT + FACTOR*LUSC3 8468C VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 8469 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),FACTOR,ONE,LUSC3,LUUT, 8470 & LUSC34,1,-1) 8471 CALL COPVCD(LUSC34,LUUT,WORK(KVEC1P),1,-1) 8472 IF(NTEST.GE.1000) THEN 8473 WRITE(6,*) ' LUUT opdated for I, NMI = ', I,NMI 8474 CALL WRTVCD(WORK(KVEC1P),LUUT,1,-1) 8475 END IF 8476 END IF 8477 END DO 8478* ^ End of loop over NMI 8479 END DO 8480* ^ End of loop over I 8481* 8482*. Test Contract from ITREFSPC to IT2REFSPC, save on LUSC34 8483* 8484C? WRITE(6,*) ' Output vector will be contracted to IT2REFSPC' 8485C? CALL EXPCIV(1,ITREFSPC,LUUT,IT2REFSPC,LUSC1,-1, 8486C? & LUSC34,1,1,IDC,NTEST) 8487 IF(NTEST.GE.100) THEN 8488 WRITE(6,*) ' exp(-T) H exp(T) |0> ' 8489 CALL WRTVCD(WORK(KVEC1P),LUUT,1,-1) 8490 END IF 8491* 8492 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'EMNTH ') 8493 RETURN 8494 END 8495 SUBROUTINE COM_JMRCC(T,NCOMMU,I_APPROX_HCOM,XJ,VCC1,VCC2,VCC3, 8496 & VCC4, 8497 & N_CC_AMP,NSPAM1,NNONSING,IREFSPC,ITREFSPC, 8498 & XNONSING) 8499* 8500* Construct - by finite difference - the MRCC Jacobian for current 8501* set of amplitudes 8502* 8503* For the finite difference the following form is used 8504* 8505* F' = (8*F(DELTA)-8*F(-DELTA)-E(2*DELTA)+E(2*DELTA))/(12*DELTA) 8506* 8507* The Jacobian will be returned in the Nonsingular basis as 8508* defined by XNONSING. 8509* 8510* Jeppe Olsen, Aug. 2005 8511* 8512* Latest modification : Sept 2005, New form of call to MRCC_VECFNC 8513* 8514* 8515 INCLUDE 'wrkspc.inc' 8516 REAL*8 INPRDD 8517* 8518 INCLUDE 'cands.inc' 8519 INCLUDE 'cstate.inc' 8520*. Input 8521 DIMENSION T(*), XNONSING(NSPAM1,NNONSING) 8522*. T is on input assumed to be in CAAB basis ! 8523*. Output 8524 DIMENSION XJ(NNONSING,NNONSING) 8525*. Scratch 8526 DIMENSION VCC1(*),VCC2(*),VCC3(*),VCC4(*) 8527* 8528 IDUM = 0 8529 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'COM_JM') 8530* 8531 NTEST = 10 8532 IF(NTEST.GE.10) THEN 8533 WRITE(6,*) ' COM_JMRCC speaking ' 8534 WRITE(6,*) ' IREFSPC, ITREFSPC = ', IREFSPC,ITREFSPC 8535 END IF 8536*. CC vector function at point of expansion in VCC2 8537 CALL MRCC_VECFNC(VCC2,T,NCOMMU,I_APPROX_HCOM,IREFSPC,ITREFSPC, 8538 & ITREFSPC,VCC2(1+N_CC_AMP)) 8539*. Transform to SPA basis and save in VCC1 8540 CALL REF_CCV_CAAB_SP(VCC2,VCC1,VCC3,1) 8541*. and to orthonormal basis, save in VCC1 8542C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 8543 CALL MATVCC(XNONSING,VCC2,VCC1,NSPAM1,NNONSING,1) 8544*. Dimension of space in which S or H is constructed 8545 DELTA = 0.0001D0 8546 DELTAM = -DELTA 8547 DELTA2= 2.0D0*DELTA 8548 DELTA2M = -2.0D0*DELTA 8549* 8550 ONE = 1.0D0 8551 ONEM = -1.0D0 8552 EIGHT = 8.0D0 8553 EIGHTM = -8.0D0 8554C DO I = 1, NSPAM1 8555 DO I = 1, NNONSING 8556 IF(NTEST.GE.10) 8557 & WRITE(6,*) ' Jacobian will be constructed, column = ', I 8558*. Transform I'th direction to CAAB basis and save in VCC1 8559 CALL REF_CCV_CAAB_SP(VCC1,XNONSING(1,I),VCC2,2) 8560* =================== 8561* a : 8*vecfnc(Delta) 8562* =================== 8563*. ( T + delta Xnonsing(*,I)) in VCC2 8564 CALL VECSUM(VCC2,VCC1,T,DELTA,ONE,N_CC_AMP) 8565*. Vecfnc( T + delta Xnonsing(*,I)) in VCC3 8566 CALL MRCC_VECFNC(VCC3,VCC2,NCOMMU,I_APPROX_HCOM,IREFSPC,ITREFSPC, 8567 & ITREFSPC,VCC3(1+N_CC_AMP)) 8568*. Transform to SPA basis and save in VCC2 8569 CALL REF_CCV_CAAB_SP(VCC3,VCC2,VCC4,1) 8570C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 8571*. and to orthonormal basis, save in VCC3 8572C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 8573 CALL MATVCC(XNONSING,VCC2,VCC3,NSPAM1,NNONSING,1) 8574*. Save 8*Vecfnc(Delta*X(I)) in XJ(1,I) 8575 CALL COPVEC(VCC3,XJ(1,I),NNONSING) 8576 CALL SCALVE(XJ(1,I),EIGHT,NNONSING) 8577 IF(NTEST.GE.1000) THEN 8578 WRITE(6,*) ' XJ(1,I), first term ' 8579 CALL WRTMAT(XJ(1,I),1,NSPAM1,1,NSPAM1) 8580 END IF 8581* =================== 8582* b : 8*vecfnc(-Delta) 8583* =================== 8584*. ( T - delta Xnonsing(*,I)) in VCC2 8585 CALL VECSUM(VCC2,VCC1,T,DELTAM,ONE,N_CC_AMP) 8586*. Vecfnc( T - delta Xnonsing(*,I)) in VCC3 8587 CALL MRCC_VECFNC(VCC3,VCC2,NCOMMU,I_APPROX_HCOM,IREFSPC,ITREFSPC, 8588 & ITREFSPC,VCC3(1+N_CC_AMP)) 8589*. Transform to SPA basis and save in VCC2 8590 CALL REF_CCV_CAAB_SP(VCC3,VCC2,VCC4,1) 8591C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 8592*. and to orthonormal basis, save in VCC3 8593C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 8594 CALL MATVCC(XNONSING,VCC2,VCC3,NSPAM1,NNONSING,1) 8595*. Save 8*Vecfnc(Delta*X(I)) in XJ(1,I) 8596 CALL VECSUM(XJ(1,I),XJ(1,I),VCC3,ONE,EIGHTM,NNONSING) 8597 IF(NTEST.GE.1000) THEN 8598 WRITE(6,*) ' XJ(1,I), second term ' 8599 CALL WRTMAT(XJ(1,I),1,NSPAM1,1,NSPAM1) 8600 END IF 8601* =================== 8602* c : vecfnc(2*Delta) 8603* =================== 8604*. ( T +2*delta Xnonsing(*,I)) in VCC2 8605 CALL VECSUM(VCC2,VCC1,T,DELTA2,ONE,N_CC_AMP) 8606*. Vecfnc( T +2*delta Xnonsing(*,I)) in VCC3 8607 CALL MRCC_VECFNC(VCC3,VCC2,NCOMMU,I_APPROX_HCOM,IREFSPC,ITREFSPC, 8608 & ITREFSPC,VCC3(1+N_CC_AMP)) 8609*. Transform to SPA basis and save in VCC2 8610 CALL REF_CCV_CAAB_SP(VCC3,VCC2,VCC4,1) 8611C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 8612*. and to orthonormal basis, save in VCC3 8613C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 8614 CALL MATVCC(XNONSING,VCC2,VCC3,NSPAM1,NNONSING,1) 8615*. add -Vecfnc(2Delta*X(I)) in XJ(1,I) 8616 CALL VECSUM(XJ(1,I),XJ(1,I),VCC3,ONE,ONEM,NNONSING) 8617 IF(NTEST.GE.1000) THEN 8618 WRITE(6,*) ' XJ(1,I), third term ' 8619 CALL WRTMAT(XJ(1,I),1,NSPAM1,1,NSPAM1) 8620 END IF 8621* =================== 8622* d : vecfnc(-2*Delta) 8623* =================== 8624*. ( T - 2*delta Xnonsing(*,I)) in VCC2 8625 CALL VECSUM(VCC2,VCC1,T,DELTA2M,ONE,N_CC_AMP) 8626*. Vecfnc( T +2*delta Xnonsing(*,I)) in VCC3 8627 CALL MRCC_VECFNC(VCC3,VCC2,NCOMMU,I_APPROX_HCOM,IREFSPC,ITREFSPC, 8628 & ITREFSPC,VCC3(1+N_CC_AMP)) 8629*. Transform to SPA basis and save in VCC2 8630 CALL REF_CCV_CAAB_SP(VCC3,VCC2,VCC4,1) 8631C REF_CCV_CAAB_SP(VEC_CAAB,VEC_SP,VEC_SCR,IWAY) 8632*. and to orthonormal basis, save in VCC3 8633C MATVCC(A,VIN,VOUT,NROW,NCOL,ITRNS) 8634 CALL MATVCC(XNONSING,VCC2,VCC3,NSPAM1,NNONSING,1) 8635*. add Vecfnc(-2Delta*X(I)) in XJ(1,I) 8636 CALL VECSUM(XJ(1,I),XJ(1,I),VCC3,ONE,ONE,NNONSING) 8637 IF(NTEST.GE.1000) THEN 8638 WRITE(6,*) ' XJ(1,I), Fourth term ' 8639 CALL WRTMAT(XJ(1,I),1,NSPAM1,1,NSPAM1) 8640 END IF 8641*. and scale 8642 FACTOR = 1.0D0/(12.0D0*DELTA) 8643 CALL SCALVE(XJ(1,I),FACTOR,NNONSING) 8644 END DO 8645* ^ End of loop over nonsingular modes 8646* 8647 IF(NTEST.GE.100) THEN 8648 WRITE(6,*) ' Constructed Jacobian matrix ' 8649 WRITE(6,*) ' ==================== ' 8650 CALL WRTMAT(XJ,NNONSING,NNONSING,NNONSING,NNONSING) 8651 END IF 8652* 8653 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'COM_JM') 8654* 8655 RETURN 8656 END 8657 SUBROUTINE LINSOL_FROM_LUCOMP(XL,XU,RHS,X,NDIM,SCR1) 8658* 8659* Solve linear set of equations from matrix given in LU decomposition 8660* 8661* L U X = RHS 8662* 8663* is solved in two steps 8664* 8665* 1) L Y = RHS 8666* 2) U X = Y 8667* 8668* Jeppe Olsen, Aug. 2005 8669* 8670* LU are given in the form defined by routine LULU 8671* 8672* L(I,J) = L(I*(I-1)/2 + J ) ( I .GE. J ) 8673* U(I,J) = U(J*(J-1)/2 + I ) ( J .GE. I ) 8674* 8675 INCLUDE 'implicit.inc' 8676*. Input 8677 DIMENSION XL(NDIM*(NDIM+1)/2), XU(NDIM*(NDIM+1)/2), RHS(NDIM) 8678*. Output 8679 DIMENSION X(NDIM) 8680*. Scratch 8681 DIMENSION SCR1(NDIM) 8682* 8683 NTEST = 10 8684 IF(NTEST.GE.10) THEN 8685 WRITE(6,*) ' LINSOL_FROM_LUCOM speaking ' 8686 END IF 8687* 8688* 1 : L Y = RHS by forward substitution and store in SCR1 8689* 8690 DO I = 1, NDIM 8691*. sum(J=1,I-1) L(I,J)Y(J) 8692 SUM = 0.0D0 8693 DO J = 1, I-1 8694 SUM = SUM + XL(I*(I-1)/2+J)*SCR1(J) 8695 END DO 8696 SCR1(I) = (RHS(I)-SUM)/XL(I*(I-1)/2+I) 8697 END DO 8698 IF(NTEST.GE.1000) THEN 8699 WRITE(6,*) ' Solution to L Y = RHS ' 8700 CALL WRTMAT(SCR1,1,NDIM,1,NDIM) 8701 END IF 8702* 8703* 2 : U X = Y by backwards substitution 8704* 8705 DO I = NDIM, 1, -1 8706*. sum(J=I+1,NDIM) U(I,J)*X(J) 8707 SUM = 0.0D0 8708 DO J = I+1, NDIM 8709 SUM = SUM + XU(J*(J-1)/2+I)*X(J) 8710 END DO 8711 X(I) = (SCR1(I)-SUM)/XU(I*(I-1)/2+I) 8712 END DO 8713* 8714 IF(NTEST.GE.100) THEN 8715 WRITE(6,*) ' RHS ' 8716 CALL WRTMAT(RHS,1,NDIM,1,NDIM) 8717 WRITE(6,*) ' Solution to set of linear equations ' 8718 CALL WRTMAT(X,1,NDIM,1,NDIM) 8719 END IF 8720* 8721 RETURN 8722 END 8723 SUBROUTINE ICCC_RELAX_REFCOEFS_COM(T_EXT,H_REF,N_REF, 8724 & NCOMMU,VEC1,VEC2,IREFSPC,ITREFSPC, 8725 & ECORE,C_REF_OUT,IREFROOT) 8726* 8727* 8728* Relax internal coefficients for MRCC wave function 8729* Initial version generating complete matrices 8730* 8731* The wave-function is given as 8732* 8733* |MRCC > = exp(T) |0 > 8734* 8735* and we want to solve the equations 8736* 8737* sum_J <I!exp(-T)H exp(T)!J> C(J) = E C(J) 8738* 8739* ( note that the metric disappears ) 8740* 8741*. Jeppe Olsen, August 2005 8742* NOTE : ONLY PROGRAMMED FOR LOWEST ROOT - Easy to modify ... 8743 INCLUDE 'wrkspc.inc' 8744 REAL*8 INPRDD, INPROD 8745* 8746 INCLUDE 'clunit.inc' 8747 INCLUDE 'crun.inc' 8748 INCLUDE 'cands.inc' 8749 INCLUDE 'cstate.inc' 8750*. Input : in CAAB form 8751 DIMENSION T_EXT(*) 8752*. Output 8753 DIMENSION H_REF(N_REF,N_REF) 8754 DIMENSION C_REF_OUT(*) 8755*. Scratch 8756 DIMENSION VEC1(*),VEC2(*) 8757* 8758 IDUM = 0 8759 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'CC_REL') 8760* 8761 WRITE(6,*) ' Code has should be modified to new MRCC vecfnc ' 8762 STOP ' Code has should be modified to new MRCC vecfnc ' 8763* 8764 NTEST = 10 8765 IF(NTEST.GE.2) THEN 8766 WRITE(6,*) ' Reoptimization of internal coefficients' 8767 WRITE(6,*) ' =======================================' 8768 IF(IDIIS.EQ.1) THEN 8769 WRITE(6,*) ' DIIS acceleration will be used ' 8770 END IF 8771 END IF 8772 IF(NTEST.GE.10) THEN 8773 WRITE(6,*) ' IREFSPC, ITREFSPC ', IREFSPC,ITREFSPC 8774 WRITE(6,*) ' IREFROOT = ', IREFROOT 8775 END IF 8776* 8777 ICSPC = IREFSPC 8778 ISSPC = ITREFSPC 8779* 8780 DO J = 1, N_REF 8781 IF(NTEST.GE.10) WRITE(6,*) ' Column J = ', J 8782*. Place |J> on LUSC1 8783 CALL REWINO(LUSC36) 8784 CALL REWINO(LUDIA) 8785C WRSVCD(LU,LBLK,VEC1,IPLAC,VAL,NSCAT,NDIM,LUFORM,JPACK) 8786 ONE = 1.0D0 8787 CALL WRSVCD(LUSC36,-1,VEC1,J,ONE,1,N_REF,LUDIA,1) 8788 IF(NTEST.GE.1000) THEN 8789 WRITE(6,*) ' Input vector on LUSC36' 8790 CALL WRTVCD(VEC1,LUSC36,1,-1) 8791 END IF 8792*. 8793* 8794*. Obtain exp(-T) H exp(T) |J> on LUHC 8795C EMNTHETO(T,LUINI,LUOUT,NCOMMU,IREFSPC,ITREFSPC) 8796 CALL EMNTHETO(T_EXT,LUSC36,LUHC,NCOMMU,IREFSPC,ITREFSPC,ITREFSPC) 8797*. Contract exp(-T) H exp(T) |J> to reference space and save on LUHC 8798 CALL EXPCIV(IREFSM,ITREFSPC,LUHC,IREFSPC,LUSC34,-1, 8799 / LUSC35,1,1,IDC,0) 8800*. and read in - the J'th column of H_REF has been constructed 8801 CALL REWINO(LUHC) 8802 CALL FRMDSCN(H_REF(1,J),-1,-1,LUHC) 8803C FRMDSCN(VEC,NREC,LBLK,LU) 8804 END DO 8805* 8806 IF(NTEST.GE.100) THEN 8807 WRITE(6,*) ' The Effective H-matrix in reference space ' 8808 CALL WRTMAT(H_REF,N_REF,N_REF,N_REF,N_REF) 8809 END IF 8810* 8811** And diagonalize 8812* 8813C EIGGMTN(AMAT,NDIM,ARVAL,AIVAL,ARVEC,AIVEC,Z,W,SCR) 8814 CALL MEMMAN(KLEIGVA_R,N_REF ,'ADDL ',2,'EIGVAR') 8815 CALL MEMMAN(KLEIGVA_I,N_REF ,'ADDL ',2,'EIGVAI') 8816 CALL MEMMAN(KLEIGVC_R,N_REF**2,'ADDL ',2,'EIGVCR') 8817 CALL MEMMAN(KLEIGVC_I,N_REF**2,'ADDL ',2,'EIGVCI') 8818 CALL MEMMAN(KLZ,N_REF**2,'ADDL ',2,'Z_SCR ') 8819 CALL MEMMAN(KLW,N_REF ,'ADDL ',2,'W_SCR ') 8820 CALL MEMMAN(KLSCR ,2*N_REF ,'ADDL ',2,'EIGSCR') 8821 CALL EIGGMTN(H_REF,N_REF,WORK(KLEIGVA_R),WORK(KLEIGVA_I), 8822 & WORK(KLEIGVC_R),WORK(KLEIGVC_I), 8823 & WORK(KLZ),WORK(KLW),WORK(KLSCR)) 8824* 8825 IF(NTEST.GE.10) THEN 8826 WRITE(6,*) ' Real and imaginary parts of eigenvalues ' 8827 DO I = 1, N_REF 8828 WRITE(6,*) I,WORK(KLEIGVA_R-1+I),WORK(KLEIGVA_I-1+I) 8829 END DO 8830 END IF 8831*. Lowest eigenvalue - should really be eigenvalue IREFROOT - here 8832*. are the bits of codes that should be generalized to general roots 8833 IMIN = 1 8834 EIGMIN = WORK(KLEIGVA_R-1+1) 8835 DO I = 2, N_REF 8836 IF( WORK(KLEIGVA_R-1+I).LT.EIGMIN) THEN 8837 EIGMIN = WORK(KLEIGVA_R-1+I) 8838 IMIN = I 8839 END IF 8840 END DO 8841 WRITE(6,*) ' Root with lowest energy ', IMIN,EIGMIN 8842 IF(WORK(KLEIGVA_I-1+IMIN).NE.0.0D0) THEN 8843 WRITE(6,*) ' Warning : Complex eigenvalue ' 8844 WRITE(6,*) ' Real and imaginary parts ', 8845 & WORK(KLEIGVA_R-1+IMIN),WORK(KLEIGVA_I-1+IMIN) 8846 STOP ' Complex eigenvalue ' 8847 END IF 8848*. Copy the coefficients of root IROOT to C_REF_OUT 8849 CALL COPVEC(WORK(KLEIGVC_R+(IMIN-1)*N_REF),C_REF_OUT,N_REF) 8850*. Ensure standard normalization 8851 XNORM = SQRT(INPROD(C_REF_OUT,C_REF_OUT,N_REF)) 8852 FACTOR = 1.0D0/XNORM 8853 CALL SCALVE(C_REF_OUT,FACTOR,N_REF) 8854 IF(NTEST.GE.100) THEN 8855 WRITE(6,*) ' Updated coefficients of reference state' 8856 CALL WRTMAT(C_REF_OUT,1,N_REF,1,N_REF) 8857 END IF 8858* 8859 CALL MEMMAN(IDUM,IDUM,'FLUSM',IDUM,'CC_REL') 8860* 8861 RETURN 8862 END 8863 SUBROUTINE HEFF_INT_TV_ICCC(T_EXT,N_REF, 8864 & NCOMMU,IAPROX_HCOM,VEC1,VEC2,IREFSPC,ITREFSPC, 8865 & IT2REFSPC,ECORE,C_REF,S_REF) 8866* 8867*. Calculate Heff times vector in reference space for ICCC 8868* 8869*. S_REF = <I!exp(-T)H exp(T)|0> 8870*. where |0> is defined by C_REF 8871* 8872* 8873*. Jeppe Olsen, August 2005 8874* 8875 INCLUDE 'wrkspc.inc' 8876 INCLUDE 'clunit.inc' 8877 INCLUDE 'crun.inc' 8878 INCLUDE 'cands.inc' 8879 INCLUDE 'cstate.inc' 8880*. Input : in CAAB form 8881 DIMENSION T_EXT(*) 8882 DIMENSION C_REF(*) 8883*. Output 8884 DIMENSION S_REF(N_REF) 8885*. Scratch 8886 DIMENSION VEC1(*),VEC2(*) 8887*. Files in use pt : LUSC1, LUSC2, LUSC3, LUSC34, LUSC35, LUHC 8888 IDUM = 0 8889 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'HEFFCC') 8890* 8891 NTEST = 0 8892 IF(NTEST.GE.2) THEN 8893 WRITE(6,*) ' Calculation of gradient for reference dets ' 8894 WRITE(6,*) ' ===========================================' 8895 WRITE(6,*) ' IREFSPC, ITREFSPC ', IREFSPC,ITREFSPC 8896 END IF 8897 IF(NTEST.GE.100) THEN 8898 WRITE(6,*) ' Input C_REF ' 8899 CALL WRTMAT(C_REF,1,N_REF,1,N_REF) 8900 END IF 8901* 8902 ICSPC = IREFSPC 8903 ISSPC = ITREFSPC 8904* 8905*. transfer new reference vector to file LUSC34 - use S_REF as integer scratch 8906*. and LUDIA as form 8907 CALL ISTVC2(S_REF,0,1,N_REF) 8908C WRSVCD(LU,LBLK,VEC1,IPLAC,VAL,NSCAT,NDIM,LUFORM,JPACK) 8909 CALL REWINO(LUSC34) 8910 CALL REWINO(LUDIA) 8911 CALL WRSVCD(LUSC34,-1,VEC1,S_REF, 8912 & C_REF,N_REF,N_REF,LUDIA,1) 8913C WRSVCD(LU,LBLK,VEC1,IPLAC,VAL,NSCAT,NDIM,LUFORM,JPACK) 8914*. Obtain exp(-T) H exp(T) |0> on LUHC 8915 IF(IAPROX_HCOM.EQ.0) THEN 8916*. No approximations in highest commutator 8917 CALL EMNTHETO(T_EXT,LUSC34,LUHC,NCOMMU,IREFSPC,ITREFSPC, 8918 & IT2REFSPC) 8919 ELSE 8920 CALL EMNTHETO(T_EXT,LUSC34,LUHC,NCOMMU-1,IREFSPC,ITREFSPC, 8921 & IT2REFSPC) 8922*. PT full Hamiltonian is used for testing 8923 CALL TCOM_H_N(T_EXT,LUSC34,LUHC,NCOMMU,IREFSPC, 8924 & ITREFSPC,IT2REFSPC,1) 8925 END IF 8926*. Contract exp(-T) H exp(T) |0> to reference space and save on LUHC 8927 CALL EXPCIV(IREFSM,ITREFSPC,LUHC,IREFSPC,LUSC34,-1, 8928 / LUSC35,1,1,IDC,0) 8929 CALL REWINO(LUHC) 8930 CALL FRMDSCN(S_REF,-1,-1,LUHC) 8931* 8932 IF(NTEST.GE.100) THEN 8933 WRITE(6,*) ' The Heff times vector in internal space ' 8934 CALL WRTMAT(S_REF,1,N_REF,1,N_REF) 8935 END IF 8936* 8937 CALL MEMMAN(IDUM,IDUM,'FLUSM',IDUM,'HEFFCC') 8938* 8939 RETURN 8940 END 8941 SUBROUTINE ICCC_OPT_SIMULT( 8942 & IREFSPC,ITREFSPC,IT2REFSPC,I_SPIN_ADAPT, 8943 & IREFROOT,T_EXT,C_0,INI_IT,IFIN_IT,VEC1,VEC2,IDIIS, 8944 & C_REF,N_REF,I_DO_COMP,CONVERL,VTHRES,I_REDO_INT, 8945 & EFINAL,VNFINAL,CONVERG,SCR_SBSPJA,MXVEC_SBSPJA) 8946 8947* 8948* Master routine for Internal Contraction Coupled Cluster 8949* 8950* It is assumed that the excitation manifold produces 8951* states that are orthogonal to the reference so 8952* no projection is carried out 8953* 8954* Routine is allowed to leave without turning the lights off, 8955* i.e. leave routine with all allocations and marks intact. 8956*: Thus : Allocations are only done if INI_IT = 1 8957* Deallocations are only done if IFIN_IT = 1 8958* 8959*. Preconditioners are only calculated if INI_IT = 1 8960* 8961* IF I_REDO_INT = 1, the internal states are recalculated at start 8962* 8963* IF IDIIS.EQ.1, DIIS is used 8964* .EQ.2, CROP is used to accelerate convergence 8965* 8966* 8967* Jeppe Olsen, Aug. 2005, modified aug 2009 - also in Washington 8968* Redo of internal states: Sept. 2009 in Sicily 8969* Subspace Jacobian added: Oct. 2009 8970* 8971* 8972*. for DIIS units LUSC37 and LUSC36 will be used for storing vectors 8973 INCLUDE 'wrkspc.inc' 8974 INCLUDE 'ctcc.inc' 8975 INCLUDE 'glbbas.inc' 8976 INCLUDE 'crun.inc' 8977 INCLUDE 'clunit.inc' 8978 INCLUDE 'cecore.inc' 8979 INCLUDE 'cei.inc' 8980 INCLUDE 'oper.inc' 8981 INCLUDE 'cands.inc' 8982 INCLUDE 'cstate.inc' 8983 INCLUDE 'lucinp.inc' 8984 INCLUDE 'orbinp.inc' 8985*. Temporary array for debugging 8986 REAL*8 XNORM_EI(1000) 8987* 8988 LOGICAL CONVERL,CONVERG 8989*. Converl: is local iterative procedure for given internal states converged 8990*. converg: is global iterative procedure converged 8991 REAL*8 8992 &INPROD 8993*. Input and Output : Coefficients of internal and external correlation 8994 DIMENSION T_EXT(*), C_REF(*) 8995 COMMON/COM_H_S_EFF_ICCI_TV/ 8996 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 8997 & IUNIOPX,NSPAX,IPROJSPCX 8998 COMMON/CLOCAL2/KVEC1,KVEC2,MXCJ, 8999 & KLVCC1,KLVCC2,KLVCC3,KLVCC4,KLVCC5,KLSMAT,KLXMAT,KLJMAT,KLU,KLL, 9000 & NSING,NNONSING,KLCDIIS,KLC_INT_DIA,KLDIA,KLVCC6,KLVCC7,KLVCC8, 9001 & NVECP,NVEC,KLA_CROP,KLSCR_CROP 9002*. Scratch for CI behind the curtain 9003 DIMENSION VEC1(*),VEC2(*) 9004*. Scratch for subspace Jacobian 9005 DIMENSION SCR_SBSPJA(*) 9006*. Threshold for convergence of norm of Vectorfuntion 9007 9008C WRITE(6,*) ' ICCC_OPT_SIMULT: I_DO_COMP =', I_DO_COMP 9009C WRITE(6,*) ' ICCC_OPT_SIMULT: MAXIT,MAXITM =', MAXIT,MAXITM 9010 WRITE(6,*) ' ICCC_OPT_SIMULT: I_DO_SBSPJA, MXVEC_SBSPJA = ', 9011 & I_DO_SBSPJA, MXVEC_SBSPJA 9012*. Number of Spin adapted functions (and NCAAB for a check) 9013 NSPA = N_ZERO_EI 9014 NCAAB = NDIM_EI 9015 WRITE(6,*) ' NCAAB og NDIM_EI = ', NCAAB, NDIM_EI 9016*. We will not include the unit-operator so ??? 9017 NSPAM1 = NSPA - 1 9018*. Different adresses of the unit op 9019 IF(I_DO_EI.EQ.0) THEN 9020 IUNI_AD = 1 9021 ELSE 9022 IUNI_AD = NCAAB 9023 END IF 9024*. Freeze internal expansion 9025CM I_FIX_INTERNAL = 0 9026*. Project on nonredundant space 9027 I_DO_PROJ_NR = 1 9028*. For file access 9029 LBLK = -1 9030 NTEST = 5 9031 IF(NTEST.GE.2) THEN 9032 WRITE(6,*) 9033 & ' Simultaneous optimization of internal and external parts ' 9034 WRITE(6,*) 9035 & ' =========================================================' 9036 WRITE(6,*) 9037 WRITE(6,*) ' Reference space is ', IREFSPC 9038 WRITE(6,*) ' Space for evaluating general operators ', ITREFSPC 9039 WRITE(6,*) ' Space for T times reference space ', IT2REFSPC 9040 WRITE(6,*) ' Number of parameters in CAAB basis ', 9041 & N_CC_AMP 9042 WRITE(6,*) ' Number of parameters in spincoupled/ort basis ', 9043 & NSPA 9044 WRITE(6,*) ' Number of coefficients in internal space ', N_REF 9045 WRITE(6,*) ' INI_IT, IFIN_IT = ', INI_IT, IFIN_IT 9046 WRITE(6,*) ' Max. number microiterations per macro ', MAXIT 9047 WRITE(6,*) ' Max. number of macroiterations ', MAXITM 9048 WRITE(6,*) ' Number of vectors allowed in subspace ', MXCIVG 9049 WRITE(6,*) ' Number of vectors allowed in initial subspace ', 9050 & MXVC_I 9051 IF(IDIIS.EQ.1) THEN 9052 WRITE(6,*)' DIIS optimization' 9053 ELSE IF (IDIIS.EQ.2) THEN 9054 WRITE(6,*)' CROP optimization' 9055 END IF 9056* 9057 IF(I_DO_PROJ_NR.EQ.1) THEN 9058 WRITE(6,*) ' Redundant directions projected out' 9059 ELSE 9060 WRITE(6,*) ' No projection of redundant directions' 9061 END IF 9062* 9063 END IF 9064* 9065 IF(NTEST.GE.1000) THEN 9066 WRITE(6,*) ' Initial T_ext-amplitudes ' 9067 CALL WRTMAT(T_EXT,1,N_CC_AMP,1,N_CC_AMP) 9068 WRITE(6,*) ' Initial C_int-amplitudes ' 9069 CALL WRTMAT(C_REF,1,N_REF,1,N_REF) 9070 END IF 9071*. Allowed number of iterations 9072 NNEW_MAX = MAXIT 9073 MAXITL = NNEW_MAX 9074* 9075 NVAR = N_CC_AMP + N_REF 9076 IF(INI_IT.EQ.1) THEN 9077 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICC_CM') 9078 CALL MEMMAN(KLVCC1,NVAR,'ADDL ',2,'VCC1 ') 9079 CALL MEMMAN(KLVCC2,NVAR,'ADDL ',2,'VCC2 ') 9080 CALL MEMMAN(KLVCC3,NVAR,'ADDL ',2,'VCC3 ') 9081 CALL MEMMAN(KLVCC4,NVAR,'ADDL ',2,'VCC4 ') 9082 CALL MEMMAN(KLVCC5,NVAR,'ADDL ',2,'VCC5 ') 9083 CALL MEMMAN(KLVCC6,2*NVAR,'ADDL ',2,'VCC6 ') 9084*. Just a few extra to be on the safe side when programming EI 9085*. approach 9086 CALL MEMMAN(KLVCC7,NVAR,'ADDL ',2,'VCC5 ') 9087 CALL MEMMAN(KLVCC8,NVAR,'ADDL ',2,'VCC5 ') 9088*. Complete matrices for external part, three used pt 9089 LEN = NSPA**2 9090 IF(I_DO_COMP.EQ.1) THEN 9091 CALL MEMMAN(KLSMAT,LEN,'ADDL ',2,'SMAT ') 9092 CALL MEMMAN(KLXMAT,LEN,'ADDL ',2,'XMAT ') 9093 CALL MEMMAN(KLJMAT,LEN,'ADDL ',2,'JMAT ') 9094*. Storage for LU decomposition of J 9095 LEN = NSPA*(NSPA+1)/2 9096 CALL MEMMAN(KLL,LEN,'ADDL ',2,'L ') 9097 CALL MEMMAN(KLU,LEN,'ADDL ',2,'U ') 9098 ELSE 9099*. Space for diagonal- space is allocated also for CI part. 9100 CALL MEMMAN(KLDIA,NVAR+1,'ADDL ',2,'DIAORT') 9101 END IF 9102*. Space for DIIS/CROP 9103 IF(IDIIS.EQ.1) THEN 9104 CALL MEMMAN(KLCDIIS,MAXITL,'ADDL ',2,'CDIIS ') 9105 ELSE IF(IDIIS.EQ.2) THEN 9106 CALL MEMMAN(KLA_CROP,MXCIVG*(MXCIVG+1)/2,'ADDL ',2,'A_CROP') 9107 LEN_SCR_CROP = 3*MXCIVG*MXCIVG + 3*MAX(MXCIVG,NVAR) 9108 CALL MEMMAN(KLSCR_CROP,LEN_SCR_CROP,'ADDL ',2,'S_CROP') 9109C? WRITE(6,*) ' KLA_CROP,KLSCR_CROP, a =', KLA_CROP,KLSCR_CROP 9110 END IF 9111*. Space Diagonal for internal part 9112 CALL MEMMAN(KLC_INT_DIA,N_REF,'ADDL ',2,'C_DIA ') 9113 END IF 9114*. ^ End if INI_IT.EQ.1 9115* 9116*====================================== 9117* 0: Redo internal states if required 9118* ===================================== 9119* 9120 IF(I_REDO_INT.EQ.1) THEN 9121 CALL GET_INTERNAL_STATES(N_EXTOP_TP,N_INTOP_TP, 9122 & WORK(KLSOBEX),WORK(KL_N_INT_FOR_EXT),WORK(KL_IB_INT_FOR_EXT), 9123 & WORK(KL_I_INT_FOR_EXT),WORK(KL_NDIM_IN_SE), 9124 & WORK(KL_N_ORTN_FOR_SE),WORK(KL_N_INT_FOR_SE), 9125 & WORK(KL_X1_INT_EI_FOR_SE), WORK(KL_X2_INT_EI_FOR_SE), 9126 & WORK(KL_SG_INT_EI_FOR_SE),WORK(KL_S_INT_EI_FOR_SE), 9127 & WORK(KL_IBX1_INT_EI_FOR_SE), WORK(KL_IBX2_INT_EI_FOR_SE), 9128 & WORK(KL_IBSG_INT_EI_FOR_SE),WORK(KL_IBS_INT_EI_FOR_SE), 9129 & WORK(KL_X2L_INT_EI_FOR_SE), 9130 & I_IN_TP,I_INT_OFF,I_EXT_OFF) 9131* 9132C IMNNMX(IVEC,NDIM,MINMAX) 9133 N_INT_MAX = IMNMX(WORK(KL_N_INT_FOR_SE),N_EXTOP_TP*NSMOB,2) 9134*. Largest number of zero-order states of given sym and external type 9135 N_ORTN_MAX = IMNMX(WORK(KL_N_ORTN_FOR_SE),N_EXTOP_TP*NSMOB,2) 9136 WRITE(6,*) ' N_INT_MAX, N_ORTN_MAX = ', N_INT_MAX, N_ORTN_MAX 9137*. Largest transformation block 9138 N_XEO_MAX = N_INT_MAX*N_ORTN_MAX 9139 IF(NTEST.GE.10) 9140 & WRITE(6,*) ' Largest (EL,ORTN) block = ', N_XEO_MAX 9141*. Number of zero-order states - does now include the unit-operator 9142 N_ZERO_EI = N_ZERO_ORDER_STATES(WORK(KL_N_ORTN_FOR_SE), 9143 & WORK(KL_NDIM_EX_ST),N_EXTOP_TP,1) 9144 NSPA = N_ZERO_EI 9145 IF(NTEST.GE.10) WRITE(6,*) 9146 & ' Number of zero-order states with sym 1 = ', N_ZERO_EI 9147 END IF 9148* 9149* ============================================================ 9150* 1 : Prepare preconditioners for external and internal parts 9151* ============================================================ 9152* 9153* -------------------- 9154*. 1a : External part 9155* -------------------- 9156* 9157*. Identify the unit operator i.e. the operator with 9158*. zero creation and annihilation operators 9159 IDOPROJ = 0 9160*. Construct metric (once again ..) 9161*. Prepare the routines used in COM_SH 9162*. Not used here 9163 C_0X = 0.0D0 9164 KLTOPX = -1 9165*. Used 9166 NREFX = N_REF 9167 IREFSPCX = IREFSPC 9168*. Space to be used for evaluating metric : If T = 0, then IT2REFSPC is sufficient 9169 ITREFSPCX = ITREFSPC 9170 ITREFSPCX = IT2REFSPC 9171* 9172 NCAABX = N_CC_AMP 9173 NSPAX = NSPA 9174 IPROJSPCX = IREFSPC 9175*. Unitoperator in SPA order ... Please check .. 9176 IUNIOPX = 0 9177 IF(I_DO_COMP.EQ.1) THEN 9178*. Set up or read in complete matrices 9179 IF(INI_IT.EQ.1.AND.IREADSJ.EQ.0) THEN 9180 CALL COM_SH(WORK(KLSMAT),WORK(KLSMAT),WORK(KLVCC1), 9181 & WORK(KLVCC2), 9182 & WORK(KLVCC3),VEC1,VEC2, 9183 & N_CC_AMP,IREFSPC,IT2REFSPC,LUC,LUHC,LUSC1,LUSC2, 9184 & IDOPROJ,IUNIOP,1,0,1,I_DO_EI,NSPA,0,0,0) 9185*. ELiminate part referring to unit operator 9186 CALL TRUNC_MAT(WORK(KLSMAT),NSPA,NSPA,NSPAM1,NSPAM1) 9187 CALL GET_ON_BASIS2(WORK(KLSMAT),NSPAM1,NSING, 9188 & WORK(KLXMAT),WORK(KLVCC1),WORK(KLVCC2),THRES_SINGU) 9189 WRITE(6,*) ' Number of singularities in S ', NSING 9190 NNONSING = NSPAM1 - NSING 9191*. Write to LU_SJ 9192 CALL REWINO(LU_SJ) 9193 WRITE(LU_SJ) NSING,NNONSING 9194 WRITE(LU_SJ) (WORK(KLXMAT-1+IJ),IJ=1,NSPAM1*NNONSING) 9195 ELSE 9196*. Read in transformation matrix from LU_SJ 9197 CALL REWINO(LU_SJ) 9198 READ(LU_SJ) NSING,NNONSING 9199 READ(LU_SJ) (WORK(KLXMAT-1+IJ),IJ=1,NSPAM1*NNONSING) 9200 END IF 9201* ^ End of switch whether complete metrix should read or calc 9202 IF(NTEST.GE.1000) THEN 9203 WRITE(6,*) ' Transformation matrix to nonsingular basis ' 9204 CALL WRTMAT(WORK(KLXMAT),NSPAM1,NNONSING,NSPAM1, 9205 & NNONSING) 9206 END IF 9207* 9208 IF(INI_IT.EQ.1.AND.IREADSJ.EQ.0) THEN 9209*. Construct exact or approximate Jacobian 9210 IF(NCOMMU_J.EQ.1) THEN 9211*. I assume that the space before ITREFSPC contains T*IREFSPC 9212 ITREFSPC_L = ITREFSPC - 1 9213 WRITE(6,*) ' Space used for approximate J ', ITREFSPC_L 9214*. Jacobian independent of T, so use T = 0 for simplicity 9215 ZERO = 0.0D0 9216 CALL SETVEC(WORK(KLVCC6),ZERO,N_CC_AMP) 9217 CALL COM_JMRCC(WORK(KLVCC6),NCOMMU_J,I_APPROX_HCOM_J, 9218 & WORK(KLJMAT),WORK(KLVCC1),WORK(KLVCC2), WORK(KLVCC3), 9219 & WORK(KLVCC4),N_CC_AMP,NSPAM1,NNONSING,IREFSPC, 9220 & ITREFSPC_L,WORK(KLXMAT) ) 9221 ELSE 9222*. More than one commutator, so J depends on T 9223 CALL COM_JMRCC(T_EXT,NCOMMU_J,I_APPROX_HCOM_J, 9224 & WORK(KLJMAT),WORK(KLVCC1),WORK(KLVCC2), WORK(KLVCC3), 9225 & WORK(KLVCC4),N_CC_AMP,NSPAM1,NNONSING,IREFSPC, 9226 & ITREFSPC,WORK(KLXMAT) ) 9227 END IF 9228* ^ End if more than one commutator 9229 WRITE(LU_SJ) (WORK(KLJMAT-1+IJ),IJ=1,NNONSING*NNONSING) 9230*. Rewind to flush buffer 9231 CALL REWINO(LU_SJ) 9232 ELSE 9233*. Read Approximate Jacobian in from LU_SJ 9234 READ(LU_SJ) (WORK(KLJMAT-1+IJ),IJ=1,NNONSING*NNONSING) 9235 END IF 9236* ^ End if matrix should be constructed or read in 9237 I_ADD_SHIFT = 0 9238 IF(I_ADD_SHIFT.EQ.1) THEN 9239*. Add a shift to the diagonal of J 9240 SHIFT = 10.0D0 9241 WRITE(6,*) ' A shift will be added to initial Jacobian' 9242 WRITE(6,'(A,E14.7)') ' Value of shift = ', SHIFT 9243 CALL ADDDIA(WORK(KLJMAT),SHIFT,NNONSING,0) 9244 END IF 9245* ^ End if shift should be added 9246* 9247 I_DIAG_J = 0 9248 IF(I_DIAG_J.EQ.1) THEN 9249*. Obtain eigenvalues of approximate Jacobian 9250*. S-matrix is not used anymore to use this space for 9251*. diagonalization 9252 WRITE(6,*) ' Approximate Jacobian will be diagonalized ' 9253 CALL COPVEC(WORK(KLJMAT),WORK(KLSMAT),NNONSING*NNONSING) 9254 CALL EIGGMT3(WORK(KLSMAT),NNONSING,WORK(KLVCC1),WORK(KLVCC2), 9255 & XDUM,XDUM,XDUM,WORK(KLVCC3),WORK(KLVCC6),1,0) 9256 WRITE(6,*) ' Real and imaginary part of eigenvalues of J ' 9257 WRITE(6,*) ' ========================================== ' 9258 CALL WRT_2VEC(WORK(KLVCC1),WORK(KLVCC2),NNONSING) 9259 END IF 9260*. Obtain LU-Decomposition of Jacobian 9261 CALL LULU(WORK(KLJMAT),WORK(KLL),WORK(KLU),NNONSING) 9262 ELSE 9263 IF(INI_IT.EQ.1) THEN 9264*. Complete matrix is not constructed, rather just a diagonal 9265*. Obtain diagonal of H 9266C GET_DIAG_H0_EI(DIAG,I_IN_TP) 9267 CALL GET_DIAG_H0_EI(WORK(KLDIA)) 9268*. The last element in KLDIA is the zero-order energy(without core) 9269 E0 = WORK(KLDIA-1+N_ZERO_EI) 9270 IF(NTEST.GE.0) 9271 & WRITE(6,*) ' Zero-order energy without core term ', E0 9272*. To get diagonal approximation to J, subtract E0 9273 DO I = 1, N_ZERO_EI 9274 WORK(KLDIA-1+I) = WORK(KLDIA-1+I) - E0 9275 END DO 9276*. The last term in KLDIA corresponds to the zero-order state. 9277*. This will not contribute, but to eliminate errors occuring 9278*. from dividing by zero do 9279*. Checl for diagonal values close to zero, and shift these 9280C MODDIAG(H0DIAG,NDIM,XMIN) 9281 WORK(KLDIA-1+N_ZERO_EI) = 300656.0 9282 XMIN = 0.2D0 9283 CALL MODDIAG(WORK(KLDIA),N_ZERO_EI,XMIN) 9284*. And save on LU_SJ 9285 CALL VEC_TO_DISC(WORK(KLDIA),N_ZERO_EI-1,1,LBLK,LU_SJ) 9286*. test norm of the E-blocks of diagonal 9287 IF(NTEST.GE.10) THEN 9288 WRITE(6,*) ' Norm of various E-blocks of diagonal' 9289 CALL NORM_T_EI(WORK(KLDIA),2,1,XNORM_EI,1) 9290 END IF 9291C NORM_T_EI(T,IEO,ITSYM,XNORM_EI,IPRT) 9292 IF(NTEST.GE.1000) THEN 9293 WRITE(6,*) ' Diagonal J-approx in ort. zero-order basis' 9294 CALL WRTMAT(WORK(KLDIA),1,N_ZERO_EI,1,N_ZERO_EI) 9295 END IF 9296 END IF 9297*. ^ End if it was first iteration 9298 END IF 9299* ^ End of complete or diagonal matrix should be set up 9300* 9301* --------------------- 9302*. 1b : internal part - constructed in all its.. no problem 9303* --------------------- 9304* 9305 CALL REWINO(LUDIA) 9306 CALL FRMDSCN(WORK(KLC_INT_DIA),-1,-1,LUDIA) 9307 IF(NTEST.GE.1000) THEN 9308 WRITE(6,*) ' Diagonal preconditioner for internal correlation' 9309 CALL WRTMAT(WORK(KLC_INT_DIA),1,N_REF,1,N_REF) 9310 END IF 9311* 9312 IF(IDIIS.EQ.1.OR.(IDIIS.EQ.2.AND.INI_IT.EQ.1)) THEN 9313 CALL REWINO(LUSC37) 9314 CALL REWINO(LUSC36) 9315 END IF 9316*. Ensure proper defs 9317 I12 = 2 9318 ICSM = IREFSM 9319 ISSM = IREFSM 9320 IF(NTEST.GE.100) 9321 & WRITE(6,*) ' After const of precond: ITREFSPC, IT2REFSPC =', 9322 & ITREFSPC, IT2REFSPC 9323* 9324C? WRITE(6,*) ' KINT before entering optimization' 9325C? CALL APRBLM2(WORK(KINT1),NTOOBS,NTOOBS,NSMOB,1) 9326*. Loop over iterations 9327 WRITE(6,*) 9328 WRITE(6,*) ' -------------------------- ' 9329 WRITE(6,*) ' Entering optimization part ' 9330 WRITE(6,*) ' -------------------------- ' 9331 WRITE(6,*) 9332*. Number of vectors in initial space for DIIS/CROP optimization 9333 IF(INI_IT.EQ.1) THEN 9334 NVECP = 0 9335 NVEC = 0 9336 END IF 9337*. (If INI_IT .ne. 0, MXVC_I vectors from previous macro are used) 9338 IF(I_DO_SBSPJA.EQ.1) THEN 9339*. Initialize files that will be used for subspace Jacobian) 9340 WRITE(6,*) ' LU_CCVECT,LU_CCVECF, LU_CCVECFL = ', 9341 & LU_CCVECT,LU_CCVECF, LU_CCVECFL 9342 CALL REWINO(LU_CCVECT) 9343 CALL REWINO(LU_CCVECF) 9344 CALL REWINO(LU_CCVECFL) 9345 END IF 9346 DO IT = 1, NNEW_MAX 9347 IF(NTEST.GE.100) THEN 9348 WRITE(6,*) 9349 WRITE(6,*) ' Information for iteration ', IT 9350 WRITE(6,*) 9351 END IF 9352 IF(IT.EQ.1) THEN 9353 MXVC_SUB = MXVC_I 9354 ELSE 9355 MXVC_SUB = MXCIVG 9356 END IF 9357* 9358* 9359* ================================================================== 9360*. Construct vectorfunction/gradient for external and internal parts 9361* ================================================================== 9362* 9363*. CC vector function for external part in VCC5 9364C? WRITE(6,*) ' NCAAB before MRCC.. ', NCAAB 9365 CALL MRCC_VECFNCN(WORK(KLVCC5),T_EXT, 9366 & IREFSPC,ITREFSPC,IT2REFSPC,WORK(KLVCC5+N_CC_AMP), 9367 & C_REF, N_REF,I_DO_PROJ_NR, 9368 & E_INT,E_EXT,ECORE,1,1) 9369* 9370C? WRITE(6,*) ' Jeppe has asked med to analyze gradient ' 9371C? CALL ANA_GENCC(WORK(KLVCC5),1) 9372* 9373 IF(NTEST.GE.1000) THEN 9374 WRITE(6,*) 9375 & ' The CC vector function including internal part' 9376 CALL WRTMAT(WORK(KLVCC5),1,N_CC_AMP+N_REF,1,N_CC_AMP+N_REF) 9377 END IF 9378 IF(NTEST.GE.10) WRITE(6,'(A,I4,1E22.15)') 9379 & ' It, Energy from external and internal ', IT, E_EXT + ECORE, 9380 & E_INT+ECORE 9381 VCFNORM_EXT =SQRT(INPROD(WORK(KLVCC5),WORK(KLVCC5),NCAAB)) 9382 VCFNORM_INT = SQRT( 9383 & INPROD(WORK(KLVCC5+N_CC_AMP),WORK(KLVCC5+N_CC_AMP), 9384 & N_REF)) 9385*. Update energy and residual norms 9386 VNFINAL = VCFNORM_EXT+VCFNORM_INT 9387 E = E_INT 9388 EFINAL = E_INT + ECORE 9389*. Converged? 9390 IF(VCFNORM_EXT+VCFNORM_INT.LE.VTHRES) THEN 9391*. Local iterative procedure converged 9392 CONVERL = .TRUE. 9393*. Is global procedure also converged? 9394 IF((I_REDO_INT.NE.1 ) .OR. 9395 & (I_REDO_INT.EQ.1.AND.IT.EQ.1)) THEN 9396 CONVERG = .TRUE. 9397 END IF 9398 WRITE(6,*) ' Iterative procedure converged' 9399 WRITE(6,'(A,I4,E22.15,2E12.5)') 9400 & ' It, energy , vecfnc_ext, vecfnc_int ', 9401 & IT, E + ECORE, VCFNORM_EXT, VCFNORM_INT 9402 GOTO 1001 9403 END IF 9404* ^ End if local procedure is converged 9405* 9406* ====================================================================== 9407*. Save vectorfunction in form that will be used in later subspace opt. 9408* ====================================================================== 9409* 9410* 9411 IF(I_DO_SBSPJA.EQ.1) THEN 9412*. Save Vectorfunction and change in vectorfunction 9413*. in EO form if subspace Jacobian is in use 9414*. Vecfunc in CAAB in VCC5 to Vecfunc in EI in VCC2 9415*. zero-order state is not to be included 9416 N_ZERO_EIM = N_ZERO_EI - 1 9417 CALL TRANS_CAAB_ORTN(WORK(KLVCC5),WORK(KLVCC2),1,1,2, 9418 & WORK(KLVCC7),1) 9419 IF(NTEST.GE.1000) THEN 9420 WRITE(6,*) ' Vector function in EI basis ' 9421 CALL WRTMAT(WORK(KLVCC2),1,N_ZERO_EIM,1,N_ZERO_EIM) 9422 END IF 9423 IF(IT.GE.2) THEN 9424*. Read previous vectorfunction in VCC7 from CCVECFL 9425 CALL VEC_FROM_DISC(WORK(KLVCC7),N_ZERO_EIM,1,LBLK, 9426 & LU_CCVECFL) 9427 ONE = 1.0D0 9428 ONEM =-1.0D0 9429*. Store in VCC7: Delta V = Vecfnc(ITER) - Vecfnc(ITER-1) 9430 CALL VECSUM(WORK(KLVCC7),WORK(KLVCC7),WORK(KLVCC2), 9431 & ONEM,ONE,N_ZERO_EIM) 9432*. Add CCVF(X_{i+1})-CCVF(X_{i}) as vector IT-1 in FILE LU_CCVECF 9433 CALL SKPVCD(LU_CCVECF,IT-2,WORK(KLVCC6),1,LBLK) 9434 CALL VEC_TO_DISC(WORK(KLVCC7),N_ZERO_EIM,0,LBLK,LU_CCVECF) 9435 END IF 9436*. Save current vector-function in EO form in LU_CCVECFL 9437 CALL VEC_TO_DISC(WORK(KLVCC2),N_ZERO_EIM,1,LBLK,LU_CCVECFL) 9438 END IF 9439* ^ End if subspace method in use 9440* 9441* ======================================================== 9442* Diis/CROP/SBSPJA based on current and previous vectors 9443* ======================================================== 9444* 9445*. Vectors are stored in CAAB basis - not the smartest- Oh yes it was- 9446*. helps a lot that a common simple basis is used and not a 9447*. specific nonsingular basis! 9448* 9449 IF(IDIIS.EQ.1.OR.IDIIS.EQ.2) THEN 9450*. It is assumed that DIIS left the file at end of file 9451*. T_ext,C_int on LUSC37, VECFNC on LUSC36 9452 CALL COPVEC(T_EXT,WORK(KLVCC1),NCAAB) 9453 CALL COPVEC(C_REF,WORK(KLVCC1+NCAAB),N_REF) 9454 IF(NTEST.GE.1000) THEN 9455 WRITE(6,*) ' Combined T_ext, C_int coefficients ' 9456 CALL WRTMAT(WORK(KLVCC1),1,NVAR,1,NVAR) 9457 END IF 9458 CALL VEC_TO_DISC(WORK(KLVCC1),NVAR,0,-1,LUSC37) 9459 CALL VEC_TO_DISC(WORK(KLVCC5),NVAR,0,-1,LUSC36) 9460 END IF 9461*. We have now a number of vectors in LUSC36, find combination with lowest 9462*. norm 9463*. DIIS: 9464 IF(IDIIS.EQ.1) THEN 9465*. Simple DIIS with no restart 9466 CALL DIIS_SIMPLE(LUSC36,IT,NVAR,WORK(KLCDIIS)) 9467*. Obtain combination of parameters given in CDIIS 9468 CALL MVCSMD(LUSC37,WORK(KLCDIIS),LUSC39,LUSC38, 9469 & WORK(KLVCC1),WORK(KLVCC2),IT,1,-1) 9470 CALL VEC_FROM_DISC(WORK(KLVCC1),NVAR,1,-1,LUSC39) 9471 CALL COPVEC(WORK(KLVCC1),T_EXT,NCAAB) 9472 CALL COPVEC(WORK(KLVCC1+NCAAB),C_REF,N_REF) 9473*. Calculate new vectorfunction in VCC5 for T_EXT and C_INT using sums 9474 CALL MVCSMD(LUSC36,WORK(KLCDIIS),LUSC39,LUSC38, 9475 & WORK(KLVCC1),WORK(KLVCC2),IT,1,-1) 9476 CALL VEC_FROM_DISC(WORK(KLVCC5),NVAR,1,-1,LUSC39) 9477 ELSE IF(IDIIS.EQ.2) THEN 9478*. CROP: 9479*. The CROP version of DIIS 9480*. Matrices are reconstructed in each IT 9481 IDIRDEL = 1 9482 NVEC = NVEC + 1 9483C CROP(NVEC,NVECP,MXNVEC,NDIM,LUE,LUP,A, 9484C & EOUT,POUT,SCR,LUSCR,IDIRDEL) 9485*. Note: NVECP is number of vectors for which subspace matrix 9486*. has been constructed and saved- CROP updates this 9487 CALL CROP(NVEC,NVECP,MXVC_SUB,NVAR,LUSC36,LUSC37, 9488 & WORK(KLA_CROP), 9489 & WORK(KLVCC5),WORK(KLVCC1),WORK(KLSCR_CROP),LUSC39, 9490 & IDIRDEL) 9491*Change of T-coefs 9492 ONE = 1.0D0 9493 ONEM = -1.0D0 9494 CALL VECSUM(WORK(KLVCC1),WORK(KLVCC1),T_EXT,ONE,ONEM,NCAAB) 9495*. Check if change is to large.. 9496 XNORM = SQRT(INPROD(WORK(KLVCC1),WORK(KLVCC1),NCAAB)) 9497 WRITE(6,*) ' Norm of CROP-correction ', XNORM 9498 XNORM_MAX = 0.5D0 9499 I_DO_SCALE = 1 9500 IF(XNORM.GT.XNORM_MAX.AND.I_DO_SCALE.EQ.1) THEN 9501 WRITE(6,*) 9502 & ' CROPStep is scaled: from and to to ', XNORM,XNORM_MAX 9503 FACTOR = XNORM_MAX/XNORM 9504 CALL SCALVE(WORK(KLVCC1),FACTOR,NCAAB) 9505 CALL VECSUM(T_EXT,T_EXT,WORK(KLVCC1),ONE,ONE,NCAAB) 9506 END IF 9507C CALL COPVEC(WORK(KLVCC1+NCAAB),C_REF,N_REF) 9508*. NOTE: If CI-coefs are changed, they should be renormalized!! 9509 END IF 9510*. ^ End of DIIS/CROP should be used 9511 VCFNORM = SQRT(INPROD(WORK(KLVCC5),WORK(KLVCC5),NVAR)) 9512 IF(NTEST.GE.10) WRITE(6,'(A,I4,1E12.5)') 9513 & ' From DIIS/CROP : It, norm of approx vecfnc ', 9514 & IT, VCFNORM 9515* 9516* =================================================================== 9517* Obtain new direction by applying preconditioners to approx vecfunc 9518* =================================================================== 9519* 9520* -------------- 9521* External part 9522* -------------- 9523* 9524*. EI- Approach: Transform Vecfunc to Orthonormal basis, 9525* multiply with diagonal transform result back to CAAB basis 9526*. Vectorfunction 9527*. Vecfunc in CAAB in VCC5 to Vecfunc in EI in VCC2 9528 CALL COPVEC(WORK(KLVCC5),WORK(KLVCC6),NDIM_EI) 9529 CALL TRANS_CAAB_ORTN(WORK(KLVCC6),WORK(KLVCC2),1,1,2, 9530 & WORK(KLVCC7),1) 9531C TRANS_CAAB_ORTN(T_CAAB,T_ORTN,ITSYM,ICO,ILR,SCR, 9532C & ICOCON) 9533 WRITE(6,*) ' Norm of various E-blocks of Vecfnc' 9534 CALL NORM_T_EI(WORK(KLVCC2),2,1,XNORM_EI,1) 9535C NORM_T_EI(T,IEO,ITSYM,XNORM_EI,IPRT) 9536 IF(NTEST.GE.1000) THEN 9537 WRITE(6,*) ' Vectorfunction i ort zero-order basis' 9538 CALL WRTMAT(WORK(KLVCC2),1,N_ZERO_EI,1,N_ZERO_EI) 9539 END IF 9540* 9541 IF(I_DO_SBSPJA.EQ.0) THEN 9542*� New direction = -diag-1 * Vecfunc 9543 DO I = 1, N_ZERO_EI 9544 WORK(KLVCC2-1+I) = - WORK(KLVCC2-1+I)/WORK(KLDIA-1+I) 9545 END DO 9546*. And no correction for the zero-order state 9547 WORK(KLVCC2-1+IUNI_AD) = 0.0D0 9548 WRITE(6,*) ' Norm of various E-blocks of step' 9549 CALL NORM_T_EI(WORK(KLVCC2),2,1,XNORM_EI,1) 9550 ELSE 9551*. Use subspace Jacobian to solve equations 9552*. Multiply current CC vector function with approximate Jacobian 9553*. to obtain new step 9554 NSBSPC_VEC = IT-1 9555 MAXVEC = MXVEC_SBSPJA 9556 CALL APRJAC_TV(NSBSPC_VEC,LU_CCVECFL,LUSC41,LU_CCVECT, 9557 & LU_CCVECF,LU_SJ,WORK(KLVCC6),WORK(KLVCC7), 9558 & SCR_SBSPJA,N_ZERO_EIM,LUSC43,LUSC44, 9559 & MAXVEC) 9560C APRJAC_TV(NVEC,LUIN,LUOUT,LUVEC,LUJVEC, 9561C & LUJDIA,VEC1,VEC2,SCR,N_CC_AMP,LUSCR,LUSCR2, 9562C & MAXVEC) 9563*. The new correction vector is now residing in LUSC41, 9564*. Fetch and multiply with -1 9565 CALL VEC_FROM_DISC(WORK(KLVCC2),N_ZERO_EIM,1,LBLK,LUSC41) 9566 ONEM = -1.D0 9567 CALL SCALVE(WORK(KLVCC2),ONEM,N_ZERO_EIM) 9568*. And no correction for the zero-order state 9569 WORK(KLVCC2-1+IUNI_AD) = 0.0D0 9570*. Add step to LU_CCVECT for future use 9571 CALL SKPVCD(LU_CCVECT,IT-1,WORK(KLVCC6),1,LBLK) 9572 CALL VEC_TO_DISC(WORK(KLVCC2),N_ZERO_EIM,0,LBLK,LU_CCVECT) 9573 END IF 9574*. ^ End if subspace Jacobian used for generating new step 9575 IF(NTEST.GE.1000) THEN 9576 WRITE(6,*) ' direction in ort zero-order basis' 9577 CALL WRTMAT(WORK(KLVCC2),1,N_ZERO_EI,1,N_ZERO_EI) 9578 END IF 9579*. Dir in EI in VCC2 to Dir in CAAB in VCC1 9580 CALL TRANS_CAAB_ORTN(WORK(KLVCC1),WORK(KLVCC2),1,2,2, 9581 & WORK(KLVCC6),2) 9582 IF(NTEST.GE.1000) THEN 9583 WRITE(6,*) ' Direction in EI approach, CAAB basis' 9584 CALL WRTMAT(WORK(KLVCC1),1,NDIM_EI,1,NDIM_EI) 9585 END IF 9586*. Norm of change 9587 XNORM_CAAB = SQRT(INPROD(WORK(KLVCC1),WORK(KLVCC1),N_CC_AMP)) 9588 IF(NTEST.GE.10) WRITE(6,*) ' Norm of correction ', XNORM_CAAB 9589 XNORM_MAX = 0.5D0 9590 I_DO_SCALE = 1 9591 IF(XNORM_CAAB.GT.XNORM_MAX.AND.I_DO_SCALE.EQ.1) THEN 9592 WRITE(6,*) 9593 & ' Step is scaled: from and to to ', XNORM_CAAB,XNORM_MAX 9594 FACTOR = XNORM_MAX/XNORM_CAAB 9595 CALL SCALVE(WORK(KLVCC1),FACTOR,N_CC_AMP) 9596 XNORM_CAAB = XNORM_MAX 9597 IF(I_DO_SBSPJA.EQ.1) THEN 9598*. Well, step was scaled, read in EI form of step and scale this 9599 CALL SKPVCD(LU_CCVECT,IT-2,WORK(KLVCC2),1,LBLK) 9600 CALL VEC_FROM_DISC(WORK(KLVCC2),N_ZERO_EIM,0,LBLK,LU_CCVECT) 9601 CALL SCALVE(WORK(KLVCC2),FACTOR,N_ZERO_EIM) 9602 CALL SKPVCD(LU_CCVECT,IT-2,WORK(KLVCC2),1,LBLK) 9603 CALL VEC_TO_DISC(WORK(KLVCC2),N_ZERO_EIM,0,LBLK,LU_CCVECT) 9604 END IF 9605 END IF 9606*. And update the T-coefficients 9607 ONE = 1.0D0 9608 CALL VECSUM(T_EXT,T_EXT,WORK(KLVCC1),ONE,ONE,N_CC_AMP) 9609 IF(NTEST.GE.1000) THEN 9610 WRITE(6,*) ' Updated T-coefficients in CAAB basis ' 9611 CALL WRTMAT(T_EXT,1,N_CC_AMP,1,N_CC_AMP) 9612 END IF 9613* 9614* -------------- 9615* Internal part 9616* -------------- 9617* 9618 IF(N_REF.EQ.1) THEN 9619 C_REF(1) = 1 9620 XNORM_CI = 0.0D0 9621 ELSE 9622 DO I = 1, N_REF 9623 XNORM_CI = 0.0D0 9624 IF(ABS(WORK(KLC_INT_DIA-1+I)-E).GE.1.0D-10) THEN 9625 DELTA = - WORK(KLVCC5+NCAAB-1+I)/(WORK(KLC_INT_DIA-1+I)-E) 9626 XNORM_CI = XNORM_CI + DELTA**2 9627 C_REF(I) = C_REF(I) + DELTA 9628 END IF 9629 END DO 9630 END IF 9631 XNORM_CI = SQRT(XNORM_CI) 9632 WRITE(6,'(A)') 9633 & ' It, Energy, vecfn_ext, vecfn_int, step_ext, step_int: ' 9634 WRITE(6,'(I4,1X,E22.15,2x,4(2X,E12.5))') 9635 & IT, E + ECORE, VCFNORM_EXT, VCFNORM_INT, XNORM_CAAB, XNORM_CI 9636*. And normalize the internal part 9637 CNORM2 = INPROD(C_REF,C_REF,N_REF) 9638 FACTOR = 1.0D0/SQRT(CNORM2) 9639 CALL SCALVE(C_REF,FACTOR,N_REF) 9640*. Write new C_ref to file LUC - used by vector function 9641 CALL ISTVC2(WORK(KLVCC2),0,1,N_REF) 9642 CALL REWINO(LUC) 9643 CALL WRSVCD(LUC,-1,VEC1,WORK(KLVCC2), 9644 & C_REF,N_REF,N_REF,LUDIA,1) 9645* 9646 END DO 9647* ^ End of loop over iterations 9648 1001 CONTINUE 9649 IF(NTEST.GE.1000) THEN 9650 WRITE(6,*) ' Info from T optimization ', IREFROOT 9651 WRITE(6,*) ' Updated amplitudes ' 9652 CALL WRTMAT(T_EXT,1,NCAAB,1,NCAAB) 9653 END IF 9654* 9655 IF(NTEST.GE.5) THEN 9656 WRITE(6,*) ' Analysis of external amplitudes' 9657 CALL ANA_GENCC(T_EXT,1) 9658 END IF 9659* 9660 IF(IFIN_IT.EQ.1.OR.CONVERG) 9661 &CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ICC_CMP') 9662 RETURN 9663 END 9664 SUBROUTINE TCOM_H_N(T,LUINI,LUUT,NCOMMU,IREFSPC,ITREFSPC, 9665 & IT2REFSPC,IAC) 9666* 9667* Obtain 1/NCOMMU! * NCOMMU-fold commutator of T with H 9668* 9669*. Input in CAAB basis 9670* Output on LUOT in SD basis 9671*. LUUT should differ from scratch files used below, one possible choice is LUHC 9672*. Scratch files in use : LUSC1, LUSC2, LUSC3, LUSC34 9673*. Jeppe Olsen, August 2005, Drinking coffee in the early morning at Red Roof Inn in Washington with Jette 9674* 9675* IAC = 1 : Add results to LUUT 9676* IAC = 2 : copy result to LUUT 9677* 9678 9679 INCLUDE 'wrkspc.inc' 9680 INCLUDE 'crun.inc' 9681 INCLUDE 'cstate.inc' 9682 INCLUDE 'cands.inc' 9683 INCLUDE 'glbbas.inc' 9684 INCLUDE 'clunit.inc' 9685* 9686*. Specific input 9687 DIMENSION T(*) 9688*. Calculated as sum_I (-1)^(NCOMMU-I) 1/(I!(NCOMMU-1)!) T^(N-I) H T^I |0> 9689*. So realize the calculation as a loop over I 9690* 9691 NTEST = 000 9692 IF(NTEST.GE.10) THEN 9693 WRITE(6,*) ' Task : 1/NCOMMU! times [H,T],T], ... ]]] |0> ' 9694 WRITE(6,*) ' Ncommu = ', NCOMMU 9695 WRITE(6,*) ' Input T-coefficients ' 9696 CALL WRTMAT(T,1,N_CC_AMP,1,N_CC_AMP) 9697 WRITE(6,'(A,3I3)') ' TCOM.., IREFSPC, IT2REFSPC, IAC = ', 9698 & IREFSPC, IT2REFSPC, IAC 9699 END IF 9700* 9701 IDUM = 0 9702 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'TCOMHN') 9703* 9704* LUINI : Initial expansion |0> 9705* LUSC1 : T^I |0> 9706* LUSC2 : H T^I |0> 9707* LUSC3 : T^N-I H T^I |0> 9708* 9709 ONE = 1.0D0 9710* 9711 DO I = 0, NCOMMU 9712 ICSPC = ITREFSPC 9713 ISSPC = ITREFSPC 9714C? WRITE(6,*) ' I = ', I 9715 IF(I.EQ.0) THEN 9716*. Expand |0> in IREFSPC on LUINI to ITREFSPC on LUSC1 9717 CALL EXPCIV(IREFSM,IREFSPC,LUINI,ITREFSPC,LUSC1,-1, 9718 / LUSC34,1,0,IDC,NTEST) 9719C? WRITE(6,*) ' After EXPCIV' 9720 ELSE 9721*T^(I-1)|0> => T^I |0> on LUSC1 9722 CALL REWINO(LUSC1) 9723 CALL REWINO(LUSC2) 9724 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUSC34,T,1) 9725C? WRITE(6,*) ' After SIGDEN_CC' 9726 CALL COPVCD(LUSC34,LUSC1,WORK(KVEC1P),1,-1) 9727 END IF 9728 IF(NTEST.GE.1000) THEN 9729 WRITE(6,*) ' T^I |0> for I = ',I 9730 CALL WRTVCD(WORK(KVEC1P),LUSC1,1,-1) 9731 END IF 9732*. Calculate H T^I |0> and save on LUSC2 9733*. Space of H T^I |0> may be reduced to IT2REFSPC 9734 ICSPC = ITREFSPC 9735 ISSPC = IT2REFSPC 9736C? WRITE(6,*) ' Before MV7 ' 9737 CALL MV7(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUSC2,0,0) 9738C? WRITE(6,*) ' After MV7 ' 9739 IF(NTEST.GE.1000) THEN 9740 WRITE(6,*) ' H T^I |0> for I = ',I 9741 CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 9742 END IF 9743*. C space may now also be restricted to IT2REFSPC 9744 ISSPC = IT2REFSPC 9745 ICSPC = IT2REFSPC 9746*. Calculate T^(NOMMU-I)H T^I on LUSC3 9747 CALL COPVCD(LUSC2,LUSC3,WORK(KVEC1P),1,-1) 9748 DO J = 1, NCOMMU-I 9749C? WRITE(6,*) ' J = ', J 9750*. Calculate T * T^(J-1) H T^I |0> and save on LUSC3 9751 REWIND(LUSC3) 9752 REWIND(LUSC34) 9753 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC34,T,1) 9754C? WRITE(6,*) 'After SIGDEN_CC, 2 ' 9755 CALL COPVCD(LUSC34,LUSC3,WORK(KVEC1P),1,-1) 9756C? WRITE(6,*) ' After second COPVCD ' 9757 IF(NTEST.GE.1000) THEN 9758 WRITE(6,*) ' T^(J) H T^I for J and I ', J,I 9759 CALL WRTVCD(WORK(KVEC1P),LUSC3,1,-1) 9760 END IF 9761 END DO 9762C? WRITE(6,*) ' After J loop ' 9763*. Add (-1)**(NCOMMU-I)1/(NCOMMU-I)!/I! T^(NCOMMU-I) H T^I |0> 9764 IF(NCOMMU-I.EQ.0) THEN 9765 XNMIFAC = 1.0D0 9766 ELSE 9767 XNMIFAC = XFAC(NCOMMU-I) 9768 END IF 9769 IF(I.EQ.0) THEN 9770 XIFAC = 1.0D0 9771 ELSE 9772 XIFAC = XFAC(I) 9773 END IF 9774 IF(MOD(NCOMMU-I,2).EQ.0) THEN 9775 FACTOR = 1.0D0/(XNMIFAC*XIFAC) 9776 ELSE 9777 FACTOR = -1.0D0/(XNMIFAC*XIFAC) 9778 END IF 9779*. First contribution : Add or copy 9780 IF(I.EQ.0) THEN 9781 IF(IAC.EQ.2) THEN 9782C SCLVCD(LUIN,LUOUT,SCALE,SEGMNT,IREW,LBLK) 9783 CALL SCLVCD(LUSC3,LUUT,FACTOR,WORK(KVEC1P),1,-1) 9784 ELSE 9785C? WRITE(6,*) ' Before VECSMD' 9786 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),FACTOR,ONE,LUSC3, 9787 & LUUT,LUSC34,1,-1) 9788C? WRITE(6,*) ' After VECSMD' 9789C VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 9790 CALL COPVCD(LUSC34,LUUT,WORK(KVEC1P),1,-1) 9791 END IF 9792 IF(NTEST.GE.1000) THEN 9793 WRITE(6,*) ' Initial vector scaled to LUUT ' 9794 CALL WRTVCD(WORK(KVEC1P),LUUT,1,-1) 9795 END IF 9796 ELSE 9797* add : LUUT = LUUT + FACTOR*LUSC3 9798 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),FACTOR,ONE,LUSC3,LUUT, 9799 & LUSC34,1,-1) 9800 CALL COPVCD(LUSC34,LUUT,WORK(KVEC1P),1,-1) 9801 IF(NTEST.GE.1000) THEN 9802 WRITE(6,*) ' LUUT opdated for I, NCOMMU-I = ', I,NCOMMU-I 9803 CALL WRTVCD(WORK(KVEC1P),LUUT,1,-1) 9804 END IF 9805 END IF 9806 END DO 9807* ^ End of loop over I 9808* 9809 IF(NTEST.GE.100) THEN 9810 WRITE(6,*) ' 1/NCOMMU! [[[H,T,],T..]] |0> (n-fold commutator)' 9811 CALL WRTVCD(WORK(KVEC1P),LUUT,1,-1) 9812 END IF 9813* 9814 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'TCOMHN') 9815 RETURN 9816 END 9817 SUBROUTINE GET_GENOP_INFO(NOBEX_TP,IOBEX_TP,NOCCLS, 9818 & IOBEX_TP_TO_OCCLS, 9819 & KLCOBEX_TP,KLAOBEX_TP,NSPOBEX_TP, 9820 & MXSPOXL,KLSOBEX,KLSOX_TO_OX,KIBSOX_FOR_OX,KNSOX_FOR_OX, 9821 & KISOX_FOR_OX,KLLSOBEX,KLIBSOBEX,KLSPOBEX_AC, 9822 & KIBSOX_FOR_OCCLS,KNSOX_FOR_OCCLS,KISOX_FOR_OCCLS, 9823 & MX_ST_TSOSO,MX_ST_TSOSO_BLK,MX_TBLK, 9824 & LEN_T_VEC,MSCOMB_CC,MX_TBLK_AS, 9825 & NAOBEX_TP,NBOBEX_TP,KLAOBEX,KLBOBEX, 9826 & MAXLENA,MAXLENB,MAXLEN_I1) 9827* 9828*. Generate information for general operators as defined by the 9829* NOBEX_TP excitationtypes in IOBEX_TP 9830* 9831* Jeppe Olsen, September 05 9832* 9833* For working with more than one set of general operators 9834* 9835 INCLUDE 'wrkspc.inc' 9836 INCLUDE 'crun.inc' 9837 INCLUDE 'cstate.inc' 9838 INCLUDE 'cgas.inc' 9839C INCLUDE 'ctcc.inc' 9840 INCLUDE 'gasstr.inc' 9841 INCLUDE 'strinp.inc' 9842 INCLUDE 'orbinp.inc' 9843 INCLUDE 'cprnt.inc' 9844 INCLUDE 'corbex.inc' 9845 INCLUDE 'csm.inc' 9846 INCLUDE 'cicisp.inc' 9847 INCLUDE 'cecore.inc' 9848 INCLUDE 'glbbas.inc' 9849 INCLUDE 'clunit.inc' 9850*. Input 9851 INTEGER IOBEX_TP(2*NGAS,NOBEX_TP) 9852 INTEGER IOBEX_TP_TO_OCCLS(NOBEX_TP) 9853* 9854 NTEST = 10 9855 IF(NTEST.GE.5) THEN 9856 WRITE(6,*) 9857 WRITE(6,*) ' Generation of general operator information ' 9858 WRITE(6,*) ' ========================================== ' 9859 WRITE(6,*) 9860 WRITE(6,*) ' Orbital excitations : ' 9861C WRT_ORBEX_LIST(IOBOX,NOBEX,NGAS) 9862 CALL WRT_ORBEX_LIST(IOBEX_TP,NOBEX_TP,NGAS) 9863 END IF 9864* 9865 IATP = 1 9866 IBTP = 2 9867* 9868 NAEL = NELEC(IATP) 9869 NBEL = NELEC(IBTP) 9870* 9871*. Number of creation and annihilation operators per op 9872 CALL MEMMAN(KLCOBEX_TP,NOBEX_TP,'ADDL ',1,'COBEX ') 9873 CALL MEMMAN(KLAOBEX_TP,NOBEX_TP,'ADDL ',1,'AOBEX ') 9874 CALL GET_NCA_FOR_ORBOP(NOBEX_TP,IOBEX_TP, 9875 & WORK(KLCOBEX_TP),WORK(KLAOBEX_TP),NGAS) 9876*. Number of spinorbital excitations 9877 IZERO = 0 9878 MXSPOXL = 0 9879 IACT_SPC = 0 9880 IAAEXC_TYP = 3 9881 IREFSPCX = 0 9882 MSCOMB_CC = 0 9883 CALL OBEX_TO_SPOBEX(1,IOBEX_TP,WORK(KLCOBEX_TP), 9884 & WORK(KLAOBEX_TP),NOBEX_TP,IDUMMY,NSPOBEX_TP,NGAS, 9885 & NOBPT,0,IZERO,IAAEXC_TYP,IACT_SPC,IPRCC,IDUMMY, 9886 & MXSPOXL,IDUMMY,IDUMMY,IDUMMY,NAEL,NBEL,IREFSPCX) 9887*. And the actual spinorbital excitations 9888 CALL MEMMAN(KLSOBEX,4*NGAS*NSPOBEX_TP,'ADDL ',1,'SPOBEX') 9889*. Map spin-orbital exc type => orbital exc type 9890 CALL MEMMAN(KLSOX_TO_OX,NSPOBEX_TP,'ADDL ',1,'SPOBEX') 9891*. First SOX of given OX ( including zero operator ) 9892 CALL MEMMAN(KIBSOX_FOR_OX,NOBEX_TP,'ADDL ',1,'IBSOXF') 9893*. Number of SOX's for given OX 9894 CALL MEMMAN(KNSOX_FOR_OX,NOBEX_TP,'ADDL ',1,'IBSOXF') 9895*. SOX for given OX 9896 CALL MEMMAN(KISOX_FOR_OX,NSPOBEX_TP,'ADDL ',1,'IBSOXF') 9897* 9898 CALL OBEX_TO_SPOBEX(2,WORK(KOBEX_TP),WORK(KLCOBEX_TP), 9899 & WORK(KLAOBEX_TP),NOBEX_TP,WORK(KLSOBEX),NSPOBEX_TP,NGAS, 9900 & NOBPT,0,MSCOMB_CC,IAAEXC_TYP,IACT_SPC,IPRCC, 9901 & WORK(KLSOX_TO_OX),MXSPOXL,WORK(KNSOX_FOR_OX), 9902 & WORK(KIBSOX_FOR_OX),WORK(KISOX_FOR_OX),NAEL,NBEL,IREFSPCX) 9903* 9904*. Mapping spinorbital excitations => occupation classes 9905 CALL MEMMAN(KIBSOX_FOR_OCCLS,NOCCLS,'ADDL ',1,'IBSXOC') 9906 CALL MEMMAN(KNSOX_FOR_OCCLS,NOCCLS,'ADDL ',1,' NSXOC') 9907 CALL MEMMAN(KISOX_FOR_OCCLS,NSPOBEX_TPE,'ADDL ',1,' ISXOC') 9908C SPOBEX_FOR_OCCLS( 9909C & IEXTP_TO_OCCLS,NOCCLS,ISOX_TO_OX,NSOX, 9910C & NSOX_FOR_OCCLS,ISOX_FOR_OCCLS,IBSOX_FOR_OCCLS) 9911 CALL SPOBEX_FOR_OCCLS(WORK(KEX_TO_OC),NOCCLS,WORK(KLSOX_TO_OX), 9912 & NSPOBEX_TPE,WORK(KNSOX_FOR_OCCLS),WORK(KISOX_FOR_OCCLS), 9913 & WORK(KIBSOX_FOR_OCCLS)) 9914* 9915* Dimension and offsets of IC operators 9916 CALL MEMMAN(KLLSOBEX,NSPOBEX_TP,'ADDL ',1,'LSPOBX') 9917 CALL MEMMAN(KLIBSOBEX,NSPOBEX_TP,'ADDL ',1,'LSPOBX') 9918 CALL MEMMAN(KLSPOBEX_AC,NSPOBEX_TP,'ADDL ',1,'SPOBAC') 9919*. ALl spinorbital excitations are initially active 9920 IONE = 1 9921 CALL ISETVC(WORK(KLSPOBEX_AC),IONE,NSPOBEX_TPE) 9922* 9923 ITOP_SM = 1 9924 CALL IDIM_TCC(WORK(KLSOBEX),NSPOBEX_TP,ITOP_SM, 9925 & MX_ST_TSOSO,MX_ST_TSOSO_BLK,MX_TBLK, 9926 & WORK(KLLSOBEX),WORK(KLIBSOBEX),LEN_T_VEC, 9927 & MSCOMB_CC,MX_TBLK_AS, 9928 & WORK(KISOX_FOR_OCCLS),NOCCLS,WORK(KIBSOX_FOR_OCCLS), 9929 & NTCONF,IPRCC) 9930 N_CC_AMP = LEN_T_VEC 9931 WRITE(6,*) ' Number of IC parameters ', N_CC_AMP 9932 WRITE(6,*) ' Dimension of the various types ' 9933 CALL IWRTMA(WORK(KLLSOBEX),1,NSPOBEX_TP,1,NSPOBEX_TP) 9934* 9935 MX_ST_TSOSO_MX = MX_ST_TSOSO 9936 MX_ST_TSOSO_BLK_MX = MX_ST_TSOSO_BLK 9937 MX_TBLK_MX = MX_TBLK 9938 MX_TBLK_AS_MX = MX_TBLK_AS 9939 LEN_T_VEC_MX = LEN_T_VEC 9940*. Some more scratch etc 9941*. Alpha- and beta-excitations constituting the spinorbital excitations 9942*. Number 9943 CALL SPOBEX_TO_ABOBEX(WORK(KLSOBEX),NSPOBEX_TP,NGAS, 9944 & 1,NAOBEX_TP,NBOBEX_TP,IDUMMY,IDUMMY) 9945*. And the alpha-and beta-excitations 9946 LENA = 2*NGAS*NAOBEX_TP 9947 LENB = 2*NGAS*NBOBEX_TP 9948 CALL MEMMAN(KLAOBEX,LENA,'ADDL ',2,'IAOBEX') 9949 CALL MEMMAN(KLBOBEX,LENB,'ADDL ',2,'IAOBEX') 9950 CALL SPOBEX_TO_ABOBEX(WORK(KLSOBEX),NSPOBEX_TP,NGAS, 9951 & 0,NAOBEX_TP,NBOBEX_TP,WORK(KLAOBEX),WORK(KLBOBEX)) 9952*. Max dimensions of CCOP !KSTR> = !ISTR> maps 9953*. For alpha excitations 9954 IATP = 1 9955 IOCTPA = IBSPGPFTP(IATP) 9956 NOCTPA = NSPGPFTP(IATP) 9957 CALL LEN_GENOP_STR_MAP( 9958 & NAOBEX_TP,WORK(KLAOBEX),NOCTPA,NELFSPGP(1,IOCTPA), 9959 & NOBPT,NGAS,MAXLENA) 9960 IBTP = 2 9961 IOCTPB = IBSPGPFTP(IBTP) 9962 NOCTPB = NSPGPFTP(IBTP) 9963 CALL LEN_GENOP_STR_MAP( 9964 & NBOBEX_TP,WORK(KLBOBEX),NOCTPB,NELFSPGP(1,IOCTPB), 9965 & NOBPT,NGAS,MAXLENB) 9966 MAXLEN_I1 = MAX(MAXLENA,MAXLENB) 9967 IF(NTEST.GE.5) WRITE(6,*) ' MAXLEN_I1 = ', MAXLEN_I1 9968* 9969 RETURN 9970 END 9971* 9972 SUBROUTINE WRT_ORBEX_LIST(IOBOX,NOBEX,NGAS) 9973* 9974* Print NOBEX orbital excitations given in IOBEX 9975* 9976 INCLUDE 'implicit.inc' 9977*. Input 9978 INTEGER IOBEX(2*NGAS,NOBEX) 9979* 9980 DO JOBEX = 1, NOBEX 9981 WRITE(6,*) ' Orbital excitation ', JOBEX 9982 CALL WRT_ORBEX(IOBEX(1,JOBEX),NGAS) 9983 END DO 9984* 9985 RETURN 9986 END 9987 SUBROUTINE WRT_ORBEX(IOBEX,NGAS) 9988* 9989* Print orbital excitation 9990* 9991 INCLUDE 'implicit.inc' 9992 INTEGER IOBEX(NGAS,2) 9993* 9994 WRITE(6,'(A,16I3)') ' Crea for each GASpace : ', 9995 & (IOBEX(I,1),I=1,NGAS) 9996 WRITE(6,'(A,16I3)') ' Anni for each GASpace : ', 9997 & (IOBEX(I,2),I=1,NGAS) 9998* 9999 RETURN 10000 END 10001 SUBROUTINE GET_ON_BASIS2(S,NVEC,NSING,X,SCRVEC1,SCRVEC2, 10002 & THRES_SINGU) 10003* 10004* NVEC vectors with overlap matrix S are given. 10005* Obtain transformation matrix to orthonormal basis 10006* 10007* NSING is the number of singularities obtained 10008* If there are singularities, the nonsingular transformation 10009* os obtained as a NVEC x (NVEC-NSING) matrix in X 10010* First vectors. The eigenvectors corresponding to the 10011* singular eigenvectors are lost. 10012* 10013* 10014* Jeppe Olsen, Palermo, oct 2002 10015* 10016 INCLUDE 'implicit.inc' 10017*. Input 10018 DIMENSION S(NVEC*NVEC) 10019*. Output 10020 DIMENSION X(NVEC*NVEC) 10021*. Local scratch 10022 DIMENSION SCRVEC1(*), SCRVEC2(*) 10023* 10024 NTEST = 000 10025 IF(NTEST.GE.100) THEN 10026 WRITE(6,*) ' GET_ON_BASIS speaking ' 10027 WRITE(6,*) ' Input overlap matrix ' 10028 CALL WRTMAT(S,NVEC,NVEC,NVEC,NVEC) 10029 END IF 10030*1 : Diagonalize S and save eigenvalues in SCRVEC1 10031 CALL COPVEC(S,X,NVEC*NVEC) 10032C DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 10033 CALL DIAG_SYMMAT_EISPACK(X,SCRVEC1,SCRVEC2,NVEC,IRETURN) 10034 IF(NTEST.GE.100) THEN 10035 WRITE(6,*) ' Eigenvalues of metric ' 10036 CALL WRTMAT(SCRVEC1,1,NVEC,1,NVEC) 10037 END IF 10038*2 : Count number of nonsingularities 10039 NNONSING = 0 10040 THRES = 1.0D-14 10041 DO I = 1, NVEC 10042 IF(ABS(SCRVEC1(I)).GT.THRES) THEN 10043 NNONSING = NNONSING + 1 10044 IF(I.NE.NNONSING) THEN 10045 SCRVEC1(NNONSING) = SCRVEC1(I) 10046 CALL COPVEC(X((I-1)*NVEC+1), X((NNONSING-1)*NVEC+1),NVEC) 10047 END IF 10048 END IF 10049 END DO 10050 NSING = NVEC - NNONSING 10051*2 : Rearrange so the nonsingular 10052* eigenvectors and eigenvalues are the first parts of X and 10053* SCRVEC1 10054CE ISING = 0 10055CE INONSING = 0 10056CE DO I = 1, NVEC 10057CE IF(ABS(SCRVEC1(I)) .GT. THRES) THEN 10058*. A nonsingular eigenpair 10059CE INONSING = INONSING + 1 10060CE ITO = INONSING 10061CE ELSE 10062*. A singular eigenpair 10063CE ISING = ISING + 1 10064CE ITO = ISING + NNONSING 10065CE END IF 10066CE IF(ITO.NE.I) THEN 10067CE SCRVEC1(ITO) = SCRVEC1(I) 10068CE CALL COPVEC(X((I-1)*NVEC+1), X((ITO-1)*NVEC+1),NVEC) 10069CE END IF 10070CE END DO 10071* 10072 IF(NTEST.GE.100) THEN 10073 WRITE(6,*) ' Nonsingular eigenvalues of metric ' 10074 CALL WRTMAT(SCRVEC1,1,NNONSING,1,NNONSING) 10075 END IF 10076*3 : Construct orthonormal basis using 10077* X = U sigma^{-1/2}, 10078* where U are the nonsingular 10079*. eigenvectors of S and sigma are the corresponding eigenvalues 10080 DO I = 1, NNONSING 10081 SCALE = 1/SQRT(SCRVEC1(I)) 10082 IBX = (I-1)*NVEC+1 10083 CALL SCALVE(X(IBX),SCALE,NVEC) 10084 END DO 10085* 10086 IF(NTEST.GE.100) THEN 10087 WRITE(6,*) ' Transformation matrix to nonsingular basis ' 10088 CALL WRTMAT(X,NVEC,NNONSING,NVEC,NNONSING) 10089 END IF 10090* 10091 RETURN 10092 END 10093C PRECTV(VEC1,VEC2,E,LUDIAM,LUDIAS) 10094 SUBROUTINE H0_EI_TV(VECIN,VECOUT,E,LUDIA,LUDIAS,VECSCR) 10095* 10096* A vector, VECIN, is given in the zero-order basis. 10097* Multiply with inverse diagonal of LUDIA 10098* 10099*. Jeppe Olsen, Sicily sept. 2009 10100* 10101 INCLUDE 'implicit.inc' 10102 INCLUDE 'cei.inc' 10103 INCLUDE 'cshift.inc' 10104 REAL*8 INPROD 10105* 10106*. Input 10107 DIMENSION VECIN(*) 10108*. Output 10109 DIMENSION VECOUT(*) 10110*. Scratch 10111 DIMENSION VECSCR(*) 10112* 10113 IDUM = 0 10114 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'H0EITV') 10115 NTEST = 100 10116 IF(NTEST.GE.100) THEN 10117 WRITE(6,*) ' Information from H0_EI_TV ' 10118 END IF 10119* 10120 VECIN_ORT= INPROD(VECIN,VECIN,N_ZERO_EI-1) 10121*. read in approximate (and unshifted) Jacobian in VECSCR 10122 CALL VEC_FROM_DISC(VECSCR,N_ZERO_EI,1,-1,LUDIA) 10123 IF(NTEST.GE.1000) THEN 10124 WRITE(6,*) ' Diagonal read in ' 10125 CALL WRTMAT(VECSCR,1,N_ZERO_EI,1,N_ZERO_EI) 10126 END IF 10127 E0 = VECSCR(N_ZERO_EI) 10128 IF(NTEST.GE.100) THEN 10129 WRITE(6,*) ' EREFX, E, E0 = ', EREFX,E,E0 10130 END IF 10131*� New direction = - Vecfunc/(diag - e) 10132 DO I = 1, N_ZERO_EI - 1 10133 VECOUT(I) = -VECIN(I)/(VECSCR(I) - E0) 10134 END DO 10135*. And the final element- corresponding to the zero-order state 10136 IF(ABS(EREFX-E).GT.1.0D-10) THEN 10137 VECOUT(N_ZERO_EI) = -VECIN(N_ZERO_EI)/(EREFX-E) 10138 ELSE 10139 VECOUT(N_ZERO_EI) = 0.0D0 10140 END IF 10141* 10142 VECOUT_ORT= INPROD(VECOUT,VECOUT,N_ZERO_EI-1) 10143* 10144 IF(NTEST.GE.100) THEN 10145 WRITE(6,*) ' VECIN_0, VECIN_ORT = ', 10146 & VECIN(N_ZERO_EI),VECIN_ORT 10147 WRITE(6,*) ' VECOUT_0, VECOUT_ORT = ', 10148 & VECOUT(N_ZERO_EI),VECOUT_ORT 10149 END IF 10150* 10151 IF(NTEST.GE.1000) THEN 10152 WRITE(6,*) ' direction in ort zero-order basis' 10153 CALL WRTMAT(VECOUT,1,N_ZERO_EI,1,N_ZERO_EI) 10154 END IF 10155* 10156 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'H0EITV') 10157 RETURN 10158 END 10159 SUBROUTINE LUCIA_ICCI(IREFSPC,ITREFSPC,ICTYP,EREF, 10160 & EFINAL,CONVER,VNFINAL) 10161* 10162* Master routine for Internal Contraction CI 10163* 10164* LUCIA_IC is assumed to have been called to do the 10165* preperatory work for working with internal contraction 10166* 10167* Jeppe Olsen, October 2009 (as separate routine) 10168* 10169C INCLUDE 'implicit.inc' 10170 INCLUDE 'wrkspc.inc' 10171 REAL*8 INPROD 10172 LOGICAL CONVER,CONVER_INT,CONVER_EXT 10173C INCLUDE 'mxpdim.inc' 10174 INCLUDE 'crun.inc' 10175 INCLUDE 'cstate.inc' 10176 INCLUDE 'cgas.inc' 10177 INCLUDE 'ctcc.inc' 10178 INCLUDE 'gasstr.inc' 10179 INCLUDE 'strinp.inc' 10180 INCLUDE 'orbinp.inc' 10181 INCLUDE 'cprnt.inc' 10182 INCLUDE 'corbex.inc' 10183 INCLUDE 'csm.inc' 10184 INCLUDE 'cicisp.inc' 10185 INCLUDE 'cecore.inc' 10186 INCLUDE 'glbbas.inc' 10187 INCLUDE 'clunit.inc' 10188 INCLUDE 'lucinp.inc' 10189 INCLUDE 'oper.inc' 10190 INCLUDE 'cintfo.inc' 10191 INCLUDE 'cei.inc' 10192*. Transfer common block for communicating with H_EFF * vector routines 10193 COMMON/COM_H_S_EFF_ICCI_TV/ 10194 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 10195 & IUNIOPX,NSPAX,IPROJSPCX 10196*. Transfer block for communicating zero order energy to 10197*. routien for performing H0-E0 * vector 10198 INCLUDE 'cshift.inc' 10199* 10200 CHARACTER*6 ICTYP 10201 EXTERNAL MTV_FUSK, STV_FUSK 10202 EXTERNAL H_S_EFF_ICCI_TV,H_S_EXT_ICCI_TV 10203 EXTERNAL HOME_SD_INV_T_ICCI 10204 EXTERNAL H0_EI_TV 10205* 10206 IDUM = 0 10207 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICCI ') 10208 NTEST = 10 10209 WRITE(6,*) 10210 WRITE(6,*) ' ====================' 10211 WRITE(6,*) ' ICCI section entered ' 10212 WRITE(6,*) ' ====================' 10213 WRITE(6,*) 10214* 10215 IF(IEI_VERSION.EQ.0) THEN 10216 I_DO_EI = 0 10217 ELSE 10218 I_DO_EI = 1 10219 END IF 10220* 10221 IF(I_DO_EI.EQ.1) THEN 10222 WRITE(6,*) ' EI approach in use' 10223 ELSE 10224 WRITE(6,*) ' Partial spin-adaptation in use' 10225 END IF 10226* 10227 10228 WRITE(6,*) ' Energy of reference state ', EREF 10229*. Number of parameters with and without spinadaptation 10230 IF(I_DO_EI.EQ.0) THEN 10231 CALL NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 10232 ELSE 10233*. zero-particle operator is included in N_ZERO_EI 10234 NSPA = N_ZERO_EI 10235*. Note: NCAAB includes unitop 10236 NCAAB = NDIM_EI 10237 END IF 10238 IF(I_DO_EI.EQ.0) THEN 10239 WRITE(6,*) ' Number of spin-adapted operators ', NSPA 10240 ELSE 10241 WRITE(6,*) ' Number of orthonormal zero-order states', 10242 & N_ZERO_EI 10243 END IF 10244 WRITE(6,*) ' Number of CAAB operators ', NCAAB 10245*. Number of spin adapted operators without the unitoperator 10246 I_IT_OR_DIR = 1 10247 IF(I_IT_OR_DIR.EQ.2) THEN 10248 WRITE(6,*) ' Explicit construction of all matrices' 10249 ELSE 10250 WRITE(6,*) ' Iterative solution of equations' 10251 END IF 10252* 10253 I_RELAX_INT = 1 10254* 10255* 10256 N_REF = XISPSM(IREFSM,IREFSPC) 10257*. Space for external correlation vector 10258 CALL MEMMAN(KLTEXT,NCAAB,'ADDL ',2,'T_EXT ') 10259*. Initial guess to T_EXT: just a 1 for the zero order state 10260 IF(IRESTRT_IC.EQ.0) THEN 10261 ZERO = 0.0D0 10262 CALL SETVEC(WORK(KLTEXT),ZERO,NSPA) 10263 WORK(KLTEXT-1+NSPA) = 1.0D0 10264*. Store inital guess on unit 54 10265 CALL VEC_TO_DISC(WORK(KLTEXT),NSPA,1,-1,LUSC54) 10266 END IF 10267* 10268 CONVER =.FALSE. 10269 CONVER_INT = .FALSE. 10270 CONVER_EXT = .FALSE. 10271 I12 = 2 10272* 10273 MAXIT_MACRO = MAXITM 10274 MAXITL = MAXIT 10275 MAXVECL = MXCIV 10276 WRITE(6,'(A,2I4)') 10277 &' Allowed number of outer and inner iterations', 10278 & MAXIT_MACRO, MAXITL 10279*. Convergence will be defined as energy change 10280 I_ER_CONV = 1 10281*. There is no external converence threshold for linear equations, 10282*. just use sqrt of energythreshold 10283 THRES_R = SQRT(THRES_E) 10284 DO IT_IE = 1, MAXIT_MACRO 10285* 10286 IF(NTEST.GE.1) THEN 10287 WRITE(6,*) 10288 WRITE(6,*) ' ------------------------------------------' 10289 WRITE(6,*) ' Information from outer iteration ', IT_IE 10290 WRITE(6,*) ' ------------------------------------------' 10291 WRITE(6,*) 10292 END IF 10293 IDUM = 0 10294 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'COMP_M') 10295*. Start by obtaining set of internal states 10296 I_REDO_ZERO = 1 10297 IF(I_DO_EI.EQ.1.AND.I_REDO_ZERO.EQ.1) THEN 10298 WRITE(6,*) ' Zero-order states recalculated' 10299 CALL GET_INTERNAL_STATES_OUTER 10300 N_INT_MAX = IMNMX(WORK(KL_N_INT_FOR_SE),N_EXTOP_TP*NSMOB,2) 10301*. Largest number of zero-order states of given sym and external type 10302 N_ORTN_MAX = IMNMX(WORK(KL_N_ORTN_FOR_SE),N_EXTOP_TP*NSMOB,2) 10303 WRITE(6,*) ' N_INT_MAX, N_ORTN_MAX = ', N_INT_MAX, N_ORTN_MAX 10304*. Largest transformation block 10305 N_XEO_MAX = N_INT_MAX*N_ORTN_MAX 10306 IF(NTEST.GE.5) WRITE(6,*) ' Largest (EL,ORTN) block = ', 10307 & N_XEO_MAX 10308*. Number of zero-order states - does now include the unit-operator 10309 N_ZERO_EI = N_ZERO_ORDER_STATES(WORK(KL_N_ORTN_FOR_SE), 10310 & WORK(KL_NDIM_EX_ST),N_EXTOP_TP,1) 10311 NSPA = N_ZERO_EI 10312 END IF 10313* 10314* ====================================================== 10315*. Coefficients for external correlation for root NROOT 10316* ====================================================== 10317 IF(NTEST.GE.0) THEN 10318 WRITE(6,*) 10319 WRITE(6,*) ' Optimization of external correlation part' 10320 WRITE(6,*) ' .........................................' 10321 WRITE(6,*) 10322 END IF 10323* 10324*. Prepare transfer common block used for H(ICCI) * v, S(ICCI) * v ( also used for constructing H,S) 10325*. Not used here 10326 C_0X = 0.0D0 10327 KLTOPX = -1 10328*. Used 10329 NREFX = N_REF 10330 IREFSPCX = IREFSPC 10331 ITREFSPCX = ITREFSPC 10332 NCAABX = N_CC_AMP 10333 NSPAX = NSPA 10334 IPROJSPCX = IREFSPC 10335*. Unitoperator in SPA order ... Please check .. 10336 IUNIOPX = NSPA 10337 IF (I_IT_OR_DIR.EQ.2 ) THEN 10338*. Construct matrices explicit and diagonalize 10339*. Not used here 10340 C_0X = 0.0D0 10341 KLTOPX = -1 10342*. Used 10343 NREFX = N_REF 10344 IREFSPCX = IREFSPC 10345 ITREFSPCX = ITREFSPC 10346 NCAABX = N_CC_AMP 10347 NSPAX = NSPA 10348 IPROJSPCX = IREFSPC 10349 CALL ICCI_COMPLETE_MAT2(IREFSPC,ITREFSPC,I_SPIN_ADAPT, 10350 & NROOT,WORK(KLTEXT),C_0,E_EXTOP) 10351 10352 EFINAL = E_EXTOP 10353 CONVER_EXT = .TRUE. 10354 VNFINAL_EXT = 0.0D0 10355 ELSE 10356*. Iterative approach to solving ICCI equations .... 10357*. Currently : no preconditioning and no elimination of singularities 10358* ( Yes, I am still an optimist ( or desperate )) 10359 NTESTL = 10 10360*. Space for CI behind the curtain 10361CMOVED CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 10362CMOVED KVEC1P = KVEC1 10363CMOVED KVEC2P = KVEC2 10364*. Allocate space for iterative solver 10365 CALL MEMMAN(KL_EXTVEC1,NCAAB,'ADDL ',2,'EXTVC1') 10366 CALL MEMMAN(KL_EXTVEC2,NCAAB,'ADDL ',2,'EXTVC2') 10367 CALL MEMMAN(KL_EXTVEC3,NCAAB,'ADDL ',2,'EXTVC3') 10368* ^ KLEXTVEC3 is also used as scratch in reformat 10369 CALL MEMMAN(KL_EXTVEC4,NCAAB,'ADDL ',2,'EXTVC3') 10370* 10371 CALL MEMMAN(KL_RNRM,MAXITL*NROOT,'ADDL ',2,'RNRM ') 10372 CALL MEMMAN(KL_EIG ,MAXITL*NROOT,'ADDL ',2,'EIG ') 10373 CALL MEMMAN(KL_FINEIG,NROOT,'ADDL ',2,'FINEIG') 10374* 10375 CALL MEMMAN(KL_APROJ,MAXVECL**2,'ADDL ',2,'APROJ ') 10376 CALL MEMMAN(KL_SPROJ,MAXVECL**2,'ADDL ',2,'SPROJ ') 10377 CALL MEMMAN(KL_AVEC ,MAXVECL**2,'ADDL ',2,'AVEC ') 10378 LLWORK = 5*MAXVECL**2 + 2*MAXVECL 10379 CALL MEMMAN(KL_WORK ,LLWORK ,'ADDL ',2,'WORK ') 10380 CALL MEMMAN(KL_AVEC ,MAXVECL**2,'ADDL ',2,'AVECP ') 10381 CALL MEMMAN(KL_AVECP,MAXVECL**2,'ADDL ',2,'AVECP ') 10382*. Obtain diagonal of H and S 10383 I_DO_PRE_IN_EXT = 0 10384 IF(I_DO_PRE_IN_EXT.EQ.1) THEN 10385 IF(I_DO_EI.EQ.0) THEN 10386 CALL GET_HS_DIA(WORK(KL_EXTVEC3),WORK(KL_EXTVEC4), 10387 & 1,1,1,WORK(KL_EXTVEC1),WORK(KL_EXTVEC2), 10388 & WORK(KVEC1),WORK(KVEC2),IREFSPC,ITREFSPC, 10389 & IUNIOPX,NSPA,0,IDUM,IDUM) 10390 ELSE 10391*. EI approach 10392 CALL GET_DIAG_H0_EI(WORK(KL_EXTVEC3)) 10393*. clean up 10394 I12 = 2 10395*. States are normalized, so 10396 ONE = 1.0D0 10397 CALL SETVEC(WORK(KL_EXTVEC4),ONE,NSPA) 10398 END IF 10399 ELSE 10400 ONE = 1.0D0 10401 CALL SETVEC(WORK(KL_EXTVEC3),ONE,NSPA) 10402 CALL SETVEC(WORK(KL_EXTVEC4),ONE,NSPA) 10403 END IF 10404*. And write diagonal to disc as single record files 10405 CALL VEC_TO_DISC(WORK(KL_EXTVEC3),NSPA,1,-1,LUSC53) 10406 CALL VEC_TO_DISC(WORK(KL_EXTVEC4),NSPA,1,-1,LUSC51) 10407*. (LUSC51 is not used) 10408 IF(IRESTRT_IC.EQ.1) THEN 10409*. Copy old CI coefficients for reference space to LUC 10410 CALL COPVCD(LUEXC,LUC,WORK(KVEC1),1,-1) 10411 END IF 10412 DO IMAC = 1, 1 10413* LUSC53 is LU_DIAH, LUSC51 is LU_DIAS 10414*. 2 implies that advanced preconditioner is called 10415*- Save reference energy for use with diagonal preconditioner 10416 EREFX = EREF 10417* 10418 IF(IT_IE.GT.1) THEN 10419 I_ENFORCE_COLD_START = 0 10420 IF(I_ENFORCE_COLD_START.EQ.1) THEN 10421 WRITE(6,*) ' Enforced start with Text = 0' 10422 ZERO = 0.0D0 10423 CALL SETVEC(WORK(KLTEXT),ZERO,NSPA) 10424 WORK(KLTEXT-1+NSPA) = 1.0D0 10425 CALL VEC_TO_DISC(WORK(KLTEXT),NSPA,1,-1,LUSC54) 10426 ELSE 10427*. Use the previous coefficients to start. 10428 T_CAAB_NORM = 10429 & SQRT(INPROD(WORK(KLTEXT),WORK(KLTEXT),NCAAB)) 10430 WRITE(6,*) ' Norm of T in CAAB basis before MINGENEIG', 10431 & T_CAAB_NORM 10432 WRITE(6,*) ' T(zero-op) in CAAB basis ', 10433 & WORK(KLTEXT-1+NCAAB) 10434*. Transform to zero-order basis- used in MINGENEIG 10435 CALL TRANS_CAAB_ORTN(WORK(KLTEXT),WORK(KL_EXTVEC1), 10436 & 1,1,2,WORK(KL_EXTVEC3),2) 10437*. Test back-transformation to CAAB basis 10438 CALL TRANS_CAAB_ORTN(WORK(KL_EXTVEC4),WORK(KL_EXTVEC1), 10439 & 1,2,2,WORK(KL_EXTVEC3),2) 10440 T_CAAB_NORM2 = 10441 & SQRT(INPROD(WORK(KL_EXTVEC4),WORK(KL_EXTVEC4),NCAAB)) 10442 WRITE(6,*) ' Norm of T in CAAB basis backtransformed', 10443 & T_CAAB_NORM2 10444*. End of test 10445 T_ORT_NORM = 10446 & SQRT(INPROD(WORK(KL_EXTVEC1),WORK(KL_EXTVEC1),NSPA)) 10447 WRITE(6,*) ' Norm of T in Ort basis before MINGENEIG', 10448 & T_ORT_NORM 10449 WRITE(6,*) ' T(zero-op) in ort basis ', 10450 & WORK(KL_EXTVEC1-1+NSPA) 10451 CALL VEC_TO_DISC(WORK(KL_EXTVEC1),NSPA,1,-1,LUSC54) 10452 END IF 10453 END IF 10454* ^ End if not first IE-iteration 10455* 10456 I12 = 2 10457 IF(I_DO_EI.EQ.0) THEN 10458 IPREC_FORM = 1 10459 SHIFT = 0.0D0 10460 CALL MINGENEIG(H_S_EXT_ICCI_TV,HOME_SD_INV_T_ICCI, 10461 & IPREC_FORM,THRES_E,THRES_R,I_ER_CONV, 10462 & WORK(KL_EXTVEC1),WORK(KL_EXTVEC2),WORK(KL_EXTVEC3), 10463 & LUSC54, LUSC37, 10464 & WORK(KL_RNRM),WORK(KL_EIG),WORK(KL_FINEIG),MAXITL, 10465 & NSPA,LUSC38,LUSC39,LUSC40,LUSC53,LUSC51,LUSC52, 10466 & NROOT,MAXVECL,NROOT,WORK(KL_APROJ), 10467 & WORK(KL_AVEC),WORK(KL_SPROJ),WORK(KL_WORK), 10468 & NTESTL,SHIFT,WORK(KL_AVECP),I_DO_PRE_IN_EXT, 10469 & CONVER_EXT,E_EXTOP,VNFINAL_EXT) 10470 ELSE 10471 IPREC_FORM = 2 10472 SHIFT = 0.0D0 10473 CALL MINGENEIG(H_S_EXT_ICCI_TV,H0_EI_TV, 10474 & IPREC_FORM,THRES_E,THRES_R,I_ER_CONV, 10475 & WORK(KL_EXTVEC1),WORK(KL_EXTVEC2),WORK(KL_EXTVEC3), 10476 & LUSC54, LUSC37, 10477 & WORK(KL_RNRM),WORK(KL_EIG),WORK(KL_FINEIG),MAXITL, 10478 & NSPA,LUSC38,LUSC39,LUSC40,LUSC53,LUSC51,LUSC52, 10479 & NROOT,MAXVECL,NROOT,WORK(KL_APROJ), 10480 & WORK(KL_AVEC),WORK(KL_SPROJ),WORK(KL_WORK), 10481 & NTESTL,SHIFT,WORK(KL_AVECP),I_DO_PRE_IN_EXT, 10482 & CONVER_EXT,E_EXTOP,VNFINAL_EXT) 10483 END IF 10484 EFINAL = E_EXTOP 10485 END DO 10486* ^ End of loop over reset eigenvalue problem 10487 CALL VEC_FROM_DISC(WORK(KL_EXTVEC1),NSPA,1,-1,LUSC54) 10488* 10489 T_ORT_NORM = 10490 & SQRT(INPROD(WORK(KL_EXTVEC1),WORK(KL_EXTVEC1),NSPA)) 10491 WRITE(6,*) ' Norm of T in Ort basis after MINGENEIG', 10492 & T_ORT_NORM 10493 C_0 = WORK(KL_EXTVEC1-1+NSPA) 10494*. And reform to CAAB basis and store in KLTEXT 10495 IF(I_DO_EI.EQ.0) THEN 10496 CALL REF_CCV_CAAB_SP(WORK(KLTEXT),WORK(KL_EXTVEC1), 10497 & WORK(KL_EXTVEC3),2) 10498 ELSE 10499 CALL TRANS_CAAB_ORTN(WORK(KLTEXT),WORK(KL_EXTVEC1),1,2,2, 10500 & WORK(KL_EXTVEC3),2) 10501 END IF 10502 T_CAAB_NORM = 10503 & SQRT(INPROD(WORK(KLTEXT),WORK(KLTEXT),NCAAB)) 10504 WRITE(6,*) ' Norm of T in CAAB basis after MINGENEIG', 10505 & T_CAAB_NORM 10506* 10507 IF(NTEST.GE.10) THEN 10508 WRITE(6,*) ' coefficient of zero-order state ', C_0 10509 WRITE(6,*) ' Analysis of external amplitudes in CAAB basis' 10510 CALL ANA_GENCC(WORK(KLTEXT),1) 10511 END IF 10512 10513 END IF 10514* ^ End of switch direct/iterative approach for T_EXT 10515 IF(I_RELAX_INT.EQ.1) THEN 10516* ============================================================ 10517*. Relax coefficients of internal/reference/zero-order state 10518* ============================================================ 10519* 10520 IF(NTEST.GE.0) THEN 10521 WRITE(6,*) 10522 WRITE(6,*) ' Optimization of internal correlation part' 10523 WRITE(6,*) ' .........................................' 10524 WRITE(6,*) 10525 END IF 10526COLD CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 10527COLD KVEC1P = KVEC1 10528COLD KVEC2P = KVEC2 10529* 10530 IF(I_IT_OR_DIR.EQ.2) THEN 10531* 10532*. Construct complete matrices and diagonalize 10533* 10534*. Space for H and S in zero-order space 10535 CALL MEMMAN(KLH_REF,N_REF**2,'ADDL ',2,'H_REF ') 10536 CALL MEMMAN(KLS_REF,N_REF**2,'ADDL ',2,'S_REF ') 10537 CALL MEMMAN(KLC_REF,N_REF ,'ADDL ',2,'C_REF ') 10538 CALL MEMMAN(KLI_REF,N_REF ,'ADDL ',1,'I_REF ') 10539* 10540 CALL ICCI_RELAX_REFCOEFS_COM(WORK(KLTEXT),NSPA, 10541 & WORK(KLH_REF), 10542 & WORK(KLS_REF),N_REF,WORK(KVEC1),WORK(KVEC2),1, 10543 & IREFSPC,ITREFSPC,C_0,ECORE,WORK(KLC_REF),NROOT, 10544 & NCAAB,E_INTOP) 10545 CONVER_INT =.TRUE. 10546 VNFINAL_INT = 0.0D0 10547 EFINAL = E_INTOP 10548*. transfer new reference vector to DISC 10549 CALL ISTVC2(WORK(KLI_REF),0,1,N_REF) 10550C WRSVCD(LU,LBLK,VEC1,IPLAC,VAL,NSCAT,NDIM,LUFORM,JPACK) 10551 CALL REWINO(LUC) 10552 CALL WRSVCD(LUC,-1,WORK(KVEC1),WORK(KLI_REF), 10553 & WORK(KLC_REF),N_REF,N_REF,LUDIA,1) 10554 ELSE 10555*. Use iterative methods to reoptimize reference coefficients 10556 MAXITL = MAXIT 10557 MAXVEC = MXCIV 10558* 10559 CALL MEMMAN(KL_REFVEC1,N_REF,'ADDL ',2,'REFVC1') 10560 CALL MEMMAN(KL_REFVEC2,N_REF,'ADDL ',2,'REFVC2') 10561 CALL MEMMAN(KL_REFVEC3,N_REF,'ADDL ',2,'REFVC3') 10562* 10563 CALL MEMMAN(KL_RNRM,MAXIT*NROOT,'ADDL ',2,'RNRM ') 10564 CALL MEMMAN(KL_EIG ,MAXIT*NROOT,'ADDL ',2,'EIG ') 10565 CALL MEMMAN(KL_FINEIG,NROOT,'ADDL ',2,'FINEIG') 10566* 10567 CALL MEMMAN(KL_APROJ,MAXVEC**2,'ADDL ',2,'APROJ ') 10568 CALL MEMMAN(KL_SPROJ,MAXVEC**2,'ADDL ',2,'SPROJ ') 10569 CALL MEMMAN(KL_AVEC ,MAXVEC**2,'ADDL ',2,'AVEC ') 10570 LLWORK = 5*MAXVEC**2 + 2*MAXVEC 10571 CALL MEMMAN(KL_WORK ,LLWORK ,'ADDL ',2,'WORK ') 10572 CALL MEMMAN(KL_AVEC ,MAXVEC**2,'ADDL ',2,'AVECP ') 10573 CALL MEMMAN(KL_AVECP,MAXVEC**2,'ADDL ',2,'AVECP ') 10574* 10575* Well, there is pt a conflict between the form of files 10576* in mingeneig and in the general CI programs 10577*. In MINGENEIG all vectors are single record files, whereas 10578* the vectors are multirecord files in the general LUCIA 10579* world. Reformatting is therefore required.. 10580*. LUC is LUC 10581*. LUSC36 is LUDIA 10582*. LUSC51 is LUDIAS 10583* 10584*. Reform LUC to single record file 10585 CALL REWINO(LUC) 10586 CALL FRMDSCN(WORK(KL_REFVEC1),-1,-1,LUC) 10587 CALL REWINO(LUC) 10588 CALL VEC_TO_DISC(WORK(KL_REFVEC1),N_REF,1,-1,LUC) 10589*. Reform LUDIA to single record file on LUSC36 10590 CALL REWINO(LUDIA) 10591 CALL FRMDSCN(WORK(KL_REFVEC1),-1,-1,LUDIA) 10592 CALL VEC_TO_DISC(WORK(KL_REFVEC1),N_REF,1,-1,LUSC36) 10593*. Write diagonal of S as unit mat as single vector file 10594 ONE = 1.0D0 10595 CALL SETVEC(WORK(KL_REFVEC1),ONE,N_REF) 10596 CALL VEC_TO_DISC(WORK(KL_REFVEC1),N_REF,1,-1,LUSC51) 10597*. (LUSC51 is not used) 10598* 10599* As preconditioners, the standard CI diagonal and the 10600* unit diagonal will be used for H and S, respectively. 10601* This is fine if the T operator is not too large... 10602* 10603*. Prepare transfer common block for communicating with 10604*. matrix-vector routines 10605C C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX 10606 C_0X = C_0 10607 KLTOPX = KLTEXT 10608 NREFX = N_REF 10609 IREFSPCX = IREFSPC 10610 ITREFSPCX = ITREFSPC 10611 NCAABX = N_CC_AMP 10612 NSPAX = NSPA 10613*. Unitoperator in SPA order ... Please check .. 10614 IUNIOPX = NSPA 10615* 10616 SHIFT = 0.0D0 10617 CALL MINGENEIG( H_S_EFF_ICCI_TV,HOME_SD_INV_T_ICCI,1, 10618 & THRES_E,THRES_R,I_ER_CONV, 10619 & WORK(KL_REFVEC1),WORK(KL_REFVEC2),WORK(KL_REFVEC3), 10620 & LUC, LUSC37, 10621 & WORK(KL_RNRM),WORK(KL_EIG),WORK(KL_FINEIG),MAXITL, 10622 & N_REF,LUSC38,LUSC39,LUSC40,LUSC36,LUSC51,LUSC52, 10623 & NROOT,MXCIV,NROOT,WORK(KL_APROJ), 10624 & WORK(KL_AVEC),WORK(KL_SPROJ),WORK(KL_WORK), 10625 & NTESTL,SHIFT,WORK(KL_AVECP),1, 10626 & CONVER_INT,E_INTOP,VNFINAL_INT) 10627 EFINAL = E_INTOP 10628C MINGENEIG(MTV,STV, 10629C & VEC1,VEC2,VEC3,LU1,LU2,RNRM,EIG,FINEIG,MAXIT, 10630C & NVAR, 10631C & LU3,LU4,LU5,LUDIAM,LUDIAS,LUS,NROOT,MAXVEC, 10632C & NINVEC, 10633C & APROJ,AVEC,SPROJ,WORK,IPRT,EIGSHF,AVECP,I_DO_PRECOND) 10634* 10635*. Read new eigenvector from LUC 10636 CALL REWINO(LUC) 10637 CALL FRMDSCN(WORK(KL_REFVEC1),-1,-1,LUC) 10638* The eigenvector is normalized with respect to the <i!T+P P T|j> 10639*. metric, normalize with standard unit metrix 10640 XNORM = INPROD(WORK(KL_REFVEC1),WORK(KL_REFVEC1),N_REF) 10641 FACTOR = 1.0D0/SQRT(XNORM) 10642 CALL SCALVE(WORK(KL_REFVEC1),FACTOR,N_REF) 10643*. And write to disc in a form suitable for the other parts of LUCIA 10644 CALL ISTVC2(WORK(KL_REFVEC2),0,1,N_REF) 10645 CALL REWINO(LUC) 10646 CALL REWINO(LUDIA) 10647 CALL WRSVCD(LUC,-1,WORK(KVEC1P),WORK(KL_REFVEC2), 10648 & WORK(KL_REFVEC1),N_REF,N_REF,LUDIA,1) 10649 IF(NTEST.GE.100) THEN 10650 WRITE(6,*) ' New reference coefficients ' 10651 CALL WRTVCD(WORK(KVEC1P),LUC,1,-1) 10652 END IF 10653 END IF 10654*. ^ End of switch direct/iterative methods for reference relaxation 10655 END IF 10656*. ^ End of reference coefs should be relaxed 10657 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'COMP_M') 10658 IF(CONVER_INT.AND.CONVER_EXT.AND. 10659 & ABS(E_INTOP-E_EXTOP).LE.THRES_E) CONVER = .TRUE. 10660 IF(CONVER) GOTO 1001 10661 END DO 10662 1001 CONTINUE 10663* 10664 IF(MAXIT_MACRO.GT.0) THEN 10665 IF(NTEST.GE.10) THEN 10666 WRITE(6,*) ' coefficient of zero-order state ', C_0 10667 WRITE(6,*) 10668 & ' Analysis of final external amplitudes in CAAB basis' 10669 CALL ANA_GENCC(WORK(KLTEXT),1) 10670 END IF 10671* 10672 VNFINAL = VNFINAL_INT + VNFINAL_EXT 10673 WRITE(6,*) ' VNFINAL_INT, VNFINAL_EXT =', 10674 & VNFINAL_INT,VNFINAL_EXT 10675*. Print the final coefs .. 10676C? CALL VEC_FROM_DISC(WORK(KL_EXTVEC1),NSPA,1,-1,LUSC54) 10677C? WRITE(6,*) ' Final list of IC-coefficients ' 10678C? CALL WRTMAT(WORK(KL_EXTVEC1),NSPA,1,NSPA,1) 10679 END IF ! There were iterations to analyze 10680 10681 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ICCI ') 10682 RETURN 10683 END 10684 SUBROUTINE GET_INTERNAL_STATES_OUTER 10685* 10686* Outer routine for obtaining set of orthonormal internal states 10687* 10688*. For hiding an ugly parameter list.. 10689* 10690*. Jeppe Olsen, Oct. 2009 10691 INCLUDE 'wrkspc.inc' 10692 INCLUDE 'cei.inc' 10693 INCLUDE 'ctcc.inc' 10694 INCLUDE 'crun.inc' 10695* 10696 WRITE(6,*) ' GET_INTERNAL..., I_INT_HAM = ', I_INT_HAM 10697 CALL GET_INTERNAL_STATES(N_EXTOP_TP,N_INTOP_TP, 10698 & WORK(KLSOBEX),WORK(KL_N_INT_FOR_EXT),WORK(KL_IB_INT_FOR_EXT), 10699 & WORK(KL_I_INT_FOR_EXT),WORK(KL_NDIM_IN_SE), 10700 & WORK(KL_N_ORTN_FOR_SE),WORK(KL_N_INT_FOR_SE), 10701 & WORK(KL_X1_INT_EI_FOR_SE), WORK(KL_X2_INT_EI_FOR_SE), 10702 & WORK(KL_SG_INT_EI_FOR_SE),WORK(KL_S_INT_EI_FOR_SE), 10703 & WORK(KL_IBX1_INT_EI_FOR_SE), WORK(KL_IBX2_INT_EI_FOR_SE), 10704 & WORK(KL_IBSG_INT_EI_FOR_SE),WORK(KL_IBS_INT_EI_FOR_SE), 10705 & WORK(KL_X2L_INT_EI_FOR_SE), 10706 & I_IN_TP,I_INT_OFF,I_EXT_OFF) 10707* 10708 RETURN 10709 END 10710 SUBROUTINE MRCC_VECFNCN(CCVECFNC,T, 10711 & IREFSPC,ITREFSPC,IT2REFSPC,CCVECFNCI,C_REF,N_REF, 10712 & I_DO_PROJ_NR,E_INT,E_EXT,ECORE,I_INI_CO,I_FIN_CO) 10713* 10714* Obtain external and internal parts of the MRCC vector function 10715* 10716*. Version allowing various forms of input and output and 10717*. includes calculation of internal part for NCOMMU_E .ne N_COMMU_V 10718* 10719* I_INI_CO = 1 => Initial guess is in CAAB basis, 10720* = 2 => Initial guess is in Orthornormal basis 10721* I_FIN_CO = 1 => Final guess is in CAAB basis, 10722* = 2 => Final guess is in Orthornormal basis 10723* 10724* Jeppe Olsen, Feb. 20, 2010 from MRCC_VECFNC 10725* 10726* Unclean: Internal CI-coefficients are handled 10727* borh through LUC and C_REF... 10728* 10729* External part: 10730* ================ 10731* 10732* <0!tau^{\dagger} exp(-T) H exp(T) !0>. 10733*. The commutator exp(-T) H exp(T) is terminated after NCOMMU_V commutators 10734* 10735*. Internal part: 10736* ================ 10737* 10738* <J! exp(-T) H exp(T) - E !0> 10739*. The commutator exp(-T) H exp(T) is terminated after NCOMMU_E commutators 10740* 10741* (initial version using CI behind the curtains) 10742* 10743* 10744 INCLUDE 'wrkspc.inc' 10745 REAL*8 10746 &INPROD 10747 INCLUDE 'crun.inc' 10748 INCLUDE 'clunit.inc' 10749 INCLUDE 'cands.inc' 10750 INCLUDE 'glbbas.inc' 10751 INCLUDE 'cstate.inc' 10752 INCLUDE 'oper.inc' 10753 INCLUDE 'cintfo.inc' 10754 INCLUDE 'cei.inc' 10755#include "errquit.fh" 10756#include "mafdecls.fh" 10757#include "global.fh" 10758 DIMENSION C_REF(N_REF) 10759*. Specific input 10760 DIMENSION T(*) 10761*. Output 10762 DIMENSION CCVECFNC(*),CCVECFNCI(*) 10763* 10764 NTEST = 05 10765 IF(NTEST.GE.100) THEN 10766 WRITE(6,*) ' Output from MRCC_VECFNCN' 10767 WRITE(6,*) ' -----------------------' 10768 WRITE(6,*) ' IREFSPC,ITREFSPC, IT2REFSPC =', 10769 & IREFSPC,ITREFSPC, IT2REFSPC 10770 END IF 10771* 10772 IDUM = 0 10773 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'MRCCVF') 10774* 10775 CALL MEMMAN(KLVCC1,N_CC_AMP,'ADDL ',2,'LCCVC1') 10776 CALL MEMMAN(KLVCC2,N_CC_AMP,'ADDL ',2,'LCCVC2') 10777* 10778 IF(I_INI_CO.EQ.2) THEN 10779*. Initial guess is in orthonormal basis, change to CAAB basis 10780*. Dir in EI in T to Dir in CAAB in VCC1 10781 CALL TRANS_CAAB_ORTN(WORK(KLVCC1),T,1,2,2, 10782 & WORK(KLVCC2),2) 10783 ELSE 10784 CALL COPVEC(T,WORK(KLVCC1),N_CC_AMP) 10785 END IF 10786* 10787* 1 : Obtain exp(-T) H exp(T) !0> and save on LUHC 10788* 10789C EMNTHETO(T,LUOUT,NCOMMU,IREFSPC,ITREFSPC) 10790 IF(I_APPROX_HCOM_V.EQ.0) THEN 10791 CALL EMNTHETO(WORK(KLVCC1),LUC,LUHC,NCOMMU_V,IREFSPC,ITREFSPC, 10792 & IT2REFSPC) 10793 ELSE 10794*. Exact calculation of all terms with upto NCOMMU_V-1 commutators 10795 CALL EMNTHETO(WORK(KLVCC1),LUC,LUHC,NCOMMU_V-1,IREFSPC,ITREFSPC, 10796 & IT2REFSPC) 10797*. and add contribution from highest commutator 10798*. Use zero-order Hamiltonian stored in 10799 I12 = 1 10800 CALL SWAPVE(WORK(KINT1),WORK(KFIFA),NINT1) 10801 CALL TCOM_H_N(WORK(KLVCC1),LUC,LUHC,NCOMMU_V,IREFSPC,ITREFSPC, 10802 & IT2REFSPC,1) 10803C TCOM_H_N(T,LUINI,LUUT,NCOMMU,IREFSPC,ITREFSPC,IT2REFSPC,IAC) 10804 I12 = 2 10805 CALL SWAPVE(WORK(KINT1),WORK(KFIFA),NINT1) 10806 END IF 10807* 10808* 2 : Obtain <0!tau^{\dagger} exp(-T) H exp(T) !0> = <LUC!tau^{\dagger}|LUHC> 10809* 10810 ICSPC = IREFSPC 10811 ISSPC = IT2REFSPC 10812C WRITE(6,*) ' IREFSPC, IT2REFSPC =', IREFSPC, IT2REFSPC 10813 IF(NTEST.GE.1000) THEN 10814 WRITE(6,*) ' Vector on LUC ' 10815 CALL WRTVCD(WORK(KVEC1P),LUC,1,-1) 10816 WRITE(6,*) ' Vector on LUHC ' 10817 CALL WRTVCD(WORK(KVEC1P),LUHC,1,-1) 10818 END IF 10819* 10820 ZERO = 0.0D0 10821 CALL SETVEC(CCVECFNC,ZERO,N_CC_AMP) 10822 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUHC,CCVECFNC,2) 10823 IF(NTEST.GE.1000) THEN 10824 WRITE(6,*) 'CCVECFNC right after SIGDEN_CC' 10825 CALL WRTMAT(CCVECFNC,1,N_CC_AMP,1,N_CC_AMP) 10826 END IF 10827 XN_CAAB = INPROD(CCVECFNC,CCVECFNC,N_CC_AMP-1) 10828 WRITE(6,*) ' Norm of CCVEC in CAAB basis = ', XN_CAAB 10829* 10830*. 2.5. Project redundant directions out if requested 10831 IF(I_DO_PROJ_NR.EQ.1) THEN 10832 IF(NTEST.GE.5) 10833 & WRITE(6,*) ' Redundant directions projected out in MRCC...' 10834C PROJ_TO_NONRED(VECIN,VECOUT,ITSYM,VECSCR) 10835 CALL PROJ_TO_NONRED(CCVECFNC,WORK(KLVCC1),1,WORK(KLVCC2)) 10836 CALL COPVEC(WORK(KLVCC1),CCVECFNC,N_CC_AMP) 10837 END IF 10838*. The energy obtained from the external vectorfunction 10839 E_EXT = CCVECFNC(N_CC_AMP) 10840 IF(NTEST.GE.5) 10841 &WRITE(6,*) ' Energy from external part of vecfnc ', E_EXT 10842C &WRITE(6,*) ' Energy from external part of vecfnc ', E_EXT+ECORE 10843*. And clear element corresponding to N_CC_AMP- not really part of 10844*. vectorfunction 10845 CCVECFNC(N_CC_AMP) = 0.0D0 10846* 10847*. 2.6: Transform if required vector function to orthonormal basis 10848 IF(I_FIN_CO.EQ.2) THEN 10849*. Vecfunc in CAAB in VCC5 to Vecfunc in EI in VCC2 10850*. zero-order state is not to be included 10851 N_ZERO_EIM = N_ZERO_EI - 1 10852 CALL TRANS_CAAB_ORTN(CCVECFNC,WORK(KLVCC1),1,1,2, 10853 & WORK(KLVCC2),1) 10854 CALL COPVEC(WORK(KLVCC1),CCVECFNC,N_ZERO_EIM) 10855*. To be sure.. 10856 CCVECFNC(N_ZERO_EI) = 0.0D0 10857 END IF 10858* 10859* 3 : Contract exp(-T) H exp(T) |0> to reference space and save on LUHC 10860* to obtain part of internal part of MRCC vector function 10861* 10862 IF((NCOMMU_E.NE.NCOMMU_V.AND. 10863 & .NOT.(NCOMMU_E.EQ.4.AND.NCOMMU_V.GT.4)) .OR. 10864 & I_APPROX_HCOM_V.NE.I_APPROX_HCOM_E) THEN 10865*. Recalculate Internal part of MRCC vector function 10866 IF(NTEST.GE.10) 10867 & WRITE(6,*) ' Internal part of vector-function recalculated' 10868 CALL HEFF_INT_TV_ICCC(T,N_REF,NCOMMU_E,I_APPROX_HCOM_E, 10869 & dbl_mb(VEC1P),dbl_mb(KVEC2P),IREFSPC,ITREFSPC,IT2REFSPC, 10870 & 0.0D0,C_REF,CCVECFNCI) 10871 ELSE 10872 CALL EXPCIV(IREFSM,IT2REFSPC,LUHC,IREFSPC,LUSC34,-1, 10873 / LUSC35,1,1,IDC,0) 10874 CALL REWINO(LUHC) 10875 CALL FRMDSCN(CCVECFNCI,-1,-1,LUHC) 10876 END IF 10877*. Energy from internal part 10878 E_INT = INPROD(C_REF,CCVECFNCI,N_REF) 10879 IF(NTEST.GE.5) 10880 &WRITE(6,*) ' Energy from internal part of vecfnc ', E_INT 10881C &WRITE(6,*) ' Energy from internal part of vecfnc ', E_INT+ECORE 10882*. And the internal vector function 10883 ONE = 1.0D0 10884 FACTOR = -E_INT 10885 CALL VECSUM(CCVECFNCI,CCVECFNCI,C_REF,ONE,FACTOR,N_REF) 10886*. Zero internal if requested 10887* - after all the work... - could be done in a more elegant way... 10888 IF(I_FIX_INTERNAL.EQ.1) THEN 10889*. set internal gradient to zero 10890 ZERO = 0.0D0 10891 CALL SETVEC(CCVECFNCI,ZERO,N_REF) 10892 WRITE(6,*) ' Internal gradient set to zero ' 10893 END IF 10894* 10895 IF(NTEST.GE.100) THEN 10896* 10897 IF(I_INI_CO.EQ.1) THEN 10898 WRITE(6,*) ' Input T-coefficients in CAAB basis' 10899 CALL WRTMAT(T,1,N_CC_AMP,1,N_CC_AMP) 10900 ELSE 10901 WRITE(6,*) ' Input T-coefficients in ortn. basis' 10902 CALL WRTMAT(T,1,N_ZERO_EI,1,N_ZERO_EI) 10903 END IF 10904* 10905 IF(I_FIN_CO.EQ.1) THEN 10906 WRITE(6,*) ' MRCC Vector function, external part (CAAB) ' 10907 CALL WRTMAT(CCVECFNC,1,N_CC_AMP,1,N_CC_AMP) 10908 ELSE 10909 WRITE(6,*) ' MRCC Vector function, external part (ortn) ' 10910 CALL WRTMAT(CCVECFNC,1,N_ZERO_EI,1,N_ZERO_EI) 10911 END IF 10912* 10913 WRITE(6,*) 'MRCC Vector function,internal part' 10914 CALL WRTMAT(CCVECFNCI,1,N_REF,1,N_REF) 10915 END IF 10916* 10917 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'MRCCVF') 10918* 10919 10920 RETURN 10921 END 10922 SUBROUTINE ICCC_OPT_SIMULT_ONB( 10923 & IREFSPC,ITREFSPC,IT2REFSPC,I_SPIN_ADAPT, 10924 & IREFROOT,T_EXT,C_0,INI_IT,IFIN_IT,VEC1,VEC2,IDIIS, 10925 & C_REF,N_REF,I_DO_COMP,CONVERL,VTHRES,I_REDO_INT, 10926 & EFINAL,VNFINAL,CONVERG,SCR_SBSPJA,MXVEC_SBSPJA) 10927 10928* 10929* Master routine for Internal Contraction Coupled Cluster 10930* 10931* It is assumed that the excitation manifold produces 10932* states that are orthogonal to the reference so 10933* no projection is carried out 10934* 10935* Routine is allowed to leave without turning the lights off, 10936* i.e. leave routine with all allocations and marks intact. 10937*: Thus : Allocations are only done if INI_IT = 1 10938* Deallocations are only done if IFIN_IT = 1 10939* 10940*. Preconditioners are only calculated if INI_IT = 1 10941* 10942* IF I_REDO_INT = 1, the internal states are recalculated at start 10943* 10944* IF IDIIS.EQ.1, DIIS is used 10945* .EQ.2, CROP is used to accelerate convergence 10946* 10947* 10948* Jeppe Olsen, Aug. 2005, modified aug 2009 - also in Washington 10949* Redo of internal states: Sept. 2009 in Sicily 10950* Subspace Jacobian added: Oct. 2009 10951* ONB version: March 2010 10952* 10953* ONB: Orthonormal basis version: all calc in zero-order basis 10954* 10955*. for DIIS units LUSC37 and LUSC36 will be used for storing vectors 10956 INCLUDE 'wrkspc.inc' 10957 INCLUDE 'ctcc.inc' 10958 INCLUDE 'glbbas.inc' 10959 INCLUDE 'crun.inc' 10960 INCLUDE 'clunit.inc' 10961 INCLUDE 'cecore.inc' 10962 INCLUDE 'cei.inc' 10963 INCLUDE 'oper.inc' 10964 INCLUDE 'cands.inc' 10965 INCLUDE 'cstate.inc' 10966 INCLUDE 'lucinp.inc' 10967 INCLUDE 'orbinp.inc' 10968 INCLUDE 'cintfo.inc' 10969*. Temporary array for debugging 10970 REAL*8 XNORM_EI(1000), XJ1(1000),XJ2(1000) 10971* 10972 LOGICAL CONVERL,CONVERG 10973*. Converl: is local iterative procedure for given internal states converged 10974*. converg: is global iterative procedure converged 10975 REAL*8 10976 &INPROD,INPRDD 10977*. Input and Output : Coefficients of internal and external correlation 10978 DIMENSION T_EXT(*), C_REF(*) 10979 COMMON/COM_H_S_EFF_ICCI_TV/ 10980 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 10981 & IUNIOPX,NSPAX,IPROJSPCX 10982 COMMON/CLOCAL2/KVEC1,KVEC2,MXCJ, 10983 & KLVCC1,KLVCC2,KLVCC3,KLVCC4,KLVCC5,KLSMAT,KLXMAT,KLJMAT,KLU,KLL, 10984 & NSING,NNONSING,KLCDIIS,KLC_INT_DIA,KLDIA,KLVCC6,KLVCC7,KLVCC8, 10985 & NVECP,NVEC,KLA_CROP,KLSCR_CROP 10986*. Scratch for CI behind the curtain 10987 DIMENSION VEC1(*),VEC2(*) 10988*. Scratch for subspace Jacobian 10989 DIMENSION SCR_SBSPJA(*) 10990*. Threshold for convergence of norm of Vectorfuntion 10991 10992C WRITE(6,*) ' ICCC_OPT_SIMULT: I_DO_COMP =', I_DO_COMP 10993C WRITE(6,*) ' ICCC_OPT_SIMULT: MAXIT,MAXITM =', MAXIT,MAXITM 10994 WRITE(6,*) ' ICCC_OPT_SIMULT: I_DO_SBSPJA, MXVEC_SBSPJA = ', 10995 & I_DO_SBSPJA, MXVEC_SBSPJA 10996 NCAAB = NDIM_EI 10997 WRITE(6,*) ' NCAAB og NDIM_EI = ', NCAAB, NDIM_EI 10998*. We will not include the unit-operator so ??? 10999*. Project on nonredundant space 11000 I_DO_PROJ_NR = 0 11001*. For file access 11002 LBLK = -1 11003 NTEST = 5 11004 IF(NTEST.GE.2) THEN 11005 WRITE(6,*) 11006 & ' Simultaneous optimization of internal and external parts ' 11007 WRITE(6,*) 11008 & ' =========================================================' 11009 WRITE(6,*) 11010 WRITE(6,*) ' CROP/DIIS performed in ortn. zero-order basis' 11011 WRITE(6,*) ' Reference space is ', IREFSPC 11012 WRITE(6,*) ' Space for evaluating general operators ', ITREFSPC 11013 WRITE(6,*) ' Space for T times reference space ', IT2REFSPC 11014 WRITE(6,*) ' Number of parameters in CAAB basis ', 11015 & N_CC_AMP 11016 WRITE(6,*) ' Number of parameters in spincoupled/ort basis ', 11017 & NSPA 11018 WRITE(6,*) ' Number of coefficients in internal space ', N_REF 11019 WRITE(6,*) ' INI_IT, IFIN_IT = ', INI_IT, IFIN_IT 11020 WRITE(6,*) ' Max. number microiterations per macro ', MAXIT 11021 WRITE(6,*) ' Max. number of macroiterations ', MAXITM 11022 WRITE(6,*) ' Number of vectors allowed in subspace ', MXCIVG 11023 WRITE(6,*) ' Number of vectors allowed in initial subspace ', 11024 & MXVC_I 11025 IF(IDIIS.EQ.1) THEN 11026 WRITE(6,*)' DIIS optimization' 11027 ELSE IF (IDIIS.EQ.2) THEN 11028 WRITE(6,*)' CROP optimization' 11029 END IF 11030* 11031 IF(I_DO_PROJ_NR.EQ.1) THEN 11032 WRITE(6,*) ' Redundant directions projected out' 11033 ELSE 11034 WRITE(6,*) ' No projection of redundant directions' 11035 END IF 11036* 11037 END IF 11038* 11039 IF(NTEST.GE.1000) THEN 11040 WRITE(6,*) ' Initial T_ext-amplitudes ' 11041 CALL WRTMAT(T_EXT,1,N_CC_AMP,1,N_CC_AMP) 11042 WRITE(6,*) ' Initial C_int-amplitudes ' 11043 CALL WRTMAT(C_REF,1,N_REF,1,N_REF) 11044 END IF 11045*. Allowed number of iterations 11046 NNEW_MAX = MAXIT 11047 MAXITL = NNEW_MAX 11048* 11049 NVAR_CAAB = N_CC_AMP + N_REF 11050 IF(INI_IT.EQ.1) THEN 11051 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICC_CM') 11052 CALL MEMMAN(KLVCC1,NVAR_CAAB,'ADDL ',2,'VCC1 ') 11053 CALL MEMMAN(KLVCC2,NVAR_CAAB,'ADDL ',2,'VCC2 ') 11054 CALL MEMMAN(KLVCC3,NVAR_CAAB,'ADDL ',2,'VCC3 ') 11055 CALL MEMMAN(KLVCC4,NVAR_CAAB,'ADDL ',2,'VCC4 ') 11056 CALL MEMMAN(KLVCC5,NVAR_CAAB,'ADDL ',2,'VCC5 ') 11057 CALL MEMMAN(KLVCC6,2*NVAR_CAAB,'ADDL ',2,'VCC6 ') 11058*. Just a few extra to be on the safe side when programming EI 11059*. approach 11060 CALL MEMMAN(KLVCC7,NVAR_CAAB,'ADDL ',2,'VCC5 ') 11061 CALL MEMMAN(KLVCC8,NVAR_CAAB,'ADDL ',2,'VCC5 ') 11062 CALL MEMMAN(KLDIA,NVAR_CAAB,'ADDL ',2,'DIAORT') 11063*. Space for DIIS/CROP 11064 IF(IDIIS.EQ.1) THEN 11065 CALL MEMMAN(KLCDIIS,MAXITL,'ADDL ',2,'CDIIS ') 11066 ELSE IF(IDIIS.EQ.2) THEN 11067 CALL MEMMAN(KLA_CROP,MXCIVG*(MXCIVG+1)/2,'ADDL ',2,'A_CROP') 11068 LEN_SCR_CROP = 3*MXCIVG*MXCIVG + 3*MAX(MXCIVG,NVAR_CAAB) 11069 CALL MEMMAN(KLSCR_CROP,LEN_SCR_CROP,'ADDL ',2,'S_CROP') 11070C? WRITE(6,*) ' KLA_CROP,KLSCR_CROP, a =', KLA_CROP,KLSCR_CROP 11071 END IF 11072*. Space Diagonal for internal part 11073 CALL MEMMAN(KLC_INT_DIA,N_REF,'ADDL ',2,'C_DIA ') 11074 END IF 11075*. ^ End if INI_IT.EQ.1 11076* 11077*====================================== 11078* 0: Redo internal states if required 11079* ===================================== 11080* 11081 IF(I_REDO_INT.EQ.1) THEN 11082 CALL GET_INTERNAL_STATES_OUTER 11083 N_INT_MAX = IMNMX(WORK(KL_N_INT_FOR_SE),N_EXTOP_TP*NSMOB,2) 11084*. Largest number of zero-order states of given sym and external type 11085 N_ORTN_MAX = IMNMX(WORK(KL_N_ORTN_FOR_SE),N_EXTOP_TP*NSMOB,2) 11086 WRITE(6,*) ' N_INT_MAX, N_ORTN_MAX = ', N_INT_MAX, N_ORTN_MAX 11087*. Largest transformation block 11088 N_XEO_MAX = N_INT_MAX*N_ORTN_MAX 11089 IF(NTEST.GE.10) 11090 & WRITE(6,*) ' Largest (EL,ORTN) block = ', N_XEO_MAX 11091*. Number of zero-order states - does now include the unit-operator 11092 N_ZERO_EI = N_ZERO_ORDER_STATES(WORK(KL_N_ORTN_FOR_SE), 11093 & WORK(KL_NDIM_EX_ST),N_EXTOP_TP,1) 11094 NVAR = N_ZERO_EI + N_REF 11095 NSPA = N_ZERO_EI 11096 NSPAM1 = NSPA - 1 11097*. Adresses of the unit op 11098 IUNI_AD = N_ZERO_EI 11099 IF(NTEST.GE.10) WRITE(6,*) 11100 & ' Number of zero-order states with sym 1 = ', N_ZERO_EI 11101 END IF 11102* 11103*. Memory for complete matrices can now be defined 11104*. Complete matrices for external part, three used pt 11105 IF(INI_IT.EQ.1.AND.I_DO_COMP.EQ.1) THEN 11106 LEN = N_ZERO_EI**2 11107 CALL MEMMAN(KLSMAT,LEN,'ADDL ',2,'SMAT ') 11108 CALL MEMMAN(KLXMAT,LEN,'ADDL ',2,'XMAT ') 11109 CALL MEMMAN(KLJMAT,LEN,'ADDL ',2,'JMAT ') 11110*. Storage for LU decomposition of J 11111 LEN = N_ZERO_EI*(N_ZERO_EI+1)/2 11112 CALL MEMMAN(KLL,LEN,'ADDL ',2,'L ') 11113 CALL MEMMAN(KLU,LEN,'ADDL ',2,'U ') 11114 ELSE 11115*. Space for diagonal- space is allocated also for CI part. 11116 END IF 11117* 11118* ============================================================ 11119* 1 : Prepare preconditioners for external and internal parts 11120* ============================================================ 11121* 11122* -------------------- 11123*. 1a : External part 11124* -------------------- 11125* 11126*. Identify the unit operator i.e. the operator with 11127*. zero creation and annihilation operators 11128 IDOPROJ = 0 11129*. Construct metric (once again ..) 11130*. Prepare the routines used in COM_SH 11131*. Not used here 11132 C_0X = 0.0D0 11133 KLTOPX = -1 11134*. Used 11135 NREFX = N_REF 11136 IREFSPCX = IREFSPC 11137*. Space to be used for evaluating metric : If T = 0, then IT2REFSPC is sufficient 11138 ITREFSPCX = ITREFSPC 11139 ITREFSPCX = IT2REFSPC 11140* 11141 NCAABX = N_CC_AMP 11142 NSPAX = N_ZERO_EI 11143 IPROJSPCX = IREFSPC 11144*. Unitoperator in SPA order ... Please check .. 11145 IUNIOPX = 0 11146* 11147 NVAR_EXT = N_ZERO_EI - 1 11148 IF(I_DO_COMP.EQ.1) THEN 11149* 11150*. Set up or read in Jacobian in orthonormal basis 11151* 11152 IF(INI_IT.EQ.1.AND.IREADSJ.EQ.0) THEN 11153*. Construct exact or approximate Jacobian 11154 IF(NCOMMU_J.EQ.1) THEN 11155*. I assume that the space before ITREFSPC contains T*IREFSPC 11156 ITREFSPC_L = ITREFSPC - 1 11157 WRITE(6,*) ' Space used for approximate J ', ITREFSPC_L 11158*. Do not include zero-order state 11159 INCLUDE0 = 0 11160 CALL COM_JAC_1COM(IREFSPC,IT2REFSPC,WORK(KLJMAT),INCLUDE0) 11161 ELSE 11162*. More than one commutator, so J depends on T 11163 CALL COM_JMRCC(T_EXT,NCOMMU_J,I_APPROX_HCOM_J, 11164 & WORK(KLJMAT),WORK(KLVCC1),WORK(KLVCC2), WORK(KLVCC3), 11165 & WORK(KLVCC4),N_CC_AMP,NSPAM1,N_ZERO_EI,IREFSPC, 11166 & ITREFSPC,WORK(KLXMAT) ) 11167 END IF 11168* ^ End if more than one commutator 11169 WRITE(LU_SJ) (WORK(KLJMAT-1+IJ),IJ=1,NVAR_EXT*NVAR_EXT) 11170*. Rewind to flush buffer 11171 CALL REWINO(LU_SJ) 11172 ELSE 11173*. Read Approximate Jacobian in from LU_SJ 11174 CALL REWINO(LU_SJ) 11175 READ(LU_SJ) (WORK(KLJMAT-1+IJ),IJ=1,NVAR_EXT*NVAR_EXT) 11176 END IF 11177* ^ End if matrix should be constructed or read in 11178 I_ADD_SHIFT = 0 11179 IF(I_ADD_SHIFT.EQ.1) THEN 11180*. Add a shift to the diagonal of J 11181 SHIFT = 10.0D0 11182 WRITE(6,*) ' A shift will be added to initial Jacobian' 11183 WRITE(6,'(A,E14.7)') ' Value of shift = ', SHIFT 11184 CALL ADDDIA(WORK(KLJMAT),SHIFT,NVAR_EXT,0) 11185 END IF 11186* ^ End if shift should be added 11187* 11188 I_DIAG_J = 0 11189 IF(I_DIAG_J.EQ.1) THEN 11190*. Obtain eigenvalues of approximate Jacobian 11191*. S-matrix is not used anymore to use this space for 11192*. diagonalization 11193 WRITE(6,*) ' Approximate Jacobian will be diagonalized ' 11194 CALL COPVEC(WORK(KLJMAT),WORK(KLSMAT),NVAR_EXT*NVAR_EXT) 11195 CALL EIGGMT3(WORK(KLSMAT),NVAR_EXT,WORK(KLVCC1),WORK(KLVCC2), 11196 & XDUM,XDUM,XDUM,WORK(KLVCC3),WORK(KLVCC6),1,0) 11197 WRITE(6,*) ' Real and imaginary part of eigenvalues of J ' 11198 WRITE(6,*) ' ========================================== ' 11199 CALL WRT_2VEC(WORK(KLVCC1),WORK(KLVCC2),NVAR_EXT) 11200 END IF 11201*. Obtain LU-Decomposition of Jacobian 11202 CALL LULU(WORK(KLJMAT),WORK(KLL),WORK(KLU),NVAR_EXT) 11203 ELSE 11204 IF(INI_IT.EQ.1) THEN 11205*. Complete matrix is not constructed, rather just a diagonal 11206*. Obtain diagonal of H 11207 CALL GET_DIAG_H0_EI(WORK(KLDIA)) 11208*. The last element in KLDIA is the zero-order energy 11209 E0 = WORK(KLDIA-1+N_ZERO_EI) 11210 IF(NTEST.GE.0) 11211 & WRITE(6,*) ' Zero-order energy ', E0 11212*. To get diagonal approximation to J, subtract E0 11213 DO I = 1, N_ZERO_EI 11214 WORK(KLDIA-1+I) = WORK(KLDIA-1+I) - E0 11215 END DO 11216*. The last term in KLDIA corresponds to the zero-order state. 11217*. This will not contribute, but to eliminate errors occuring 11218*. from dividing by zero 11219 WORK(KLDIA-1+N_ZERO_EI) = 300656.0 11220*. Check for diagonal values close to zero, and shift these 11221 XMIN = 0.2D0 11222 CALL MODDIAG(WORK(KLDIA),N_ZERO_EI,XMIN) 11223C MODDIAG(H0DIAG,NDIM,XMIN) 11224*. And save on LU_SJ 11225 CALL VEC_TO_DISC(WORK(KLDIA),N_ZERO_EI-1,1,LBLK,LU_SJ) 11226*. test norm of the E-blocks of diagonal 11227 WRITE(6,*) ' Norm of various E-blocks of diagonal' 11228 CALL NORM_T_EI(WORK(KLDIA),2,1,XNORM_EI,1) 11229C NORM_T_EI(T,IEO,ITSYM,XNORM_EI,IPRT) 11230 IF(NTEST.GE.1000) THEN 11231 WRITE(6,*) ' Diagonal J-approx in ort. zero-order basis' 11232 CALL WRTMAT(WORK(KLDIA),1,N_ZERO_EI,1,N_ZERO_EI) 11233 END IF 11234 END IF 11235*. ^ End if it was first iteration 11236 END IF 11237* ^ End of complete or diagonal matrix should be set up 11238* 11239* --------------------- 11240*. 1b : internal part - Fetch in all macroiterations 11241* --------------------- 11242* 11243 CALL REWINO(LUDIA) 11244 CALL FRMDSCN(WORK(KLC_INT_DIA),-1,-1,LUDIA) 11245 IF(NTEST.GE.1000) THEN 11246 WRITE(6,*) ' Diagonal preconditioner for internal correlation' 11247 CALL WRTMAT(WORK(KLC_INT_DIA),1,N_REF,1,N_REF) 11248 END IF 11249* 11250 IF(IDIIS.EQ.1.OR.(IDIIS.EQ.2.AND.INI_IT.EQ.1)) THEN 11251 CALL REWINO(LUSC37) 11252 CALL REWINO(LUSC36) 11253 END IF 11254*. Ensure proper defs 11255 I12 = 2 11256 ICSM = IREFSM 11257 ISSM = IREFSM 11258 IF(IUSE_PH.EQ.1) THEN 11259 CALL COPVEC(WORK(KFI),WORK(KINT1),NINT1) 11260 END IF 11261* 11262 IF(NTEST.GE.100) 11263 & WRITE(6,*) ' After const of precond: ITREFSPC, IT2REFSPC =', 11264 & ITREFSPC, IT2REFSPC 11265* 11266*. Transformation of T from CAAB to orthonormal basis should 11267*. initialize procedure 11268 CALL TRANS_CAAB_ORTN(T_EXT,WORK(KLVCC1),1,1,2, 11269 & WORK(KLVCC2),2) 11270 CALL COPVEC(WORK(KLVCC1),T_EXT,N_ZERO_EI) 11271 XTNORM_INI = SQRT(INPROD(T_EXT,T_EXT,N_ZERO_EI)) 11272 WRITE(6,*) ' Norm of initial T-vector', XTNORM_INI 11273* 11274*. Loop over iterations 11275 WRITE(6,*) 11276 WRITE(6,*) ' -------------------------- ' 11277 WRITE(6,*) ' Entering optimization part ' 11278 WRITE(6,*) ' -------------------------- ' 11279 WRITE(6,*) 11280*. Number of vectors in initial space for DIIS/CROP optimization 11281 IF(INI_IT.EQ.1) THEN 11282 NVECP = 0 11283 NVEC = 0 11284 END IF 11285*. (If INI_IT .ne. 0, MXVC_I vectors from previous macro are used) 11286 IF(I_DO_SBSPJA.EQ.1) THEN 11287*. Initialize files that will be used for subspace Jacobian) 11288 WRITE(6,*) ' LU_CCVECT,LU_CCVECF, LU_CCVECFL = ', 11289 & LU_CCVECT,LU_CCVECF, LU_CCVECFL 11290 CALL REWINO(LU_CCVECT) 11291 CALL REWINO(LU_CCVECF) 11292 CALL REWINO(LU_CCVECFL) 11293 END IF 11294* 11295 DO IT = 1, NNEW_MAX 11296 IF(NTEST.GE.100) THEN 11297 WRITE(6,*) 11298 WRITE(6,*) ' Information for iteration ', IT 11299 WRITE(6,*) 11300 END IF 11301 IF(IT.EQ.1) THEN 11302 MXVC_SUB = MXVC_I 11303 ELSE 11304 MXVC_SUB = MXCIVG 11305 END IF 11306* 11307* 11308* ================================================================== 11309*. Construct vectorfunction/gradient for external and internal parts 11310* ================================================================== 11311* 11312*. CC vector function for external part in VCC5 11313C? WRITE(6,*) ' NCAAB before MRCC.. ', NCAAB 11314 CALL MRCC_VECFNCN(WORK(KLVCC5),T_EXT, 11315 & IREFSPC,ITREFSPC,IT2REFSPC,WORK(KLVCC5+N_CC_AMP), 11316 & C_REF, N_REF,I_DO_PROJ_NR, 11317 & E_INT,E_EXT,ECORE,2,2) 11318 CALL COPVEC(WORK(KLVCC5+N_CC_AMP),WORK(KLVCC5+N_ZERO_EI), 11319 & N_REF) 11320* 11321 IF(NTEST.GE.10) THEN 11322 WRITE(6,*) ' Norm of various E-blocks of Vecfnc' 11323 CALL NORM_T_EI(WORK(KLVCC5),2,1,XNORM_EI,1) 11324 END IF 11325 IF(NTEST.GE.1000) THEN 11326 WRITE(6,*) 11327 & ' The CC vector function including internal part' 11328 CALL WRTMAT(WORK(KLVCC5),1,NVAR,1,NVAR,1) 11329 END IF 11330 IF(NTEST.GE.10) WRITE(6,'(A,I4,2E22.15)') 11331 & ' It, Energy from external and internal ', IT, E_EXT , 11332 & E_INT 11333C & ' It, Energy from external and internal ', IT, E_EXT + ECORE, 11334C & E_INT+ECORE 11335 VCFNORM_EXT =SQRT(INPROD(WORK(KLVCC5),WORK(KLVCC5),N_ZERO_EI)) 11336 VCFNORM_INT = SQRT( 11337 & INPROD(WORK(KLVCC5+N_ZERO_EI),WORK(KLVCC5+N_ZERO_EI),N_REF)) 11338*. Update energy and residual norms 11339 VNFINAL = VCFNORM_EXT+VCFNORM_INT 11340 E = E_INT 11341 EFINAL = E_INT 11342*. Converged? 11343 IF(VCFNORM_EXT+VCFNORM_INT.LE.VTHRES) THEN 11344*. Local iterative procedure converged 11345 CONVERL = .TRUE. 11346*. Is global procedure also converged? 11347 IF((I_REDO_INT.NE.1 ) .OR. 11348 & (I_REDO_INT.EQ.1.AND.IT.EQ.1)) THEN 11349 CONVERG = .TRUE. 11350 END IF 11351 WRITE(6,*) ' Iterative procedure converged' 11352 WRITE(6,'(A,I4,E22.15,2E12.5)') 11353 & ' It, energy , vecfnc_ext, vecfnc_int ', 11354 & IT, E, VCFNORM_EXT, VCFNORM_INT 11355 GOTO 1001 11356 END IF 11357* ^ End if local procedure is converged 11358* 11359* ====================================================================== 11360*. Save vectorfunction in form that will be used in later subspace opt. 11361* ====================================================================== 11362* 11363* 11364 IF(I_DO_SBSPJA.EQ.1) THEN 11365* 11366* Has not been bebugged for Zero-order states 11367*. Save Vectorfunction and change in vectorfunction 11368*. if subspace Jacobian is in use 11369 N_ZERO_EIM = N_ZERO_EI - 1 11370 IF(IT.GE.2) THEN 11371*. Read previous vectorfunction in VCC7 from CCVECFL 11372 CALL VEC_FROM_DISC(WORK(KLVCC7),N_ZERO_EIM,1,LBLK, 11373 & LU_CCVECFL) 11374 ONE = 1.0D0 11375 ONEM =-1.0D0 11376*. Store in VCC7: Delta V = Vecfnc(ITER) - Vecfnc(ITER-1) 11377 CALL VECSUM(WORK(KLVCC7),WORK(KLVCC5),WORK(KLVCC2), 11378 & ONEM,ONE,N_ZERO_EIM) 11379*. Add CCVF(X_{i+1})-CCVF(X_{i}) as vector IT-1 in FILE LU_CCVECF 11380 CALL SKPVCD(LU_CCVECF,IT-2,WORK(KLVCC6),1,LBLK) 11381 CALL VEC_TO_DISC(WORK(KLVCC7),N_ZERO_EIM,0,LBLK,LU_CCVECF) 11382 END IF 11383*. Save current vector-function in EO form in LU_CCVECFL 11384 CALL VEC_TO_DISC(WORK(KLVCC5),N_ZERO_EIM,1,LBLK,LU_CCVECFL) 11385 END IF 11386* ^ End if subspace method in use 11387* 11388* ======================================================== 11389* Diis/CROP/SBSPJA based on current and previous vectors 11390* ======================================================== 11391* 11392* Subspace is in this version saved in orthonormal basis 11393* 11394 IF(IDIIS.EQ.1.OR.IDIIS.EQ.2) THEN 11395*. It is assumed that DIIS left the file at end of file 11396*. T_ext,C_int on LUSC37, VECFNC on LUSC36 11397 CALL COPVEC(T_EXT,WORK(KLVCC1),N_ZERO_EI) 11398 CALL COPVEC(C_REF,WORK(KLVCC1+N_ZERO_EI),N_REF) 11399 IF(NTEST.GE.1000) THEN 11400 WRITE(6,*) ' Combined T_ext, C_int coefficients ' 11401 CALL WRTMAT(WORK(KLVCC1),1,NVAR,1,NVAR) 11402 END IF 11403 CALL VEC_TO_DISC(WORK(KLVCC1),NVAR,0,-1,LUSC37) 11404 CALL VEC_TO_DISC(WORK(KLVCC5),NVAR,0,-1,LUSC36) 11405 END IF 11406*. We have now a number of vectors in LUSC36, find combination with lowest 11407*. norm 11408*. DIIS: 11409 IF(IDIIS.EQ.1) THEN 11410*. Simple DIIS with no restart 11411 CALL DIIS_SIMPLE(LUSC36,IT,NVAR,WORK(KLCDIIS)) 11412*. Obtain combination of parameters given in CDIIS 11413 CALL MVCSMD(LUSC37,WORK(KLCDIIS),LUSC39,LUSC38, 11414 & WORK(KLVCC1),WORK(KLVCC2),IT,1,-1) 11415 CALL VEC_FROM_DISC(WORK(KLVCC1),NVAR,1,-1,LUSC39) 11416 CALL COPVEC(WORK(KLVCC1),T_EXT,N_ZERO_EI) 11417 CALL COPVEC(WORK(KLVCC1+N_ZERO_EI),C_REF,N_REF) 11418*. Calculate new vectorfunction in VCC5 for T_EXT and C_INT using sums 11419 CALL MVCSMD(LUSC36,WORK(KLCDIIS),LUSC39,LUSC38, 11420 & WORK(KLVCC1),WORK(KLVCC2),IT,1,-1) 11421 CALL VEC_FROM_DISC(WORK(KLVCC5),NVAR,1,-1,LUSC39) 11422 ELSE IF(IDIIS.EQ.2) THEN 11423*. CROP: 11424*. The CROP version of DIIS 11425*. Matrices are reconstructed in each IT 11426 IDIRDEL = 1 11427 NVEC = NVEC + 1 11428*. Note: NVECP is number of vectors for which subspace matrix 11429*. has been constructed and saved- CROP updates this 11430*. Obtain improved amplitudes in VCC1, improved vectorfunction in VCC4 11431 CALL CROP(NVEC,NVECP,MXVC_SUB,NVAR,LUSC36,LUSC37, 11432 & WORK(KLA_CROP), 11433 & WORK(KLVCC4),WORK(KLVCC1),WORK(KLSCR_CROP),LUSC39, 11434 & IDIRDEL) 11435C CROP(NVEC,NVECP,MXNVEC,NDIM,LUE,LUP,A, 11436C & EOUT,POUT,SCR,LUSCR,IDIRDEL) 11437*Change of T-coefs 11438 ONE = 1.0D0 11439 ONEM = -1.0D0 11440 CALL VECSUM(WORK(KLVCC1),WORK(KLVCC1),T_EXT,ONE,ONEM, 11441 & N_ZERO_EI) 11442*. Update of external coefficients 11443*. Check if change is to large.. 11444 XNORM = SQRT(INPROD(WORK(KLVCC1),WORK(KLVCC1),N_ZERO_EI)) 11445 WRITE(6,*) ' Norm of CROP external correction ', XNORM 11446 XNORM_MAX = 0.5D0 11447 I_DO_SCALE = 1 11448 IF(XNORM.GT.XNORM_MAX.AND.I_DO_SCALE.EQ.1) THEN 11449 WRITE(6,*) 11450 & ' CROPStep is scaled: from and to to ', XNORM,XNORM_MAX 11451 FACTOR = XNORM_MAX/XNORM 11452 CALL VECSUM(T_EXT,T_EXT,WORK(KLVCC1),ONE,FACTOR,N_ZERO_EI) 11453*. Well, if change in parameters was reduced, then change in 11454*. vector function should also be reduced 11455* VEC5 = VEC5 + Factor*(vec4-vec5) = (1-factor)vec5 + factor*vec4 11456 FACTOR5 = 1.0D0-FACTOR 11457 FACTOR4 = FACTOR 11458 CALL VECSUM(WORK(KLVCC5),WORK(KLVCC5),WORK(KLVCC4), 11459 % FACTOR5,FACTOR4, N_ZERO_EI) 11460 ELSE 11461 CALL VECSUM(T_EXT,T_EXT,WORK(KLVCC1),ONE,ONE,N_ZERO_EI) 11462 CALL COPVEC(WORK(KLVCC4),WORK(KLVCC5),N_ZERO_EI) 11463 END IF 11464*. And update internal (CI-)coefficients 11465 CALL COPVEC(WORK(KLVCC1+N_ZERO_EI),C_REF,N_REF) 11466 XNORM = INPROD(C_REF,C_REF,N_REF) 11467 FACTOR = 1.0D0/SQRT(XNORM) 11468 FACTOR = 1.0D0 11469 WRITE(6,*) ' No normalization of C_REF in CROP' 11470 CALL SCALVE(C_REF,FACTOR,N_REF) 11471*. And scale CI-vector function 11472 CALL COPVEC(WORK(KLVCC4+N_ZERO_EI),WORK(KLVCC5+N_ZERO_EI), 11473 & N_REF) 11474 CALL SCALVE(WORK(KLVCC5+N_ZERO_EI),FACTOR,N_REF) 11475 END IF 11476*. ^ End of DIIS/CROP should be used 11477 VCFNORM = SQRT(INPROD(WORK(KLVCC5),WORK(KLVCC5),NVAR)) 11478 IF(NTEST.GE.5) WRITE(6,'(A,I4,1E12.5)') 11479 & ' From DIIS/CROP : It, norm of approx vecfnc ', 11480 & IT, VCFNORM 11481* 11482* =================================================================== 11483* Obtain new direction by applying preconditioners to approx vecfunc 11484* =================================================================== 11485* 11486* -------------- 11487* External part 11488* -------------- 11489* 11490* multiply with diagonal transform 11491*. Vectorfunction 11492 IF(NTEST.GE.10) THEN 11493 WRITE(6,*) ' Norm of various E-blocks of apr Vecfnc' 11494 CALL NORM_T_EI(WORK(KLVCC5),2,1,XNORM_EI,1) 11495 END IF 11496* 11497 IF(I_DO_COMP.EQ.1) THEN 11498* 11499*. Complete matrix approximation to J in use 11500* 11501*. Solve Linear equations J Delta = - Vecfnc, store solution in VCC1 11502 ONEM = -1.0D0 11503 CALL SCALVE(WORK(KLVCC5),ONEM,NVAR_EXT) 11504 CALL LINSOL_FROM_LUCOMP(WORK(KLL),WORK(KLU),WORK(KLVCC5), 11505 & WORK(KLVCC1),NVAR_EXT,WORK(KLVCC2)) 11506 11507*. And no correction for the zero-order state 11508 WORK(KLVCC1-1+IUNI_AD) = 0.0D0 11509 ELSE 11510* 11511*. Complete matrices not in use.. 11512* 11513 IF(I_DO_SBSPJA.EQ.0) THEN 11514*� New direction = -diag-1 * Vecfunc 11515 DO I = 1, N_ZERO_EI 11516 WORK(KLVCC1-1+I) = - WORK(KLVCC5-1+I)/WORK(KLDIA-1+I) 11517 END DO 11518*. And no correction for the zero-order state 11519 WORK(KLVCC1-1+IUNI_AD) = 0.0D0 11520 IF(NTEST.GE.10) THEN 11521 WRITE(6,*) ' Norm of various E-blocks of step' 11522 CALL NORM_T_EI(WORK(KLVCC1),2,1,XNORM_EI,1) 11523 END IF 11524 ELSE 11525*. Use subspace Jacobian to solve equations 11526*. Multiply current CC vector function with approximate Jacobian 11527*. to obtain new step 11528 NSBSPC_VEC = IT-1 11529 MAXVEC = MXVEC_SBSPJA 11530 CALL APRJAC_TV(NSBSPC_VEC,LU_CCVECFL,LUSC41,LU_CCVECT, 11531 & LU_CCVECF,LU_SJ,WORK(KLVCC6),WORK(KLVCC7), 11532 & SCR_SBSPJA,N_ZERO_EIM,LUSC43,LUSC44, 11533 & MAXVEC) 11534C APRJAC_TV(NVEC,LUIN,LUOUT,LUVEC,LUJVEC, 11535C & LUJDIA,VEC1,VEC2,SCR,N_CC_AMP,LUSCR,LUSCR2, 11536C & MAXVEC) 11537*. The new correction vector is now residing in LUSC41, 11538*. Fetch and multiply with -1 11539 CALL VEC_FROM_DISC(WORK(KLVCC1),N_ZERO_EIM,1,LBLK,LUSC41) 11540 ONEM = -1.D0 11541 CALL SCALVE(WORK(KLVCC1),ONEM,N_ZERO_EIM) 11542*. And no correction for the zero-order state 11543 WORK(KLVCC1-1+IUNI_AD) = 0.0D0 11544*. Add step to LU_CCVECT for future use 11545 CALL SKPVCD(LU_CCVECT,IT-1,WORK(KLVCC6),1,LBLK) 11546 CALL VEC_TO_DISC(WORK(KLVCC1),N_ZERO_EIM,0,LBLK,LU_CCVECT) 11547 END IF 11548*. ^ End if subspace Jacobian used for generating new step 11549 END IF 11550* ^ End of switch between complete matrices and not complete 11551* matrices 11552 IF(NTEST.GE.1000) THEN 11553 WRITE(6,*) ' direction in ort zero-order basis' 11554 CALL WRTMAT(WORK(KLVCC1),1,N_ZERO_EI,1,N_ZERO_EI) 11555 END IF 11556*. Norm of change 11557 XNORM = SQRT(INPROD(WORK(KLVCC1),WORK(KLVCC1),N_ZERO_EI)) 11558 IF(NTEST.GE.10) WRITE(6,*) ' Norm of correction ', XNORM 11559 XNORM_MAX = 0.5D0 11560 I_DO_SCALE = 1 11561 IF(XNORM.GT.XNORM_MAX.AND.I_DO_SCALE.EQ.1) THEN 11562 WRITE(6,*) 11563 & ' Step is scaled: from and to to ', XNORM,XNORM_MAX 11564 FACTOR = XNORM_MAX/XNORM 11565 CALL SCALVE(WORK(KLVCC1),FACTOR,N_ZERO_EI) 11566 XNORM = XNORM_MAX 11567 IF(I_DO_SBSPJA.EQ.1) THEN 11568*. Well, step was scaled, read in EI form of step and scale this 11569 CALL SKPVCD(LU_CCVECT,IT-2,WORK(KLVCC2),1,LBLK) 11570 CALL VEC_FROM_DISC(WORK(KLVCC2),N_ZERO_EIM,0,LBLK,LU_CCVECT) 11571 CALL SCALVE(WORK(KLVCC2),FACTOR,N_ZERO_EIM) 11572 CALL SKPVCD(LU_CCVECT,IT-2,WORK(KLVCC2),1,LBLK) 11573 CALL VEC_TO_DISC(WORK(KLVCC2),N_ZERO_EIM,0,LBLK,LU_CCVECT) 11574 END IF 11575 END IF 11576*. And update the T-coefficients 11577 ONE = 1.0D0 11578 CALL VECSUM(T_EXT,T_EXT,WORK(KLVCC1),ONE,ONE,N_ZERO_EI) 11579 IF(NTEST.GE.1000) THEN 11580 WRITE(6,*) ' Updated T-coefficients in ortn. basis ' 11581 CALL WRTMAT(T_EXT,1,N_ZERO_EI,1,N_ZERO_EIP) 11582 END IF 11583* 11584* -------------- 11585* Internal part 11586* -------------- 11587* 11588 IF(N_REF.EQ.1) THEN 11589 C_REF(1) = 1 11590 XNORM_CI = 0.0D0 11591 ELSE 11592 DO I = 1, N_REF 11593 XNORM_CI = 0.0D0 11594 IF(ABS(WORK(KLC_INT_DIA-1+I)-E).GE.1.0D-10) THEN 11595 DELTA = 11596 & - WORK(KLVCC5+N_ZERO_EI-1+I)/(WORK(KLC_INT_DIA-1+I)-E) 11597 XNORM_CI = XNORM_CI + DELTA**2 11598 C_REF(I) = C_REF(I) + DELTA 11599 END IF 11600 END DO 11601 END IF 11602 XNORM_CI = SQRT(XNORM_CI) 11603 WRITE(6,'(A)') 11604 & ' It, Energy, vecfn_ext, vecfn_int, step_ext, step_int: ' 11605 WRITE(6,'(I4,1X,E22.15,2x,4(2X,E12.5))') 11606 & IT, E, VCFNORM_EXT, VCFNORM_INT, XNORM, XNORM_CI 11607*. And normalize the internal part 11608 CNORM2 = INPROD(C_REF,C_REF,N_REF) 11609 FACTOR = 1.0D0/SQRT(CNORM2) 11610 CALL SCALVE(C_REF,FACTOR,N_REF) 11611*. Write new C_ref to file LUC - used by vector function 11612 CALL ISTVC2(WORK(KLVCC2),0,1,N_REF) 11613 CALL REWINO(LUC) 11614 CALL WRSVCD(LUC,-1,VEC1,WORK(KLVCC2), 11615 & C_REF,N_REF,N_REF,LUDIA,1) 11616* 11617 END DO 11618* ^ End of loop over iterations 11619 1001 CONTINUE 11620* 11621*. Transformation of T to CAAB from orthonormal basis 11622*. finalize procedure 11623 CALL TRANS_CAAB_ORTN(WORK(KLVCC1),T_EXT,1,2,2, 11624 & WORK(KLVCC2),2) 11625 CALL COPVEC(WORK(KLVCC1),T_EXT,NCAAB) 11626* 11627 IF(NTEST.GE.1000) THEN 11628 WRITE(6,*) ' Info from T optimization ', IREFROOT 11629 WRITE(6,*) ' Updated amplitudes ' 11630 CALL WRTMAT(T_EXT,1,NCAAB,1,NCAAB) 11631 END IF 11632* 11633 IF(NTEST.GE.5) THEN 11634 WRITE(6,*) ' Analysis of external amplitudes' 11635 CALL ANA_GENCC(T_EXT,1) 11636 END IF 11637* 11638 IF(IFIN_IT.EQ.1.OR.CONVERG) 11639 &CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ICC_CMP') 11640 RETURN 11641 END 11642 SUBROUTINE COM_JAC_1COM(IREFSPC,IT2REFSPC,XJ,INCLUDE0) 11643* 11644*. Obtain in the orthonormal EI basis, 11645* the complete one-commutator approximation to Jacobian: 11646* XJ(I,J) = <0!O+(I)[H,O(J)]|0> 11647* 11648* If INCLUDE0 = 1, then the zero-order state is included in Jacobian 11649* 11650* The spaces: IREFSPC : Space of !0> 11651* IT2REFSPC : Space for T !0> 11652* 11653 INCLUDE 'wrkspc.inc' 11654 INCLUDE 'crun.inc' 11655 INCLUDE 'cstate.inc' 11656 INCLUDE 'cands.inc' 11657 INCLUDE 'glbbas.inc' 11658 INCLUDE 'clunit.inc' 11659 INCLUDE 'cei.inc' 11660*. Output 11661 DIMENSION XJ(*) 11662* 11663 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'COMJC1') 11664* 11665 CALL MEMMAN(KLVCC1,NDIM_EI,'ADDL ',2,'LVEC1 ') 11666 CALL MEMMAN(KLVCC2,NDIM_EI,'ADDL ',2,'LVEC2 ') 11667 CALL MEMMAN(KLVCC3,NDIM_EI,'ADDL ',2,'LVEC3 ') 11668* 11669 NTEST = 10 11670 IF(NTEST.GE.10) THEN 11671 WRITE(6,*) 11672 WRITE(6,*) ' --------------------------------- ' 11673 WRITE(6,*) ' COM_JAC_1COM reporting to service ' 11674 WRITE(6,*) ' --------------------------------- ' 11675 WRITE(6,*) 11676 END IF 11677* 11678 IF(INCLUDE0.EQ.1) THEN 11679 NVAR = N_ZERO_EI 11680 ELSE 11681 NVAR = N_ZERO_EI - 1 11682 END IF 11683* 11684*. Part 1: <0| O(+)i H O j|0> 11685* 11686 11687 ZERO = 0.0D0 11688 ONE = 1.0D0 11689 ONEM = -1.0D0 11690 WRITE(6,*) 'N_ZERO_EI = ', N_ZERO_EI 11691 11692 DO J = 1, NVAR 11693 IF(NTEST.GE.10) WRITE(6,*) ' Part I, J =', J 11694 CALL SETVEC(WORK(KLVCC1),ZERO,N_ZERO_EI) 11695 WORK(KLVCC1-1+J) = 1.0D0 11696*. transform to CAAB basis 11697*. Dir in EI in T to Dir in CAAB in VCC1 11698 CALL TRANS_CAAB_ORTN(WORK(KLVCC2),WORK(KLVCC1),1,2,2, 11699 & WORK(KLVCC3),2) 11700 CALL COPVEC(WORK(KLVCC2),WORK(KLVCC1),NDIM_EI) 11701* O(j) |0> on LUSC34 11702 ICSPC = IREFSPC 11703 ISSPC = IT2REFSPC 11704 CALL REWINO(LUSC34) 11705 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUSC34, 11706 & WORK(KLVCC1),1) 11707*. Space of H T^I |0> may be reduced to IT2REFSPC 11708*. H O(j) |0> 11709 ICSPC = IT2REFSPC 11710 ISSPC = IT2REFSPC 11711 CALL REWINO(LUSC34) 11712 CALL REWINO(LUSC2) 11713 CALL MV7(WORK(KVEC1P),WORK(KVEC2P),LUSC34,LUSC2,0,0) 11714 IF(NTEST.GE.1000) THEN 11715 WRITE(6,*) ' Output from MV7' 11716 CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 11717 END IF 11718*. The density <0|o+(CAAB) H O(j)|0> 11719 ZERO = 0.0D0 11720 ICSPC = IREFSPC 11721 ISSPC = IT2REFSPC 11722 CALL SETVEC(WORK(KLVCC1),ZERO,N_CC_AMP) 11723 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUSC2, 11724 & WORK(KLVCC1),2) 11725*. And transform to obtain <0|o+(i) H O(j)|0> 11726*. Vecfunc in CAAB in VCC1 to Vecfunc in ortn in VCC2 11727 CALL TRANS_CAAB_ORTN(WORK(KLVCC1),WORK(KLVCC2),1,1,2, 11728 & WORK(KLVCC3),1) 11729 CALL COPVEC(WORK(KLVCC2),XJ((J-1)*NVAR+1),NVAR) 11730 END DO 11731* 11732 IF(NTEST.GE.100) THEN 11733 WRITE(6,*) ' The matrix <0|O+(i) H O(j)|0> ' 11734 CALL WRTMAT(XJ,NVAR,NVAR,NVAR,NVAR) 11735 END IF 11736* 11737*. Part 2: -<0| O(+)iO j H|0> 11738* 11739*. H |0> on LUSC2 11740 ICSPC = IREFSPC 11741 ISSPC = IT2REFSPC 11742 CALL MV7(WORK(KVEC1P),WORK(KVEC2P),LUC,LUSC2,0,0) 11743 DO J = 1, NVAR 11744 IF(NTEST.GE.10) WRITE(6,*) ' Part II, J =', J 11745* O j H|0> 11746 CALL SETVEC(WORK(KLVCC1),ZERO,N_ZERO_EI) 11747 WORK(KLVCC1-1+J) = 1.0D0 11748*. transform to CAAB basis 11749*. Dir in ortn in VCC1 to Dir in CAAB in VCC2 11750 CALL TRANS_CAAB_ORTN(WORK(KLVCC2),WORK(KLVCC1),1,2,2, 11751 & WORK(KLVCC3),2) 11752 CALL COPVEC(WORK(KLVCC2),WORK(KLVCC1),NDIM_EI) 11753*. O(j) H |0> 11754 ISSPC = IT2REFSPC 11755*. ISSPC kan reduceres til IREFSPC 11756 ICSPC = IT2REFSPC 11757 CALL REWINO(LUSC34) 11758 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC2,LUSC34, 11759 & WORK(KLVCC1),1) 11760*. The density <0|o+(CAAB) O(j) H|0> 11761 ZERO = 0.0D0 11762 ICSPC = IREFSPC 11763*. ISSPC kan reduceres til IREFSPC 11764 ISSPC = IT2REFSPC 11765 CALL SETVEC(WORK(KLVCC1),ZERO,N_CC_AMP) 11766 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUC,LUSC34, 11767 & WORK(KLVCC1),2) 11768*. And transform to obtain <0|o+(i) O(j) H|0> 11769*. Vecfunc in CAAB in VCC1 to Vecfunc in ortn in VCC2 11770 CALL TRANS_CAAB_ORTN(WORK(KLVCC1),WORK(KLVCC2),1,1,2, 11771 & WORK(KLVCC3),1) 11772 CALL VECSUM(XJ((J-1)*NVAR+1),XJ((J-1)*NVAR+1), 11773 & WORK(KLVCC2),ONE,ONEM,NVAR) 11774 END DO 11775* 11776 IF(NTEST.GE.100) THEN 11777 WRITE(6,*) ' The matrix <0|O+(i) [H, O(j)]|0> ' 11778 CALL WRTMAT(XJ,NVAR,NVAR,NVAR,NVAR) 11779 END IF 11780* 11781 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'COMJC1') 11782 RETURN 11783 END 11784 SUBROUTINE LUCIA_GICCI( 11785 & ICTYP,EREF,EFINAL,CONVER,VNFINAL) 11786* 11787* Master routine for General Internal Contraction CI 11788* (alowing more than one external operators) 11789* 11790* LUCIA_IC is assumed to have been called to do the 11791* preperatory work for working with internal contraction 11792* 11793* Jeppe Olsen, March 2010 for the Zurich tensor meeting 11794* 11795* Last modifications; Oct. 27, 2012; Jeppe Olsen; aligning.. 11796* 11797C INCLUDE 'implicit.inc' 11798 INCLUDE 'wrkspc.inc' 11799 REAL*8 11800 &INPROD, INPRDD 11801 LOGICAL CONVER,CONVER_INT,CONVER_EXT 11802C INCLUDE 'mxpdim.inc' 11803 INCLUDE 'crun.inc' 11804 INCLUDE 'cstate.inc' 11805 INCLUDE 'cgas.inc' 11806 INCLUDE 'ctcc.inc' 11807 INCLUDE 'gasstr.inc' 11808 INCLUDE 'strinp.inc' 11809 INCLUDE 'orbinp.inc' 11810 INCLUDE 'cprnt.inc' 11811 INCLUDE 'corbex.inc' 11812 INCLUDE 'csm.inc' 11813 INCLUDE 'cicisp.inc' 11814 INCLUDE 'cecore.inc' 11815 INCLUDE 'glbbas.inc' 11816 INCLUDE 'clunit.inc' 11817 INCLUDE 'lucinp.inc' 11818 INCLUDE 'oper.inc' 11819 INCLUDE 'cintfo.inc' 11820 INCLUDE 'cei.inc' 11821*. Transfer common block for communicating with H_EFF * vector routines 11822 COMMON/COM_H_S_EFF_ICCI_TV/ 11823 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 11824 & IUNIOPX,NSPAX,IPROJSPCX 11825 INCLUDE 'gicci.inc' 11826*.Pointers for the external correlation operators 11827*.Number of parameters in the various spaces 11828*. Transfer block for communicating zero order energy to 11829*. routien for performing H0-E0 * vector 11830 INCLUDE 'cshift.inc' 11831* 11832 CHARACTER*6 ICTYP 11833 EXTERNAL MTV_FUSK, STV_FUSK 11834 EXTERNAL H_S_EFF_ICCI_TV,H_S_EXT_ICCI_TV 11835 EXTERNAL H_S_EFF_GICCI_TV,H_S_EXT_GICCI_TV 11836 EXTERNAL HOME_SD_INV_T_ICCI 11837 EXTERNAL H0_EI_TV 11838* 11839 IDUM = 0 11840 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GICCI ') 11841 NTEST = 10 11842 WRITE(6,*) 11843 WRITE(6,*) ' =======================' 11844 WRITE(6,*) ' GICCI section entered ' 11845 WRITE(6,*) ' =======================' 11846 WRITE(6,*) 11847* 11848 IF(IEI_VERSION.EQ.0) THEN 11849 I_DO_EI = 0 11850 ELSE 11851 I_DO_EI = 1 11852 END IF 11853* 11854 IF(I_DO_EI.EQ.1) THEN 11855 WRITE(6,*) ' EI approach in use' 11856 ELSE 11857 WRITE(6,*) ' Partial spin-adaptation in use' 11858 END IF 11859*. Notes 11860* 11861* In the initial version of this approach, a CI calculation typically 11862* preceeded the internal contraction calculations. In the GICCI approach 11863* T-operators are used for all correlation. 11864* 11865* The wavefunction is therefore: |0> = t_s(T(n)T(n-1)...T(1)|ref> 11866* +T(n-1)...T(1)|ref> 11867* ..... 11868* +|ref>) 11869* 11870*. So space I is the initial HF or CAS space (|ref>) 11871* 11872* 11873*. Transfer information on spaces 11874 NTEXC_GX = NTEXC_G 11875 DO IEX = 1, NTEXC_G 11876 IPTCSPC_GX(IEX) = IPTCSPC_G(IEX) 11877 ITCSPC_GX(IEX) = ITCSPC_G(IEX) 11878 END DO 11879 11880 IREFSPC = 1 11881 WRITE(6,*) ' Energy of reference state ', EREF 11882* 11883*. Information about the various CI spaces 11884* 11885 NCAAB_MX = 0 11886 NCAAB_TOT = 0 11887 NSPA_TOT = 0 11888 DO IEX = 1, NTEXC_G 11889*. Prepare 11890 CALL PREPARE_FOR_IEX(IEX) 11891*. Number of parameters with and without spinadaptation 11892 IF(I_DO_EI.EQ.0) THEN 11893 CALL NSPA_FOR_EXP_FUSK(NSPA,NCAAB) 11894 NCAAB_FOR_IEX(IEX) = NCAAB 11895 NSPA_FOR_IEX(IEX) = NSPA 11896 NCAAB_MX = MAX(NCAAB_MX,NCAAB) 11897 NSPA_MX = MAX(NSPA_MX,NSPA) 11898 NSPA_TOT = NSPA_TOT + NSPA 11899 NCAAB_TOT = NCAAB_TOT + NCAAB 11900 ELSE 11901*. Not updated pt 11902*. zero-particle operator is included in N_ZERO_EI 11903 NSPA = N_ZERO_EI 11904*. Note: NCAAB includes unitop 11905 NCAAB = NDIM_EI 11906 END IF 11907 END DO 11908* 11909 IF(NTEST.GE.10) THEN 11910 WRITE(6,*) 11911 WRITE(6,*) ' Information about External operators ' 11912 WRITE(6,*) ' ------------------------------------ ' 11913 WRITE(6,*) 11914 WRITE(6,*) ' Operator NCAAB NSPA ' 11915 WRITE(6,*) '---------------------------' 11916 DO IEX = 1, NTEXC_G 11917 WRITE(6,'(3X,I3,3X,I8,3X,I8)') 11918 & IEX, NCAAB_FOR_IEX(IEX),NSPA_FOR_IEX(IEX) 11919 END DO 11920 END IF 11921 I_IT_OR_DIR = 1 11922 IF(I_IT_OR_DIR.EQ.2) THEN 11923 WRITE(6,*) ' Explicit construction of all matrices' 11924 ELSE 11925 WRITE(6,*) ' Iterative solution of equations' 11926 END IF 11927 I_RELAX_INT = 0 11928 IF(I_RELAX_INT.EQ.1) THEN 11929 WRITE(6,*) ' Expansion of |ref> will be reoptimized ' 11930 ELSE 11931 WRITE(6,*) ' Expansion of |ref> will be not be reoptimized ' 11932 END IF 11933*. Space for CI behind the curtain 11934 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 11935 KVEC1P = KVEC1 11936 KVEC2P = KVEC2 11937* Allocate space and define pointers for two complete 11938* external operators in the CAAB basis 11939 CALL MEMMAN(KTEX_FOR_IEX(1),NCAAB_TOT+1, 11940 & 'ADDL ',2,'T_EXT ') 11941 CALL MEMMAN(KTEXP_FOR_IEX(1),NCAAB_TOT+1, 11942 & 'ADDL ',2,'T_EXT ') 11943 11944 DO IEX = 2, NTEXC_G + 1 11945 KTEX_FOR_IEX(IEX) = KTEX_FOR_IEX(IEX-1)+NSPA_FOR_IEX(IEX-1) 11946 KTEXP_FOR_IEX(IEX) = KTEXP_FOR_IEX(IEX-1)+NSPA_FOR_IEX(IEX-1) 11947 END DO 11948*. And a vector that can hold the expansion for any given IEX_G 11949 CALL MEMMAN(KLTACT,NCAAB_MX,'ADDL ',2,'TACT ') 11950* 11951 N_REF = XISPSM(IREFSM,IREFSPC) 11952*. Initial guess to T_EXT: Just the reference state: 11953* Zeroes in all T and coefficient one for the reference 11954 IF(IRESTRT_IC.EQ.0) THEN 11955 ZERO = 0.0D0 11956 DO IEX = 1, NTEXC_G 11957 NSPA = NSPA_FOR_IEX(IEX) 11958 KLTEXT = KTEX_FOR_IEX(IEX) 11959 CALL SETVEC(WORK(KLTEXT),ZERO,NSPA) 11960 END DO 11961*. And the coefficient for the reference state 11962 WORK(KTEX_FOR_IEX(NTEXC_G+1)) = 1.0D0 11963C WRT_GICCI_VEC(KTEX) 11964C? WRITE(6,*) ' TEX as set ' 11965C? CALL WRT_GICCI_VEC(KTEX_FOR_IEX) 11966C? WRITE(6,*) ' KTEX_FOR_IEX(1), KTEX_FOR_IEX(NTEXC_G+1) =', 11967C? & KTEX_FOR_IEX(1), KTEX_FOR_IEX(NTEXC_G+1) 11968*. Store inital guess on unit 54 11969C GIC_VEC_TO_DISC(KTEX,LEN_TEX,NTEX_G,IREW,LU) 11970 CALL GIC_VEC_TO_DISC(KTEX_FOR_IEX,NSPA_FOR_IEX,NTEXC_G, 11971 & 1,LUSC54) 11972 END IF 11973* 11974 CONVER =.FALSE. 11975 CONVER_INT = .FALSE. 11976 CONVER_EXT = .FALSE. 11977 I12 = 2 11978 MAXIT_MACRO = MAXITM 11979*. Convergence will be defined as energy change 11980 I_ER_CONV = 1 11981*. There is no external converence threshold for residual 11982*. just use sqrt of energythreshold 11983 THRES_R = SQRT(THRES_E) 11984 DO IT_IE = 1, MAXIT_MACRO 11985 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'COMP_M') 11986* 11987 IF(NTEST.GE.1) THEN 11988 WRITE(6,*) 11989 WRITE(6,*) ' ------------------------------------------' 11990 WRITE(6,*) ' Information from outer iteration ', IT_IE 11991 WRITE(6,*) ' ------------------------------------------' 11992 WRITE(6,*) 11993 END IF 11994 IDUM = 0 11995*. In iteration IT_IE, the internal operators upto and including T(IT_IE) 11996* are reoptimed 11997* 11998 ITMAX = MIN(IT_IE,NTEXC_G) 11999 WRITE(6,*) ' Number of operators to be optimized ', ITMAX 12000* and loop over the various T-operators to be optimized 12001 DO ITACT = 1, ITMAX 12002 WRITE(6,*) 12003 WRITE(6,*) 12004 & ' Information about optimization of operator ', ITACT 12005 WRITE(6,*) 12006 & ' .........................................' 12007 WRITE(6,*) 12008*. Prepare for calculation in this space 12009 CALL PREPARE_FOR_IEX(ITACT) 12010*. Number of parameters with and without spinadaptation 12011 NCAAB = NCAAB_FOR_IEX(ITACT) 12012 NSPA = NSPA_FOR_IEX(ITACT) 12013* 12014 IF (I_IT_OR_DIR.EQ.2 ) THEN 12015* 12016* -------------------------------------------- 12017*. Construct matrices explicit and diagonalize 12018* -------------------------------------------- 12019* 12020 CALL ICCI_COMPLETE_MAT2(IREFSPC,ITREFSPC,I_SPIN_ADAPT, 12021 & NROOT,WORK(KLTEXT),C_0,E_EXTOP) 12022 EFINAL = E_EXTOP 12023 CONVER_EXT = .TRUE. 12024 VNFINAL_EXT = 0.0D0 12025 ELSE 12026* 12027*.------------------------------------------------ 12028* Iterative methods used to solve GICCI equations 12029*.------------------------------------------------ 12030* 12031*. Currently : no preconditioning and no elimination of singularities 12032* ( Yes, I am still an optimist ( or desperate )) 12033 NTESTL = 10 12034 MAXITL = MAXIT 12035 MAXVECL = MXCIV 12036*. Jeppe Playing around 12037CD IF(ITACT.EQ.1) THEN 12038CD MAXITL = 2 12039CD DO I = 1, 100 12040CD WRITE(6,*) ' MAXITL = 2 for ITACT = 1 set by Jeppe !!' 12041CD END DO 12042CD END IF 12043*- End of Jeppe playing around 12044*. Allocate space for iterative solver 12045 CALL MEMMAN(KL_EXTVEC1,NCAAB,'ADDL ',2,'EXTVC1') 12046 CALL MEMMAN(KL_EXTVEC2,NCAAB,'ADDL ',2,'EXTVC2') 12047 CALL MEMMAN(KL_EXTVEC3,NCAAB,'ADDL ',2,'EXTVC3') 12048 CALL MEMMAN(KL_EXTVEC4,NCAAB,'ADDL ',2,'EXTVC3') 12049* 12050 CALL MEMMAN(KL_RNRM,MAXITL*NROOT,'ADDL ',2,'RNRM ') 12051 CALL MEMMAN(KL_EIG ,MAXITL*NROOT,'ADDL ',2,'EIG ') 12052 CALL MEMMAN(KL_FINEIG,NROOT,'ADDL ',2,'FINEIG') 12053* 12054 CALL MEMMAN(KL_APROJ,MAXVECL**2,'ADDL ',2,'APROJ ') 12055 CALL MEMMAN(KL_SPROJ,MAXVECL**2,'ADDL ',2,'SPROJ ') 12056 CALL MEMMAN(KL_AVEC ,MAXVECL**2,'ADDL ',2,'AVEC ') 12057 LLWORK = 5*MAXVECL**2 + 2*MAXVECL 12058 CALL MEMMAN(KL_WORK ,LLWORK ,'ADDL ',2,'WORK ') 12059 CALL MEMMAN(KL_AVEC ,MAXVECL**2,'ADDL ',2,'AVECP ') 12060 CALL MEMMAN(KL_AVECP,MAXVECL**2,'ADDL ',2,'AVECP ') 12061*. Obtain diagonal of H and S 12062 I_DO_PRE_IN_EXT = 0 12063 IF(I_DO_PRE_IN_EXT.EQ.1) THEN 12064*. Generate non-trivial preconditioner 12065 IF(I_DO_EI.EQ.0) THEN 12066 CALL GET_HS_DIA(WORK(KL_EXTVEC3),WORK(KL_EXTVEC4), 12067 & 1,1,1,WORK(KL_EXTVEC1),WORK(KL_EXTVEC2), 12068 & WORK(KVEC1),WORK(KVEC2),IREFSPC,ITREFSPC, 12069 & IUNIOPX,NSPA,0,IDUM,IDUM) 12070 ELSE 12071*. EI approach 12072 CALL GET_DIAG_H0_EI(WORK(KL_EXTVEC3)) 12073*. clean up 12074 I12 = 2 12075*. States are normalized, so 12076 ONE = 1.0D0 12077 CALL SETVEC(WORK(KL_EXTVEC4),ONE,NSPA) 12078 END IF 12079 ELSE 12080*. Generate trivial preconditioner 12081 ONE = 1.0D0 12082 CALL SETVEC(WORK(KL_EXTVEC3),ONE,NSPA) 12083 CALL SETVEC(WORK(KL_EXTVEC4),ONE,NSPA) 12084 END IF 12085*. And write diagonal to disc as single record files 12086 CALL VEC_TO_DISC(WORK(KL_EXTVEC3),NSPA,1,-1,LUSC53) 12087 CALL VEC_TO_DISC(WORK(KL_EXTVEC4),NSPA,1,-1,LUSC51) 12088*. (LUSC51 is not used) 12089 IF(IRESTRT_IC.EQ.1) THEN 12090*. Copy old CI coefficients for reference space to LUC 12091 CALL COPVCD(LUEXC,LUC,WORK(KVEC1),1,-1) 12092 END IF 12093*. Obtain current amplitudes for TACT and save in LUSC34 12094C GIC_VEC_FROM_DISC(KTEX,LEN_TEX,NTEX_G,IREW,LU) 12095C? WRITE(6,*) ' Before GIC_VEC_FROM... ' 12096 CALL GIC_VEC_FROM_DISC(KTEX_FOR_IEX,NSPA_FOR_IEX,NTEXC_G, 12097 & 1,LUSC54) 12098C? WRITE(6,*) ' After GIC_VEC_FROM... T read in ' 12099C? CALL WRT_GICCI_VEC(KTEX_FOR_IEX) 12100* 12101 C0 = WORK(KTEX_FOR_IEX(1)-1+NSPA_TOT+1) 12102C? WRITE(6,*) ' coefficient of ref before MINGENEIG', 12103C? & C0 12104 CALL COPVEC(WORK(KTEX_FOR_IEX(ITACT)),WORK(KLTACT),NSPA-1) 12105*. Coefficient for constant part of expansion (independent of T(IACT)) 12106 WORK(KLTACT-1+NSPA) = 1.0D0 12107C? WRITE(6,*) ' KLTACT, KLTACT-1+NSPA+1=', 12108C? & KLTACT, KLTACT-1+NSPA+1 12109C? WRITE(6,*) ' WORK(KLTACT) as defined' 12110C? CALL WRTMAT(WORK(KLTACT),1,NSPA,1,NSPA) 12111*. and save amplitudes 12112 CALL VEC_TO_DISC(WORK(KLTACT),NSPA,1,-1,LUSC34) 12113 DO IMAC = 1, 1 12114* LUSC53 is LU_DIAH, LUSC51 is LU_DIAS, LUSC36 is LUC where 12115* eigenvector is stored 12116*. 2 implies that advanced preconditioner is called 12117*- Save reference energy for use with diagonal preconditioner 12118 EREFX = EREF 12119* 12120C? WRITE(6,*) ' I_DO_EI = ', I_DO_EI 12121 I12 = 2 12122 IF(I_DO_EI.EQ.0) THEN 12123 IPREC_FORM = 1 12124 SHIFT = 0.0D0 12125 CALL MINGENEIG(H_S_EXT_GICCI_TV,HOME_SD_INV_T_ICCI, 12126 & IPREC_FORM,THRES_E,THRES_R,I_ER_CONV, 12127 & WORK(KL_EXTVEC1),WORK(KL_EXTVEC2),WORK(KL_EXTVEC3), 12128 & LUSC34, LUSC37, 12129 & WORK(KL_RNRM),WORK(KL_EIG),WORK(KL_FINEIG),MAXITL, 12130 & NSPA,LUSC38,LUSC39,LUSC40,LUSC53,LUSC51,LUSC52, 12131 & NROOT,MAXVECL,NROOT,WORK(KL_APROJ), 12132 & WORK(KL_AVEC),WORK(KL_SPROJ),WORK(KL_WORK), 12133 & NTESTL,SHIFT,WORK(KL_AVECP),I_DO_PRE_IN_EXT, 12134 & CONVER_EXT,E_EXTOP,VNFINAL_EXT) 12135 ELSE 12136 IPREC_FORM = 2 12137 CALL MINGENEIG(H_S_EXT_GICCI_TV,H0_EI_TV, 12138 & IPREC_FORM,THRES_E,THRES_R,I_ER_CONV, 12139 & WORK(KL_EXTVEC1),WORK(KL_EXTVEC2),WORK(KL_EXTVEC3), 12140 & LUSC34, LUSC37, 12141 & WORK(KL_RNRM),WORK(KL_EIG),WORK(KL_FINEIG),MAXITL, 12142 & NSPA,LUSC38,LUSC39,LUSC40,LUSC53,LUSC51,LUSC52, 12143 & NROOT,MAXVECL,NROOT,WORK(KL_APROJ), 12144 & WORK(KL_AVEC),WORK(KL_SPROJ),WORK(KL_WORK), 12145 & NTESTL,SHIFT,WORK(KL_AVECP),I_DO_PRE_IN_EXT, 12146 & CONVER_EXT,E_EXTOP,VNFINAL_EXT) 12147 END IF 12148 EFINAL = E_EXTOP 12149 END DO 12150* ^ End of loop over reset eigenvalue problem 12151*. Update T-coefficients on LU54 12152 CALL GIC_VEC_FROM_DISC(KTEX_FOR_IEX,NSPA_FOR_IEX, 12153 & NTEXC_G,1,LUSC54) 12154 CALL VEC_FROM_DISC(WORK(KLTACT),NSPA,1,-1,LUSC34) 12155C UPDATE_GICCI_VEC(KTEX,I_EX_ACT,TACTVEC,ISCALE) 12156 CALL UPDATE_GICCI_VEC(KTEX_FOR_IEX,ITACT,WORK(KLTACT),1) 12157* 12158 IF(NTEST.GE.1000) THEN 12159 WRITE(6,*) ' Updated T-coefficients to be written ' 12160 CALL WRT_GICCI_VEC(KTEX_FOR_IEX) 12161C WRT_GICCI_VEC(KTEX) 12162 END IF 12163* 12164 CALL GIC_VEC_TO_DISC(KTEX_FOR_IEX,NSPA_FOR_IEX,NTEXC_G, 12165 & 1,LUSC54) 12166*. Test: construct wave function 12167 CALL GET_GICCI_0(KTEX_FOR_IEX,LUSC38,LUC,LUSC39,LUSC40) 12168 XNORM0 = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUSC38,LUSC38, 12169 & 1,-1) 12170C? WRITE(6,*) ' Square norm of |0> after MINGENEIG', XNORM0 12171C GET_GICCI_0(KTEXG,LUOUT,LUC,LUSC2,LUSC3) 12172 C_0 = WORK(KTEX_FOR_IEX(NTEXC_G+1)) 12173*. And the current T(ACT) 12174 CALL COPVEC(WORK(KTEX_FOR_IEX(ITACT)),WORK(KLTACT),NSPA) 12175 IF(I_DO_EI.EQ.0) THEN 12176 CALL PREPARE_FOR_IEX(ITACT) 12177 CALL REF_CCV_CAAB_SP(WORK(KL_EXTVEC1),WORK(KLTACT), 12178 & WORK(KL_EXTVEC3),2) 12179 ELSE 12180 CALL TRANS_CAAB_ORTN(WORK(KL_EXTVEC1),WORK(KLTACT),1,2,2, 12181 & WORK(KL_EXTVEC3),2) 12182 END IF 12183 T_CAAB_NORM = 12184 & SQRT(INPROD(WORK(KL_EXTVEC1),WORK(KL_EXTVEC1),NCAAB)) 12185 WRITE(6,*) ' Norm of T in CAAB basis after MINGENEIG', 12186 & T_CAAB_NORM 12187* 12188 IF(NTEST.GE.10) THEN 12189 WRITE(6,*) ' coefficient of zero-order state ', C_0 12190 WRITE(6,*) 12191 & ' Analysis of external amplitudes in CAAB basis' 12192 CALL ANA_GENCC(WORK(KL_EXTVEC1),1) 12193 END IF 12194 END IF 12195* ^ End of switch direct/iterative approach for T_EXT 12196 END DO 12197* ^ End of loop over Operators to be optimized in this outer 12198* iteration 12199 12200 VNFINAL_INT = 0.0D0 12201 IF(I_RELAX_INT.EQ.1) THEN 12202* ============================================================ 12203*. Relax coefficients of internal/reference/zero-order state 12204* ============================================================ 12205* 12206 IF(NTEST.GE.0) THEN 12207 WRITE(6,*) 12208 WRITE(6,*) ' Optimization of internal correlation part' 12209 WRITE(6,*) ' .........................................' 12210 WRITE(6,*) 12211 END IF 12212 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 12213 KVEC1P = KVEC1 12214 KVEC2P = KVEC2 12215* 12216 IF(I_IT_OR_DIR.EQ.2) THEN 12217* 12218*. Construct complete matrices and diagonalize 12219* 12220*. Space for H and S in zero-order space 12221 CALL MEMMAN(KLH_REF,N_REF**2,'ADDL ',2,'H_REF ') 12222 CALL MEMMAN(KLS_REF,N_REF**2,'ADDL ',2,'S_REF ') 12223 CALL MEMMAN(KLC_REF,N_REF ,'ADDL ',2,'C_REF ') 12224 CALL MEMMAN(KLI_REF,N_REF ,'ADDL ',1,'I_REF ') 12225* 12226 CALL ICCI_RELAX_REFCOEFS_COM(WORK(KLTEXT),NSPA, 12227 & WORK(KLH_REF), 12228 & WORK(KLS_REF),N_REF,WORK(KVEC1),WORK(KVEC2),1, 12229 & IREFSPC,ITREFSPC,C_0,ECORE,WORK(KLC_REF),NROOT, 12230 & NCAAB,E_INTOP) 12231 CONVER_INT =.TRUE. 12232 VNFINAL_INT = 0.0D0 12233 EFINAL = E_INTOP 12234*. transfer new reference vector to DISC 12235 CALL ISTVC2(WORK(KLI_REF),0,1,N_REF) 12236C WRSVCD(LU,LBLK,VEC1,IPLAC,VAL,NSCAT,NDIM,LUFORM,JPACK) 12237 CALL REWINO(LUC) 12238 CALL WRSVCD(LUC,-1,WORK(KVEC1),WORK(KLI_REF), 12239 & WORK(KLC_REF),N_REF,N_REF,LUDIA,1) 12240 ELSE 12241*. Use iterative methods to reoptimize reference coefficients 12242 MAXITL = MAXIT 12243 MAXVEC = MXCIV 12244* 12245 CALL MEMMAN(KL_REFVEC1,N_REF,'ADDL ',2,'REFVC1') 12246 CALL MEMMAN(KL_REFVEC2,N_REF,'ADDL ',2,'REFVC2') 12247 CALL MEMMAN(KL_REFVEC3,N_REF,'ADDL ',2,'REFVC3') 12248* 12249 CALL MEMMAN(KL_RNRM,MAXIT*NROOT,'ADDL ',2,'RNRM ') 12250 CALL MEMMAN(KL_EIG ,MAXIT*NROOT,'ADDL ',2,'EIG ') 12251 CALL MEMMAN(KL_FINEIG,NROOT,'ADDL ',2,'FINEIG') 12252* 12253 CALL MEMMAN(KL_APROJ,MAXVEC**2,'ADDL ',2,'APROJ ') 12254 CALL MEMMAN(KL_SPROJ,MAXVEC**2,'ADDL ',2,'SPROJ ') 12255 CALL MEMMAN(KL_AVEC ,MAXVEC**2,'ADDL ',2,'AVEC ') 12256 LLWORK = 5*MAXVEC**2 + 2*MAXVEC 12257 CALL MEMMAN(KL_WORK ,LLWORK ,'ADDL ',2,'WORK ') 12258 CALL MEMMAN(KL_AVEC ,MAXVEC**2,'ADDL ',2,'AVECP ') 12259 CALL MEMMAN(KL_AVECP,MAXVEC**2,'ADDL ',2,'AVECP ') 12260* 12261* Well, there is pt a conflict between the form of files 12262* in mingeneig and in the general CI programs 12263*. In MINGENEIG all vectors are single record files, whereas 12264* the vectors are multirecord files in the general LUCIA 12265* world. Reformatting is therefore required.. 12266*. LUC is LUC 12267*. LUSC36 is LUDIA 12268*. LUSC51 is LUDIAS 12269* 12270*. Reform LUC to single record file 12271 CALL REWINO(LUC) 12272 CALL FRMDSCN(WORK(KL_REFVEC1),-1,-1,LUC) 12273 CALL REWINO(LUC) 12274 CALL VEC_TO_DISC(WORK(KL_REFVEC1),N_REF,1,-1,LUC) 12275*. Reform LUDIA to single record file on LUSC36 12276 CALL REWINO(LUDIA) 12277 CALL FRMDSCN(WORK(KL_REFVEC1),-1,-1,LUDIA) 12278 CALL VEC_TO_DISC(WORK(KL_REFVEC1),N_REF,1,-1,LUSC36) 12279*. Write diagonal of S as unit mat as single vector file 12280 ONE = 1.0D0 12281 CALL SETVEC(WORK(KL_REFVEC1),ONE,N_REF) 12282 CALL VEC_TO_DISC(WORK(KL_REFVEC1),N_REF,1,-1,LUSC51) 12283*. (LUSC51 is not used) 12284* 12285* As preconditioners, the standard CI diagonal and the 12286* unit diagonal will be used for H and S, respectively. 12287* This is fine if the T operator is not too large... 12288* 12289*. Prepare transfer common block for communicating with 12290*. matrix-vector routines 12291C C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX 12292 C_0X = C_0 12293 KLTOPX = KLTEXT 12294 NREFX = N_REF 12295 IREFSPCX = IREFSPC 12296 ITREFSPCX = ITREFSPC 12297 NCAABX = N_CC_AMP 12298 NSPAX = NSPA 12299*. Unitoperator in SPA order ... Please check .. 12300 IUNIOPX = NSPA 12301* 12302 NTESTL = 10 12303 CALL MINGENEIG( H_S_EFF_ICCI_TV,HOME_SD_INV_T_ICCI,1, 12304 & THRES_E,THRES_R,I_ER_CONV, 12305 & WORK(KL_REFVEC1),WORK(KL_REFVEC2),WORK(KL_REFVEC3), 12306 & LUC, LUSC37, 12307 & WORK(KL_RNRM),WORK(KL_EIG),WORK(KL_FINEIG),MAXITL, 12308 & N_REF,LUSC38,LUSC39,LUSC40,LUSC36,LUSC51,LUSC52, 12309 & NROOT,MXCIV,NROOT,WORK(KL_APROJ), 12310 & WORK(KL_AVEC),WORK(KL_SPROJ),WORK(KL_WORK), 12311 & NTESTL,ECORE,WORK(KL_AVECP),1, 12312 & CONVER_INT,E_INTOP,VNFINAL_INT) 12313 E_FINAL = E_INTOP 12314C MINGENEIG(MTV,STV, 12315C & VEC1,VEC2,VEC3,LU1,LU2,RNRM,EIG,FINEIG,MAXIT, 12316C & NVAR, 12317C & LU3,LU4,LU5,LUDIAM,LUDIAS,LUS,NROOT,MAXVEC, 12318C & NINVEC, 12319C & APROJ,AVEC,SPROJ,WORK,IPRT,EIGSHF,AVECP,I_DO_PRECOND) 12320* 12321*. Read new eigenvector from LUC 12322 CALL REWINO(LUC) 12323 CALL FRMDSCN(WORK(KL_REFVEC1),-1,-1,LUC) 12324* The eigenvector is normalized with respect to the <i!T+P P T|j> 12325*. metric, normalize with standard unit metrix 12326 XNORM = INPROD(WORK(KL_REFVEC1),WORK(KL_REFVEC1),N_REF) 12327 FACTOR = 1.0D0/SQRT(XNORM) 12328 CALL SCALVE(WORK(KL_REFVEC1),FACTOR,N_REF) 12329*. And write to disc in a form suitable for the other parts of LUCIA 12330 CALL ISTVC2(WORK(KL_REFVEC2),0,1,N_REF) 12331 CALL REWINO(LUC) 12332 CALL REWINO(LUDIA) 12333 CALL WRSVCD(LUC,-1,WORK(KVEC1P),WORK(KL_REFVEC2), 12334 & WORK(KL_REFVEC1),N_REF,N_REF,LUDIA,1) 12335 IF(NTEST.GE.100) THEN 12336 WRITE(6,*) ' New reference coefficients ' 12337 CALL WRTVCD(WORK(KVEC1P),LUC,1,-1) 12338 END IF 12339 END IF 12340*. ^ End of switch direct/iterative methods for reference relaxation 12341 END IF 12342*. ^ End of reference coefs should be relaxed 12343 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'COMP_M') 12344 IF(CONVER_INT.AND.CONVER_EXT.AND. 12345 & ABS(E_INTOP-E_EXTOP).LE.THRES_E) CONVER = .TRUE. 12346 IF(CONVER) GOTO 1001 12347 END DO 12348 1001 CONTINUE 12349* 12350 IF(NTEST.GE.10) THEN 12351 WRITE(6,*) ' coefficient of zero-order state ', C_0 12352 WRITE(6,*) 12353 & ' Analysis of final external amplitudes in CAAB basis' 12354 CALL ANA_GENCC(WORK(KLTEXT),1) 12355 END IF 12356* 12357 VNFINAL = VNFINAL_INT + VNFINAL_EXT 12358 WRITE(6,*) ' VNFINAL_INT, VNFINAL_EXT =', 12359 & VNFINAL_INT,VNFINAL_EXT 12360*. ^ End of loop over Internal/external correlation iterations 12361*. Print the final coefs .. 12362C? CALL VEC_FROM_DISC(WORK(KL_EXTVEC1),NSPA,1,-1,LUSC54) 12363C? WRITE(6,*) ' Final list of IC-coefficients ' 12364C? CALL WRTMAT(WORK(KL_EXTVEC1),NSPA,1,NSPA,1) 12365 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GICCI ') 12366 RETURN 12367 END 12368 SUBROUTINE LUCIA_IC(IREFSPC,ITREFSPC,ICTYP,EREF,I_DO_CUMULANTS, 12369 & EFINAL,CONVER,VNFINAL) 12370* 12371* 12372* Master routine for internally contracted CI calculations, 12373* Fall 02 version 12374* 12375* Allowing CAS as well as RAS and MRSDCI references -I hope 12376* 12377* Jeppe Olsen, September 02 12378* 12379* Last modification; Oct. 21, 2012; Jeppe Olsen; error in defining NSPOBEX_TPE corrected 12380* 12381* Also used for generating cumulant matrices 12382* 12383 INCLUDE 'wrkspc.inc' 12384 REAL*8 12385 &INPROD 12386 INCLUDE 'crun.inc' 12387 INCLUDE 'cstate.inc' 12388 INCLUDE 'cgas.inc' 12389 INCLUDE 'ctcc.inc' 12390 INCLUDE 'gasstr.inc' 12391 INCLUDE 'strinp.inc' 12392 INCLUDE 'orbinp.inc' 12393 INCLUDE 'cprnt.inc' 12394 INCLUDE 'corbex.inc' 12395 INCLUDE 'csm.inc' 12396 INCLUDE 'cicisp.inc' 12397 INCLUDE 'cecore.inc' 12398 INCLUDE 'glbbas.inc' 12399 INCLUDE 'clunit.inc' 12400*. Transfer common block for communicating with H_EFF * vector routines 12401 COMMON/COM_H_S_EFF_ICCI_TV/ 12402 & C_0X,KLTOPX,NREFX,IREFSPCX,ITREFSPCX,NCAABX, 12403 & IUNIOPX,NSPAX,IPROJSPCX 12404*. A bit of local scratch 12405 DIMENSION ICASCR(MXPNGAS) 12406 CHARACTER*6 ICTYP 12407 LOGICAL CONVER 12408* 12409 EXTERNAL MTV_FUSK, STV_FUSK 12410 EXTERNAL H_S_EFF_ICCI_TV,H_S_EXT_ICCI_TV 12411 EXTERNAL HOME_SD_INV_T_ICCI 12412*. Test of new transformer 12413C? CALL tranma_lm_test 12414C? STOP ' Enforced stop after tranma_lm_test ' 12415 IDUM = 0 12416 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ICCI ') 12417*. I will play with spinadaptation in this routine so 12418*. It is probably not working of I_SPIN_ADAPT = 0 is used !!! 12419 IF(I_DO_CUMULANTS.EQ.0) THEN 12420 I_SPIN_ADAPT = 1 12421 ELSE 12422 I_SPIN_ADAPT = 0 12423 END IF 12424* 12425 NTEST = 10 12426 IF(NTEST.GE.5) THEN 12427 IF(I_DO_CUMULANTS.EQ.0) THEN 12428 WRITE(6,*) 12429 WRITE(6,*) ' Internal contracted section entered ' 12430 WRITE(6,*) ' ==================================== ' 12431 WRITE(6,*) 12432 WRITE(6,*) ' Symmetri of reference vector ' , IREFSM 12433 WRITE(6,*) ' Space of Reference vector ', IREFSPC 12434 WRITE(6,*) ' Space of Internal contracted vector ', ITREFSPC 12435 WRITE(6,*) 12436 WRITE(6,*) ' Parameters defining internal contraction ' 12437 WRITE(6,*) ' Min excitation rank ', ICEXC_RANK_MIN 12438 WRITE(6,*) ' Max excitation rank ', ICEXC_RANK_MAX 12439 WRITE(6,'(A,A)') ' Form of calculation ', ICTYP 12440 IF(ICEXC_INT.EQ.1) THEN 12441 WRITE(6,*) 12442 & ' Internal (ina->ina, sec->sec) excitations allowed' 12443 ELSE 12444 WRITE(6,*) 12445 & ' Internal (ina->ina, sec->sec) excitations not allowed' 12446 END IF 12447 WRITE(6,*) 12448 & ' Largest number of vectors in iterative supspace ', MXCIV 12449 WRITE(6,*) 12450 & ' Largest initial number of vectors in iterative supspace ', 12451 & MXVC_I 12452 IF(IRESTRT_IC.EQ.1) THEN 12453 WRITE(6,*) ' Restarted calculation : ' 12454 WRITE(6,*) ' IC coefficients read from LUSC54' 12455 WRITE(6,*) ' CI for reference read from LUSC54 ' 12456 END IF 12457 ELSE 12458 WRITE(6,*) ' Cumulants will be calculated upto order ', 12459 & ICUMULA 12460 END IF 12461* 12462 END IF 12463* 12464 IDUM = 0 12465*. Divide orbital spaces into inactive, active, secondary using 12466*. space 1 12467 CALL CC_AC_SPACES(1,IREFTYP) 12468C CC_AC_SPACES(ISPC,IREFTYP) 12469* 12470*. Orbital excitations to work in reference state 12471* 12472*. Number of orbital excitations 12473C IC_ORBOP(IWAY,NIC_ORBOP,IC_ORBOP,MX_OP_RANK,MN_OP_RANK, 12474C & IONLY_EXCOP) 12475* 12476 IATP = 1 12477 IBTP = 2 12478* 12479 NAEL = NELEC(IATP) 12480 NBEL = NELEC(IBTP) 12481* 12482 IF(ICEXC_INT.EQ.1) THEN 12483 IONLY_EXCOP = 0 12484 ELSE 12485 IONLY_EXCOP = 1 12486 END IF 12487 IF(I_DO_CUMULANTS.EQ.0) THEN 12488*. Normal internal contracted run - unit operator included 12489 IADD_UNI = 1 12490 CALL GEN_IC_ORBOP(1,NOBEX_TP,IDUMMY, 12491 & ICEXC_RANK_MAX,ICEXC_RANK_MIN, 12492 & IONLY_EXCOP,IREFSPC,ITREFSPC,IADD_UNI, 12493 & IPRSTR) 12494*. and the orbital excitations 12495 CALL MEMMAN(KOBEX_TP,2*NGAS*NOBEX_TP,'ADDL ',2,'IC_OBX') 12496 KLOBEX = KOBEX_TP 12497 CALL GEN_IC_ORBOP(2,NOBEX_TP,WORK(KOBEX_TP), 12498 & ICEXC_RANK_MAX,ICEXC_RANK_MIN, 12499 & IONLY_EXCOP,IREFSPC,ITREFSPC,IADD_UNI, 12500 & IPRSTR) 12501 NOBEX_TPE = NOBEX_TP+1 12502 ELSE 12503*. Cumulant calculation 12504C GEN_IC_IN_ORBSPC(IWAY,NIC_ORBOP,IC_ORBOP,MX_OP_NUM, 12505C & IORBSPC) 12506*. Identify the active space ( determined in CC_AC_SPACES) 12507 NACT_SPC = 0 12508 DO IGAS = 1, NGAS 12509 IF(IHPVGAS(IGAS).EQ.3) THEN 12510 IACTSPC = IGAS 12511 NACT_SPC = NACT_SPC + 1 12512 END IF 12513 END DO 12514 IF(NACT_SPC.GT.1) THEN 12515 WRITE(6,*) ' More than one active space in cumulant expansion' 12516 WRITE(6,*) ' Cumulant code currently assumes one active space ' 12517 STOP ' More than one active space for cumulant calculation ' 12518 END IF 12519 IF(NACT_SPC.EQ.0) THEN 12520 WRITE(6,*) ' No active space ' 12521 WRITE(6,*) ' Cumulant matrices only calculated in active space' 12522 WRITE(6,*) ' I am therefore finished and stop ' 12523 STOP ' Zero active space for cumulant calculation ' 12524 END IF 12525 CALL GEN_IC_IN_ORBSPC(1,NOBEX_TP,IDUMMY,ICUMULA,IACTSPC) 12526*. and the orbital excitations 12527 CALL MEMMAN(KOBEX_TP,2*NGAS*NOBEX_TP,'ADDL ',2,'IC_OBX') 12528 KLOBEX = KOBEX_TP 12529 CALL GEN_IC_IN_ORBSPC(2,NOBEX_TP,WORK(KLOBEX),ICUMULA,IACTSPC) 12530 NOBEX_TPE = NOBEX_TP+1 12531 END IF 12532* 12533 IF(I_SPIN_ADAPT.EQ.1) THEN 12534* 12535*. Excitation operators will be spin adapted 12536* 12537 DO JOBEX_TP = 1, NOBEX_TP 12538C? WRITE(6,*) ' Constructing CA confs for JOBEX_TP = ', JOBEX_TP 12539*. Integer arrays for creation and annihilation part 12540 CALL ICOPVE2(WORK(KOBEX_TP),1+(JOBEX_TP-1)*2*NGAS,2*NGAS, 12541 & ICASCR) 12542 NOP_C = IELSUM(ICASCR,NGAS) 12543 NOP_A = IELSUM(ICASCR(1+NGAS),NGAS) 12544 NOP_CA = NOP_C + NOP_A 12545 CALL GET_CA_CONF_FOR_ORBEX(ICASCR,ICASCR(1+NGAS), 12546 & NCOC_FSM(1,JOBEX_TP),NAOC_FSM(1,JOBEX_TP), 12547 & IBCOC_FSM(1,JOBEX_TP),IBAOC_FSM(1,JOBEX_TP), 12548 & KCOC(JOBEX_TP),KAOC(JOBEX_TP), 12549 & KZC(JOBEX_TP),KZA(JOBEX_TP), 12550 & KCREO(JOBEX_TP),KAREO(JOBEX_TP)) 12551C? WRITE(6,*) ' NCOC_FSM and NAOC_FSM after GET_CA ... ' 12552C? CALL IWRTMA(NCOC_FSM,1,NSMST,1,NSMST) 12553C? CALL IWRTMA(NAOC_FSM,1,NSMST,1,NSMST) 12554 12555*. Offsets in CA block for given symmetry of creation occ 12556C IOFF_SYMBLK_MAT(NSMST,NA,NB,ITOTSM,IOFF,IRESTRICT 12557 CALL IOFF_SYMBLK_MAT(NSMST,NCOC_FSM(1,JOBEX_TP), 12558 & NAOC_FSM(1,JOBEX_TP),1,IBCAOC_FSM(1,JOBEX_TP),0) 12559C NDIM_1EL_MAT(IHSM,NRPSM,NCPSM,NSM,IPACK) 12560 NCAOC(JOBEX_TP) = NDIM_1EL_MAT(1,NCOC_FSM(1,JOBEX_TP), 12561 & NAOC_FSM(1,JOBEX_TP),NSMST,0) 12562*. And the actual configurations 12563 CALL MEMMAN(KCAOC(JOBEX_TP),NOP_CA*NCAOC(JOBEX_TP),'ADDL ', 12564 & 2,'CA_OC ') 12565C GET_CONF_FOR_ORBEX(NCOC_FSM,NAOC_FSM,ICOC,IAOC, 12566C & NOP_C,NOP_A, IBCOC_FSM,IBAOC_FSM,NSMST,IOPSM, 12567C & ICAOC) 12568 CALL GET_CONF_FOR_ORBEX( 12569 & NCOC_FSM(1,JOBEX_TP),NAOC_FSM(1,JOBEX_TP), 12570 & WORK(KCOC(JOBEX_TP)),WORK(KAOC(JOBEX_TP)), 12571 & NOP_C, NOP_A, 12572 & IBCOC_FSM(1,JOBEX_TP),IBAOC_FSM(1,JOBEX_TP), 12573 & NSMST,1,WORK(KCAOC(JOBEX_TP)) ) 12574 END DO 12575 END IF 12576*. Number of creation and annihilation operators per op 12577 CALL MEMMAN(KLCOBEX_TP,NOBEX_TPE,'ADDL ',1,'COBEX ') 12578 CALL MEMMAN(KLAOBEX_TP,NOBEX_TPE,'ADDL ',1,'AOBEX ') 12579 CALL GET_NCA_FOR_ORBOP(NOBEX_TP,WORK(KOBEX_TP), 12580 & WORK(KLCOBEX_TP),WORK(KLAOBEX_TP),NGAS) 12581*. Number of spinorbital excitations 12582 IZERO = 0 12583 MXSPOX = 0 12584 IACT_SPC = 0 12585 IAAEXC_TYP = 3 12586 IREFSPCX = 0 12587 MSCOMB_CC = 0 12588 CALL OBEX_TO_SPOBEX(1,WORK(KOBEX_TP),WORK(KLCOBEX_TP), 12589 & WORK(KLAOBEX_TP),NOBEX_TP,IDUMMY,NSPOBEX_TPE,NGAS, 12590 & NOBPT,0,IZERO ,IAAEXC_TYP,IACT_SPC,IPRCC,IDUMMY, 12591 & MXSPOX,WORK(KNSOX_FOR_OX), 12592 & WORK(KIBSOX_FOR_OX),WORK(KISOX_FOR_OX),NAEL,NBEL,IREFSPCX) 12593*CJO, Oct, 21, 2012, start 12594C NSPOBEX_TPE = NSPOBEX_TP + 1 12595 NSPOBEX_TP = NSPOBEX_TPE - 1 12596*CJO, Oct, 21, 2012, end 12597*. And the actual spinorbital excitations 12598 CALL MEMMAN(KLSOBEX,4*NGAS*NSPOBEX_TPE,'ADDL ',1,'SPOBEX') 12599*. Map spin-orbital exc type => orbital exc type 12600 CALL MEMMAN(KLSOX_TO_OX,NSPOBEX_TPE,'ADDL ',1,'SPOBEX') 12601*. First SOX of given OX ( including zero operator ) 12602 CALL MEMMAN(KIBSOX_FOR_OX,NOBEX_TPE,'ADDL ',1,'IBSOXF') 12603*. Number of SOX's for given OX 12604 CALL MEMMAN(KNSOX_FOR_OX,NOBEX_TPE,'ADDL ',1,'IBSOXF') 12605*. SOX for given OX 12606 CALL MEMMAN(KISOX_FOR_OX,NSPOBEX_TPE,'ADDL ',1,'IBSOXF') 12607* 12608 CALL OBEX_TO_SPOBEX(2,WORK(KOBEX_TP),WORK(KLCOBEX_TP), 12609 & WORK(KLAOBEX_TP),NOBEX_TP,WORK(KLSOBEX),NSPOBEX_TPE,NGAS, 12610 & NOBPT,0,MSCOMB_CC,IAAEXC_TYP,IACT_SPC,IPRCC, 12611 & WORK(KLSOX_TO_OX),MXSPOX,WORK(KNSOX_FOR_OX), 12612 & WORK(KIBSOX_FOR_OX),WORK(KISOX_FOR_OX),NAEL,NBEL,IREFSPCX) 12613 IF(I_DO_CUMULANTS.EQ.0) THEN 12614* 12615* A bit of info on prototype-excitations 12616* 12617*. Number of prototype-excitations 12618C NPROTO_CA(NOBEX_TP,IOBEX_TP,NGAS) 12619 NPROTO_CA_EX = NPROTO_CA(NOBEX_TP,WORK(KOBEX_TP),NGAS) 12620*. And info on the prototypes 12621 CALL MEMMAN(K_MX_DLB_C,NOBEX_TP,'ADDL ',2,'MXDB_C') 12622 CALL MEMMAN(K_MX_DLB_A,NOBEX_TP,'ADDL ',2,'MXDB_A') 12623 CALL MEMMAN(K_IB_PROTO,NOBEX_TP,'ADDL ',2,'IB_PRO') 12624 CALL MEMMAN(K_NCOMP_FOR_PROTO,NPROTO_CA_EX,'ADDL ',2, 12625 & 'NCO_PR') 12626 CALL INFO2_FOR_PROTO_CA( 12627 & NOBEX_TP,WORK(KOBEX_TP),WORK(KISOX_FOR_OX), 12628 & WORK(KNSOX_FOR_OX),WORK(KIBSOX_FOR_OX), 12629 & WORK(KLSOBEX),NGAS, 12630 & WORK(K_IB_PROTO),WORK(K_MX_DLB_C),WORK(K_MX_DLB_A), 12631 & WORK(K_NCOMP_FOR_PROTO),NPROTO_CA_EX) 12632C INFO2_FOR_PROTO_CA( 12633C & NOBEX_TP,IOBEX_TP,ISOX_FOR_OX,NSOX_FOR_OX,IBSOX_FOR_OX, 12634C & ISPOBEX_TP,NGAS, 12635C & IB_PROTO_CA, MX_DBL_C_CA, MX_DBL_A_CA, 12636C & NCOMP_FOR_PROTO_CA,NPROTO_CA) 12637 END IF 12638* 12639* Dimension and offsets of IC operators 12640* 12641 CALL MEMMAN(KLLSOBEX,NSPOBEX_TPE,'ADDL ',1,'LSPOBX') 12642 CALL MEMMAN(KLIBSOBEX,NSPOBEX_TPE,'ADDL ',1,'LSPOBX') 12643 CALL MEMMAN(KLSPOBEX_AC,NSPOBEX_TPE,'ADDL ',1,'SPOBAC') 12644 CALL MEMMAN(KLSPOBEX_FRZ,NSPOBEX_TPE,'ADDL ',1,'SPOBAC') 12645*. ALl spinorbital excitations are initially active 12646 IONE = 1 12647 CALL ISETVC(WORK(KLSPOBEX_AC),IONE,NSPOBEX_TPE) 12648*. And none are frozen 12649 IZERO = 0 12650 CALL ISETVC(WORK(KLSPOBEX_FRZ),IZERO,NSPOBEX_TPE) 12651* 12652 ITOP_SM = 1 12653C? WRITE(6,*) ' IREFSPC before IDIM.. ', IREFSPC 12654 CALL IDIM_TCC(WORK(KLSOBEX),NSPOBEX_TPE,ITOP_SM, 12655 & MX_ST_TSOSO,MX_ST_TSOSO_BLK,MX_TBLK, 12656 & WORK(KLLSOBEX),WORK(KLIBSOBEX),LEN_T_VEC, 12657 & MSCOMB_CC,MX_TBLK_AS, 12658 & WORK(KISOX_FOR_OCCLS),NOCCLS,WORK(KIBSOX_FOR_OCCLS), 12659 & NTCONF,IPRCC) 12660 N_CC_AMP = LEN_T_VEC 12661 WRITE(6,*) ' Number of IC parameters ', N_CC_AMP 12662 WRITE(6,*) ' Dimension of the various types ' 12663 CALL IWRTMA(WORK(KLLSOBEX),1,NSPOBEX_TP,1,NSPOBEX_TP) 12664* 12665 MX_ST_TSOSO_MX = MX_ST_TSOSO 12666 MX_ST_TSOSO_BLK_MX = MX_ST_TSOSO_BLK 12667 MX_TBLK_MX = MX_TBLK 12668 MX_TBLK_AS_MX = MX_TBLK_AS 12669 LEN_T_VEC_MX = LEN_T_VEC 12670*. Some more scratch etc 12671*. Alpha- and beta-excitations constituting the spinorbital excitations 12672*. Number 12673 CALL SPOBEX_TO_ABOBEX(WORK(KLSOBEX),NSPOBEX_TP,NGAS, 12674 & 1,NAOBEX_TP,NBOBEX_TP,IDUMMY,IDUMMY) 12675*. And the alpha-and beta-excitations 12676 LENA = 2*NGAS*NAOBEX_TP 12677 LENB = 2*NGAS*NBOBEX_TP 12678 CALL MEMMAN(KLAOBEX,LENA,'ADDL ',2,'IAOBEX') 12679 CALL MEMMAN(KLBOBEX,LENB,'ADDL ',2,'IAOBEX') 12680 CALL SPOBEX_TO_ABOBEX(WORK(KLSOBEX),NSPOBEX_TP,NGAS, 12681 & 0,NAOBEX_TP,NBOBEX_TP,WORK(KLAOBEX),WORK(KLBOBEX)) 12682*. Max dimensions of CCOP !KSTR> = !ISTR> maps 12683*. For alpha excitations 12684 IATP = 1 12685 IOCTPA = IBSPGPFTP(IATP) 12686 NOCTPA = NSPGPFTP(IATP) 12687 CALL LEN_GENOP_STR_MAP( 12688 & NAOBEX_TP,WORK(KLAOBEX),NOCTPA,NELFSPGP(1,IOCTPA), 12689 & NOBPT,NGAS,MAXLENA) 12690 IBTP = 2 12691 IOCTPB = IBSPGPFTP(IBTP) 12692 NOCTPB = NSPGPFTP(IBTP) 12693 CALL LEN_GENOP_STR_MAP( 12694 & NBOBEX_TP,WORK(KLBOBEX),NOCTPB,NELFSPGP(1,IOCTPB), 12695 & NOBPT,NGAS,MAXLENB) 12696 MAXLEN_I1 = MAX(MAXLENA,MAXLENB) 12697 IF(NTEST.GE.5) WRITE(6,*) ' MAXLEN_I1 = ', MAXLEN_I1 12698* 12699*. Space for old fashioned CI behind the curtain 12700*. For calculations without EI VEC1, VEC2, VEC3 have not been defined, do this. 12701* There must be inserted a check to see if EI calculation is called or move 12702* allocation 12703 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 12704 KVEC1P = KVEC1 12705 KVEC2P = KVEC2 12706 IF(I_DO_CUMULANTS.EQ.1) THEN 12707*. 1 : construct standard density matrices 12708 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'CUMULA') 12709*. Space for old fashioned CI behind the curtain 12710*. For calculations without EI VEC1, VEC2, VEC3 have not been defined, do this. 12711* There must be inserted a check 12712 CALL GET_3BLKS_GCC(KVEC1,KVEC2,KVEC3,MXCJ) 12713 KVEC1P = KVEC1 12714 KVEC2P = KVEC2 12715*. and space for the reduced density matrices/cumulants 12716 WRITE(6,*) ' IREFSPC = ', IREFSPC 12717 ICSPC = IREFSPC 12718 ISSPC = IREFSPC 12719 CALL MEMMAN(KLCUMULANTS,N_CC_AMP,'ADDL ',2,'CUMULA') 12720 ZERO = 0.0D0 12721 CALL SETVEC(WORK(KLCUMULANTS),ZERO,N_CC_AMP) 12722*. And an independent copy of the reference vector 12723 CALL COPVCD(LUC,LUSC1,WORK(KVEC1),1,-1) 12724*. Calculate reduced density matrices 12725 CALL SIGDEN_CC(WORK(KVEC1),WORK(KVEC2),LUC,LUSC1, 12726 & WORK(KLCUMULANTS),2) 12727*. And reform to cumulant expansion 12728 WRITE(6,*) ' RDM => Cumulant reformer will be called ' 12729 CALL REFORM_RDM_TO_CUMULANTS(WORK(KLCUMULANTS),WORK(KLSOBEX), 12730 & WORK(KLLSOBEX)) 12731C REFORM_RDM_TO_CUMULANTS(CUMULANTS,ISPOBEX_TP,LSOBEX_TP) 12732 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'CUMULA') 12733 END IF 12734* 12735 IF(I_SPIN_ADAPT.EQ.1) THEN 12736*. Generate maps CAAB excitations to CA .ie. the spinorbital 12737*. excitations belonging to the various orbital excitations 12738 DO JOBEX = 1, NOBEX_TP 12739*. Number of spinorbital excitations belonging to this orbital 12740*, excitation type 12741 NSOX = IFRMR(WORK(KNSOX_FOR_OX),1,JOBEX) 12742 IBSOX = IFRMR(WORK(KIBSOX_FOR_OX),1,JOBEX) 12743 NCAAB = IGATSUM(WORK(KLLSOBEX),WORK(KISOX_FOR_OX), 12744 & IBSOX,NSOX) 12745 WRITE(6,*) ' JOBEX, NSOX, IBSOX, NCAAB = ', 12746 & JOBEX, NSOX, IBSOX, NCAAB 12747 NCA = NCAOC(JOBEX) 12748C IGATSUM(IVEC,IGAT,IOFF,NELMNT) 12749 NOP_C = IFRMR(WORK(KLCOBEX_TP),1,JOBEX) 12750 NOP_CA = 2*NOP_C 12751 WRITE(6,*) ' NOP_CA = ', NOP_CA 12752* 12753*. Allocate space 12754* KICAAB_FOR_CA_OP : The CA CB AA AB operators for each CAAB 12755 LEN = NOP_CA*NCAAB 12756 CALL MEMMAN(KICAAB_FOR_CA_OP(JOBEX),LEN,'ADDL ',2,'ICAABO') 12757* KICAAB_FOR_CA_NUM : A number for each CAAB 12758 LEN = NCAAB 12759 CALL MEMMAN(KICAAB_FOR_CA_NUM(JOBEX),LEN,'ADDL ',2,'ICAABN') 12760*.KLCAAB_FOR_CA : Length of CA CB AA AB for each CAAB 12761 LEN = 4*NCAAB 12762 CALL MEMMAN(KLCAAB_FOR_CA(JOBEX),LEN,'ADDL ',2,'LCAAB ') 12763*.KNCAAB_FOR_CA : A length for each CA 12764 LEN = NCA 12765 CALL MEMMAN(KNCAAB_FOR_CA(JOBEX),LEN,'ADDL ',2,'NCAAB ') 12766*.KIBCAAB_FOR_CA : First CAAB for given CA 12767 LEN = NCA 12768 CALL MEMMAN(KIBCAAB_FOR_CA(JOBEX),LEN,'ADDL ',2,'IBCAAB') 12769* 12770 CALL CAAB_TO_CA_OC(1,WORK(KLSOBEX),WORK(KLOBEX),JOBEX, 12771 & WORK(KISOX_FOR_OX),WORK(KIBSOX_FOR_OX), 12772 & WORK(KNSOX_FOR_OX),WORK(KLIBSOBEX), 12773 & MX_ST_TSOSO_BLK_MX,NOP_CA, 12774 & WORK(KZC(JOBEX)),WORK(KZA(JOBEX)),WORK(KCREO(JOBEX)), 12775 & WORK(KAREO(JOBEX)),WORK(KCAOC(JOBEX)), 12776 & IBCAOC_FSM(1,JOBEX),NCOC_FSM(1,JOBEX), 12777 & WORK(KIBCAAB_FOR_CA(JOBEX)), 12778 & WORK(KICAAB_FOR_CA_OP(JOBEX)), 12779 & WORK(KICAAB_FOR_CA_NUM(JOBEX)), 12780 & WORK(KLCAAB_FOR_CA(JOBEX)), 12781 & WORK(KNCAAB_FOR_CA(JOBEX)),NCA,NCAAB, 12782 & WORK(K_NCOMP_FOR_PROTO) ) 12783 12784 END DO 12785 IF(NTEST.GE.100) CALL WRITE_CAAB_CONFM 12786*. Construct reorder array, CONF => CAAB order 12787 CALL MEMMAN(KLREORDER_CAAB,N_CC_AMP,'ADDL ',1,'RECAAB') 12788 CALL GEN_REORDER_CAABM(WORK(KLREORDER_CAAB)) 12789C GEN_REORDER_CAABM(ICAAB_REO) 12790* 12791* Construct matrices for Spinadaptation 12792* 12793 CALL PROTO_SPIN_MAT 12794*. Number of SPA and CAAB excitations per orbital excitation type 12795 CALL DIM_FOR_OBEXTP 12796C DIM_FOR_OBEXTP 12797 END IF 12798* ^ End if spinadaptation 12799* 12800* Call routines for explicit construction of matrices 12801* and complete diagonalizations 12802* 12803 I_ANALYZE_SING = 0 12804 IF(I_ANALYZE_SING.EQ.1) THEN 12805*. Check single excitation like operators for singularities 12806 CALL SXLIKE_SING(IREFSPC,ITREFSPC,NSXLIKE,I_SPIN_ADAPT) 12807C? WRITE(6,*) ' Enforced stop after SXLIKE_SING ' 12808C? STOP ' Enforced stop after SXLIKE_SING ' 12809*. Still checking singularities : Find singularities in SX and a+p a+h a ah ah 12810* space 12811* 12812 WRITE(6,*) 12813 & ' singularities in space spanned by sx,a+pa+ha h a h,a+pa+papah' 12814 WRITE(6,*) ' ==================================================' 12815 ICASCR(1) = 1 12816 ICASCR(2) = 2 12817 ICASCR(3) = 4 12818 CALL SING_IN_OCCLS(IREFSPC,ITREFSPC,ICASCR,3) 12819* 12820 WRITE(6,*) 12821 & ' singularities in space spanned by a+pa+ha h a h,a+pa+papah' 12822 WRITE(6,*) ' ==================================================' 12823 ICASCR(1) = 2 12824 ICASCR(2) = 4 12825 CALL SING_IN_OCCLS(IREFSPC,ITREFSPC,ICASCR,2) 12826* 12827 WRITE(6,*) ' singularities in space spanned by sx, a+pa+hahah' 12828 WRITE(6,*) ' ================================================' 12829 ICASCR(1) = 1 12830 ICASCR(2) = 2 12831 CALL SING_IN_OCCLS(IREFSPC,ITREFSPC,ICASCR,2) 12832* 12833 WRITE(6,*) ' singularities in space spanned by SX, a+pa+papah ' 12834 WRITE(6,*) ' =================================================' 12835 ICASCR(1) = 1 12836 ICASCR(2) = 4 12837 CALL SING_IN_OCCLS(IREFSPC,ITREFSPC,ICASCR,2) 12838* 12839 WRITE(6,*) ' singularities in space spanned by a+pa+ha h a h ' 12840 WRITE(6,*) ' ================================================' 12841 ICASCR(1) = 2 12842 CALL SING_IN_OCCLS(IREFSPC,ITREFSPC,ICASCR,1) 12843* 12844 WRITE(6,*) ' singularities in space spanned by a+pa+pa p a h ' 12845 WRITE(6,*) ' =================================================' 12846 ICASCR(1) = 4 12847 CALL SING_IN_OCCLS(IREFSPC,ITREFSPC,ICASCR,1) 12848* 12849 WRITE(6,*) ' Enforced stop After checking singularities ' 12850 STOP ' Enforced stop After checking singularities ' 12851 END IF 12852* 12853*. Analyze singularities in SX-space by diagonaling 12854*. the various 2-e spin-densities 12855C CALL GET_SING_IN_SX_SPACE(IREFSPC) 12856C GET_SING_IN_SX_SPACE 12857 IF(ICTYP(1:4).EQ.'ICCI') THEN 12858* 12859* ============================== 12860* Internal contracted CI section 12861* ============================== 12862* 12863* Solve Internal contracted CI problem 12864 CALL LUCIA_ICCI(IREFSPC,ITREFSPC,ICTYP,EREF, 12865 & EFINAL,CONVER,VNFINAL) 12866* 12867 ELSE IF(ICTYP(1:4).EQ.'ICPT') THEN 12868* 12869* ========================================== 12870* Internal contracted Perturbation expansion 12871* ========================================== 12872* 12873 CALL LUCIA_ICPT(IREFSPC,ITREFSPC,ICTYP,EREF, 12874 & EFINAL,CONVER,VNFINAL) 12875* 12876 ELSE IF(ICTYP(1:4).EQ.'ICCC') THEN 12877* Internal contracted coupled cluster 12878* 12879* ====================================== 12880* Internal contracted Coupled Cluster 12881* ======================================= 12882* 12883 CALL LUCIA_ICCC(IREFSPC,ITREFSPC,ICTYP,EREF,EFINAL, 12884 & CONVER,VNFINAL) 12885 END IF 12886* 12887*. 12888 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ICCI ') 12889* 12890 RETURN 12891 END 12892 SUBROUTINE GET_TEX_INFO( 12893 & IREFSPC,ITREFSPC, 12894 & MX_ST_TSOSO, MX_ST_TSOSO_BLK, MX_TBLK, MX_TBLK_AS) 12895* 12896* Generate all information about orbital and spin-orbital excitations 12897* Information is stored in scalars in CTCC 12898* 12899* 12900*. Jeppe Olsen, collecting and restructuring for GICCI etc. 12901*. March 27, 2010 12902* 12903 INCLUDE 'wrkspc.inc' 12904 INCLUDE 'strinp.inc' 12905 INCLUDE 'cgas.inc' 12906 INCLUDE 'gasstr.inc' 12907 INCLUDE 'orbinp.inc' 12908 INCLUDE 'crun.inc' 12909 INCLUDE 'ctcc.inc' 12910 INCLUDE 'cprnt.inc' 12911*. Controlling print flag: IPRSTR 12912* 12913 IATP = 1 12914 IBTP = 2 12915* 12916 NAEL = NELEC(IATP) 12917 NBEL = NELEC(IBTP) 12918* 12919 IF(ICEXC_INT.EQ.1) THEN 12920 IONLY_EXCOP = 0 12921 ELSE 12922 IONLY_EXCOP = 1 12923 END IF 12924* 12925 IADD_UNI = 1 12926 IDUM = 0 12927 CALL GEN_IC_ORBOP(1,NOBEX_TP,IDUM, 12928 & ICEXC_RANK_MAX,ICEXC_RANK_MIN, 12929 & IONLY_EXCOP,IREFSPC,ITREFSPC,IADD_UNI, 12930 & IPRSTR) 12931*. and the orbital excitations 12932 CALL MEMMAN(KOBEX_TP,2*NGAS*NOBEX_TP,'ADDL ',2,'IC_OBX') 12933 KLOBEX = KOBEX_TP 12934 CALL GEN_IC_ORBOP(2,NOBEX_TP,WORK(KOBEX_TP), 12935 & ICEXC_RANK_MAX,ICEXC_RANK_MIN, 12936 & IONLY_EXCOP,IREFSPC,ITREFSPC,IADD_UNI, 12937 & IPRSTR) 12938 NOBEX_TPE = NOBEX_TP+1 12939*. Number of creation and annihilation operators per op 12940 CALL MEMMAN(KLCOBEX_TP,NOBEX_TPE,'ADDL ',1,'COBEX ') 12941 CALL MEMMAN(KLAOBEX_TP,NOBEX_TPE,'ADDL ',1,'AOBEX ') 12942 CALL GET_NCA_FOR_ORBOP(NOBEX_TP,WORK(KOBEX_TP), 12943 & WORK(KLCOBEX_TP),WORK(KLAOBEX_TP),NGAS) 12944*. Number of spinorbital excitations 12945 IZERO = 0 12946 MXSPOX = 0 12947 IACT_SPC = 0 12948 IAAEXC_TYP = 3 12949 IREFSPCX = 0 12950 MSCOMB_CC = 0 12951 CALL OBEX_TO_SPOBEX(1,WORK(KOBEX_TP),WORK(KLCOBEX_TP), 12952 & WORK(KLAOBEX_TP),NOBEX_TP,IDUM,NSPOBEX_TPE,NGAS, 12953 & NOBPT,0,IZERO ,IAAEXC_TYP,IACT_SPC,IPRSTR,IDUM, 12954 & MXSPOX,IDUM, 12955 & IDUM,IDUM,NAEL,NBEL,IREFSPCX) 12956 NSPOBEX_TP = NSPOBEX_TPE 12957*. And the actual spinorbital excitations 12958 CALL MEMMAN(KLSOBEX,4*NGAS*NSPOBEX_TPE,'ADDL ',1,'SPOBEX') 12959*. Map spin-orbital exc type => orbital exc type 12960 CALL MEMMAN(KLSOX_TO_OX,NSPOBEX_TPE,'ADDL ',1,'SPOBEX') 12961*. First SOX of given OX ( including zero operator ) 12962 CALL MEMMAN(KIBSOX_FOR_OX,NOBEX_TPE,'ADDL ',1,'IBSOXF') 12963*. Number of SOX's for given OX 12964 CALL MEMMAN(KNSOX_FOR_OX,NOBEX_TPE,'ADDL ',1,'IBSOXF') 12965*. SOX for given OX 12966 CALL MEMMAN(KISOX_FOR_OX,NSPOBEX_TPE,'ADDL ',1,'IBSOXF') 12967*. KLSOBEX,KIBSOX_FOR_OX,KNSOX_FOR_OX,KISOX_FOR_OX, 12968 CALL OBEX_TO_SPOBEX(2,WORK(KOBEX_TP),WORK(KLCOBEX_TP), 12969 & WORK(KLAOBEX_TP),NOBEX_TP,WORK(KLSOBEX),NSPOBEX_TPE,NGAS, 12970 & NOBPT,0,MSCOMB_CC,IAAEXC_TYP,IACT_SPC,IPRSTR, 12971 & WORK(KLSOX_TO_OX),MXSPOX,WORK(KNSOX_FOR_OX), 12972 & WORK(KIBSOX_FOR_OX),WORK(KISOX_FOR_OX),NAEL,NBEL,IREFSPCX) 12973C? WRITE(6,*) 'ISOX_FOR_OX after OBEX_TO.....' 12974C? CALL IWRTMA(WORK(KISOX_FOR_OX),1,NSPOBEX_TP,1,NSPOBEX_TP) 12975* Dimension and offsets of IC operators 12976 CALL MEMMAN(KLLSOBEX,NSPOBEX_TPE,'ADDL ',1,'LSPOBX') 12977 CALL MEMMAN(KLIBSOBEX,NSPOBEX_TPE,'ADDL ',1,'LSPOBX') 12978 CALL MEMMAN(KLSPOBEX_AC,NSPOBEX_TPE,'ADDL ',1,'SPOBAC') 12979 CALL MEMMAN(KLSPOBEX_FRZ,NSPOBEX_TPE,'ADDL ',1,'SPOBAC') 12980*. KLLSOBEX, KLIBSOBEX, KLSPOBEX_AC, KLSPOBEX_FRZ 12981*. ALl spinorbital excitations are initially active 12982 IONE = 1 12983 CALL ISETVC(WORK(KLSPOBEX_AC),IONE,NSPOBEX_TPE) 12984*. And none are frozen 12985 IZERO = 0 12986 CALL ISETVC(WORK(KLSPOBEX_FRZ),IZERO,NSPOBEX_TPE) 12987* 12988 ITOP_SM = 1 12989*. Dimension of blocks of CC and of total expansion 12990 CALL IDIM_TCC(WORK(KLSOBEX),NSPOBEX_TP,ITOP_SM, 12991 & MX_ST_TSOSO,MX_ST_TSOSO_BLK,MX_TBLK, 12992 & WORK(KLLSOBEX),WORK(KLIBSOBEX),LEN_T_VEC, 12993 & MSCOMB_CC,MX_TBLK_AS, 12994 & WORK(KISOX_FOR_OCCLS),NOCCLS,WORK(KIBSOX_FOR_OCCLS), 12995 & NTCONF,IPRSTR) 12996 N_CC_AMP = LEN_T_VEC 12997 WRITE(6,*) ' Number of IC parameters ', N_CC_AMP 12998 IF(IPRSTR.GE.5) THEN 12999 WRITE(6,*) ' Dimension of the various types ' 13000 CALL IWRTMA(WORK(KLLSOBEX),1,NSPOBEX_TP,1,NSPOBEX_TP) 13001 END IF 13002* MX_ST_TSOSO, MX_ST_TSOSO_BLK, MX_TBLK, MX_TBLK_AS, 13003 MX_ST_TSOSO_MX = MX_ST_TSOSO 13004 MX_ST_TSOSO_BLK_MX = MX_ST_TSOSO_BLK 13005 MX_TBLK_MX = MX_TBLK 13006 MX_TBLK_AS_MX = MX_TBLK_AS 13007 LEN_T_VEC_MX = LEN_T_VEC 13008*. Alpha- and beta-excitations constituting the spinorbital excitations 13009*. Number 13010 CALL SPOBEX_TO_ABOBEX(WORK(KLSOBEX),NSPOBEX_TP,NGAS, 13011 & 1,NAOBEX_TP,NBOBEX_TP,IDUMMY,IDUMMY) 13012*. And the alpha-and beta-excitations 13013 LENA = 2*NGAS*NAOBEX_TP 13014 LENB = 2*NGAS*NBOBEX_TP 13015 CALL MEMMAN(KLAOBEX,LENA,'ADDL ',2,'IAOBEX') 13016 CALL MEMMAN(KLBOBEX,LENB,'ADDL ',2,'IAOBEX') 13017 CALL SPOBEX_TO_ABOBEX(WORK(KLSOBEX),NSPOBEX_TP,NGAS, 13018 & 0,NAOBEX_TP,NBOBEX_TP,WORK(KLAOBEX),WORK(KLBOBEX)) 13019*. Max dimensions of CCOP !KSTR> = !ISTR> maps 13020*. For alpha excitations 13021 IATP = 1 13022 IOCTPA = IBSPGPFTP(IATP) 13023 NOCTPA = NSPGPFTP(IATP) 13024 CALL LEN_GENOP_STR_MAP( 13025 & NAOBEX_TP,WORK(KLAOBEX),NOCTPA,NELFSPGP(1,IOCTPA), 13026 & NOBPT,NGAS,MAXLENA) 13027 IBTP = 2 13028 IOCTPB = IBSPGPFTP(IBTP) 13029 NOCTPB = NSPGPFTP(IBTP) 13030 CALL LEN_GENOP_STR_MAP( 13031 & NBOBEX_TP,WORK(KLBOBEX),NOCTPB,NELFSPGP(1,IOCTPB), 13032 & NOBPT,NGAS,MAXLENB) 13033 MAXLEN_I1 = MAX(MAXLENA,MAXLENB) 13034 IF(NTEST.GE.5) WRITE(6,*) ' MAXLEN_I1 = ', MAXLEN_I1 13035* 13036 RETURN 13037 END 13038 SUBROUTINE TRANSFER_T_OFFSETS(I_FT_GLOBAL,IEX_G) 13039* 13040*. Transfer offsets for T-operators between specific and 13041*. general arrays for offsets and lengths 13042* 13043 INCLUDE 'wrkspc.inc' 13044 INCLUDE 'ctcc.inc' 13045 INCLUDE 'crun.inc' 13046* 13047*. Jeppe Olsen, March 2009 13048* 13049*. Last modification; Oct. 27, 2012; Jeppe Olsen; NSPOBEX_TPE added 13050* 13051 NTEST = 00 13052 IF(NTEST.GE.100) THEN 13053 WRITE(6,*) 13054 WRITE(6,*) ' ---------------------------' 13055 WRITE(6,*) ' Entering TRANSFER_T_OFFSETS' 13056 WRITE(6,*) ' ---------------------------' 13057 WRITE(6,*) 13058 WRITE(6,*) ' I_FT_GLOBAL, IEX_G =', I_FT_GLOBAL,IEX_G 13059 END IF 13060* 13061 IF(I_FT_GLOBAL.EQ.2) THEN 13062*. Write information to permanent arrays 13063 NOBEX_TP_G(IEX_G) = NOBEX_TP 13064C? WRITE(6,*) ' NOBEX_TP_G, NOBEX_TP = ', 13065C? & NOBEX_TP_G(IEX_G), NOBEX_TP 13066 KOBEX_TP_G(IEX_G) = KOBEX_TP 13067C? WRITE(6,*) ' KOBEX_TP_G(IEX_G), KOBEX_TP (a) ', 13068C? & KOBEX_TP_G(IEX_G), KOBEX_TP 13069 KLCOBEX_TP_G(IEX_G) = KLCOBEX_TP 13070 KLAOBEX_TP_G(IEX_G) = KLAOBEX_TP 13071 NSPOBEX_TP_G(IEX_G) = NSPOBEX_TP 13072 KLSOBEX_G(IEX_G) = KLSOBEX 13073 KIBSOX_FOR_OX_G(IEX_G) = KIBSOX_FOR_OX 13074 KNSOX_FOR_OX_G(IEX_G) = KNSOX_FOR_OX 13075 KISOX_FOR_OX_G(IEX_G) = KISOX_FOR_OX 13076 KLSOX_TO_OX_G(IEX_G) = KLSOX_TO_OX 13077C? WRITE(6,*) 'KISOX_FOR_OX_G, KISOX_FOR_OX(a)' 13078C? WRITE(6,*) KISOX_FOR_OX_G(IEX_G),KISOX_FOR_OX 13079 KLLSOBEX_G(IEX_G) = KLLSOBEX 13080 KLIBSOBEX_G(IEX_G) = KLIBSOBEX 13081 KLSPOBEX_AC_G(IEX_G) = KLSPOBEX_AC 13082 KLSPOBEX_FRZ_G(IEX_G) = KLSPOBEX_FRZ 13083 N_CC_AMP_G(IEX_G) = N_CC_AMP 13084 NAOBEX_TP_G(IEX_G) = NAOBEX_TP 13085 NBOBEX_TP_G(IEX_G) = NBOBEX_TP 13086 KLAOBEX_G(IEX_G) = KLAOBEX 13087 KLBOBEX_G(IEX_G) = KLBOBEX 13088 ELSE 13089 NOBEX_TP = NOBEX_TP_G(IEX_G) 13090C? WRITE(6,*) ' NOBEX_TP_G, NOBEX_TP = ', 13091C? & NOBEX_TP_G(IEX_G), NOBEX_TP 13092 KOBEX_TP = KOBEX_TP_G(IEX_G) 13093C? WRITE(6,*) ' KOBEX_TP_G(IEX_G), KOBEX_TP (b) ', 13094C? & KOBEX_TP_G(IEX_G), KOBEX_TP 13095 KLCOBEX_TP = KLCOBEX_TP_G(IEX_G) 13096 KLAOBEX_TP = KLAOBEX_TP_G(IEX_G) 13097 NSPOBEX_TP = NSPOBEX_TP_G(IEX_G) 13098 NSPOBEX_TPE = NSPOBEX_TP 13099 KLSOBEX = KLSOBEX_G(IEX_G) 13100 KIBSOX_FOR_OX = KIBSOX_FOR_OX_G(IEX_G) 13101 KNSOX_FOR_OX = KNSOX_FOR_OX_G(IEX_G) 13102 KISOX_FOR_OX = KISOX_FOR_OX_G(IEX_G) 13103 KLSOX_TO_OX = KLSOX_TO_OX_G(IEX_G) 13104C? WRITE(6,*) 'KISOX_FOR_OX_G, KISOX_FOR_OX(b)' 13105C? WRITE(6,*) KISOX_FOR_OX_G(IEX_G),KISOX_FOR_OX 13106 KLLSOBEX = KLLSOBEX_G(IEX_G) 13107 KLIBSOBEX = KLIBSOBEX_G(IEX_G) 13108 KLSPOBEX_AC = KLSPOBEX_AC_G(IEX_G) 13109 KLSPOBEX_FRZ = KLSPOBEX_FRZ_G(IEX_G) 13110 N_CC_AMP = N_CC_AMP_G(IEX_G) 13111 NAOBEX_TP = NAOBEX_TP_G(IEX_G) 13112 NBOBEX_TP = NBOBEX_TP_G(IEX_G) 13113 KLAOBEX = KLAOBEX_G(IEX_G) 13114 KLBOBEX = KLBOBEX_G(IEX_G) 13115 END IF 13116* 13117 RETURN 13118 END 13119 SUBROUTINE GET_SP_INFO 13120* 13121*. Information in partial spin-adaptation of excitation operators 13122* Information is stored in specific arrays in corbex, ctcc. glbbas 13123* 13124*. Jeppe Olsen, march 27, 2010 13125* 13126 INCLUDE 'wrkspc.inc' 13127 INCLUDE 'cgas.inc' 13128 INCLUDE 'csm.inc' 13129 INCLUDE 'corbex.inc' 13130 INCLUDE 'glbbas.inc' 13131 INCLUDE 'ctcc.inc' 13132 INCLUDE 'crun.inc' 13133* 13134 DIMENSION ICASCR(MXPNGAS) 13135* 13136 NTEST = 0 13137 IF(NTEST.GE.10) THEN 13138 WRITE(6,*) 13139 WRITE(6,*) ' ----------------------------' 13140 WRITE(6,*) ' Information from GET_SP_INFO' 13141 WRITE(6,*) ' ----------------------------' 13142 WRITE(6,*) 13143 END IF 13144* 13145 DO JOBEX_TP = 1, NOBEX_TP 13146 IF(NTEST.GE.100) 13147 & WRITE(6,*) ' Constructing CA confs for JOBEX_TP = ', JOBEX_TP 13148*. Integer arrays for creation and annihilation part 13149 CALL ICOPVE2(WORK(KOBEX_TP),1+(JOBEX_TP-1)*2*NGAS,2*NGAS, 13150 & ICASCR) 13151 NOP_C = IELSUM(ICASCR,NGAS) 13152 NOP_A = IELSUM(ICASCR(1+NGAS),NGAS) 13153 NOP_CA = NOP_C + NOP_A 13154 CALL GET_CA_CONF_FOR_ORBEX(ICASCR,ICASCR(1+NGAS), 13155 & NCOC_FSM(1,JOBEX_TP),NAOC_FSM(1,JOBEX_TP), 13156 & IBCOC_FSM(1,JOBEX_TP),IBAOC_FSM(1,JOBEX_TP), 13157 & KCOC(JOBEX_TP),KAOC(JOBEX_TP), 13158 & KZC(JOBEX_TP),KZA(JOBEX_TP), 13159 & KCREO(JOBEX_TP),KAREO(JOBEX_TP)) 13160 IF(NTEST.GE.100) THEN 13161 WRITE(6,*) ' NCOC_FSM and NAOC_FSM after GET_CA ... ' 13162 CALL IWRTMA(NCOC_FSM,1,NSMST,1,NSMST) 13163 CALL IWRTMA(NAOC_FSM,1,NSMST,1,NSMST) 13164 END IF 13165*. Offsets in CA block for given symmetry of creation occ 13166C IOFF_SYMBLK_MAT(NSMST,NA,NB,ITOTSM,IOFF,IRESTRICT 13167 CALL IOFF_SYMBLK_MAT(NSMST,NCOC_FSM(1,JOBEX_TP), 13168 & NAOC_FSM(1,JOBEX_TP),1,IBCAOC_FSM(1,JOBEX_TP),0) 13169C NDIM_1EL_MAT(IHSM,NRPSM,NCPSM,NSM,IPACK) 13170 NCAOC(JOBEX_TP) = NDIM_1EL_MAT(1,NCOC_FSM(1,JOBEX_TP), 13171 & NAOC_FSM(1,JOBEX_TP),NSMST,0) 13172*. And the actual configurations 13173 CALL MEMMAN(KCAOC(JOBEX_TP),NOP_CA*NCAOC(JOBEX_TP),'ADDL ', 13174 & 2,'CA_OC ') 13175C GET_CONF_FOR_ORBEX(NCOC_FSM,NAOC_FSM,ICOC,IAOC, 13176C & NOP_C,NOP_A, IBCOC_FSM,IBAOC_FSM,NSMST,IOPSM, 13177C & ICAOC) 13178 CALL GET_CONF_FOR_ORBEX( 13179 & NCOC_FSM(1,JOBEX_TP),NAOC_FSM(1,JOBEX_TP), 13180 & WORK(KCOC(JOBEX_TP)),WORK(KAOC(JOBEX_TP)), 13181 & NOP_C, NOP_A, 13182 & IBCOC_FSM(1,JOBEX_TP),IBAOC_FSM(1,JOBEX_TP), 13183 & NSMST,1,WORK(KCAOC(JOBEX_TP)) ) 13184 END DO 13185* 13186* A bit of info on prototype-excitations 13187* 13188*. Number of prototype-excitations 13189C NPROTO_CA(NOBEX_TP,IOBEX_TP,NGAS) 13190 NPROTO_CA_EX = NPROTO_CA(NOBEX_TP,WORK(KOBEX_TP),NGAS) 13191*. And info on the prototypes 13192 CALL MEMMAN(K_MX_DLB_C,NOBEX_TP,'ADDL ',2,'MXDB_C') 13193 CALL MEMMAN(K_MX_DLB_A,NOBEX_TP,'ADDL ',2,'MXDB_A') 13194 CALL MEMMAN(K_IB_PROTO,NOBEX_TP,'ADDL ',2,'IB_PRO') 13195 CALL MEMMAN(K_NCOMP_FOR_PROTO,NPROTO_CA_EX,'ADDL ',2, 13196 & 'NCO_PR') 13197 CALL INFO2_FOR_PROTO_CA( 13198 & NOBEX_TP,WORK(KOBEX_TP),WORK(KISOX_FOR_OX), 13199 & WORK(KNSOX_FOR_OX),WORK(KIBSOX_FOR_OX), 13200 & WORK(KLSOBEX),NGAS, 13201 & WORK(K_IB_PROTO),WORK(K_MX_DLB_C),WORK(K_MX_DLB_A), 13202 & WORK(K_NCOMP_FOR_PROTO),NPROTO_CA_EX) 13203C? WRITE(6,*) ' After INFO2' 13204C INFO2_FOR_PROTO_CA( 13205C & NOBEX_TP,IOBEX_TP,ISOX_FOR_OX,NSOX_FOR_OX,IBSOX_FOR_OX, 13206C & ISPOBEX_TP,NGAS, 13207C & IB_PROTO_CA, MX_DBL_C_CA, MX_DBL_A_CA, 13208C & NCOMP_FOR_PROTO_CA,NPROTO_CA) 13209* 13210* 13211*. Generate maps CAAB excitations to CA .ie. the spinorbital 13212*. excitations belonging to the various orbital excitations 13213* 13214 DO JOBEX = 1, NOBEX_TP 13215*. Number of spinorbital excitations belonging to this orbital 13216*, excitation type 13217 NSOX = IFRMR(WORK(KNSOX_FOR_OX),1,JOBEX) 13218 IBSOX = IFRMR(WORK(KIBSOX_FOR_OX),1,JOBEX) 13219 NCAAB = IGATSUM(WORK(KLLSOBEX),WORK(KISOX_FOR_OX), 13220 & IBSOX,NSOX) 13221 NCA = NCAOC(JOBEX) 13222C IGATSUM(IVEC,IGAT,IOFF,NELMNT) 13223 NOP_C = IFRMR(WORK(KLCOBEX_TP),1,JOBEX) 13224 NOP_CA = 2*NOP_C 13225* 13226*. Allocate space 13227* KICAAB_FOR_CA_OP : The CA CB AA AB operators for each CAAB 13228 LEN = NOP_CA*NCAAB 13229 CALL MEMMAN(KICAAB_FOR_CA_OP(JOBEX),LEN,'ADDL ',2,'ICAABO') 13230* KICAAB_FOR_CA_NUM : A number for each CAAB 13231 LEN = NCAAB 13232 CALL MEMMAN(KICAAB_FOR_CA_NUM(JOBEX),LEN,'ADDL ',2,'ICAABN') 13233*.KLCAAB_FOR_CA : Length of CA CB AA AB for each CAAB 13234 LEN = 4*NCAAB 13235 CALL MEMMAN(KLCAAB_FOR_CA(JOBEX),LEN,'ADDL ',2,'LCAAB ') 13236*.KNCAAB_FOR_CA : A length for each CA 13237 LEN = NCA 13238 CALL MEMMAN(KNCAAB_FOR_CA(JOBEX),LEN,'ADDL ',2,'NCAAB ') 13239*.KIBCAAB_FOR_CA : First CAAB for given CA 13240 LEN = NCA 13241 CALL MEMMAN(KIBCAAB_FOR_CA(JOBEX),LEN,'ADDL ',2,'IBCAAB') 13242* 13243 CALL CAAB_TO_CA_OC(1,WORK(KLSOBEX),WORK(KOBEX_TP),JOBEX, 13244 & WORK(KISOX_FOR_OX),WORK(KIBSOX_FOR_OX), 13245 & WORK(KNSOX_FOR_OX),WORK(KLIBSOBEX), 13246 & MX_ST_TSOSO_BLK_MX,NOP_CA, 13247 & WORK(KZC(JOBEX)),WORK(KZA(JOBEX)),WORK(KCREO(JOBEX)), 13248 & WORK(KAREO(JOBEX)),WORK(KCAOC(JOBEX)), 13249 & IBCAOC_FSM(1,JOBEX),NCOC_FSM(1,JOBEX), 13250 & WORK(KIBCAAB_FOR_CA(JOBEX)), 13251 & WORK(KICAAB_FOR_CA_OP(JOBEX)), 13252 & WORK(KICAAB_FOR_CA_NUM(JOBEX)), 13253 & WORK(KLCAAB_FOR_CA(JOBEX)), 13254 & WORK(KNCAAB_FOR_CA(JOBEX)),NCA,NCAAB, 13255 & WORK(K_NCOMP_FOR_PROTO) ) 13256C? WRITE(6,*) ' After CAAB_TO' 13257 13258 END DO 13259* 13260 IF(NTEST.GE.100) CALL WRITE_CAAB_CONFM 13261*. Construct reorder array, CONF => CAAB order 13262C? WRITE(6,*) ' N_CC_AMP before GEN_REORDER... ', N_CC_AMP 13263 CALL MEMMAN(KLREORDER_CAAB,N_CC_AMP,'ADDL ',1,'RECAAB') 13264 CALL GEN_REORDER_CAABM(WORK(KLREORDER_CAAB)) 13265C GEN_REORDER_CAABM(ICAAB_REO) 13266*. Number of SPA and CAAB excitations per orbital excitation type 13267 CALL DIM_FOR_OBEXTP 13268C DIM_FOR_OBEXTP 13269* 13270 RETURN 13271 END 13272 SUBROUTINE TRANSFER_SPIN_OFFSETS(I_FT_GLOBAL,IEX_G) 13273* 13274* Transfer from (I_FT_GLOBAL=1) or to (I_FT_GLOBAL=2) 13275* global arrays from specific/actual arrays 13276* 13277 INCLUDE 'wrkspc.inc' 13278 INCLUDE 'csm.inc' 13279 INCLUDE 'cgas.inc' 13280 INCLUDE 'ctcc.inc' 13281 INCLUDE 'corbex.inc' 13282 INCLUDE 'glbbas.inc' 13283 COMMON/PROTO_SP_MAT/NSPA_FOP(6),NCAAB_FOP(6),IB_FOP(6),XTRA(100), 13284 & NSPA_FOP_G(6,MXPCYC),NCAAB_FOP_G(6,MXPCYC), 13285 & IB_FOP_G(6,MXPCYC) 13286* 13287 IF(I_FT_GLOBAL.EQ.2) THEN 13288 DO IOBEX_TP = 1, NOBEX_TP 13289 CALL ICOPVE(NCOC_FSM(1,IOBEX_TP),NCOC_FSM_G(1,IOBEX_TP,IEX_G), 13290 & NSMST) 13291 CALL ICOPVE(NAOC_FSM(1,IOBEX_TP),NAOC_FSM_G(1,IOBEX_TP,IEX_G), 13292 & NSMST) 13293 CALL ICOPVE(IBCOC_FSM(1,IOBEX_TP), 13294 & IBCOC_FSM_G(1,IOBEX_TP,IEX_G),NSMST) 13295 CALL ICOPVE(IBAOC_FSM(1,IOBEX_TP), 13296 & IBAOC_FSM_G(1,IOBEX_TP,IEX_G),NSMST) 13297 KCOC_G(IOBEX_TP,IEX_G) = KCOC(IOBEX_TP) 13298 KAOC_G(IOBEX_TP,IEX_G) = KAOC(IOBEX_TP) 13299 KZC_G(IOBEX_TP,IEX_G) = KZC(IOBEX_TP) 13300 KZA_G(IOBEX_TP,IEX_G) = KZA(IOBEX_TP) 13301 KCREO_G(IOBEX_TP,IEX_G) = KCREO(IOBEX_TP) 13302 KAREO_G(IOBEX_TP,IEX_G) = KAREO(IOBEX_TP) 13303 CALL ICOPVE(IBCAOC_FSM(1,IOBEX_TP), 13304 & IBCAOC_FSM_G(1,IOBEX_TP,IEX_G),NSMST) 13305 NCAOC_G(IOBEX_TP,IEX_G) = NCAOC(IOBEX_TP) 13306 KCAOC_G(IOBEX_TP,IEX_G) = KCAOC(IOBEX_TP) 13307* 13308 KICAAB_FOR_CA_NUM_G(IOBEX_TP,IEX_G) = 13309 & KICAAB_FOR_CA_NUM(IOBEX_TP) 13310 KICAAB_FOR_CA_OP_G(IOBEX_TP,IEX_G) = 13311 & KICAAB_FOR_CA_OP(IOBEX_TP) 13312 KLCAAB_FOR_CA_G(IOBEX_TP,IEX_G) = KLCAAB_FOR_CA(IOBEX_TP) 13313 KNCAAB_FOR_CA_G(IOBEX_TP,IEX_G) = KNCAAB_FOR_CA(IOBEX_TP) 13314 KIBCAAB_FOR_CA_G(IOBEX_TP,IEX_G) = KIBCAAB_FOR_CA(IOBEX_TP) 13315 NSPA_FOR_OCCLS_G(IOBEX_TP,IEX_G) = NSPA_FOR_OCCLS(IOBEX_TP) 13316 NCAAB_FOR_OCCLS_G(IOBEX_TP,IEX_G) = NCAAB_FOR_OCCLS(IOBEX_TP) 13317 IBSPA_FOR_OCCLS_G(IOBEX_TP,IEX_G) = IBSPA_FOR_OCCLS(IEX_G) 13318 END DO 13319* 13320 K_NCOMP_FOR_PROTO_G(IEX_G) = K_NCOMP_FOR_PROTO 13321 K_MX_DLB_C_G(IEX_G) = K_MX_DLB_C 13322 K_MX_DLB_A_G(IEX_G) = K_MX_DLB_A 13323 K_IB_PROTO_G(IEX_G) = K_IB_PROTO 13324 KLREORDER_CAAB_G(IEX_G) = KLREORDER_CAAB 13325* 13326 MAXNDET = 6 13327 CALL ICOPVE(NSPA_FOP,NSPA_FOP_G(1,IEX_G),MAXNDET) 13328 CALL ICOPVE(NCAAB_FOP,NCAAB_FOP_G(1,IEX_G),MAXNDET) 13329 CALL ICOPVE(IB_FOP,IB_FOP_G(1,IEX_G),MAXNDET) 13330 ELSE 13331*. From general to specific/actual 13332 DO IOBEX_TP = 1, NOBEX_TP 13333 CALL ICOPVE(NCOC_FSM_G(1,IOBEX_TP,IEX_G),NCOC_FSM(1,IOBEX_TP), 13334 & NSMST) 13335 CALL ICOPVE(NAOC_FSM_G(1,IOBEX_TP,IEX_G),NAOC_FSM(1,IOBEX_TP), 13336 & NSMST) 13337 CALL ICOPVE(IBCOC_FSM_G(1,IOBEX_TP,IEX_G), 13338 & IBCOC_FSM(1,IOBEX_TP),NSMST) 13339 CALL ICOPVE(IBAOC_FSM_G(1,IOBEX_TP,IEX_G), 13340 & IBAOC_FSM(1,IOBEX_TP),NSMST) 13341 KCOC(IOBEX_TP) = KCOC_G(IOBEX_TP,IEX_G) 13342 KAOC(IOBEX_TP) = KAOC_G(IOBEX_TP,IEX_G) 13343 KZC(IOBEX_TP) = KZC_G(IOBEX_TP,IEX_G) 13344 KZA(IOBEX_TP) = KZA_G(IOBEX_TP,IEX_G) 13345 KCREO(IOBEX_TP) = KCREO_G(IOBEX_TP,IEX_G) 13346 KAREO(IOBEX_TP) = KAREO_G(IOBEX_TP,IEX_G) 13347 CALL ICOPVE(IBCAOC_FSM_G(1,IOBEX_TP,IEX_G), 13348 & IBCAOC_FSM(1,IOBEX_TP),NSMST) 13349 NCAOC(IOBEX_TP) = NCAOC_G(IOBEX_TP,IEX_G) 13350 KCAOC(IOBEX_TP) = KCAOC_G(IOBEX_TP,IEX_G) 13351* 13352 KICAAB_FOR_CA_NUM(IOBEX_TP) = 13353 & KICAAB_FOR_CA_NUM_G(IOBEX_TP,IEX_G) 13354 KICAAB_FOR_CA_OP = 13355 & KICAAB_FOR_CA_OP_G(IOBEX_TP,IEX_G) 13356 KLCAAB_FOR_CA(IOBEX_TP) = KLCAAB_FOR_CA_G(IOBEX_TP,IEX_G) 13357 KNCAAB_FOR_CA(IOBEX_TP) = KNCAAB_FOR_CA_G(IOBEX_TP,IEX_G) 13358 KIBCAAB_FOR_CA(IOBEX_TP) = KIBCAAB_FOR_CA_G(IOBEX_TP,IEX_G) 13359 NSPA_FOR_OCCLS(IOBEX_TP) = NSPA_FOR_OCCLS_G(IOBEX_TP,IEX_G) 13360 NCAAB_FOR_OCCLS(IOBEX_TP) = NCAAB_FOR_OCCLS_G(IOBEX_TP,IEX_G) 13361 IBSPA_FOR_OCCLS(IOBEX_TP) = IBSPA_FOR_OCCLS_G(IOBEX_TP,IEX_G) 13362 END DO 13363* 13364 K_NCOMP_FOR_PROTO = K_NCOMP_FOR_PROTO_G(IEX_G) 13365 K_MX_DLB_C = K_MX_DLB_C_G(IEX_G) 13366 K_MX_DLB_A = K_MX_DLB_A_G(IEX_G) 13367 K_IB_PROTO = K_IB_PROTO_G(IEX_G) 13368 KLREORDER_CAAB = KLREORDER_CAAB_G(IEX_G) 13369* 13370 MAXNDET = 6 13371 CALL ICOPVE(NSPA_FOP_G(1,IEX_G),NSPA_FOP,MAXNDET) 13372 CALL ICOPVE(NCAAB_FOP_G(1,IEX_G),NCAAB_FOP,MAXNDET) 13373 CALL ICOPVE(IB_FOP_G(1,IEX_G),IB_FOP,MAXNDET) 13374 END IF 13375* 13376 RETURN 13377 END 13378 SUBROUTINE PREPARE_FOR_IEX(IEX) 13379* 13380*. Prepare setup for calculation with general excitation operator IEX 13381* 13382*. Jeppe Olsen, on the way to Zurick, march 2010 13383* 13384 INCLUDE 'implicit.inc' 13385* 13386 I_FT_GLOBAL = 1 13387 CALL TRANSFER_T_OFFSETS(I_FT_GLOBAL,IEX) 13388 CALL TRANSFER_SPIN_OFFSETS(I_FT_GLOBAL,IEX) 13389* 13390 RETURN 13391 END 13392 SUBROUTINE GIC_VEC_TO_DISC(KTEX,LEN_TEX,NTEX_G,IREW,LU) 13393* 13394* put a GIC vector to DISC 13395* 13396*. Jeppe Olsen, Billund on the way to Zurich, march 2010 13397* 13398 INCLUDE 'wrkspc.inc' 13399*. Input: pointers to start and length of each TEX 13400 INTEGER KTEX(NTEX_G), LEN_TEX(NTEX_G) 13401* 13402 NTEST = 00 13403 IF(NTEST.GE.100) WRITE(6,*) ' Entering GIC_VEC_TO_DISC' 13404 IF(IREW.EQ.1) CALL REWINO(LU) 13405* 13406 DO IEX = 1, NTEX_G 13407C? WRITE(6,*) ' Record to be written ', IEX 13408 KP = KTEX(IEX) 13409 LEN = LEN_TEX(IEX) 13410 CALL VEC_TO_DISC(WORK(KP),LEN,-1,-1,LU) 13411 END DO 13412 KP = KTEX(NTEX_G+1) 13413 LEN = 1 13414C? WRITE(6,*) ' Reference coefficient written', WORK(KP) 13415 CALL VEC_TO_DISC(WORK(KP),LEN,-1,-1,LU) 13416C? IF(NTEST.GE.100) WRITE(6,*) ' Leaving GIC_VEC_TO_DISC' 13417* 13418 RETURN 13419 END 13420 SUBROUTINE GIC_VEC_FROM_DISC(KTEX,LEN_TEX,NTEX_G,IREW,LU) 13421* 13422* Read a GIC vector to DISC 13423* 13424*. Jeppe Olsen, Billund on the way to Zurich, march 2010 13425* 13426 INCLUDE 'wrkspc.inc' 13427*. Input: pointers to start and length of each TEX 13428 INTEGER KTEX(NTEX_G), LEN_TEX(NTEX_G) 13429* 13430 NTEST = 00 13431 IF(NTEST.GE.100) THEN 13432 WRITE(6,*) ' Entering GIC_VEC_FROM_DISC' 13433 WRITE(6,*) ' IREW, LU = ', IREW, LU 13434 END IF 13435* 13436 IF(IREW.EQ.1) CALL REWINO(LU) 13437* 13438 DO IEX = 1, NTEX_G 13439C? WRITE(6,*) ' Record to be read ', IEX 13440 KP = KTEX(IEX) 13441 LEN = LEN_TEX(IEX) 13442 CALL VEC_FROM_DISC(WORK(KP),LEN,-1,-1,LU) 13443C? WRITE(6,*) ' Record read ' 13444 END DO 13445*. And the coefficient of the reference state 13446 KP = KTEX(NTEX_G+1) 13447 LEN = 1 13448 CALL VEC_FROM_DISC(WORK(KP),LEN,-1,-1,LU) 13449C? WRITE(6,*) ' coefficient read in', WORK(KP) 13450* 13451 IF(NTEST.GE.100) WRITE(6,*) ' Leaving GIC_VEC_FROM_DISC' 13452 RETURN 13453 END 13454 SUBROUTINE H_S_EXT_GICCI_TV(VECIN,VECOUT_H,VECOUT_S, 13455 & I_DO_H,I_DO_S) 13456* 13457*. Obtain gradient of general GICCI vector function for 13458* active operator ITACT (given in gicci) 13459* 13460* The current set of T-parameters are stored at KTEX_FOR_IEX 13461* 13462* The input is the T-coefficients for the active operators 13463* The remaining operators are accessed through KTEX. 13464* KTEX is also updated with the coefficients in VECIN 13465* 13466* 13467* If(I_DO_H.eq.1) vecout_h(i): (I = ITACT) 13468* <L|O(i,I)|R> 13469* <F(I)!H!0'> 13470* where 13471* |R> = T(I-1)...T(1)|ref> 13472* |L> = P(I)(H|0'> + O+(I+1)H|0'> + .... + O+(N)...O(I+1)H|0'>) 13473* |F(I)> = (1 + O(1) + O(2)O(1) + ... + O(I-1)...O(1)|ref> 13474* 13475* if(I_DO_S.eq.1) vecout_s(i) : 13476* <L'|O(i,I)|R> 13477* <F(I)!0'> 13478* where 13479* |R> = O(I-1)...O(1)|ref> 13480* |L'> = P(I) (|0'> + O+(I+1)|0'> + .... + O+(N)...O(I+1)|0'>) 13481* 13482* where O(J) as usual is a combination of a projection operator 13483* and a two-electron operator 13484* 13485* O(J) = P(J) T(J) 13486* P(J) projects on a space (ITCSPC(J)) and projects a space out 13487* (IPTCSPC(J)) 13488* 13489* <0!0> is assumed normalized 13490* 13491* Vecin is supposed to be delivered in SPA basis (if I_DO_EI = 0) 13492* or in the Zeroorder basis (if I_DO_EI = 1) 13493* 13494* Jeppe Olsen, March 2010 for the Zurich conference 13495* 13496 INCLUDE 'wrkspc.inc' 13497 REAL*8 13498 &INPRDD 13499 INCLUDE 'clunit.inc' 13500 INCLUDE 'cands.inc' 13501 INCLUDE 'glbbas.inc' 13502 INCLUDE 'cstate.inc' 13503 INCLUDE 'crun.inc' 13504 INCLUDE 'ctcc.inc' 13505*. Input 13506 DIMENSION VECIN(*) 13507*. Output 13508 DIMENSION VECOUT_H(*), VECOUT_S(*) 13509*. For transfer of data 13510 INCLUDE 'gicci.inc' 13511 NTEST = 00 13512* 13513 NSPA = NSPA_FOR_IEX(ITACT) 13514 NCAAB = NCAAB_FOR_IEX(ITACT) 13515* 13516 IF(NTEST.GE.100) THEN 13517 WRITE(6,*) '---------------------------------' 13518 WRITE(6,*) ' Reporting from H_S_EXT_GICCI_TV ' 13519 WRITE(6,*) '---------------------------------' 13520 WRITE(6,*) 13521 WRITE(6,*) ' ITACT = ', ITACT 13522 WRITE(6,*) ' I_DO_H, I_DO_S =', I_DO_H, I_DO_S 13523 WRITE(6,*) ' NSPA, NCAAB = ', NSPA, NCAAB 13524 END IF 13525 IF(NTEST.GE.1000) THEN 13526 WRITE(6,*) ' Input vector for active operator' 13527 CALL WRTMAT(VECIN,1,NSPA,1,NSPA) 13528 WRITE(6,*) ' The current set of T-parameters' 13529 CALL WRT_GICCI_VEC(KTEX_FOR_IEX) 13530C WRT_GICCI_VEC(KTEX) 13531 END IF 13532 13533 IDUM = 0 13534 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'HSG_TV') 13535 CALL MEMMAN(KL_VIC1,NCAAB_MX+1,'ADDL ',2,'VIC1 ') 13536 CALL MEMMAN(KL_VIC2,NCAAB_MX+1,'ADDL ',2,'VIC2 ') 13537* 13538*. Obtain GICCI vector |0'> corresponding to set of coefficients 13539* for active operator 13540*. Obtain T-coefficients for |0'> in KTEXP_FOR_IEX 13541COLD CALL COPVEC(WORK(KTEX_FOR_IEX(1)),WORK(KTEXP_FOR_IEX(1)),NSPA_TOT) 13542COLD WORK(KTEXP_FOR_IEX(NTEXC_GX+1)) = WORK(KTEX_FOR_IEX(NTEXC_GX+1)) 13543C UPDATE_GICCI_VEC(KTEX,I_EX_ACT,TACTVEC,ISCALE) 13544COLD CALL UPDATE_GICCI_VEC(KTEXP_FOR_IEX,ITACT,VECIN,1) 13545C GET_GICCI_DELTA(KTEXG,IACT,TACT,LUC,LUOUT,LUSC2, 13546C & LUSC3) 13547*- Obtain |0'> on LUSC1 using LUSC2 and LUSC3 as scratch 13548COLD CALL GET_GICCI_0(KTEXP_FOR_IEX,LUSC1,LUC,LUSC35,LUSC2,LUSC3) 13549C CALL GET_GICCI_DELTA(KTEX_FOR_IEX,IACT,TACT,LUC,LUSC1, 13550C & LUSC2,LUSC3) 13551C GET_GICCI_DELTA(KTEXG,IACT,TACT,LUC,LUOUT,LUSC2, 13552C & LUSC3) 13553* 13554 IF(I_DO_H.EQ.1) THEN 13555* 13556* ================ 13557*. Hamiltonian terms 13558* ================ 13559* 13560* If(I_DO_H.eq.1) vecout_h(i) : 13561* <L|O(i,I)|R> 13562* <F(I)!H!0> 13563* where 13564* |R> = O(I-1)...O(1)|ref> 13565* |L> = P(I)(H|0'> + O+(I+1)H|0'> + .... + O+(N)...O(I+1)H|0'>) 13566* 13567*. 1.05: Obtain |0'> on LUSC1 using LUSC2 and LUSC3 as scratch 13568 CALL GET_GICCI_DELTA(KTEX_FOR_IEX,ITACT,VECIN,LUC,LUSC1, 13569 & LUSC2,LUSC3) 13570 XNORM0P = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUSC1,1,-1) 13571 IF(NTEST.GE.5) WRITE(6,*) ' Square norm of |0''> ', XNORM0P 13572*. 1: Obtain |L> on LUSC2 13573*. For simplicity evrything is calculated in the largest space 13574 ICSPC = ITCSPC_GX(NTEXC_GX) 13575 ISSPC = ITCSPC_GX(NTEXC_GX) 13576* 13577*. 1.1: H|0'> on LUHC 13578* 13579 IF(NTEST.GE.1000) THEN 13580 WRITE(6,*) ' Input to MV7 ' 13581 CALL WRTVCD(WORK(KVEC1P),LUSC1,1,-1) 13582 END IF 13583 CALL MV7(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUHC,0,0) 13584 IF(NTEST.GE.1000) THEN 13585 WRITE(6,*) ' Result of MV7' 13586 CALL WRTVCD(WORK(KVEC1P),LUHC,1,-1) 13587 END IF 13588 DHD = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUHC,1,-1) 13589 IF(NTEST.GE.5) WRITE(6,*) ' <Delta 0|H|Delta 0> = ', DHD 13590* 13591*. 1.2: Obtain |L> on LUSC2, start with H|0'> 13592* |L> = P(I)(H|0'> + O+(I+1)H|0'> + .... + O+(N)...O(I+1)H|0'>) 13593* 13594 CALL COPVCD(LUHC,LUSC2,WORK(KVEC1P),1,-1) 13595 ICSPC = ITCSPC_GX(NTEXC_GX) 13596 ISSPC = ITCSPC_GX(NTEXC_GX) 13597 DO IEX = ITACT+1, NTEXC_GX 13598C? WRITE(6,*) ' IEX = ', IEX 13599*. obtain O+(ITACT+1) ... O+(IEX)H|0'> on LUSC3 13600 CALL COPVCD(LUHC,LUSC3,WORK(KVEC1P),1,-1) 13601 DO ISUB = 0, IEX-ITACT-1 13602 JEX = IEX-ISUB 13603 IF(NTEST.GE.1000) 13604 & WRITE(6,*) ' IEX, ISUB, JEX =', IEX, ISUB, JEX 13605 CALL PREPARE_FOR_IEX(JEX) 13606*. Obtain T(JEX) amplitudes in CAAB basis in KL_VIC2 13607 KP = KTEX_FOR_IEX(JEX) 13608 CALL REF_CCV_CAAB_SP(WORK(KL_VIC2),WORK(KP), 13609 & WORK(KL_VIC1),2) 13610*. Conjugate amplitudes 13611 CALL CONJ_CCAMP(WORK(KL_VIC2),1,WORK(KL_VIC1)) 13612*. and conjugate spinorbital classes 13613 CALL CONJ_T 13614 CALL REWINO(LUSC3) 13615 CALL REWINO(LUSC35) 13616*. Start by projection- conjugated operator, copy result back to LUSC3 13617 IPROJSPC = IPTCSPC_GX(JEX) 13618 IF(IPROJSPC.NE.0) THEN 13619 LUSCX = -1 13620 CALL REWINO(LUSC3) 13621 CALL REWINO(LUSC35) 13622 CALL EXTR_CIV(IREFSM,ISSPC,LUSC3,IPROJSPC,2, 13623 & LUSC35,-1,LUSCX,1,1,IDC,NTEST) 13624 END IF 13625 CALL REWINO(LUSC3) 13626 CALL REWINO(LUSC35) 13627 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC35, 13628 & WORK(KL_VIC1),1) 13629 CALL COPVCD(LUSC35,LUSC3,WORK(KVEC1P),1,-1) 13630*. Clean up by conjugating classes back to original 13631 CALL CONJ_T 13632 END DO 13633*. and add to LUSC2 13634 ONE = 1.0D0 13635* VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 13636 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),ONE,ONE,LUSC2,LUSC3, 13637 & LUSC35,1,-1) 13638 CALL COPVCD(LUSC35,LUSC2,WORK(KVEC1P),-1,-1) 13639 END DO 13640*. And project for active op 13641 IPROJSPC = IPTCSPC_GX(ITACT) 13642 IF(IPROJSPC.NE.0) THEN 13643 LUSCX = -1 13644 CALL REWINO(LUSC2) 13645 CALL REWINO(LUSC35) 13646 CALL EXTR_CIV(IREFSM,ISSPC,LUSC2,IPROJSPC,2, 13647 & LUSC35,-1,LUSCX,1,1,IDC,NTEST) 13648 END IF 13649 IF(NTEST.GE.1000) THEN 13650 WRITE(6,*) ' The L-vector ' 13651 CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 13652 END IF 13653* 13654*.2 |R> = O(I-1)...O(1)|ref> on LUSC3 13655* 13656*. Expand [ref> 13657 ICSPC = ITCSPC_GX(NTEXC_GX) 13658 ISSPC = ITCSPC_GX(NTEXC_GX) 13659 CALL EXPCIV(IREFSM,1,LUC,ISSPC,LUSC3,-1, 13660 & LUSC35,1,0,IDC,NTEST) 13661* 13662 DO IEX = 1, ITACT-1 13663* T(IEX) LUSC3 on LUSC35 13664 CALL PREPARE_FOR_IEX(IEX) 13665 KP = KTEX_FOR_IEX(IEX) 13666 CALL REF_CCV_CAAB_SP(WORK(KL_VIC2),WORK(KP), 13667 & WORK(KL_VIC1),2) 13668 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC35, 13669 & WORK(KL_VIC2),1) 13670*. P(IEX)T(IEX) LUSC3 on LUSC3 13671 IPROJSPC = IPTCSPC_GX(IEX) 13672 IF(IPROJSPC.EQ.0) THEN 13673*. Just copy 13674 CALL COPVCD(LUSC35, LUSC3,WORK(KVEC1P),1,-1) 13675 ELSE 13676 CALL EXTR_CIV(IREFSM,ISSPC,LUSC35,IPROJSPC,2, 13677 & LUSC3,-1,LUSCX,1,0,IDC,NTEST) 13678 END IF 13679* 13680 END DO 13681 IF(NTEST.GE.1000) THEN 13682 WRITE(6,*) ' The R-vector ' 13683 CALL WRTVCD(WORK(KVEC1P),LUSC3,1,-1) 13684 END IF 13685*. We are now ready to calculate obtain the density <L!O(mu,ITACT)|R> 13686 CALL PREPARE_FOR_IEX(ITACT) 13687 ZERO = 0.0D0 13688 NCAAB = NCAAB_FOR_IEX(ITACT) 13689 NSPA = NSPA_FOR_IEX(ITACT) 13690 CALL SETVEC(WORK(KL_VIC1),ZERO,NCAAB) 13691 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC2, 13692 & WORK(KL_VIC1),2) 13693 IF(NTEST.GE.1000) THEN 13694 WRITE(6,*) ' The Sigma vector in the CAAB basis ' 13695 CALL WRTMAT(WORK(KL_VIC1),1,NCAAB,1,NCAAB) 13696 END IF 13697*. And reform to SPA basis 13698 CALL REF_CCV_CAAB_SP(WORK(KL_VIC1),VECOUT_H,WORK(KL_VIC2),1) 13699 IF(NTEST.GE.1000) THEN 13700 WRITE(6,*) ' The Sigma vector in the SPA basis ' 13701 CALL WRTMAT(VECOUT_H,1,NSPA,1,NSPA) 13702 END IF 13703*. 2. Obtain on LUSC1 |F(I)> = (C_0 + T(1) + T(2)T(1) + ... + T(I-1)...T(1)|ref> 13704C GET_GICCI_EXP(KTEXG,IEX_MAX,LUC,LUOUT,LUSC2,LUSC3) 13705 CALL GET_GICCI_EXP(KTEX_FOR_IEX,ITACT-1,LUC,LUSC1,LUSC2,LUSC3) 13706 IF(NTEST.GE.1000) THEN 13707 WRITE(6,*) ' The F(I) vector ' 13708 CALL WRTVCD(WORK(KVEC1P),LUSC1,1,-1) 13709 END IF 13710*.2.1 and <F(I)|H|0'> 13711 FIH0P = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUHC,1,-1) 13712 IF(NTEST.GE.1000) WRITE(6,*) ' FIH0P = ', FIH0P 13713 VECOUT_H(NSPA) = FIH0P 13714 END IF 13715* ^ End of Hamiltonian terms were to be calculated 13716 IF(I_DO_S.EQ.1) THEN 13717* 13718* ================ 13719*. Overlap terms 13720* ================ 13721* 13722* vecout_S(i) : 13723* <L'|O(i,I)|R> 13724* <F(I)!0'> 13725* where 13726* |R> = O(I-1)...O(1)|ref> 13727* |L'> = P(I)(|0'> + O+(I+1)|0'> + .... + O+(N)...O(I+1)|0'>) 13728* 13729*. 3. Obtain |L'> 13730* 13731*. 3.05: Obtain |0'> on LUSC1 using LUSC2 and LUSC3 as scratch 13732C CALL GET_GICCI_0(KTEXP_FOR_IEX,LUSC1,LUC,LUSC35,LUSC2,LUSC3) 13733 CALL GET_GICCI_DELTA(KTEX_FOR_IEX,ITACT,VECIN,LUC,LUSC1, 13734 & LUSC2,LUSC3) 13735C? WRITE(6,*) ' After GET_GICCI_DELTA' 13736* 13737*. 3.1: Obtain |L'> on LUSC2, start with |0'> 13738* 13739 CALL COPVCD(LUSC1,LUSC2,WORK(KVEC1P),1,-1) 13740 ICSPC = ITCSPC_GX(NTEXC_GX) 13741 ISSPC = ITCSPC_GX(NTEXC_GX) 13742 DO IEX = ITACT+1, NTEXC_GX 13743*. obtain O+(ITACT+1) ... O+(IEX)|0'> on LUSC3 13744 CALL COPVCD(LUSC1,LUSC3,WORK(KVEC1P),1,-1) 13745 DO ISUB = 0, IEX-ITACT-1 13746 JEX = IEX-ISUB 13747 IF(NTEST.GE.1000) 13748 & WRITE(6,*) ' IEX, ISUB, JEX =', IEX, ISUB, JEX 13749 CALL PREPARE_FOR_IEX(JEX) 13750*. Obtain T(JEX) amplitudes in CAAB basis in KL_VIC2 13751 KP = KTEX_FOR_IEX(JEX) 13752 CALL REF_CCV_CAAB_SP(WORK(KL_VIC2),WORK(KP), 13753 & WORK(KL_VIC1),2) 13754*. Conjugate amplitudes 13755 CALL CONJ_CCAMP(WORK(KL_VIC2),1,WORK(KL_VIC1)) 13756*. and conjugate spinorbital classes 13757 CALL CONJ_T 13758 CALL REWINO(LUSC3) 13759 CALL REWINO(LUSC35) 13760*. Start by projection- conjugated operator, copy result back to LUSC3 13761 IPROJSPC = IPTCSPC_GX(JEX) 13762 IF(IPROJSPC.NE.0) THEN 13763 LUSCX = -1 13764 CALL REWINO(LUSC3) 13765 CALL REWINO(LUSC35) 13766 CALL EXTR_CIV(IREFSM,ISSPC,LUSC3,IPROJSPC,2, 13767 & LUSC35,-1,LUSCX,1,1,IDC,NTEST) 13768 END IF 13769 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC35, 13770 & WORK(KL_VIC1),1) 13771 CALL COPVCD(LUSC35,LUSC3,WORK(KVEC1P),1,-1) 13772*. Clean up by conjugating classes back to original 13773 CALL CONJ_T 13774 END DO 13775*. and add to LUSC2 13776 ONE = 1.0D0 13777* VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 13778 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),ONE,ONE,LUSC2,LUSC3, 13779 & LUSC35,1,-1) 13780 CALL COPVCD(LUSC35,LUSC2,WORK(KVEC1P),-1,-1) 13781 END DO 13782*. And project for active op 13783 IPROJSPC = IPTCSPC_GX(ITACT) 13784 IF(IPROJSPC.NE.0) THEN 13785 LUSCX = -1 13786 CALL REWINO(LUSC2) 13787 CALL REWINO(LUSC35) 13788 CALL EXTR_CIV(IREFSM,ISSPC,LUSC2,IPROJSPC,2, 13789 & LUSC35,-1,LUSCX,1,1,IDC,NTEST) 13790 END IF 13791 IF(NTEST.GE.1000) THEN 13792 WRITE(6,*) ' The L(prime)-vector ' 13793 CALL WRTVCD(WORK(KVEC1P),LUSC2,1,-1) 13794 END IF 13795C? WRITE(6,*) ' After L(prime)' 13796* |R> = O(I-1)...O(1)|ref> on LUSC3 13797*. Expand [ref> 13798 ICSPC = ITCSPC_GX(NTEXC_GX) 13799 ISSPC = ITCSPC_GX(NTEXC_GX) 13800 CALL EXPCIV(IREFSM,1,LUC,ISSPC,LUSC3,-1, 13801 & LUSC35,1,0,IDC,NTEST) 13802 DO IEX = 1, ITACT-1 13803* T(IEX) LUSC3 on LUSC35 13804 CALL PREPARE_FOR_IEX(IEX) 13805 KP = KTEX_FOR_IEX(IEX) 13806 CALL REF_CCV_CAAB_SP(WORK(KL_VIC2),WORK(KP), 13807 & WORK(KL_VIC1),2) 13808 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC35, 13809 & WORK(KL_VIC2),1) 13810*. P(IEX)T(IEX) LUSC3 on LUSC3 13811 IPROJSPC = IPTCSPC_GX(IEX) 13812 IF(IPROJSPC.EQ.0) THEN 13813*. Just copy 13814 CALL COPVCD(LUSC35, LUSC3,WORK(KVEC1P),1,-1) 13815 ELSE 13816 CALL EXTR_CIV(IREFSM,ISSPC,LUSC35,IPROJSPC,2, 13817 & LUSC3,-1,LUSCX,1,0,IDC,NTEST) 13818 END IF 13819 END DO 13820 IF(NTEST.GE.1000) THEN 13821 WRITE(6,*) ' The R-vector( for S) ' 13822 CALL WRTVCD(WORK(KVEC1P),LUSC3,1,-1) 13823 END IF 13824*. We are now ready to calculate obtain the density <L'!O(mu,ITACT)|R> 13825 CALL PREPARE_FOR_IEX(ITACT) 13826 ZERO = 0.0D0 13827 NCAAB = NCAAB_FOR_IEX(ITACT) 13828 CALL SETVEC(WORK(KL_VIC1),ZERO,NCAAB) 13829 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC3,LUSC2, 13830 & WORK(KL_VIC1),2) 13831 IF(NTEST.GE.1000) THEN 13832 WRITE(6,*) ' The S-vector before REF_CCV ' 13833 CALL WRTMAT(WORK(KL_VIC1),1,NCAAB,1,NCAAB) 13834 END IF 13835*. And reform to SPA basis 13836 CALL REF_CCV_CAAB_SP(WORK(KL_VIC1),VECOUT_S,WORK(KL_VIC2),1) 13837 NSPA = NSPA_FOR_IEX(ITACT) 13838 IF(NTEST.GE.1000) THEN 13839 WRITE(6,*) ' The S-vector after REF_CCV ' 13840 CALL WRTMAT(VECOUT_S,1,NSPA,1,NSPA) 13841 END IF 13842*. 4. Obtain on LUHC |F(I)> = (C_0 + O(1) + O(2)O(1) + ... + O(I-1)...O(1)|ref> 13843C GET_GICCI_EXP(KTEXG,IEX_MAX,LUC,LUOUT,LUSC2,LUSC3) 13844 CALL GET_GICCI_EXP(KTEX_FOR_IEX,ITACT-1,LUC,LUHC,LUSC2,LUSC3) 13845 IF(NTEST.GE.1000) THEN 13846 WRITE(6,*) ' The F(I) vector ' 13847 CALL WRTVCD(WORK(KVEC1P),LUHC,1,-1) 13848 END IF 13849*.4.1 and <F(I)|0> 13850 FI0P = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUSC1,LUHC,1,-1) 13851 IF(NTEST.GE.1000) WRITE(6,*) ' FI0P = ', FI0P 13852 VECOUT_S(NSPA) = FI0P 13853 END IF 13854* 13855 IF(NTEST.GE.100) THEN 13856 WRITE(6,*) ' Direct ICCI, external part ' 13857 WRITE(6,*) ' Input vector ' 13858 CALL WRTMAT(VECIN,1,NSPA,1,NSPA) 13859 IF(I_DO_H.EQ.1) THEN 13860 WRITE(6,*) ' H(ICCI) times input vector ' 13861 CALL WRTMAT(VECOUT_H,1,NSPA,1,NSPA) 13862 END IF 13863 IF(I_DO_S.EQ.1) THEN 13864 WRITE(6,*) ' S(ICCI) times input vector ' 13865 CALL WRTMAT(VECOUT_S,1,NSPA,1,NSPA) 13866 END IF 13867 END IF 13868* 13869 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'HSG_TV') 13870 RETURN 13871 END 13872 SUBROUTINE GET_GICCI_0(KTEXG,LUOUT,LUC,LUSC2,LUSC3) 13873* 13874* Obtain GICCI wavefunction as defined by amplitudes in WORK(KTEXG) 13875* and save in LUOUT 13876* 13877 INCLUDE 'wrkspc.inc' 13878 DIMENSION KTEXG(MXPCYC) 13879 INCLUDE 'gicci.inc' 13880* 13881C? SCALE = WORK(KTEXG(NTEXC_GX+1)) 13882C? WRITE(6,*) ' scale from GET_GICCI =', SCALE 13883C? WRITE(6,*) ' LUOUT, LUC, LUSC, LUSC2, LUSC3 =', 13884C? & LUOUT, LUC, LUSC, LUSC2, LUSC3 13885 CALL GET_GICCI_EXP(KTEXG,NTEXC_GX,LUC,LUOUT,LUSC2,LUSC3) 13886* 13887 RETURN 13888 END 13889 SUBROUTINE GET_GICCI_EXP(KTEXG,IEX_MAX,LUC,LUOUT,LUSC2,LUSC3) 13890* 13891* Obtain on LUOUT GICCI expansion of wavefunction i 13892* to excitation operator IEX_MAX: 13893* 13894* |GICCI> = C_0|ref> + O_1|ref> + O_2 O_1|ref> + .... 13895* + O_IEX_MAX ...O_1|ref> 13896* 13897*. For the set of GICCI coefficients in WORK(KTEXG) 13898* 13899*. Jeppe Olsen, Zurich, march 2010 13900* 13901 INCLUDE 'wrkspc.inc' 13902 REAL*8 13903 &INPRDD 13904C INCLUDE 'clunit.inc' 13905 INCLUDE 'cands.inc' 13906 INCLUDE 'glbbas.inc' 13907 INCLUDE 'cstate.inc' 13908 INCLUDE 'crun.inc' 13909*. Offsets to the individual excitation vectors 13910 INTEGER KTEXG(MXPCYC) 13911 INCLUDE 'gicci.inc' 13912* 13913 NTEST = 000 13914* 13915 IF(NTEST.GE.100) THEN 13916 WRITE(6,*) 13917 WRITE(6,*) ' -----------------------------' 13918 WRITE(6,*) ' Reporting from GET_GICCI_EXP ' 13919 WRITE(6,*) ' -----------------------------' 13920 WRITE(6,*) 13921 WRITE(6,*) ' Excitations are included upto ', IEX_MAX 13922 WRITE(6,*) ' LUC, LUSC2, LUSC3, LUOUT =', 13923 & LUC, LUSC2, LUSC3, LUOUT 13924 END IF 13925* 13926 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GTGIC0') 13927 CALL MEMMAN(KLVEC1,NCAAB_MX,'ADDL ',2,'LVEC1 ') 13928 CALL MEMMAN(KLVEC2,NCAAB_MX,'ADDL ',2,'LVEC2 ') 13929* reference vector is on LUC 13930* 13931*. Initialize Ref on LUOUT (|0>) 13932* Ref on LUSC2 (|S_0>) 13933*. 13934* 13935 ICSPC = ITCSPC_GX(NTEXC_GX) 13936 ISSPC = ITCSPC_GX(NTEXC_GX) 13937* 13938 CALL REWINO(LUC) 13939 CALL REWINO(LUOUT) 13940*. expand reference to complete space 13941 CALL EXPCIV(IREFSM,1,LUC,ITCSPC_GX(NTEXC_GX),LUOUT,-1, 13942 & LUSC2,1,0,IDC,NTEST) 13943 CALL COPVCD(LUOUT,LUSC2,WORK(KVEC1P),1,-1) 13944* 13945 13946*. Iterate 13947 DO IEX = 1, IEX_MAX 13948 IF(NTEST.GE.1000) WRITE(6,*) ' IEX, ICSPC =', IEX,ICSPC 13949C PREPARE_FOR_IEX(IEX) 13950 CALL PREPARE_FOR_IEX(IEX) 13951*. Obtain in KLVEC1 T(IEX) in CAAB basis 13952 CALL REF_CCV_CAAB_SP(WORK(KLVEC1),WORK(KTEXG(IEX)), 13953 & WORK(KLVEC2),2) 13954 NSPA_L = NSPA_FOR_IEX(IEX) 13955 NCAAB_L = NCAAB_FOR_IEX(IEX) 13956 IF(NTEST.GE.1000) THEN 13957 WRITE(6,*) ' CAAB and SPA expansion of T(IEX)-vector' 13958 CALL WRTMAT(WORK(KLVEC1),1,NCAAB_L,1,NCAAB_L) 13959 CALL WRTMAT(WORK(KTEXG(IEX)),1,NSPA_L,1,NSPA_L) 13960 END IF 13961 13962*. |S_I> = O_I|S_I-1> on LUSC3 13963 CALL REWINO(LUSC2) 13964 CALL REWINO(LUSC3) 13965 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC2,LUSC3, 13966 & WORK(KLVEC1),1) 13967*. Project space IPTCSCP(IEX) out 13968 IF(IPTCSPC_GX(IEX).EQ.0) THEN 13969*. No projections, transfer |S_I> to LUSC2 13970 CALL COPVCD(LUSC3,LUSC2,WORK(KVEC1P),1,-1) 13971 ELSE 13972*. Project space IPTCSCP(IEX) out 13973 IPROJSPC = IPTCSPC_GX(IEX) 13974*. T |vecin> on LUSC3 => P T |vecin> on LUSC2 13975*. No scratch file is needed for 1 root 13976 LUSCX = -1 13977 CALL REWINO(LUSC2) 13978 CALL REWINO(LUSC3) 13979 CALL EXTR_CIV(IREFSM,ISSPC,LUSC3,IPROJSPC,2, 13980 & LUSC2,-1,LUSCX,1,0,IDC,NTEST) 13981C EXTR_CIV(ISM,ISPCIN,LUIN, 13982C & ISPCX,IEX_OR_DE,LUUT,LBLK, 13983C & LUSCR,NROOT,ICOPY,IDC,NTESTG) 13984 END IF 13985*. Add |S_I> to |0> 13986C VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 13987 ONE = 1.0D0 13988 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),ONE,ONE,LUOUT,LUSC2,LUSC3, 13989 & 1,-1) 13990 CALL COPVCD(LUSC3,LUOUT,WORK(KVEC1P),1,-1) 13991* 13992 IF(NTEST.GE.1000) THEN 13993 WRITE(6,*) ' Result after operator ', IEX 13994 CALL WRTVCD(WORK(KVEC1P),LUOUT,1,-1) 13995 END IF 13996 END DO 13997*. We are now only missing to change the coefficient of the 13998* reference state to C_0 13999 C_0 = WORK(KTEXG(NTEXC_GX+1)) 14000C? WRITE(6,*) ' C_0 in GET_GICCI', C_0 14001 ONE = 1.0D0 14002 FACTOR = C_0 - 1.0D0 14003 CALL EXPCIV(IREFSM,1,LUC,ITCSPC_GX(NTEXC_GX),LUSC3,-1, 14004 & LUSC2,1,0,IDC,NTEST) 14005 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),ONE, FACTOR,LUOUT,LUSC3, 14006 & LUSC2,1,-1) 14007 CALL COPVCD(LUSC2,LUOUT,WORK(KVEC1P),1,-1) 14008* 14009 IF(NTEST.GE.100) THEN 14010 WRITE(6,*) ' The Final GICCI vector ' 14011 CALL WRTVCD(WORK(KVEC1P),LUOUT,1,-1) 14012 END IF 14013* 14014 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GTGIC0') 14015* 14016 RETURN 14017 END 14018 SUBROUTINE UPDATE_GICCI_VEC(KTEX,I_EX_ACT,TACTVEC,ISCALE) 14019* 14020* Modify the collected GICCI vector by coefficients in TACTVEC 14021* which are the coefficient for excitation I_EX_ACT 14022* and a coefficient for the operators preceeding I_EX_ACT 14023* 14024*. The coefficients in TACTVEC is in the SPA basis 14025* 14026* ISCALE is inactive 14027* 14028*. Jeppe Olsen, March 2010 14029* 14030 INCLUDE 'wrkspc.inc' 14031 INTEGER KTEXG(MXPCYC) 14032 INCLUDE 'gicci.inc' 14033*. Input 14034 DIMENSION TACTVEC(*),KTEX(MXPCYC) 14035* 14036 NTEST = 000 14037 IF(NTEST.GE.100) THEN 14038 WRITE(6,*) ' Output from UPDATE_GICI_VEC' 14039 WRITE(6,*) ' ---------------------------' 14040 WRITE(6,*) ' Active excitation operator: ', I_EX_ACT 14041 END IF 14042* 14043*. The update: 14044*. =========== 14045* 14046* I = I_EX_ACT: 14047* I = 1: 14048* ----- 14049* C_0(new) = delta_0 C_0 14050* T_1(new) = delta 14051* T_J(new) = T_J for J> 1 14052* 14053* I > 1: 14054* ------ 14055* C_0(new) = delta_0 C_0 14056* T_1(new) = T_1*delta_0 14057* T_I(new) = delta/delta_0 14058* T_J(new) = T_J for J neq 1,I 14059* 14060 NSPA = NSPA_FOR_IEX(I_EX_ACT) 14061 NSPA1 = NSPA_FOR_IEX(1) 14062 KP = KTEX(I_EX_ACT) 14063 K1 = KTEX(1) 14064 KREF = KTEX(1)-1+NSPA_TOT+1 14065 DELTA_0 = TACTVEC(NSPA) 14066 IF(NTEST.GE.100) WRITE(6,*) 14067 & ' NSPA, KP, KREF DELTA_0 =', NSPA,KP, KREF, DELTA_0 14068*. Updated coefficient for reference state 14069 WORK(KREF) = DELTA_0*WORK(KREF) 14070*. Active excitations 14071 CALL COPVEC(TACTVEC,WORK(KP),NSPA-1) 14072 IF(I_EX_ACT.NE.1) THEN 14073 FACTOR = 1.0D0/DELTA_0 14074 CALL SCALVE(WORK(KP),FACTOR,NSPA-1) 14075 END IF 14076*. First excitationvector 14077 IF(I_EX_ACT.NE.1) THEN 14078 CALL SCALVE(WORK(K1),DELTA_0,NSPA1-1) 14079 END IF 14080* 14081 IF(NTEST.GE.1000) THEN 14082 WRITE(6,*) ' Updated T_GICCI vector' 14083 CALL WRT_GICCI_VEC(KTEX) 14084 END IF 14085* 14086 RETURN 14087 END 14088 SUBROUTINE WRT_GICCI_VEC(KTEX) 14089* Write GICCI vector with coefficent KTEX and specifications 14090* defined in COM_H_S_EFF_GICCI_TV 14091* 14092 INCLUDE 'wrkspc.inc' 14093 INTEGER KTEX(MXPCYC) 14094 INCLUDE 'gicci.inc' 14095* 14096 DO IEX = 1, NTEXC_GX 14097 WRITE(6,*) ' Excitation operator number', IEX 14098 KP = KTEX(IEX) 14099 NSPA = NSPA_FOR_IEX(IEX) 14100 CALL WRTMAT(WORK(KP),1,NSPA,1,NSPA) 14101 END DO 14102 WRITE(6,*) ' Coefficient of reference =', 14103 & WORK(KTEX(1)-1+NSPA_TOT+1) 14104* 14105 RETURN 14106 END 14107 SUBROUTINE GET_GICCI_DELTA(KTEXG,IACT,TACT,LUC,LUOUT,LUSC2, 14108 & LUSC3) 14109* 14110* Obtain on LUOUT the correction to the GICCI vector defined by 14111* TACT and KTEXG 14112* 14113* 14114* |GICCI> = Delta*(C_0|ref> + O_1|ref> + ... O_(IACT-1)... O_2 O_1|ref> ) 14115* + O_IACT O_(IACT-1)....O_1|ref> 14116* + O_(IACT+1) O_IACT .... O_1|ref> 14117* + ..... 14118* + O_IEX_MAX ...O_1|ref> 14119* 14120*. For O(I, I.NE. IACT) the coefficients in WORK(KTEXG) are used 14121* whereas Delta and O(IACT) are defined by TACT 14122* 14123*. Jeppe Olsen, Aarhus, april 2010 14124* 14125 INCLUDE 'wrkspc.inc' 14126 REAL*8 14127 &INPRDD 14128C INCLUDE 'clunit.inc' 14129 INCLUDE 'cands.inc' 14130 INCLUDE 'glbbas.inc' 14131 INCLUDE 'cstate.inc' 14132 INCLUDE 'crun.inc' 14133*. Offsets to the individual excitation vectors 14134 INTEGER KTEXG(MXPCYC) 14135*. And active vector 14136 DIMENSION TACT(*) 14137 INCLUDE 'gicci.inc' 14138* 14139 NTEST = 000 14140* 14141 IF(NTEST.GE.100) THEN 14142 WRITE(6,*) 14143 WRITE(6,*) ' -----------------------------' 14144 WRITE(6,*) ' Reporting from GET_GICCI_DELTA ' 14145 WRITE(6,*) ' -----------------------------' 14146 WRITE(6,*) 14147 WRITE(6,*) ' Active excitation ', IACT 14148 WRITE(6,*) ' LUC, LUSC2, LUSC3, LUOUT =', 14149 & LUC, LUSC2, LUSC3, LUOUT 14150 END IF 14151* 14152 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GTGIDE') 14153 CALL MEMMAN(KLVEC1,NCAAB_MX,'ADDL ',2,'LVEC1 ') 14154 CALL MEMMAN(KLVEC2,NCAAB_MX,'ADDL ',2,'LVEC2 ') 14155* reference vector is on LUC 14156* 14157*. Initialize C_0 Ref on LUOUT (|0>) 14158* Ref on LUSC2 (|S_0>) 14159*. 14160* 14161 ICSPC = ITCSPC_GX(NTEXC_GX) 14162 ISSPC = ITCSPC_GX(NTEXC_GX) 14163* 14164 CALL REWINO(LUC) 14165 CALL REWINO(LUOUT) 14166 CALL REWINO(LUSC2) 14167*. expand reference to complete space 14168 CALL EXPCIV(IREFSM,1,LUC,ITCSPC_GX(NTEXC_GX),LUSC2,-1, 14169 & LUOUT,1,0,IDC,NTEST) 14170 C_0 = WORK(KTEXG(NTEXC_GX+1)) 14171C? WRITE(6,*) ' C_0 in GET_GICCI', C_0 14172 CALL SCLVCD(LUSC2,LUOUT,C_0,WORK(KVEC1P),1,-1) 14173 14174*. Iterate 14175 DO IEX = 1, NTEXC_GX 14176 IF(NTEST.GE.1000) WRITE(6,*) ' IEX, ICSPC =', IEX,ICSPC 14177 CALL PREPARE_FOR_IEX(IEX) 14178C PREPARE_FOR_IEX(IEX) 14179 NSPA_L = NSPA_FOR_IEX(IEX) 14180 NCAAB_L = NCAAB_FOR_IEX(IEX) 14181* 14182 IF(IEX.EQ.IACT) THEN 14183*. Scale (C_0 + O_1 + O_2O_1 + ... O_(IACT-1)... O(1))|ref> with delta 14184 DELTA = TACT(NSPA_FOR_IEX(IACT)) 14185 IF(NTEST.GE.1000) WRITE(6,*) ' DELTA = ', DELTA 14186 CALL SCLVCD(LUOUT,LUSC3,DELTA,WORK(KVEC1P),1,-1) 14187 CALL COPVCD(LUSC3,LUOUT,WORK(KVEC1P),1,-1) 14188 END IF 14189*. Obtain in KLVEC1 T(IEX) in CAAB basis 14190 IF(IEX.NE.IACT) THEN 14191 CALL REF_CCV_CAAB_SP(WORK(KLVEC1),WORK(KTEXG(IEX)), 14192 & WORK(KLVEC2),2) 14193 ELSE 14194 CALL REF_CCV_CAAB_SP(WORK(KLVEC1),TACT, 14195 & WORK(KLVEC2),2) 14196 END IF 14197*. Zero coef for unit op 14198 WORK(KLVEC1) = 0.0D0 14199* 14200 IF(NTEST.GE.10000) THEN 14201 WRITE(6,*) ' CAAB and SPA expansion of T(IEX)-vector' 14202 CALL WRTMAT(WORK(KLVEC1),1,NCAAB_L,1,NCAAB_L) 14203 WRITE(6,*) 14204 IF(IEX.NE.IACT) THEN 14205 CALL WRTMAT(WORK(KTEXG(IEX)),1,NSPA_L,1,NSPA_L) 14206 ELSE 14207 CALL WRTMAT(TACT,1,NSPA_L,1,NSPA_L) 14208 END IF 14209 END IF 14210 14211*. |S_I> = O_I|S_I-1> on LUSC3 14212 CALL REWINO(LUSC2) 14213 CALL REWINO(LUSC3) 14214 CALL SIGDEN_CC(WORK(KVEC1P),WORK(KVEC2P),LUSC2,LUSC3, 14215 & WORK(KLVEC1),1) 14216 IF(NTEST.GE.1000) THEN 14217 WRITE(6,*) ' The unprojected |S_I> ' 14218 CALL WRTVCD(WORK(KVEC1P),LUSC3,1,-1) 14219 END IF 14220*. Project space IPTCSCP(IEX) out 14221 IF(IPTCSPC_GX(IEX).EQ.0) THEN 14222*. No projections, transfer |S_I> to LUSC2 14223 CALL COPVCD(LUSC3,LUSC2,WORK(KVEC1P),1,-1) 14224 ELSE 14225*. Project space IPTCSCP(IEX) out 14226 IPROJSPC = IPTCSPC_GX(IEX) 14227*. T |vecin> on LUSC3 => P T |vecin> on LUSC2 14228*. No scratch file is needed for 1 root 14229 LUSCX = -1 14230 CALL REWINO(LUSC2) 14231 CALL REWINO(LUSC3) 14232 CALL EXTR_CIV(IREFSM,ISSPC,LUSC3,IPROJSPC,2, 14233 & LUSC2,-1,LUSCX,1,0,IDC,NTEST) 14234C EXTR_CIV(ISM,ISPCIN,LUIN, 14235C & ISPCX,IEX_OR_DE,LUUT,LBLK, 14236C & LUSCR,NROOT,ICOPY,IDC,NTESTG) 14237 END IF 14238*. Add |S_I> to |0> 14239C VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 14240 ONE = 1.0D0 14241 CALL VECSMD(WORK(KVEC1P),WORK(KVEC2P),ONE,ONE,LUOUT,LUSC2,LUSC3, 14242 & 1,-1) 14243 CALL COPVCD(LUSC3,LUOUT,WORK(KVEC1P),1,-1) 14244* 14245 IF(NTEST.GE.1000) THEN 14246 WRITE(6,*) ' Result after operator ', IEX 14247 CALL WRTVCD(WORK(KVEC1P),LUOUT,1,-1) 14248 END IF 14249* 14250 END DO 14251* ^ End of loop over excitation operators 14252* 14253 IF(NTEST.GE.100) THEN 14254 WRITE(6,*) ' The Final GICCI_DELTA vector ' 14255 CALL WRTVCD(WORK(KVEC1P),LUOUT,1,-1) 14256 END IF 14257* 14258 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GTGIDE') 14259* 14260 RETURN 14261 END 14262 14263 14264c $Id$ 14265