1 SUBROUTINE LUCIA_NORT(I_DO_NONORT_MCSCF, 2 & JCMBSPC,E_FINAL,CONV_F,ERROR_NORM_FINAL,INI_NORT, 3 & IVBGNSP,IVBGNSP_PREV) 4* 5* Perform Nonorthogonal CI calculation 6* 7 INCLUDE 'wrkspc.inc' 8 INCLUDE 'crun.inc' 9 INCLUDE 'lucinp.inc' 10 INCLUDE 'orbinp.inc' 11 INCLUDE 'vb.inc' 12 INCLUDE 'cstate.inc' 13 INCLUDE 'cprnt.inc' 14 INCLUDE 'spinfo.inc' 15 INCLUDE 'glbbas.inc' 16 INCLUDE 'csm.inc' 17 INCLUDE 'cintfo.inc' 18 INCLUDE 'intform.inc' 19 INCLUDE 'fragmol.inc' 20 INCLUDE 'cgas.inc' 21 INCLUDE 'cecore.inc' 22 LOGICAL CONV_F, CONV_NORTCI 23* 24 IPRVB = 10 25 NTEST = 1000 26 NTEST = MAX(IPRVB, NTEST) 27* 28 WRITE(6,*) ' *************************************** ' 29 WRITE(6,*) ' * * ' 30 WRITE(6,*) ' * Nonorthogonal section entered * ' 31 WRITE(6,*) ' * * ' 32 WRITE(6,*) ' * Jeppe Olsen * ' 33 WRITE(6,*) ' * * ' 34 WRITE(6,*) ' * Version of June 2013 ( 0.96) * ' 35 WRITE(6,*) ' *************************************** ' 36* 37 WRITE(6,*) ' TEST: INI_NORT, IRESTR = ', INI_NORT, IRESTR 38 WRITE(6,*) ' TEST: IVBGNSP, IVBGNSP_PREV = ', 39 & IVBGNSP, IVBGNSP_PREV 40* 41 IF(IVBGNSP.NE.0) THEN 42*. Copy general space to reference VB space 43 NORBVBSPC = NOBPT(NORTCIX_SCVB_SPACE) 44 CALL ICOPVE(VB_GNSPC_MIN(1,IVBGNSP),VB_REFSPC_MIN(1),NORBVBSPC) 45 CALL ICOPVE(VB_GNSPC_MAX(1,IVBGNSP),VB_REFSPC_MAX(1),NORBVBSPC) 46 END IF 47* 48 IF(NTEST.GE.0) THEN 49 WRITE(6,*) ' Information on nonorthogonal calculation: ' 50 WRITE(6,*) ' ==========================================' 51 WRITE(6,*) 52* 53 IF(NORT_MET.EQ.1) THEN 54 WRITE(6,'(5X,A)') 55 & ' Non-orthogonal wave function will be expanded in CI space' 56 ELSE IF( NORT_MET.EQ.2) THEN 57 WRITE(6,'(5X,A)') 58 & ' Non-orthogonal wave function will be expanded configurations' 59 ELSE 60 WRITE(6,*) ' Currently unknown NORT_MET = ', NORT_MET 61 STOP ' Currently unknown NORT_MET ' 62 END IF 63* 64 WRITE(6,'(5X,A,I3)') 65 & ' Orbital space for non-orthogonal calculation:', 66 & NORTCIX_SCVB_SPACE 67 WRITE(6,'(5X,A,I3)') 68 & ' Allowed excitation level from Spin-coupled valence space', 69 & NORTCI_SCVB_EXCIT 70 WRITE(6,'(5X,A,I3)') 71 & ' Spanning CI-space:', JCMBSPC 72* 73 WRITE(6,'(5X,A)') 74 &' Min and max accumulated occupation in valence ref CI space: ' 75 NORBVBSPC = NOBPT(NORTCIX_SCVB_SPACE) 76 DO IORB = 1, NORBVBSPC 77 WRITE(6,'(10X,2I3)') VB_REFSPC_MIN(IORB),VB_REFSPC_MAX(IORB) 78 END DO 79 END IF !NTEST is large enough for printing 80* 81 IF(NTEST.GE.10) THEN 82 IF(INI_NORT.EQ.1) THEN 83C WRITE(6,*) ' INI_MO_TP, INI_MO_ORT = ', INI_MO_TP, INI_MO_ORT 84 WRITE(6,*) 85 WRITE(6,*) ' ======================= ' 86 WRITE(6,*) ' Initial set of orbitals ' 87 WRITE(6,*) ' ======================= ' 88 WRITE(6,*) 89* 90 IF(INI_MO_TP.EQ.1) THEN 91 WRITE(6,'(4X,A)') ' Atomic orbitals will be used ' 92 ELSE IF (INI_MO_TP.EQ.2) THEN 93 WRITE(6,'(4X,A)') 94 & ' Input MOs in VB space rotated to give diagonal block' 95 ELSE IF (INI_MO_TP.EQ.3) THEN 96 WRITE(6,'(4X,A)') 97 & ' Initial MO orbitals from SIRIFC will be used' 98 ELSE IF (INI_MO_TP.EQ.4) THEN 99 WRITE(6,'(4X,A)') 100 & ' Constructed from fragment orbitals' 101 END IF 102 WRITE(6,'(4X,A)') 103 & ' Orbitals in inactive and secondary space will be ort.' 104 WRITE(6,'(4X,A)') ' Orbitals in GAS orbital spaces(.ne. VB ): ' 105 IF(INI_MO_ORT.EQ.0) THEN 106 WRITE(6,'(6X,A)') ' No orthogonalization ' 107 ELSE IF (INI_MO_ORT.EQ.1) THEN 108 WRITE(6,'(6X,A)') ' Orthogonalized' 109 END IF 110 WRITE(6,'(4X,A)') ' Orbitals in VB orbital space: ' 111 IF(INI_ORT_VBGAS.EQ.0) THEN 112 WRITE(6,'(6X,A)') ' No orthogonalization ' 113 ELSE IF (INI_ORT_VBGAS.EQ.1) THEN 114 WRITE(6,'(6X,A)') ' Orthogonalized' 115 END IF 116* 117 IF(INI_MO_TP.EQ.4) THEN 118 WRITE(6,*) ' Distribution of orbitals from fragments:' 119 DO IFRAG = 1, NFRAG_MOL 120 NSMOB_L = NSMOB_FRAG(IFRAG) 121 WRITE(6,'(A,I3)') ' For fragment ', IFRAG 122 WRITE(6,*) ' ====================' 123 WRITE(6,*) ' Number of orbitals per GAS (row) and sym (col) ' 124 CALL IWRTMA 125 & (N_GS_SM_BAS_FRAG(0,1,IFRAG),NGAS+2,NSMOB_L,MXPNGAS+1,MXPOBS) 126 END DO 127 END IF ! End if INI_MO_TP.eq.4 128 ELSE 129 WRITE(6,*) ' Start from orbitals in place ' 130 END IF 131* 132 IF(IRESTR.EQ.0) THEN 133 WRITE(6,*) 134 WRITE(6,*) ' ======================= ' 135 WRITE(6,*) ' Initial configuration: ' 136 WRITE(6,*) ' ======================= ' 137 WRITE(6,*) 138 IF(I_HAVE_INI_CONF.EQ.0) THEN 139 WRITE(6,'(5X,A)') ' None given ' 140 ELSE 141 WRITE(6,'(5X,A)') ' In compressed form ' 142 CALL IWRTMA(INI_CONF,1,NOB_INI_CONF,1,NOB_INI_CONF) 143 END IF 144 ELSE 145 WRITE(6,*) ' Restarted calculation ' 146 END IF 147* 148 END IF ! NTEST is large enough for testoutput 149* 150* Some general info on configuration expansions 151* 152*. First orbital and number of electrons in VB orbital space 153 IB_VBOBSPC= NINOB + 1 154 DO IOBSPC = 1, NORTCIX_SCVB_SPACE-1 155 IB_VBOBSPC = IB_VBOBSPC + NOBPT(IOBSPC) 156 END DO 157 NORBVBSPC = NOBPT(NORTCIX_SCVB_SPACE) 158 IF(NTEST.GE.10) 159 &WRITE(6,*) ' Dimension and offset for orbitals in VB-space', 160 & NORBVBSPC,IB_VBOBSPC 161*. Number of electrons 162 NELEC = VB_REFSPC_MIN(NORBVBSPC) 163 IF(NTEST.GE.10) WRITE(6,*) ' Test: NELEC = ', NELEC 164*. Save for communication with configuration routines 165 IB_ORB_CONF = IB_VBOBSPC 166 N_ORB_CONF = NORBVBSPC 167 N_EL_CONF = NELEC 168* 169*. Check number of electrons in initial configuration 170* 171 IF(I_HAVE_INI_CONF.EQ.1) THEN 172 NEL_INI = NEL_IN_COMPACT_CONF(INI_CONF,NOB_INI_CONF) 173 IF(NEL_INI.NE.NELEC) THEN 174 WRITE(6,*) 175 & ' Incorrect number of electrons in initial configuration' 176 WRITE(6,*) ' Actual and required number of electrons ', 177 & NEL_INI, NELEC 178 STOP 179 & ' Incorrect number of electrons in initial configuration' 180 END IF 181 END IF 182* 183* ========================================================= 184* information about prototype configurations in CI space 185* ========================================================= 186* 187* 188*. Max. and min. number of open orbitals- based only number of orbitals 189* and electrons 190*. And the prototype information 191* 192* ====================================== 193* The various min-max occupation spaces 194* ====================================== 195* 196* Space 1: The reference space for |0> 197 ICSPC_CNF = 1 198 CALL ICOPVE(VB_REFSPC_MIN,IOCC_MIN_GN(1,ICSPC_CNF),NORBVBSPC) 199 CALL ICOPVE(VB_REFSPC_MAX,IOCC_MAX_GN(1,ICSPC_CNF),NORBVBSPC) 200*. Space 2: Space where Hamiltonian vector will be calculated, currently 201* also reference space 202 ISSPC_CNF = 2 203 CALL ICOPVE(VB_REFSPC_MIN,IOCC_MIN_GN(1,ISSPC_CNF),NORBVBSPC) 204 CALL ICOPVE(VB_REFSPC_MAX,IOCC_MAX_GN(1,ISSPC_CNF),NORBVBSPC) 205*. Space 3: Intermediate space where |0> is expanded in biothonormal basis, 206*. Must interact with final space (2) through a given level of excit 207 IMSPC_CNF = 3 208*. For atmost two-body operators 209 IF(NORT_M.EQ.1) THEN 210 NEXCIT = 2 211 NEXCIT = NELEC 212*. I have been having some errors with orb gradient when reordering 213*. orbitals, so I have increased this in the aboce 214 WRITE(6,*) ' IMPORTANT: NEXCIT raised to NELEC for test' 215 ELSE 216 NEXCIT = 2 217 END IF 218 CALL MINMAX_EXCIT( 219 & IOCC_MIN_GN(1,ISSPC_CNF),IOCC_MAX_GN(1,ISSPC_CNF),NEXCIT, 220 & IOCC_MIN_GN(1,IMSPC_CNF),IOCC_MAX_GN(1,IMSPC_CNF), 221 & NORBVBSPC) 222 NVBCISPC = 3 223 NVBCNSPC = NVBCISPC 224 IB_INTM_SPC = NVBCISPC + 1 225 226 IF(NORT_MET.EQ.2) THEN 227*. The bioorthogonal C vector will be obtained as a 228*. sequence of one-orbital transformations. Generate spaces for these 229 N_INTM_SPC = N_ORB_CONF 230*.Is there enough space for pointers 231 IF(NVBCISPC+N_INTM_SPC.GE.MXPICI) THEN 232 WRITE(6,*) ' Too many intermediate MAXMIN spaces required' 233 WRITE(6,*) ' Needed number of spaces ', N_ORB_CONF 234 WRITE(6,*) ' Present number of spaces ', MXPICI - NVBCISPC 235 WRITE(6,*) ' Increase MXPICI and recompile ' 236 STOP ' Too many intermediate MAXMIN spaces required' 237 END IF 238*. Generate the various MAXMIN spaces and their dimensions 239C MINMAX_FOR_ORBTRA(MIN_IN,MAX_IN,MIN_OUT,MAX_OUT, 240C & MIN_INTM,MAX_INTM,MIN_INTMS,MAX_INTMS,ISYM,IDODIM) 241 IDODIM = 1 242 WRITE(6,*) ' ICSPC_CNF, IOCC_MIN_GN(1,ICSPC_CNF) = ', 243 & ICSPC_CNF, IOCC_MIN_GN(1,ICSPC_CNF) 244 WRITE(6,*) 245 & ' Configuration information for orbital transformation' 246 WRITE(6,*) 247 & ' ====================================================' 248 CALL MINMAX_FOR_ORBTRA( 249 & IOCC_MIN_GN(1,ICSPC_CNF), 250 & IOCC_MAX_GN(1,ICSPC_CNF), 251 & IOCC_MIN_GN(1,IMSPC_CNF), 252 & IOCC_MAX_GN(1,IMSPC_CNF), 253 & IOCC_MIN_GN(1,IB_INTM_SPC), 254 & IOCC_MAX_GN(1,IB_INTM_SPC), 255 & ISYM,IDODIM,NCONF_GN(IB_INTM_SPC), 256 & NCSF_GN(IB_INTM_SPC), 257 & NSD_GN(IB_INTM_SPC)) 258*. In and out spaces for the orbital transformation 259 DO IORB = 1, N_ORB_CONF 260 IF(IORB.EQ.1) THEN 261 IORBTRA_SPC_IN(IORB) = ICSPC_CNF 262 ELSE 263 IORBTRA_SPC_IN(IORB) = IORBTRA_SPC_OUT(IORB-1) 264 END IF 265 IF(IORB.LT.N_ORB_CONF) THEN 266 IORBTRA_SPC_OUT(IORB) = IB_INTM_SPC - 1 + IORB 267 ELSE 268 IORBTRA_SPC_OUT(IORB) = IMSPC_CNF 269 END IF 270 END DO 271* 272 IF(NTEST.GE.100) THEN 273 WRITE(6,*) ' In and out spaces for the orbital trans ' 274 WRITE(6,*) ' ======================================= ' 275 WRITE(6,*) 276 WRITE(6,*) ' Orbital Inspace Outspace ' 277 WRITE(6,*) ' =========================' 278 DO IORB = 1, N_ORB_CONF 279 WRITE(6,'(3(I3,4X))') 280 & IORB, IORBTRA_SPC_IN(IORB), IORBTRA_SPC_OUT(IORB) 281 END DO 282 END IF 283* 284 NVBCNSPC = NVBCNSPC+N_INTM_SPC 285* 286*. Largest number of CSFs of given sym in a CI space 287* 288 END IF! NORT_MET = 2 289* 290* ================================================== 291* Generate configurations for the active CN spaces 292* ================================================== 293* 294 NCSF_MNMX_MAX = 0 295 DO ISPC = 1, NVBCNSPC 296 IF(NTEST.GE.100) THEN 297 WRITE(6,*) 298 WRITE(6,*) ' ========================================' 299 WRITE(6,*) ' Information about MINMAX space= ', ISPC 300 WRITE(6,*) ' ========================================' 301 WRITE(6,*) 302 END IF 303* 304 CALL GEN_CONF_FOR_MINMAX_SPC( 305 & IOCC_MIN_GN(1,ISPC),IOCC_MAX_GN(1,ISPC), 306 & NORBVBSPC, IREFSM,IB_VBOBSPC,ISPC) 307*. Configurations are returned in WORK(KICONF_OCC_GN(IREFSM,ISPC)) 308*. Number of SD's .. 309C NPARA_FOR_MINMAX_SPC(NCONF_OP,NCSF,NSD,NCMB) 310 CALL NPARA_FOR_MINMAX_SPC(NCONF_PER_OPEN_GN(1,IREFSM,ISPC), 311 & NCSF,NSD,NCMB,NCNF) 312 NSD_PER_SYM_GN(IREFSM,ISPC) = NSD 313 NCSF_PER_SYM_GN(IREFSM,ISPC) = NCSF 314 NCONF_PER_SYM_GN(IREFSM,ISPC) = NCNF 315* 316 NCSF_MNMX_MAX = MAX(NCSF_MNMX_MAX,NCSF) 317* 318 IF(NORT_MET.EQ.1) THEN 319* 320* ======================================================= 321*. Generate mapping of SD's from configuration order to 322*. standard string order 323* ======================================================= 324* 325*. Obtain information about reexpansion in CI space 326* Reorder array for determinants, index and sign 327 CALL MEMMAN(KSDREO_I_GN(IREFSM,ISPC),NSD,'ADDL ',1,'SDREOI') 328*. Offsets for determinants with a given numbner of open orbitals 329*. The code below is a but confusing, I am not sure of its use.. 330 IZERO = 0 331 CALL ISETVC(IB_SD_OPEN_GN(1,ISPC),IZERO,MAXOP+1) 332 IB = 1 333 DO IOPEN = MINOP, MAXOP 334 IB_SD_OPEN_GN(IOPEN+1,ISPC) = IB 335 IF(MOD(IOPEN-MS2,2).EQ.0) THEN 336 IB = IB + 337 & NCONF_PER_OPEN_GN(IOPEN+1,IREFSM,ISPC)*NPCMCNF(IOPEN+1) 338 END IF 339 END DO 340 341*. Reorder array for determinants, index and sign 342 CALL MEMMAN(KSDREO_I_GN(IREFSM,ISPC),NSD,'ADDL ',1,'SDREOI') 343*. And then the reordering 344C CNFORD2(ISM,ICTSDT,ICONF_OCC,NCONF_PER_OP, 345C & IDFTP,ICONF_ORBSPC) 346 CALL CNFORD2(IREFSM,WORK(KSDREO_I_GN(IREFSM,ISPC)), 347 & WORK(KICONF_OCC_GN(IREFSM,ISPC)), 348 & NCONF_PER_OPEN_GN(1,IREFSM,ISPC), 349 & WORK(KDFTP),NORTCIX_SCVB_SPACE, 350 & JCMBSPC) 351 ENDIF ! End if NORTCI = 1 352 END DO ! End of loop over CI spaces 353* 354 WRITE(6,*) ' Largest number of CSF''s in a space ', 355 & NCSF_MNMX_MAX 356* 357* ============================================================= 358* Generate atom orbitals and integrals over these orbitals 359* ============================================================== 360* 361* At the moment: It is assumed that integrals have been 362* delivered in an orthogonal basis defined by C(MOAO) in WORK(KMOAOIN). 363* Obtain matrix for transforming from MO's to AO's 364* and backtransform integrals.... 365* 366* IN MOAOIN we actually have the actual expansion of the set of non-orthoginal 367* orbitals that we will use. Save this, and read in original copy of C(MOAO) 368 LENC = LEN_BLMAT(NSMOB,NTOOBS,NTOOBS,0) 369 CALL COPVEC(WORK(KMOAOIN),WORK(KMOAO_ACT),LENC) 370 CALL GET_CMOAO_ENV(WORK(KMOAOIN)) 371* 372*. Allocate space for H in AO basis 373 LEN1E = NTOOB **2 374 IF(NTEST.GE.1000) 375 &WRITE(6,*) ' NTOOB, LEN1E = ', NTOOB, LEN1E 376 CALL MEMMAN(KLHAO,LEN1E,'ADDL ',2,'H_AO ') 377*. Allocate space for inverse of C(MOAO) 378 CALL MEMMAN(KLCAOMO,LEN1E,'ADDL ',2,'CAOMO ') 379*. Obtain AO integrals SAO 380 XDUM = 2810.1979 381 CALL GET_HSAO(XDUM,WORK(KSAO),0,1) 382C GETHSAO(HAO,SAO,IGET_HAO,IGET_SAO) 383*. Obtain SAO in expanded (unpacked form) 384C? WRITE(6,*) ' LEN1E = ', LEN1E 385 CALL MEMMAN(KLSAOE,LEN1E,'ADDL ',2,'S_AO_E') 386C TRIPAK_AO_MAT(AUTPAK,APAK,IWAY) 387* 388 CALL TRIPAK_AO_MAT(WORK(KLSAOE),WORK(KSAO),2) 389 IF(NTEST.GE.1000) THEN 390 WRITE(6,*) ' SAOE: ' 391 CALL APRBLM2(WORK(KLSAOE),NTOOBS,NTOOBS,NSMOB,0) 392 WRITE(6,*) ' MOAOIN: ' 393 CALL APRBLM2(WORK(KMOAOIN),NTOOBS,NTOOBS,NSMOB,0) 394 END IF 395 396*. CMOAO(T) * SAO - it is assumed that CMOAO is in KMOAOIN 397 CALL MULT_BLOC_MAT(WORK(KLCAOMO),WORK(KMOAOIN),WORK(KLSAOE), 398 & NSMOB,NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,1) 399 IF(NTEST.GE.1000) THEN 400 WRITE(6,*) ' C(AOMO) matrix: ' 401 CALL WRTVH1(WORK(KLCAOMO),1,NTOOBS,NTOOBS,NSMOB,0) 402 END IF 403*. And clean up 404 CALL COPVEC(WORK(KMOAO_ACT),WORK(KMOAOIN),LENC) 405*. 406* 407*.The two-electron integrals in the AO basis - only done in initial NORT 408* 409 IF(INI_NORT.EQ.1) THEN 410* 411 IF(NOMOFL.EQ.1) THEN 412 WRITE(6,*) 413 & ' Lucia is trying to make a MO=>AO transformation of integrals' 414 WRITE(6,*) 415 & ' But there is no AO=> MO transformation present' 416 STOP ' NORTCI: NO AO => MO transformation matrix present' 417 END IF 418* 419 IF(NTEST.GE.10) WRITE(6,*) ' Integral transformation:' 420*. Input integrals in place for integral transformation 421 KINT2 = KINT_2EMO 422 CALL COPVEC(WORK(KH),WORK(KINT1O), NINT1) 423*. Flag type of integral list to be obtained: Pt complete list of integrals 424 IE2LIST_A = IE2LIST_FULL 425 IOCOBTP_A = 1 426 INTSM_A = 1 427 KKCMO_I = KLCAOMO 428 KKCMO_J = KLCAOMO 429 KKCMO_K = KLCAOMO 430 KKCMO_L = KLCAOMO 431 IH1FORM = 1 432 IH2FORM = 1 433 CALL TRAINT 434*. Move integrals in AO basis to KINT_2EMO (sorry for the name..) 435 IE2ARR_F = IE2LIST_I(IE2LIST_IB(IE2LIST_FULL)) 436 NINT2_F = NINT2_G(IE2ARR_F) 437 KINT2_F = KINT2_A(IE2ARR_F) 438 CALL COPVEC(WORK(KINT2_F),WORK(KINT_2EMO),NINT2_F) 439C? WRITE(6,*) ' NINT2_F = ', NINT2_F 440C? WRITE(6,*) ' Integrals transformed to KINT_2EMO' 441C? CALL WRTMAT(WORK(KINT_2EMO),1,NINT2_F,1,NINT2_F) 442*. one-electron AO integrals to KINT1O 443 CALL COPVEC(WORK(KINT1),WORK(KINT1O),NINT1) 444* 445* End of generation of integrals over atomic orbitals: We have now in KINT_2EMO the 446* two-electron integrals over AO's and in KINT1O, the one-electron integrals in the AP basis. 447 ELSE 448 WRITE(6,*) ' AO integrals assumed in place ' 449 END IF 450* 451* ====================================== 452*. Obtain initial set of orbitals 453* ====================================== 454* 455* Two steps : 1) Obtain a set of (nonorthogonal) initial orbitals 456* 2) Perform (partial) orthonormalization to obtain 457* Final initial orbitals 458* 459*. 1: Generate/Read in the initial orbitals 460* Generate set of (nonorthogonal) initial orbitals 461* 462 IF(INI_NORT.EQ.1) THEN 463 CALL GET_INIMO(WORK(KMOAOUT)) 464C GET_INIMO(CMO_INI) 465 ELSE 466 WRITE(6,*) ' Starting from MOAOUT orbitals ' 467 END IF 468* 469*. Obtain, if required, supersymmetry of MO's 470* 471 IF(I_USE_SUPSYM.EQ.1) THEN 472*. Supersymmetry of orbital in MOAOUT 473 WRITE(6,*) ' Supersymmetry of orbitals in MOAOUT: ' 474 CALL SUPSYM_FROM_CMOAO(WORK(KMOAOUT),WORK(KISUPSYM_FOR_BAS), 475 & WORK(KMO_ACT_SUPSYM)) 476*. Obtain reorder array going from correct order to actual order 477 CALL REO_2SUPSYM_ORDERS(WORK(KMO_OCC_SUPSYM), 478 & WORK(KMO_ACT_SUPSYM),WORK(KIREO_INI_OCC)) 479*. Reorder to obtain the occ order of supersymmetry 480 CALL REO_CMOAO(WORK(KMOAOUT),WORK(KMOAO_ACT), 481 & WORK(KIREO_INI_OCC),1,2) 482*. Check that we now have correct supersymmetry (Jeppe has been messing up...) 483 CALL SUPSYM_FROM_CMOAO(WORK(KMOAOUT),WORK(KISUPSYM_FOR_BAS), 484 & WORK(KMO_ACT_SUPSYM)) 485 CALL ICOPVE(WORK(KMO_ACT_SUPSYM), WORK(KMO_SUPSYM), NTOOB) 486 IDENT = IS_I1_EQ_I2(WORK(KMO_OCC_SUPSYM), 487 & WORK(KMO_SUPSYM),NTOOB) 488 IF(IDENT.EQ.0) THEN 489 WRITE(6,*) ' Error: Reordered orbitals are not in occ order' 490 WRITE(6,*) ' Obtained symmetry of reordered orbitals ' 491 CALL IWRTMA3(WORK(KMO_SUPSYM),1,NTOOB,1,NTOOB) 492 WRITE(6,*) ' Required order ' 493 CALL IWRTMA3(WORK(KMO_OCC_SUPSYM),1,NTOOB,1,NTOOB) 494 STOP ' Error: Jeppe is STILL messing supersymmetry up!!! ' 495 END IF 496 497 498 499 END IF 500 501 IF(NTEST.GE.100) THEN 502 WRITE(6,*) ' Expansion of initial MOs in AOs ' 503 WRITE(6,*) ' ================================' 504 CALL APRBLM2(WORK(KMOAOUT),NTOOBS,NTOOBS,NSMOB,0) 505 END IF 506*. Calculate metric over MO's in KLCMOAO2).. 507 CALL GET_SMO(WORK(KMOAOUT),WORK(KLSAOE),0) 508 IF(NTEST.GE.10) THEN 509 WRITE(6,*) ' Metric in final initial orbitals ... ' 510 WRITE(6,*) ' ====================================' 511 CALL APRBLM2(WORK(KLSAOE),NTOOBS,NTOOBS,NSMOB,0) 512 END IF 513*. Obtain CBIO: expansion of orbitals in MO's, CBIO2: expansion 514* of orbitals in AO's orbitals 515 CALL GET_CBIO(WORK(KMOAOUT),WORK(KCBIO),WORK(KCBIO2)) 516* 517* ======================================================================= 518* Bioorthogonal integral transformation with indices corresponding to 519* annihilation indices being in bioorthonormal basis 520* ======================================================================= 521* 522 IF(NTEST.GE.10) THEN 523 WRITE(6,*) ' Bioorthogonal integral transformation ' 524 END IF 525 IE2LIST_A = IE2LIST_FULL_BIO 526 IOCOBTP_A = 1 527 INTSM_A = 1 528 CALL PREPARE_2EI_LIST 529*. Two forms 1: Operator acts on bioorthonormal expansion 530* creation operators are in bio, annihilation are in orig, 531* integral indices converse 532* 2: Operator acts on origonal expansion 533*. 534 I_STRINGS_BIO_OR_ORIG = 1 535 IF(I_STRINGS_BIO_OR_ORIG.EQ.1) THEN 536 KKCMO_I = KMOAOUT 537 KKCMO_J = KCBIO2 538 KKCMO_K = KMOAOUT 539 KKCMO_L = KCBIO2 540 ELSE 541 KKCMO_I = KCBIO2 542 KKCMO_J = KMOAOUT 543 KKCMO_K = KCBIO2 544 KKCMO_L = KMOAOUT 545 END IF 546C DO_ORBTRA(IDOTRA,IDOFI,IDOFA,IE2LIST_IN,IOCOBTP_IN,INTSM_IN) 547 CALL DO_ORBTRA(1,1,0,IE2LIST_FULL_BIO,IOCOBTP_A,INTSM_A) 548 CALL FLAG_ACT_INTLIST(IE2LIST_FULL_BIO) 549* 550 IF(NTEST.GE.1000) THEN 551 WRITE(6,*) ' one-electron integrals in biobase' 552 WRITE(6,*) ' =================================' 553 CALL APRBLM2(WORK(KINT1),NTOOBS,NTOOBS,NSMOB,0) 554 END IF 555*. Transfer the inactive Fock-matrix to feeder matrix for integral fetchers 556 NINT1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 557 CALL COPVEC(WORK(KFI),WORK(KINT1),NINT1_F) 558* 559 IPRNTL = IPRDIA 560 CALL NORTCALC(IREFSM,JCMBSPC,ICSPC_CNF,I_DO_NONORT_MCSCF,IPRNTL, 561 & E_FINAL,ERROR_NORM_FINAL,CONV_F,IVBGNSP_PREV) 562 563 RETURN 564 END 565 SUBROUTINE NORTCALC(ISM,ISPC_GAS,ISPC_CNF,I_DO_NONORT_MCSCF, 566 & IPRNT, 567 & E_FINAL,VN_NORTCI,CONV_NORTCI,IVBGNSP_PREV) 568* 569* CI optimization in GAS space number ISPC for symmetry ISM 570* 571* Information about the number of SD, CSF's is assumed to have 572* been determined outside this routine 573* 574* 575* Jeppe Olsen, June 2011 576* 577*. Last modifications; Jeppe 2013; Analytic orbital Hessian and more 578* 579 INCLUDE 'wrkspc.inc' 580 LOGICAL CONVER_NORTCI, CONVER_NORTMC 581 INCLUDE 'cicisp.inc' 582 INCLUDE 'orbinp.inc' 583 INCLUDE 'clunit.inc' 584 INCLUDE 'csm.inc' 585 INCLUDE 'cstate.inc' 586 INCLUDE 'crun.inc' 587 INCLUDE 'strinp.inc' 588 INCLUDE 'stinf.inc' 589 INCLUDE 'strbas.inc' 590 INCLUDE 'glbbas.inc' 591 INCLUDE 'cprnt.inc' 592 INCLUDE 'oper.inc' 593 INCLUDE 'gasstr.inc' 594 INCLUDE 'cgas.inc' 595 INCLUDE 'lucinp.inc' 596 INCLUDE 'intform.inc' 597 INCLUDE 'comjep.inc' 598 INCLUDE 'cc_exc.inc' 599 INCLUDE 'cintfo.inc' 600 INCLUDE 'spinfo.inc' 601 INCLUDE 'cands.inc' 602 INCLUDE 'vb.inc' 603*. Common block for communicating with sigma 604 COMMON/SCRFILES_MATVEC/LUSCR1,LUSCR2,LUSCR3, 605 & LUCBIO_SAVE, LUHCBIO_SAVE,LUC_SAVE 606*. Common block for transferring info to finite difference routines. 607 COMMON/EVB_TRANS/KLIOOEXC_A, KLKAPPA_A, 608 & KLIOOEXC_S,KLKAPPA_S, 609 & KL_C,KL_VEC2,KL_VEC3, 610 & KLOOEXC 611* 612 INCLUDE 'cecore.inc' 613 COMMON/CMXCJ/MXCJ,MAXK1_MX,LSCMAX_MX 614* 615 COMMON/H_OCC_CONS/IH_OCC_CONS 616* 617 REAL*8 INPRDD, INPROD 618* 619 EXTERNAL SIGMA_NORTCI, PRECOND_NORTCI, E_VB_FROM_KAPPA_WRAP 620* 621 622 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'NORTCI') 623 NTEST = 10 624 NTEST = MAX(NTEST,IPRNT) 625* 626 IF(NORT_MET.GE.3) THEN 627 WRITE(6,*) ' Currently unknown NORT_MET = ', NORT_MET 628 STOP ' Currently unknown NORT_MET ' 629 END IF 630* 631 IF(NTEST.GT.1) THEN 632 WRITE(6,*) 633 WRITE(6,*) ' =======================================' 634 WRITE(6,*) ' Control has been transferred to NORTCI' 635 WRITE(6,*) ' =======================================' 636 WRITE(6,*) 637 IF(NORT_MET.EQ.1) THEN 638 WRITE(6,'(5X,A)') 639 & ' Non-orthogonal wave function will be expanded in CI space' 640 ELSE IF (NORT_MET.EQ.2) THEN 641 WRITE(6,'(5X,A)') 642 & ' Initial suite of non-orthogonal configuration codes ' 643 ELSE 644 WRITE(6,*) ' Currently unknown NORT_MET = ', NORT_MET 645 STOP ' Currently unknown NORT_MET ' 646 END IF 647* 648 IF(I_DO_NONORT_MCSCF.EQ.1) THEN 649 WRITE(6,*) ' I will also do MCSCF.... ' 650 WRITE(6,*) ' =========================' 651 END IF 652* 653 WRITE(6,'(5X,A,I3)') 654 & ' Configuration space', ISPC_CNF 655 WRITE(6,'(5X,A,I3)') 656 & ' Spanning CI-space:', ISPC_GAS 657 WRITE(6,'(5X,A,I3)') 658 & ' Orbital space containing non-orthogonal orbitals ', 659 & NORTCIX_SCVB_SPACE 660 WRITE(6,'(5X,A,I3)') 661 & ' Allowed excitation level from Spin-coupled valence space', 662 & NORTCI_SCVB_EXCIT 663 WRITE(6,*) ' Orbital Min. occ Max. occ ' 664 WRITE(6,*) ' ==========================' 665 DO IORB = 1, NOBPT(NORTCIX_SCVB_SPACE) 666 WRITE(6,'(3X,I4,2I3)') 667 & IORB, IOCC_MIN_GN(IORB,ISPC_CNF), IOCC_MAX_GN(IORB,ISPC_CNF) 668 END DO 669 END IF 670* 671*. Prepare for integral handling for complete array 672*. (needed for codes where integrals are accessed individually) 673 IE2ARRAY_A = IE2LIST_I(IE2LIST_IB(IE2LIST_FULL_BIO)) 674 I12S_A = I12S_G(IE2ARRAY_A) 675 I34S_A = I34S_G(IE2ARRAY_A) 676 I1234S_A = I1234S_G(IE2ARRAY_A) 677 IOCOBTP_A = IOCOBTP_G(IE2ARRAY_A) 678 KINT2_LA = KINT2_A(IE2ARRAY_A) 679 KPINT2_LA = KPINT2_A(IE2ARRAY_A) 680* 681*. Number of dets, csf's and configs in CI expansion 682* 683 NDET = NSD_PER_SYM_GN(ISM,ISPC_CNF) 684 NCSF = NCSF_PER_SYM_GN(ISM,ISPC_CNF) 685 NCONF = NCONF_PER_SYM_GN(ISM,ISPC_CNF) 686 687 IF(IPRNT.GT.1) THEN 688 WRITE(6,'(A,I9)') 689 & ' Number of determinants/combinations ',NDET 690 WRITE(6,'(A,I9)') 691 & ' Number of CSFs ',NCSF 692 WRITE(6,'(A,I9)') 693 & ' Number of Confs ',NCONF 694 END IF 695*.Transfer to CANDS 696 ICSM = ISM 697 ISSM = ISM 698*. Complete operator 699 I12 = 2 700* 701 ICSPC_CN = ICSPC_CNF 702 ISSPC_CN = ISSPC_CNF 703 IMSPC_CN = IMSPC_CNF 704* 705 IF(NORT_MET.EQ.1) THEN 706* 707*.Initial version with standard CI behind the scene 708* 709*. allocate memory for this 710 ICSPC = ISPC_GAS 711 ISSPC = ISPC_GAS 712 IMSPC = ISPC_GAS 713* 714 WRITE(6,*) ' NORTCI: ICSPC_CNF,ISSPC_CNF,IMSPC_CNF', 715 & ICSPC_CNF,ISSPC_CNF,IMSPC_CNF 716 WRITE(6,*) ' NORTCI: ICSPC_CN,ISSPC_CN,IMSPC_CN', 717 & ICSPC_CN,ISSPC_CN,IMSPC_CN 718* 719 CALL GET_3BLKS(KVEC1,KVEC2,KVEC3) 720 KVEC1P = KVEC1 721 KVEC2P = KVEC2 722 END IF ! if NORT_MET = 1 723 IF(NORT_MET.EQ.2) THEN 724* We will use a number of different spaces, vectors should be 725* able to store max space 726 END IF 727* 728* 729* Set up complete H and S for test 730* 731 I_DO_COMHAM = 0 732 IF(I_DO_COMHAM .EQ. 1) THEN 733 CALL COMHAM_HS_GEN(SIGMA_NORTCI,NCSF) 734C COMHAM_HS_GEN(MSTV,NDIM) 735 STOP ' Enforced stop after COMHAM_HS_GEN ' 736 END IF 737* 738*. CI diagonal - if required 739* 740*. Not yet implemented 741* 742 WRITE(6,*) ' Diagonal in Non-orthogonal CI not yet implemented' 743* 744 I_DO_PRECOND = 0 745 IPREC_FORM = 0 746 I_ER_CONV = 2 747 THRES_R = SQRT(THRES_E) 748 SHIFT = 0.0D0 749* 750 MAXITL = MAXIT 751 MAXVECL = MXCIV 752* 753*. Allocate space for iterative solver: 754*. Four scratch vectors 755C CALL MEMMAN(KL_VEC1,NCSF,'ADDL ',2,'EXTVC1') 756C CALL MEMMAN(KL_VEC2,NCSF,'ADDL ',2,'EXTVC2') 757C CALL MEMMAN(KL_VEC3,NCSF,'ADDL ',2,'EXTVC3') 758*. Increased for CONF approach 759 CALL MEMMAN(KL_VEC1,NCSF_MNMX_MAX,'ADDL ',2,'EXTVC1') 760 CALL MEMMAN(KL_VEC2,NCSF_MNMX_MAX,'ADDL ',2,'EXTVC2') 761 CALL MEMMAN(KL_VEC3,NCSF_MNMX_MAX,'ADDL ',2,'EXTVC3') 762*. Space for subsspace matrices 763 CALL MEMMAN(KL_RNRM,MAXITL*NROOT,'ADDL ',2,'RNRM ') 764 CALL MEMMAN(KL_EIG ,MAXITL*NROOT,'ADDL ',2,'EIG ') 765 CALL MEMMAN(KL_FINEIG,NROOT,'ADDL ',2,'FINEIG') 766 CALL MEMMAN(KL_APROJ,MAXVECL**2,'ADDL ',2,'APROJ ') 767 CALL MEMMAN(KL_SPROJ,MAXVECL**2,'ADDL ',2,'SPROJ ') 768 CALL MEMMAN(KL_AVEC ,MAXVECL**2,'ADDL ',2,'AVEC ') 769 LLWORK = 5*MAXVECL**2 + 2*MAXVECL 770 CALL MEMMAN(KL_WORK ,LLWORK ,'ADDL ',2,'WORK ') 771 CALL MEMMAN(KL_AVEC ,MAXVECL**2,'ADDL ',2,'AVECP ') 772 CALL MEMMAN(KL_AVECP,MAXVECL**2,'ADDL ',2,'AVECP ') 773*. And a matrix over active orbitals 774 CALL MEMMAN(KL_MACT,NACOB**2,'ADDL ',2,'M_ACT ') 775* 776*. Initial approximation to CI-vector 777* 778 IF(IRESTR.EQ.0) THEN 779C INI_CSFEXP(CINI) 780 CALL INI_CSFEXP(WORK(KL_VEC1)) 781*. and transfer initial guess to DISC 782 CALL VEC_TO_DISC(WORK(KL_VEC1),NCSF,1,-1,LUSC54) 783 ELSE 784 WRITE(6,*) ' Restart from previous CI vector ' 785*. Expand from previous to current cnf-space 786 NCSF_PREV = NVB_CSF(IVBGNSP_PREV) 787 WRITE(6,*) 'IVBGNSP_PREV, NCSF_PREV = ', 788 & IVBGNSP_PREV, NCSF_PREV 789 CALL VEC_FROM_DISC(WORK(KL_VEC1),NCSF_PREV,1,-1,LUSC54) 790C EXP_CNFSPC(CIVECIN,CIVECUT,ICONF_OCC,NCONF_FOR_OPEN, 791C & MINOCC_IN,MAXOC_IN,NOBCNF) 792 IF(IVBGNSP_PREV.EQ.0) THEN 793 CALL EXP_CNFSPC(WORK(KL_VEC1), WORK(KL_VEC2), 794 & WORK(KICONF_OCC_GN(ICSM,ISPC_CNF)), 795 & NCONF_PER_OPEN_GN(1,ICSM,ISPC_CNF), 796 & VB_REFSPCO_MIN, VB_REFSPCO_MAX, 797 & NACOB) 798 ELSE 799 CALL EXP_CNFSPC(WORK(KL_VEC1), WORK(KL_VEC2), 800 & WORK(KICONF_OCC_GN(ICSM,ISPC_CNF)), 801 & NCONF_PER_OPEN_GN(1,ICSM,ISPC_CNF), 802 & VB_GNSPC_MIN(1,IVBGNSP_PREV),VB_GNSPC_MAX(1,IVBGNSP_PREV), 803 & NACOB) 804 END IF ! Test of VBGNSP_PREV 805 CALL VEC_TO_DISC(WORK(KL_VEC2),NCSF,1,-1,LUSC54) 806 END IF 807*. And diagonalize 808 NTESTL = 10000 809 SHIFT = 0.0D0 810 CALL MINGENEIG(SIGMA_NORTCI,PRECOND_NORTCI, 811 & IPREC_FORM,THRES_E,THRES_R,I_ER_CONV, 812 & WORK(KL_VEC1),WORK(KL_VEC2),WORK(KL_VEC3), 813 & LUSC54, LUSC37, 814 & WORK(KL_RNRM),WORK(KL_EIG),WORK(KL_FINEIG),MAXITL, 815 & NCSF,LUSC38,LUSC39,LUSC40,LUSC53,LUSC51,LUSC52, 816 & NROOT,MAXVECL,NROOT,WORK(KL_APROJ), 817 & WORK(KL_AVEC),WORK(KL_SPROJ),WORK(KL_WORK), 818 & NTESTL,SHIFT,WORK(KL_AVECP),I_DO_PRECOND, 819 & CONV_NORTCI,E_NORTCI,VN_NORTCI) 820 E_FINAL = E_NORTCI 821* 822 IF(I_DO_NONORT_MCSCF.EQ.0) CONV_F = CONV_NORTCI 823* 824 WRITE(6,*) ' Final energy in non-orthogonal CI ', E_NORTCI 825 WRITE(6,*) ' Final residual norm in non-orthogonal CI', 826 & VN_NORTCI 827 IF(NTEST.GE.10000) THEN 828 WRITE(6,*) ' Final approximation to eigenvector from MINGENEIG' 829 CALL WRTMAT(WORK(KL_VEC1),1,NCSF,1,NCSF) 830 END IF 831* 832* Analyze the CI- coefficients of the resulting wave function 833* 834C ANACSF(CIVEC,ICONF_OCC,NCONF_FOR_OPEN,IPROCS,THRES, 835C & MAXTRM,IOUT) 836 MAXTRM = 1000 837 THRES = 0.03 838 IOUT = 6 839*. The analyzer assumes full set of active electrons, adjust for this 840 NACTEL = NACTEL - 2*(IB_ORB_CONF-NINOB-1) 841 CALL ANACSF(WORK(KL_VEC1),WORK(KICONF_OCC_GN(ICSM,ISPC_CNF)), 842 & NCONF_PER_OPEN_GN(1,ICSM,ISPC_CNF), 843 & WORK(KCFTP),THRES, MAXTRM,IOUT) 844 NACTEL = NACTEL + 2*(IB_ORB_CONF-NINOB-1) 845*. Density etc not implemented for NORT_MET = 2, so 846 IF(NORT_MET.EQ.2) GOTO 9999 847* 848* And construct density matrix 849* 850 XDUM = 0.0D0 851 CALL VB_DENSI(WORK(KRHO1),XDUM,1,WORK(KL_VEC1),WORK(KL_VEC2), 852 & WORK(KL_VEC3)) 853*. Obtain natural orbitals and natural occupation numbers 854*. 1: Metric over active orbitals 855C SACT(SACT,C) 856 CALL GET_SACT(WORK(KL_MACT),WORK(KMOAOUT)) 857*. 2: and diagonalize using metric of active orbitals 858C NONORT_NATORB(SACT,RHO1) 859 CALL NONORT_NATORB(WORK(KL_MACT),WORK(KRHO1)) 860* 861 IF(I_DO_NONORT_MCSCF.EQ.1) THEN 862 IREFSPC_MCSCF = ISPC_GAS 863* 864 IF(NORT_MET.NE.1) THEN 865 WRITE(6,*) ' MCSCF works only for NORT_MET = 1' 866 STOP ' MCSCF works only for NORT_MET = 1' 867 END IF 868*. Allowed number of micro and macro's 869 870 WRITE(6,*) ' MCSCF part entered ' 871 WRITE(6,*) ' ===================' 872 WRITE(6,*) ' Allowed number of macroiterations ', MAXIT_MAC 873 WRITE(6,*) ' Allowed number of microiterations ', MAXIT_MIC 874* 875* ==================== 876* Generate excitations 877* ==================== 878* 879* Two types: 880* Interspace excitations: only antisymmtric conformal operators 881* Active-Active exciations: both symmetric and antisymmetric operators 882* 883* For historical reasons, there is a flag for eliminating the 884* interspace excitations 885* 886*. Number of excitations 887* ====================== 888* 889* 890 INCLUDE_ONLY_TOTSYM_SUPSYM = 1 891 IF(I_USE_SUPSYM.EQ.1.AND.INCLUDE_ONLY_TOTSYM_SUPSYM.EQ.1) THEN 892 I_RESTRICT_SUPSYM = 1 893 ELSE 894 I_RESTRICT_SUPSYM = 0 895 END IF 896 I_DO_INTER_EXC = 1 897* 898*. Number of internal excitations in active space 899C ORB_EXCIT_INT_SPACE(IORBSPC,ITOTSYM,NOOEXC,IOOEXC,NUMONLY) 900 CALL ORB_EXCIT_INT_SPACE 901 & (NORTCIX_SCVB_SPACE,1,NOOEXC_AA,IDUM,1,1, 902 & I_RESTRICT_SUPSYM,WORK(KMO_SUPSYM)) 903*.Number of interspace excitations 904 IF(I_DO_INTER_EXC.EQ.1) THEN 905*. Number of interspace excitations 906*. Nonredundant type-type excitations 907 CALL MEMMAN(KLTTACT,(NGAS+2)**2,'ADDL ',1,'TTACT ') 908 CALL NONRED_TT_EXC(WORK(KLTTACT),IREFSPC_MCSCF,0) 909*. Nonredundant interspace orbital excitations 910 KLOOEXC = 1 911 KLOOEXCC= 1 912*. Number of interspace excitations 913 CALL NONRED_OO_EXC2(NOOEXC_IS,WORK(KLOOEXC),WORK(KLOOEXCC), 914 & 1,WORK(KLTTACT),I_RESTRICT_SUPSYM,WORK(KMO_SUPSYM), 915 & N_INTER_EXC,N_INTRA_EXC,1) 916 END IF 917*. Number of symmetric rotations 918 NOOEXC_S = NOOEXC_AA 919*. Number of antisymmetric rotations 920 NOOEXC_A = NOOEXC_IS + NOOEXC_AA 921*. The total number of excitations 922 NOOEXC = NOOEXC_S + NOOEXC_A 923* 924*. Allocate space 925* ====================== 926* 927*. Separate arrays are set up for all and symmetric excitations(??) 928*. 929*. For all excitations 930 CALL MEMMAN(KLOOEXC,NTOOB*NTOOB,'ADDL ',1,'OOEXC ') 931 CALL MEMMAN(KLOOEXCC,2*NOOEXC,'ADDL ',1,'OOEXCC') 932*. For the symmetric excitations 933 CALL MEMMAN(KLOOEXCC_S,2*NOOEXC_S,'ADDL ',1,'OOEXCS') 934*. Allow these parameters to be known outside 935 KIOOEXC = KLOOEXC 936 KIOOEXCC = KLOOEXCC 937* 938*. And the excitations: The active- active are added twice.. 939* ====================== 940* 941 IF(I_DO_INTER_EXC.EQ. 1) THEN 942*. The interspace excitations 943 CALL NONRED_OO_EXC2(NOOEXC_IS,WORK(KLOOEXC),WORK(KLOOEXCC), 944 & 1,WORK(KLTTACT),I_RESTRICT_SUPSYM,WORK(KMO_SUPSYM), 945 & N_INTER_EXC,N_INTRA_EXC,2) 946 END IF 947*. The internal excitations 948 CALL ORB_EXCIT_INT_SPACE(NORTCIX_SCVB_SPACE,1,NOOEXC_S, 949 & WORK(KLOOEXCC),0,NOOEXC_IS+1, 950 & I_RESTRICT_SUPSYM,WORK(KMO_SUPSYM)) 951 CALL ORB_EXCIT_INT_SPACE(NORTCIX_SCVB_SPACE,1,NOOEXC_S, 952 & WORK(KLOOEXCC),0,NOOEXC_IS+NOOEXC_S+1, 953 & I_RESTRICT_SUPSYM,WORK(KMO_SUPSYM)) 954*. Save also the internal excitations in KLOOEXCC_S 955 CALL ICOPVE3(WORK(KLOOEXCC),NOOEXC_IS*2+1, 956 & WORK(KLOOEXCC_S),1,2*NOOEXC_S) 957C ICOPVE3(IIN,IOFFIN,IOUT,IOFFOUT,NDIM) 958 WRITE(6,*) ' NOOEXC after ORB_EXCIT.. ', NOOEXC 959C PRINT_ORBEXC_LIST(IOOEXC,NOOEXC_A,NOOEXC_S) 960 WRITE(6,*) ' The list of orbital excitations' 961 CALL PRINT_ORBEXC_LIST(WORK(KLOOEXCC),NOOEXC_A,NOOEXC_S) 962 WRITE(6,*) ' The list of symmetric excitations' 963 CALL PRINT_ORBEXC_LIST(WORK(KLOOEXCC_S),0,NOOEXC_S) 964* 965* Allocate space for gradient, kappa, Hessian, etc 966* ================================================ 967* 968 WRITE(6,*) ' NOOEXC before MEMMAN ', NOOEXC 969 CALL MEMMAN(KLE1,NOOEXC,'ADDL ',2,'E1_MC ') 970 CALL MEMMAN(KLKAPPA,NOOEXC,'ADDL ',2,'LKAPPA') 971 CALL MEMMAN(KLE2SC,NOOEXC,'ADDL ',2,'E2SC ') 972*. Memory for orbital-Hessian - if required 973 LE2 = NOOEXC*(NOOEXC+1)/2 974 CALL MEMMAN(KLE2,LE2,'ADDL ',2,'E2P_MC') 975*. For eigenvectors of orbhessian 976 LE2F = NOOEXC**2 977 CALL MEMMAN(KLE2F,LE2F,'ADDL ',2,'E2_MC ') 978*. and eigenvalues, scratch, kappa 979 CALL MEMMAN(KLE2VL,NOOEXC,'ADDL ',2,'EIGVAL') 980*. Space for two one-bodydensity matrices 981 CALL MEMMAN(KLS,NTOOB**2,'ADDL ',2,'SMO ') 982*. KMOAOIN will be used for storing MO's that should be transformed 983 I_STRINGS_BIO_OR_ORIG = 1 984 IF(I_STRINGS_BIO_OR_ORIG.EQ.1) THEN 985 KKCMO_I = KMOAOIN 986 KKCMO_J = KCBIO2 987 KKCMO_K = KMOAOIN 988 KKCMO_L = KCBIO2 989 ELSE 990 KKCMO_I = KCBIO2 991 KKCMO_J = KMOAOIN 992 KKCMO_K = KCBIO2 993 KKCMO_L = KMOAOIN 994 END IF 995* 996 LEN1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 997 LEN1_A = NDIM_1EL_MAT(1,NACOBS,NACOBS,NSMOB,0) 998 CALL COPVEC(WORK(KMOAOUT),WORK(KMOAOIN),LEN1_F) 999*. For summary 1000 NITEM = 6 1001 CALL MEMMAN(KL_SUMMARY,NITEM*MAXIT_MAC,'ADDL ',2,'SUMMAR') 1002* 1003*. Finished with the preparations 1004* 1005 CONVER_NORTMC = .FALSE. 1006 XKAP_THRES = 1.0D-6 1007 STEP_MAX = 0.75D0 1008* 1009 DO IMAC = 1, MAXIT_MAC 1010 NMAC = IMAC 1011 WRITE(6,*) ' Output from Macroiteration', IMAC 1012 WRITE(6,*) ' ==================================' 1013 INIMIC = 1 1014 DO IMIC = 1, MAXIT_MIC 1015 WRITE(6,*) ' Output from Microiteration', IMIC 1016 WRITE(6,*) ' ==================================' 1017* 1018*. The current expansion of the AOs is in KMOAOIN. Obtain the 1019* bioorbitals 1020 CALL GET_CBIO(WORK(KMOAOIN),WORK(KCBIO),WORK(KCBIO2)) 1021 IF(NTEST.GE.100) THEN 1022 WRITE(6,*) 1023 & ' Current set of orbitals' 1024 CALL APRBLM2(WORK(KMOAOIN),NTOOBS,NTOOBS,NSMOB,0) 1025 END IF 1026 IF(NTEST.GE.1000) THEN 1027 WRITE(6,*) ' Current set of bioorbitals ' 1028 CALL APRBLM2(WORK(KCBIO),NTOOBS,NTOOBS,NSMOB,0) 1029 END IF 1030* 1031 IF(NTEST.GE.100) THEN 1032* Calculate and print metric 1033 CALL GET_SMO(WORK(KMOAOIN),WORK(KLS),0) 1034 WRITE(6,*) ' Metric in Current MO basis ' 1035 CALL APRBLM2(WORK(KLS),NTOOBS,NTOOBS,NSMOB,0) 1036 END IF 1037* 1038* ===================================================== 1039* Integral transformation to current set of orbitals 1040* ===================================================== 1041* 1042 IF(NTEST.GE.10) THEN 1043 WRITE(6,*) 1044 & ' Bioorthogonal integral transformation ' 1045 END IF 1046 IOCOBTP_A = 1 1047 INTSM_A = 1 1048 CALL FLAG_ACT_INTLIST(IE2LIST_FULL_BIO) 1049 CALL DO_ORBTRA(1,1,0,IE2LIST_FULL_BIO, 1050 & IOCOBTP_A,INTSM_A) 1051* 1052 1053* 1054 IF(NTEST.GE.1000) THEN 1055 WRITE(6,*) ' one-electron integrals in biobase' 1056 WRITE(6,*) ' =================================' 1057 CALL APRBLM2(WORK(KINT1),NTOOBS,NTOOBS,NSMOB,0) 1058 END IF 1059 NINT1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 1060 CALL COPVEC(WORK(KFI),WORK(KINT1),NINT1_F) 1061* 1062* ============================== 1063*. Perform CI in current basis in first Micro of each macro 1064* ============================== 1065* 1066 IF(IMIC.EQ.1) THEN 1067 IF(NTEST.GE.1000) WRITE(6,*) ' CI optimization ' 1068 CALL MINGENEIG(SIGMA_NORTCI,PRECOND_NORTCI, 1069 & IPREC_FORM,THRES_E,THRES_R,I_ER_CONV, 1070 & WORK(KL_VEC1),WORK(KL_VEC2),WORK(KL_VEC3), 1071 & LUSC54, LUSC37, 1072 & WORK(KL_RNRM),WORK(KL_EIG),WORK(KL_FINEIG),MAXITL, 1073 & NCSF,LUSC38,LUSC39,LUSC40,LUSC53,LUSC51,LUSC52, 1074 & NROOT,MAXVECL,NROOT,WORK(KL_APROJ), 1075 & WORK(KL_AVEC),WORK(KL_SPROJ),WORK(KL_WORK), 1076 & NTESTL,SHIFT,WORK(KL_AVECP),I_DO_PRECOND, 1077 & CONV_NORTCI,E_NORTCI,VN_NORTCI) 1078 WORK(KL_SUMMARY-1+(IMAC-1)*NITEM + 1) = E_NORTCI 1079 IF(IMAC.EQ.1) THEN 1080 DELTA = 0.0D0 1081 ELSE 1082 DELTA = E_NORTCI - WORK(KL_SUMMARY-1+(IMAC-2)*NITEM + 1) 1083 END IF 1084 WORK(KL_SUMMARY-1+(IMAC-1)*NITEM + 2) = DELTA 1085*. Preliminary final energy 1086 E_FINAL = E_NORTCI 1087* 1088 IF(NTEST.GE.10000) THEN 1089 WRITE(6,*) 1090 & ' Final approximation to eigenvector from MINGENEIG' 1091 CALL WRTMAT(WORK(KL_VEC1),1,NCSF,1,NCSF) 1092 END IF 1093* 1094* And construct the one- and two-body density matrices 1095* 1096 CALL VB_DENSI(WORK(KRHO1),WORK(KRHO2),2,WORK(KL_VEC1), 1097 & WORK(KL_VEC2),WORK(KL_VEC3)) 1098*. Construct Active Fock-matrix 1099 CALL DO_ORBTRA(1,1,1,IE2LIST_FULL_BIO, 1100 & IOCOBTP_A,INTSM_A) 1101 END IF !micit = 1 1102* 1103* ===================================== 1104*. Construct Gradient at current point 1105* ===================================== 1106* 1107*. The Fock-matrices for biorthogonal expansion 1108C FOCK_MAT_NORT(F1,F2,I12,FI,FA) 1109 CALL FOCK_MAT_NORT(WORK(KF),WORK(KF2),2,WORK(KFI),WORK(KFA)) 1110*. And the interspace gradient 1111C E1_FROM_F_NORT(E1,F1,F2,IOPSM,IOOEXC,IOOEXCC, 1112C & NOOEXC,NTOOB,NTOOBS,NSMOB,IBSO,IREOST) 1113 CALL E1_FROM_F_NORT(WORK(KLE1),WORK(KF),WORK(KF2),1, 1114 & WORK(KLOOEXC),WORK(KLOOEXCC),NOOEXC_A,NTOOB, 1115 & NTOOBS,NSMOB,IBSO,IREOST) 1116*. And add the active-active gradient 1117* The interspace excitations 1118C VB_GRAD_ORBVBSPC(NOOEXC,IOOEXC,E1,C,VEC1_CSF,VEC2_CSF) 1119 IF(NTEST.GE.1000) 1120 & WRITE(6,*) ' Active-active gradient will be calculated ' 1121 CALL VB_GRAD_ORBVBSPC(NOOEXC_S,WORK(KLOOEXCC_S), 1122 & WORK(KLE1+NOOEXC_IS), 1123 & WORK(KL_VEC1),WORK(KL_VEC2),WORK(KL_VEC3)) 1124 IF(NTEST.GE.0) WRITE(6,*) ' Gradient calculated ' 1125 IF(NTEST.GE.1000) THEN 1126 WRITE(6,*) ' Gradient vector ' 1127 CALL WRTMAT(WORK(KLE1),1,NOOEXC,1,NOOEXC) 1128 END IF 1129 E1NORM = INPROD(WORK(KLE1),WORK(KLE1),NOOEXC) 1130 WORK(KL_SUMMARY-1+(IMAC-1)*NITEM + 3) = E1NORM 1131C STOP ' Enforced stop ' 1132* 1133 I_DO_DIFTEST = 0 1134 IF(I_DO_DIFTEST.EQ.1) THEN 1135*. Finite difference test of gradient at Kappa = 0 1136 KLIOOEXC_A = KIOOEXCC 1137 KLIOOEXC_S = KLOOEXCC_S 1138 KLKAPPA_A = KLKAPPA 1139 KLKAPPA_S = KLKAPPA+NOOEXC_A 1140 KL_C = KL_VEC1 1141* 1142C COMMON/EVB_TRANS/KLIOOEXC_A, KLKAPPA_A, 1143C & KLIOOEXC_S,KLKAPPA_S, 1144C & KL_C,KL_VEC2,KL_VEC3 1145 ZERO = 0.0D0 1146 CALL SETVEC(WORK(KLKAPPA),ZERO,NOOEXC) 1147 CALL MEMMAN(KLE1_EXTRA,NOOEXC,'ADDL ',2,'E1_EXT') 1148 CALL GENERIC_GRAD_FROM_F(WORK(KLE1_EXTRA),NOOEXC, 1149 & E_VB_FROM_KAPPA_WRAP, WORK(KLKAPPA)) 1150* 1151*. Clean up: recalculate integrals corresponding to MO's in MOAOIN 1152* 1153 IF(I_STRINGS_BIO_OR_ORIG.EQ.1) THEN 1154 KKCMO_I = KMOAOIN 1155 KKCMO_J = KCBIO2 1156 KKCMO_K = KMOAOIN 1157 KKCMO_L = KCBIO2 1158 ELSE 1159 KKCMO_I = KCBIO2 1160 KKCMO_J = KMOAOIN 1161 KKCMO_K = KCBIO2 1162 KKCMO_L = KMOAOIN 1163 END IF 1164 IF(NTEST.GE.10) THEN 1165 WRITE(6,*) 1166 & ' Bioorthogonal integral transformation ' 1167 END IF 1168 CALL TRAINT 1169 CALL FLAG_ACT_INTLIST(IE2LIST_FULL_BIO) 1170 STOP ' Enforced stop after FD calc of gradient' 1171 END IF ! Finite Difference test 1172* 1173 IF(IMIC.EQ.1) THEN 1174* 1175*. Obtain new orbital Hessian 1176* 1177*. Complete orbital Hessian 1178 IE2FORM = 1 1179*. Prepare for finite difference calc of Hessian 1180 KLIOOEXC_A = KIOOEXCC 1181 KLIOOEXC_S = KLOOEXCC_S 1182 KLKAPPA_A = KLKAPPA 1183 KLKAPPA_S = KLKAPPA+NOOEXC_A 1184 KL_C = KL_VEC1 1185* 1186*. IE2FORM Is not active at the moment 1187 IE2FORM = 1 1188 CALL ORBHES_VB(WORK(KLE2),IE2FORM) 1189* 1190*. Diagonalize to determine lowest eigenvalue 1191* 1192*. Outpack to complete form 1193 CALL TRIPAK(WORK(KLE2F),WORK(KLE2),2,NOOEXC,NOOEXC) 1194C TRIPAK(AUTPAK,APAK,IWAY,MATDIM,NDIM) 1195*. Lowest eigenvalue 1196C DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 1197 CALL DIAG_SYMMAT_EISPACK(WORK(KLE2F),WORK(KLE2VL), 1198 & WORK(KLE2SC),NOOEXC,IRETURN) 1199 IF(IRETURN.NE.0) THEN 1200 WRITE(6,*) 1201 & ' Problem with diagonalizing E2, IRETURN = ', IRETURN 1202 END IF 1203 IF(IPRNT.GE.1000) THEN 1204 WRITE(6,*) ' Eigenvalues: ' 1205 CALL WRTMAT(WORK(KLE2VL),1,NOOEXC,1,NOOEXC) 1206 END IF 1207 IF(NTEST.GE.1000) THEN 1208 WRITE(6,*) ' Eigenvectors of Hessian ' 1209 CALL WRTMAT(WORK(KLE2F),NOOEXC,NOOEXC, 1210 & NOOEXC,NOOEXC) 1211 END IF 1212*. Lowest eigenvalue 1213C XMNMX(VEC,NDIM,MINMAX) 1214 E2VL_MN = XMNMX(WORK(KLE2VL),NOOEXC,1) 1215 IF(NTEST.GE.2) 1216 & WRITE(6,*) ' Lowest eigenvalue of E2(orb) = ', E2VL_MN 1217 END IF !imic = 1 1218*. Transform gradient to diagonal basis 1219 IF(NTEST.GE.1000) THEN 1220 WRITE(6,*) ' Gradient in original basis before MATVCC' 1221 CALL WRTMAT(WORK(KLE1),1,NOOEXC,1,NOOEXC) 1222 END IF 1223 CALL MATVCC(WORK(KLE2F),WORK(KLE1),WORK(KLE2SC), 1224 & NOOEXC,NOOEXC,1) 1225 CALL COPVEC(WORK(KLE2SC),WORK(KLE1),NOOEXC) 1226*. Solve shifted NR equations with step control 1227 666 CONTINUE 1228 TOLER = 1.1D0 1229* SOLVE_SHFT_NR_IN_DIAG_BASIS( 1230* & E1,E2,NDIM,STEP_MAX,TOLERANCE,X,ALPHA)A 1231 CALL SOLVE_SHFT_NR_IN_DIAG_BASIS(WORK(KLE1),WORK(KLE2VL), 1232 & NOOEXC,STEP_MAX,TOLER,WORK(KLKAPPA),ALPHA,DELTA_E_PRED) 1233 XNORM_STEP = 1234 & SQRT(INPROD(WORK(KLKAPPA),WORK(KLKAPPA),NOOEXC)) 1235 WORK(KL_SUMMARY-1+(IMAC-1)*NITEM + 4) = XNORM_STEP 1236 IF(NTEST.GE.2) WRITE(6,*) ' Norm of step = ', XNORM_STEP 1237*. transform step to original basis 1238 CALL MATVCC(WORK(KLE2F),WORK(KLKAPPA),WORK(KLE2SC), 1239 & NOOEXC,NOOEXC,0) 1240 CALL COPVEC(WORK(KLE2SC),WORK(KLKAPPA),NOOEXC) 1241 IF(NTEST.GE.1000) THEN 1242 WRITE(6,*) ' Kappa in original basis ' 1243 CALL WRTMAT(WORK(KLKAPPA),1,NOOEXC,1,NOOEXC) 1244 END IF 1245*. Energy for new step: 1246 ENEW = E_VB_FROM_KAPPA_WRAP(WORK(KLKAPPA)) 1247 WRITE(6,*) ' Energy at new iteration point ', ENEW 1248*. Preliminary E_FINAL .. 1249 E_FINAL = ENEW 1250 THRESD = 1.0D-7 1251 IF(ENEW.GT.E_NORTCI+THRES) THEN 1252*. Step was to large, Decrease steplength and recalculate step 1253 STEP_MAX = STEP_MAX/2.0D0 1254 GOTO 666 1255 END IF 1256 1257* 1258*. Obtain New MO coefficients in MOAOUT: MOAOIN* Exp(-Kappa_A S) Exp(-Kappa_S S) 1259* 1260C NEWMO_FROM_KAPPA_NORT( 1261C & NOOEXC_A,IOOEXC_A,KAPPA_A, 1262C & NOOEXC_S,IOOEXC_S,KAPPA_S,CMOAO_IN,CMOAO_OUT) 1263 CALL NEWMO_FROM_KAPPA_NORT( 1264 & NOOEXC_A,WORK(KIOOEXCC),WORK(KLKAPPA), 1265 & NOOEXC_S,WORK(KLIOOEXC_S),WORK(KLKAPPA+NOOEXC_A), 1266 & WORK(KMOAOIN),WORK(KMOAOUT)) 1267*. And copy to KMOAOIN for next round 1268 CALL COPVEC(WORK(KMOAOUT),WORK(KMOAOIN),LEN1_F) 1269* 1270 IF(IPRNT.GE.100) THEN 1271 WRITE(6,*) ' Updated MOAO-coefficients' 1272 CALL APRBLM2(WORK(KMOAOUT),NTOOBS,NTOOBS,NSMOB,0) 1273 END IF 1274 IF(XNORM_STEP.LT.XKAP_THRES) THEN 1275 CONVER_NORTMC = .TRUE. 1276 GOTO 1001 1277 END IF 1278* 1279 END DO ! End of loop over microiterations 1280 END DO ! End of loop over macroiterations 1281 1001 CONTINUE 1282* 1283 IF(CONVER_NORTMC) THEN 1284 WRITE(6,*) ' Convergence was obtained in ', NMAC , ' iterations' 1285 ELSE 1286 WRITE(6,*) ' Convergence was not obtained ' 1287 END IF 1288* 1289 WRITE(6,*) ' Final energy = ', E_FINAL 1290* 1291 IF(IPRNT.GE.2) THEN 1292 WRITE(6,*) ' Optimized MOAO-coefficients:' 1293 WRITE(6,*) ' ============================' 1294 CALL PRINT_CMOAO(WORK(KMOAOUT)) 1295 END IF 1296* 1297* And construct the final density matrices 1298* 1299 CALL VB_DENSI(WORK(KRHO1),WORK(KRHO2),1,WORK(KL_VEC1), 1300 & WORK(KL_VEC2),WORK(KL_VEC3)) 1301*. Obtain natural orbitals and natural occupation numbers 1302*. 1: Metric over active orbitals 1303C SACT(SACT,C) 1304 CALL GET_SACT(WORK(KL_MACT),WORK(KMOAOUT)) 1305*. 2: and diagonalize using metric of active orbitals 1306C NONORT_NATORB(SACT,RHO1) 1307 CALL NONORT_NATORB(WORK(KL_MACT),WORK(KRHO1)) 1308* 1309* Analyze the CI- coefficients of the resulting wave function 1310* 1311C ANACSF(CIVEC,ICONF_OCC,NCONF_FOR_OPEN,IPROCS,THRES, 1312C & MAXTRM,IOUT) 1313 MAXTRM = 1000 1314 THRES = 0.03 1315 IOUT = 6 1316 NACTEL = NACTEL - 2*(IB_ORB_CONF-NINOB-1) 1317 CALL ANACSF(WORK(KL_VEC1),WORK(KICONF_OCC_GN(ICSM,ISPC_CNF)), 1318 & NCONF_PER_OPEN_GN(1,ICSM,ISPC_CNF), 1319 & WORK(KCFTP),THRES, MAXTRM,IOUT) 1320 NACTEL = NACTEL + 2*(IB_ORB_CONF-NINOB-1) 1321* 1322 WRITE(6,*) ' =======================' 1323 WRITE(6,*) ' Summary of convergence ' 1324 WRITE(6,*) ' =======================' 1325 WRITE(6,*) 1326 WRITE(6,*) 1327 &' Iter Energy Delta E E1-norm Step ' 1328 WRITE(6,*) 1329 &' ====================================================' 1330 DO IMAC = 1, NMAC 1331 II = KL_SUMMARY + (IMAC-1)*NITEM-1 1332 WRITE(6,'(2X, I3, 1X, F18.10,1X, E10.3, E10.3, E10.3)') 1333 & IMAC, WORK(II+1),WORK(II+2),WORK(II+3), WORK(II+4) 1334 END DO 1335* 1336 END IF ! I do MCSCF 1337* 1338 9999 CONTINUE 1339* 1340* 1341 CALL MEMMAN(IDUMMY,IDUMMY,'FLUSM ',IDUM,'NORTCI') 1342 RETURN 1343 END 1344 SUBROUTINE SIGMA_NORTCI(C,HC,SC,IDOHC,IDOSC) 1345* 1346* Routine for sigma-generation, nonorthogonal CI, using biortogonal 1347* approach. Integrals in biobasis assumed in place 1348* 1349* Initial version, Jeppe Olsen June 2011 1350* 1351 INCLUDE 'implicit.inc' 1352 INCLUDE 'mxpdim.inc' 1353 INCLUDE 'wrkspc-static.inc' 1354 INCLUDE 'crun.inc' 1355 INCLUDE 'cstate.inc' 1356 INCLUDE 'cands.inc' 1357 INCLUDE 'cicisp.inc' 1358 INCLUDE 'orbinp.inc' 1359 INCLUDE 'glbbas.inc' 1360 INCLUDE 'spinfo.inc' 1361 INCLUDE 'cintfo.inc' 1362 INCLUDE 'oper.inc' 1363 INCLUDE 'cecore.inc' 1364 INCLUDE 'intform.inc' 1365 INCLUDE 'lucinp.inc' 1366 INCLUDE 'vb.inc' 1367*. Two local scratch files 1368 COMMON/SCRFILES_MATVEC/LUSCR1,LUSCR2,LUSCR3, 1369 & LUCBIO_SAVE, LUHCBIO_SAVE,LUC_SAVE 1370*. Input: C in CSF basis, configuration space ICSPC_CN 1371*. Output: Sigma CSF basis, configuration space ISSPC_CN 1372*. Output files 1373 DIMENSION HC(*), SC(*) 1374* 1375 DIMENSION C(*) 1376* 1377 IDUM = 0 1378 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'NOCISI') 1379* 1380 NTEST = 00 1381 IF(NTEST.GE.10) THEN 1382 WRITE(6,*) 1383 WRITE(6,*) ' Output from SIGMA_NORTCI' 1384 WRITE(6,*) ' ========================' 1385 WRITE(6,*) 1386 IF(IDOHC.EQ.1) WRITE(6,*) ' HC will be calculated ' 1387 IF(IDOSC.EQ.1) WRITE(6,*) ' SC will be calculated' 1388 WRITE(6,*) 1389 WRITE(6,*) ' CI and MINMAX space for C ', ICSPC,ICSPC_CN 1390 WRITE(6,*) ' CI and MINMAX space for S ', ISSPC,ISSPC_CN 1391 WRITE(6,*) ' CI and MINMAX space, Intermediate ', IMSPC,IMSPC_CN 1392* 1393 IF(NORT_MET.EQ.1) THEN 1394 WRITE(6,*) 'Approach based on reexpansion in GASpace ' 1395 ELSE IF (NORT_MET.EQ.2) THEN 1396 WRITE(6,*) ' Approach using initial configuration routines' 1397 END IF 1398* 1399 END IF 1400*. This routine does all the CSF-SD transformation explicitly, 1401*. so fool inner routines, especially MV7, to believe that we 1402*. are working with SD's 1403 NOCSF_SAVE = NOCSF 1404 NOCSF = 1 1405* 1406 NCSF_CSPC_CNF = NCSF_PER_SYM_GN(ICSM,ICSPC_CN) 1407 IF(NTEST.GE.100) THEN 1408 WRITE(6,*) ' Input vector in CSF basis ' 1409 CALL WRTMAT(C,1,NCSF_CSPC_CNF,1,NCSF_CSPC_CNF) 1410 END IF 1411* 1412 IF(NORT_MET.EQ.1) THEN 1413* 1414* Initial version, with standard FCI behind the screen (and you are pt 1415* behind the screen...) 1416* The route 1417* 1418* 1) Obtain Input state in biortogonal basis in space IMSPC_CN - 1419* in Slater determinants 1420* 2) Obtain Hamiltonian times input state in bioorthogonal basis 1421* 1422* In the initial version step 1 consists of 1423* 1.1) Transform C from CSF to SD in CI ICSPC_CN 1424* 1.2) Expand C in SD from from SPACE ICSPC_CN to space ICSPC 1425* 1.3) Calculate biortogonal C-vector 1426* in CI space IMSPC 1427* 1.4) Contract bioorthogonal C-vector from space IMSPC to IMSPC_CN 1428* whereas step 2 consists of 1429* 2.1) Expand Bioorthogonal C-vector from space IMSPC_CN to IMSPC 1430* 2.2) calculate biorthogonal sigma-vector in space ISSPC 1431* 2.2) Contract bioothogonal sigma-vector to space ISSPC_CN 1432* 2.3) Transform sigma-vector from SD to CSF-basis 1433* 1434* The SC-vector is obtained from step 1.4 1435* 1436 ICSPC_ORIG = ICSPC 1437 ISSPC_ORIG = ISSPC 1438 IMSPC_ORIG = IMSPC 1439 ICSM_ORIG = ICSM 1440 ISSM_ORIG = ISSM 1441* 1442*. The CI space are actually assumed to be identical 1443 1444* ========= 1445*. Step 1 1446* ========= 1447* 1448* 1.1) Transform C from CSF to SD in CI ICSPC_CN 1449* 1450* Allocate space for output CI vector in SD basis in config basis 1451* 1452 NSD_CSPC_CNF = NSD_PER_SYM_GN(ICSM,ICSPC_CN) 1453* 1454 NSD = NSD_CSPC_CNF 1455 NCSF = NCSF_CSPC_CNF 1456* 1457 CALL MEMMAN(KLC_SD,NSD_CSPC_CNF,'ADDL ',2,'C_SD ') 1458 CALL MEMMAN(KLVCI ,NSD_CSPC_CNF,'ADDL ',2,'VCI ') 1459*. Expand Input C vector from CSD to SD form 1460 CALL COPVEC(C,WORK(KLVCI),NCSF_CSPC_CNF) 1461C CSDTVCM(CSFVEC,DETVEC,IWAY,ICOPY,ISYM,ICSPC,IMAXMIN_OR_GAS) 1462 XDUM = 0.0D0 1463 CALL CSDTVCM(WORK(KLVCI),WORK(KLC_SD),XDUM,1,0,ICSM,ICSPC_CN,1) 1464* 1465* 1.2) Expand C in SD from SPACE ICSPC_CN to space ICSPC 1466* 1467*.Obtain number and length of blocks of expansion 1468 CALL MEMMAN(KLBLK,MXNTTS,'ADDL ',1,'LBLKCI') 1469C LBLOCK_FOR_CIXP(LBLOCK,NBLOCK,ICISPC,ISYM) 1470 CALL LBLOCK_FOR_CIXP(WORK(KLBLK),NBLOCK_C,ICSPC,ICSM) 1471C SCA_VEC_TO_BLKV_DISC(VEC,ISCA,NELMNT,LUOUT,NBLOCK,LBLOCK,VECBLK,IREW) 1472 IF(NTEST.GE.10) WRITE(6,*) ' I will CALL SCA_VEC ... ' 1473 CALL SCA_VEC_TO_BLKV_DISC(WORK(KLC_SD), 1474 & WORK(KSDREO_I_GN(ICSM,ICSPC_CN)), 1475 & NSD_CSPC_CNF,LUSCR1,NBLOCK_C,WORK(KLBLK),WORK(KVEC1P),1) 1476 IF(NTEST.GE.10) WRITE(6,*) ' Home from SCAVEC .... ' 1477 IF(NTEST.GE.1000) THEN 1478 WRITE(6,*) ' Input C-vector in GAS space form ' 1479 CALL WRTVCD(WORK(KVEC1P),LUSCR1,1,-1) 1480 END IF 1481* 1482* 1.3) Calculate biortogonal C-vector in CI space IMSPC 1483* 1484*. Expand CI vector to space IMSPC 1485 CALL EXPCIV(ICSM,ICSPC,LUSCR1,IMSPC,LUSCR2,-1,LUSCR3,1,1,IDC, 1486 & NTEST) 1487C EXPCIV(ISM,ISPCIN,LUIN,ISPCUT,LUUT,LBLK,LUSCR,NROOT,ICOPY,IDC,NTESTG) 1488 IF(NTEST.GE.10) WRITE(6,*) ' Back from EXPCIV I' 1489*. And then do the transformation defined by KCBIO 1490*. Save one-electron integrals 1491 IF(IH1FORM.EQ.1) THEN 1492 IPACK_H1 = 1 1493 ELSE 1494 IPACK_H1 = 0 1495 END IF 1496C NDIM_1EL_MAT(IHSM,NRPSM,NCPSM,NSM,IPACK) 1497 LEN_H1 = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,IPACK_H1) 1498 CALL MEMMAN(KLH1SAVE,NTOOB**2,'ADDL ',2,'H1SAVE') 1499 CALL COPVEC(WORK(KINT1),WORK(KLH1SAVE),LEN_H1) 1500*. Ecore is now adays included in MV7( called in TRACI) --hide it 1501 ECORE_SAVE = ECORE 1502 ECORE = 0.0D0 1503* 1504 IF(LUC_SAVE.NE.0) THEN 1505C? WRITE(6,*) ' C in orig base will be saved in unit ', LUC_SAVE 1506 CALL COPVCD(LUSCR1,LUC_SAVE,WORK(KVEC1P),1,-1) 1507 END IF 1508 CALL REWINO(LUSCR2) 1509*. biotransform and save result in LUSCR2 1510 IF(NTEST.GE.1000) WRITE(6,*) ' Traci will be called ' 1511 CALL TRACI(WORK(KCBIO),LUSCR1,LUSCR2,IMSPC,ICSM, 1512 & WORK(KVEC1P),WORK(KVEC2P)) 1513 IF(NTEST.GE.1000) WRITE(6,*) ' Home from Traci ' 1514 IF(NTEST.GE.1000) THEN 1515 WRITE(6,*) ' C in biobase, SD expansion ' 1516 CALL WRTVCD(WORK(KVEC1P),LUSCR2,1,-1) 1517 END IF 1518C TRACI(X,LUCIN,LUCOUT,IXSPC,IXSM,VEC1,VEC2) 1519 ECORE = ECORE_SAVE 1520 CALL COPVEC(WORK(KLH1SAVE),WORK(KINT1),LEN_H1) 1521 IF(NTEST.GE.1000) WRITE(6,*) ' Back from TRACI ' 1522 CALL LBLOCK_FOR_CIXP(WORK(KLBLK),NBLOCK_M,IMSPC,ICSM) 1523* 1524 IF(LUCBIO_SAVE.NE.0) THEN 1525C? WRITE(6,*) ' C in biobase will be saved in unit ', LUCBIO_SAVE 1526 CALL COPVCD(LUSCR2,LUCBIO_SAVE,WORK(KVEC1P),1,-1) 1527 END IF 1528 IF(IDOSC.EQ.1) THEN 1529* Obtain the metric vector = <i!0> in space ICSPC_CNF 1530 CALL GAT_VEC_FROM_BLKV_DISC(WORK(KLC_SD), 1531 & WORK(KSDREO_I_GN(ICSM,ICSPC_CN)), 1532 & NSD_CSPC_CNF,LUSCR2,NBLOCK_M,WORK(KLBLK),WORK(KVEC1P),1) 1533 IF(NTEST.GE.10) WRITE(6,*) ' Back from GAT_VEC ' 1534*. And transform to CSF basis 1535C CSDTVCM(CSFVEC,DETVEC,IWAY,ICOPY,ISYM,ISPC,IMAXMIN_OR_GAS) 1536 XDUM = 0.0D0 1537 CALL CSDTVCM(WORK(KLVCI),WORK(KLC_SD),XDUM,2,0,ICSM,ICSPC_CN,1) 1538 CALL COPVEC(WORK(KLVCI),SC,NCSF) 1539 IF(NTEST.GE.10) THEN 1540 WRITE(6,*) ' Back from CSDTVCM ' 1541 END IF 1542 END IF 1543 IF(IDOHC.EQ.1) THEN 1544*. Obtain the transformed vector for the determinants of space IMSPC_CN 1545 CALL LBLOCK_FOR_CIXP(WORK(KLBLK),NBLOCK_M,IMSPC,ICSM) 1546 NSD_MSPC_CNF = NSD_PER_SYM_GN(ICSM,IMSPC_CN) 1547 CALL MEMMAN(KLCM_SD,NSD_MSPC_CNF,'ADDL ',2,'CM_SD ') 1548 CALL GAT_VEC_FROM_BLKV_DISC(WORK(KLCM_SD), 1549 & WORK(KSDREO_I_GN(ICSM,IMSPC_CN)), 1550 & NSD_MSPC_CNF,LUSCR2,NBLOCK_M,WORK(KLBLK),WORK(KVEC1P),1) 1551C GAT_VEC_FRM_BLKV_DISC(VEC,ISCA,NELMNT,LUIN,NBLOCK,LBLOCK,VECBLK,IREW) 1552 IF(NTEST.GE.1000) THEN 1553 WRITE(6,*) ' Biotransformed C in Intermediate CN space ' 1554 CALL WRTMAT(WORK(KLCM_SD),1,NSD_MSPC_CNF,1,NSD_MSPC_CNF) 1555 WRITE(6,*) ' SIGMA_NORTCI speaking, end of step 1: ' 1556 END IF 1557 END IF 1558* 1559* ====== 1560* Step 2 1561* ====== 1562* 1563 IF(IDOHC.EQ.1) THEN 1564* 2.1) Expand Bioorthogonal C-vector from space IMSPC_CN to IMSPC 1565 CALL SCA_VEC_TO_BLKV_DISC(WORK(KLCM_SD), 1566 & WORK(KSDREO_I_GN(ICSM,IMSPC_CN)), 1567 & NSD_MSPC_CNF,LUSCR1,NBLOCK_M,WORK(KLBLK),WORK(KVEC1P),1) 1568* 2.2) calculate biorthogonal sigma-vector in space ISSPC 1569* 1570 ICSPC = IMSPC_ORIG 1571 ISSPC = ISSPC_ORIG 1572 I12 = 2 1573 XDUM = 3006.1956D0 1574 CALL MV7(WORK(KVEC1P),WORK(KVEC2P),LUSCR1,LUSCR2,XDUM,XDUM) 1575 IF(NTEST.GE.1000) THEN 1576 WRITE(6,*) ' HC in Biobase ' 1577 CALL WRTVCD(WORK(KVEC1P),LUSCR2,1,-1) 1578 END IF 1579 IF(LUHCBIO_SAVE.NE.0) THEN 1580C? WRITE(6,*) ' HC in biobase will be saved in unit ', LUHCBIO_SAVE 1581 CALL COPVCD(LUSCR2,LUHCBIO_SAVE,WORK(KVEC1P),1,-1) 1582 END IF 1583* 2.2) Contract biothogonal sigma-vector to space ISSPC_CN 1584 CALL LBLOCK_FOR_CIXP(WORK(KLBLK),NBLOCK_S,ISSPC,ISSM) 1585 NSD_SSPC_CNF = NSD_PER_SYM_GN(ISSM,ISSPC_CN) 1586 CALL MEMMAN(KLSS_SD,NSD_SSPC_CNF,'ADDL ',2,'SS_SD ') 1587 CALL GAT_VEC_FROM_BLKV_DISC(WORK(KLSS_SD), 1588 & WORK(KSDREO_I_GN(ISSM,ISSPC_CN)), 1589 & NSD_SSPC_CNF,LUSCR2,NBLOCK_S,WORK(KLBLK),WORK(KVEC1P),1) 1590* 2.3) Transform sigma-vector from SD to CSF-basis 1591 XDUM = 0.0D0 1592 CALL CSDTVCM(WORK(KLVCI),WORK(KLSS_SD),XDUM,2,0,ISSM,ISSPC_CN,1) 1593C CSDTVCM(CSFVEC,DETVEC,IWAY,ICOPY,ISYM,ISPC,IMAXMIN_OR_GAS) 1594 CALL COPVEC(WORK(KLVCI),HC,NCSF) 1595 END IF 1596* 1597 ELSE IF (NORT_MET.EQ.2) THEN 1598* 1599* 1:. Perform Bioorthogonal transformation of C from space ISPC_CN to 1600* space IMSPC_CN. It is required that the spaces for for the individual steps 1601* have been defined in IORBTRA_SPC_IN, IORBTRA_SPC_OUT 1602*. Pt evrything is in CORE 1603* 1604* 1605 ICISTR = 1 1606 IF(NTEST.GE.10) 1607 & WRITE(6,*) 1608 & ' TRACI_CONF will be called to perform orbital transformation' 1609 LUC = 0 1610 LUS = 0 1611*. TRACI_CONF modifies input vector, so 1612 NCSF_C = NCSF_PER_SYM_GN(ICSM,ICSPC_CN) 1613 NCSF_S = NCSF_PER_SYM_GN(ISSM,ISSPC_CN) 1614 NCSF_CS = MAX(NCSF_C,NCSF_S) 1615 CALL MEMMAN(KLC_CSF,NCSF_MNMX_MAX,'ADDL ',2,'C_CSF ') 1616 WRITE(6,*) ' TEST: ICSM, ICSPC_CN, NCSF_C = ', 1617 & ICSM, ICSPC_CN, NCSF_C 1618*. 1619*. Obtained transformed vector in C_CSF 1620 CALL COPVEC(C,SC,NCSF_C) 1621 IF(NTEST.GE.1000) THEN 1622 WRITE(6,*) ' Input C vector (CSF basis) ' 1623 CALL WRTMAT(C, NCSCF_C, 1, NCSCF_C, 1) 1624 WRITE(6,*) 1625 END IF 1626 CALL TRACI_CONF(SC,WORK(KLC_CSF),LUC,LUS) 1627C TRACI_CONF(C,S,LUC,LUHC) 1628 IF(NTEST.GE.1000) THEN 1629 NCSF_M = NCSF_PER_SYM_GN(ISSM,IMSPC_CNF) 1630 WRITE(6,*) ' IMSPC_CNF, NCSF_M = ', IMSPC_CNF, NCSF_M 1631 CALL WRTMAT(WORK(KLC_CSF),1,NCSF_M,1,NCSF_M) 1632 END IF 1633*. Extract metric in initial space 1634 IF(NTEST.GE.10) WRITE(6,*) 1635 & ' REF_CNFVEC will be called to get metric times initial vector' 1636C REF_CNFVEC(VECIN,ISPCIN,VECOUT,ISPCOUT,ISYM) 1637 CALL REF_CNFVEC(WORK(KLC_CSF),IMSPC_CN,SC,ICSPC_CN,ICSM) 1638 IF(NTEST.GE.10) WRITE(6,*) ' Returned from REF_CNFVEC' 1639*. And then do the Sigma from M space to S space 1640 IF(IDOHC.EQ.1) THEN 1641 ICSPC_CN_SAVE = ICSPC_CN 1642 ISSPC_CN_SAVE = ISSPC_CN 1643 ICSPC_CN = IMSPC_CN 1644 ISSPC_CN = ISSPC_CN 1645 LUC = 0 1646 LUHC = 0 1647 CALL SIGMA_CONF(WORK(KLC_CSF),HC,LUC,LUHC) 1648 IF(NTEST.GE.1000) WRITE(6,*) ' Home from SIGMA_CONF' 1649*. And restore 1650 ICSPC_CN = ICSPC_CN_SAVE 1651 ISSPC_CN = ISSPC_CN_SAVE 1652 END IF !DOHC = 1 1653 END IF! switch between different algorithms 1654* 1655C? WRITE(6,*) ' TEST, NTEST = ', NTEST 1656 IF(NTEST.GE.100) THEN 1657 NCSF_SSPC_CNF = NCSF_PER_SYM_GN(ISSM,ISSPC_CN) 1658* 1659 WRITE(6,*) ' Final vectors from SIGMA_NORTCI ' 1660 WRITE(6,*) ' ================================' 1661 IF(IDOSC.EQ.1) THEN 1662 WRITE(6,*) ' Metric times C vector: ' 1663 CALL WRTMAT(SC,1,NCSF_SSPC_CNF,1,NCSF_SSPC_CNF) 1664 END IF 1665* 1666 IF(IDOHC.EQ.1) THEN 1667 WRITE(6,*) ' Hamiltonian times C vector: ' 1668 CALL WRTMAT(HC,1,NCSF_SSPC_CNF,1,NCSF_SSPC_CNF) 1669 END IF 1670 END IF 1671*. And clean up 1672 NOCSF = NOCSF_SAVE 1673* 1674 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'NOCISI') 1675 WRITE(6,*) ' Returning from SIGMA_NORTCI' 1676COLD STOP ' Enforced stop at end of SIGMA_NORTCI' 1677 RETURN 1678 END 1679 SUBROUTINE SCA_VEC_TO_BLKV_DISC(VEC,ISCA,NELMNT,LUOUT,NBLOCK, 1680 & LBLOCK,VECBLK,IREW) 1681* A vector is given in compact as elements and scatter array. 1682* Write this vector to disc, FILE LUOUT, in blocked form as defined by LBLOCK. 1683* Vecblk shoul be able to hold largest block 1684* 1685*. Jeppe Olsen, June 2011 1686* 1687 INCLUDE 'implicit.inc' 1688 DIMENSION VEC(NELMNT), VECBLK(*) 1689 INTEGER LBLOCK(NBLOCK), ISCA(NELMNT) 1690* 1691 NTEST = 0 1692 IF(NTEST.GE.10) THEN 1693 WRITE(6,*) ' Output from SCA_VEC_TO_BLKV_DISC ' 1694 WRITE(6,*) ' LUOUT, IREW = ', LUOUT, IREW 1695 END IF 1696 IF(NTEST.GE.1000) THEN 1697 WRITE(6,*) ' ISCA: ' 1698 CALL IWRTMA(ISCA,1,NELMNT,1,NELMNT) 1699 WRITE(6,*) ' LBLOCK: ' 1700 CALL IWRTMA(LBLOCK,1,NBLOCK,1,NBLOCK) 1701 WRITE(6,*) ' Input vector: ' 1702 CALL WRTMAT(VEC,1,NELMNT,1,NELMNT) 1703 END IF 1704* 1705 IF(IREW.EQ.1) THEN 1706 CALL REWINO(LUOUT) 1707 END IF 1708* 1709 IB_BL = 1 1710 DO IBLOCK = 1, NBLOCK 1711 LEN_BL = LBLOCK(IBLOCK) 1712 IF(NTEST.GE.1000) THEN 1713 WRITE(6,*) ' IBLOCK, LEN_BLK = ', IBLOCK, LEN_BL 1714 END IF 1715* 1716 ZERO = 0.0D0 1717 CALL SETVEC(VECBLK,ZERO,LEN_BL) 1718* 1719*. Find and copy elements in input vector that are in block IBLOCK 1720 DO IELMNT = 1, NELMNT 1721 JSCA = ISCA(IELMNT) 1722 JSCA_ABS = IABS(JSCA) 1723 IF(NTEST.GE.10000) WRITE(6,*) ' IELMNT, JSCA, JSCA_ABS =', 1724 & IELMNT, JSCA, JSCA_ABS 1725 IF(IB_BL.LE.JSCA_ABS.AND.JSCA_ABS.LE.IB_BL+LEN_BL-1) THEN 1726* Element is in block 1727 IF(NTEST.GE.10000) THEN 1728 WRITE(6,*) ' Element in block, IELMNT, JSCA', IELMNT,JSCA 1729 WRITE(6,*) ' Output address = ', JSCA_ABS-IB_BL + 1 1730 END IF 1731 IF(JSCA.GT.0) THEN 1732 VECBLK(JSCA_ABS-IB_BL + 1) = VEC(IELMNT) 1733 ELSE 1734 VECBLK(JSCA_ABS-IB_BL + 1) =-VEC(IELMNT) 1735 END IF 1736 END IF 1737 END DO 1738*. Write block to disc 1739 CALL ITODS(LEN_BL,1,-1,LUOUT) 1740 CALL TODSCP(VECBLK,LEN_BL,-1,LUOUT) 1741 IB_BL = IB_BL + LEN_BL 1742 END DO! End of loop over blocks 1743*. Write end of file 1744 CALL ITODS(-1,1,-1,LUOUT) 1745* 1746 RETURN 1747 END 1748 SUBROUTINE GAT_VEC_FROM_BLKV_DISC(VEC,ISCA,NELMNT,LUIN,NBLOCK, 1749 & LBLOCK,VECBLK,IREW) 1750* A vector is given in disc, file LUIN, with block-structure defined by LBLOCK 1751* Obtain elements given by scatter vector ISCA 1752* Vecblk shoul be able to hold largest block 1753* 1754*. Jeppe Olsen, June 2011 1755* 1756 INCLUDE 'implicit.inc' 1757 DIMENSION VEC(NELMNT), VECBLK(*) 1758 INTEGER LBLOCK(NBLOCK), ISCA(NELMNT) 1759* 1760 NTEST = 000 1761 IF(NTEST.GE.10) THEN 1762 WRITE(6,*) ' Output from GAT_VEC_TO_BLKV_DISC ' 1763 WRITE(6,*) ' LUIN, IREW = ', LUIN, IREW 1764 END IF 1765 IF(NTEST.GE.1000) THEN 1766 WRITE(6,*) ' ISCA: ' 1767 CALL IWRTMA(ISCA,1,NELMNT,1,NELMNT) 1768 WRITE(6,*) ' LBLOCK: ' 1769 CALL IWRTMA(LBLOCK,1,NBLOCK,1,NBLOCK) 1770 WRITE(6,*) ' Initial vector on disc ' 1771 CALL WRTVCD(VECBLK,LUIN,1,-1) 1772 END IF 1773* 1774 IF(IREW.EQ.1) THEN 1775 CALL REWINO(LUIN) 1776 END IF 1777* 1778 IB_BL = 1 1779 DO IBLOCK = 1, NBLOCK 1780 LEN_BL = LBLOCK(IBLOCK) 1781*. Obtain block 1782 CALL IFRMDS(LBL,1,-1,LUIN) 1783 IF(LBL.NE.LEN_BL) THEN 1784 WRITE(6,*) 1785 & ' Difference between expected and actual block sizes', 1786 & LEN_BL, LBL 1787 STOP 1788 & ' Difference between expected and actual block sizes' 1789 END IF 1790 NO_ZEROING = 0 1791 CALL FRMDSC2(VECBLK,LBL,-1,LUIN,IMZERO,IAMPACK, 1792 & NO_ZEROING) 1793*. Find and copy elements from input vector that are in block IBLOCK 1794 DO IELMNT = 1, NELMNT 1795 JSCA = ISCA(IELMNT) 1796 JSCA_ABS = IABS(JSCA) 1797 IF(IB_BL.LE.JSCA_ABS.AND.JSCA_ABS.LE.IB_BL+LEN_BL-1) THEN 1798* Element is in block 1799 IF(JSCA.GT.0) THEN 1800 VEC(IELMNT) = VECBLK(JSCA_ABS-IB_BL + 1) 1801 ELSE 1802 VEC(IELMNT) =-VECBLK(JSCA_ABS-IB_BL + 1) 1803 END IF 1804 END IF 1805 END DO 1806 IB_BL = IB_BL + LEN_BL 1807 END DO! End of loop over blocks 1808* 1809 IF(NTEST.GE.100) THEN 1810 WRITE(6,*) ' Vector gathered from DISC ' 1811 CALL WRTMAT(VEC,1,NELMNT,1,NELMN) 1812 END IF 1813* 1814 RETURN 1815 END 1816 SUBROUTINE LBLOCK_FOR_CIXP(LBLOCK,NBLOCK,ICISPC,ISYM) 1817* 1818* Obtain number of blocks and lengths of blocks for CI expansion 1819* in space ICISPC and symmetry ISYM 1820* 1821* Jeppe Olsen, June 2011 1822* 1823 INCLUDE 'implicit.inc' 1824 INCLUDE 'mxpdim.inc' 1825 INCLUDE 'wrkspc-static.inc' 1826 INCLUDE 'gasstr.inc' 1827 INCLUDE 'stinf.inc' 1828 INCLUDE 'cgas.inc' 1829 INCLUDE 'orbinp.inc' 1830 INCLUDE 'cicisp.inc' 1831 INCLUDE 'strbas.inc' 1832 INCLUDE 'cstate.inc' 1833 INCLUDE 'csm.inc' 1834* 1835 NTEST = 000 1836* 1837 IDUM = 0 1838 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'LBLCIX') 1839* 1840* Number of occupation classes 1841* 1842 IATP = 1 1843 IBTP = 2 1844* 1845 NOCTPA = NOCTYP(IATP) 1846 NOCTPB = NOCTYP(IBTP) 1847* 1848 NAEL = NELFTP(IATP) 1849 NBEL = NELFTP(IBTP) 1850 NEL = NAEL + NBEL 1851* 1852 IWAY = 1 1853 CALL OCCLS(1,NOCCLS,IOCCLS,NEL,NGAS, 1854 & IGSOCC(1,1),IGSOCC(1,2),0,0,NOBPT) 1855*. and the occupation classes 1856 CALL MEMMAN(KLOCCLS,NGAS*NOCCLS,'ADDL ',1,'KLOCCL') 1857 CALL MEMMAN(KLBASSPC,NOCCLS,'ADDL ',1,'BASSPC') 1858 IWAY = 2 1859 CALL OCCLS(2,NOCCLS,WORK(KLOCCLS),NEL,NGAS, 1860 & IGSOCC(1,1),IGSOCC(1,2),1,WORK(KLBASSPC),NOBPT) 1861*. Allocate space for largest encountered number of TTSS blocks 1862 NTTS = MXNTTS 1863C WRITE(6,*) ' GASCI : NTTS = ', NTTS 1864*. 1865 CALL MEMMAN(KLCLBT ,NTTS ,'ADDL ',1,'CLBT ') 1866 CALL MEMMAN(KLCLEBT ,NTTS ,'ADDL ',1,'CLEBT ') 1867 CALL MEMMAN(KLCI1BT,NTTS ,'ADDL ',1,'CI1BT ') 1868 CALL MEMMAN(KLCIBT ,8*NTTS,'ADDL ',1,'CIBT ') 1869 CALL MEMMAN(KLC2B , NTTS,'ADDL ',1,'C2BT ') 1870 CALL MEMMAN(KLCIOIO,NOCTPA*NOCTPB,'ADDL ',2,'CIOIO ') 1871 CALL MEMMAN(KLCBLTP,NSMST,'ADDL ',2,'CBLTP ') 1872*. Matrix giving allowed combination of alpha- and beta-strings 1873 CALL IAIBCM(ICISPC,WORK(KLCIOIO)) 1874*. option KSVST not active so 1875 KSVST = 1 1876 CALL ZBLTP(ISMOST(1,ISYM),NSMST,IDC,WORK(KLCBLTP),WORK(KSVST)) 1877*. Blocks of CI vector, using a single batch for complete expansion 1878 ICOMP = 1 1879 ISIMSYM = 1 1880 CALL PART_CIV2(IDC,WORK(KLCBLTP),WORK(KNSTSO(IATP)), 1881 & WORK(KNSTSO(IBTP)), 1882 & NOCTPA,NOCTPB,NSMST,LBLOCK,WORK(KLCIOIO), 1883 & ISMOST(1,ISYM), 1884 & NBATCH,WORK(KLCLBT),WORK(KLCLEBT), 1885 & WORK(KLCI1BT),WORK(KLCIBT),ICOMP,ISIMSYM) 1886*. Number of BLOCKS 1887 NBLOCK = IFRMR(WORK(KLCI1BT),1,NBATCH) 1888 & + IFRMR(WORK(KLCLBT),1,NBATCH) - 1 1889 IF(NTEST.GE.1000) WRITE(6,*) ' Number of blocks ', NBLOCK 1890*. And the lengths of the various blocks 1891* 1892 CALL EXTRROW(WORK(KLCIBT),8,8,NBLOCK,LBLOCK) 1893* 1894 IF(NTEST.GE.100) THEN 1895 WRITE(6,*) ' Info in CI space ', ICISPC, ' with sym ', ISYM 1896 WRITE(6,*) ' ==============================================' 1897 WRITE(6,*) 1898 WRITE(6,*) ' Number of blocks: ', NBLOCK 1899 WRITE(6,*) ' Length of each block: ' 1900 CALL IWRTMA(LBLOCK,1,NBLOCK,1,NBLOCK) 1901 END IF 1902* 1903 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'LBLCIX') 1904* 1905 RETURN 1906 END 1907 SUBROUTINE MINMAX_EXCIT(IOCC_MIN_IN,IOCC_MAX_IN,NEXCIT, 1908 & IOCC_MIN_OUT,IOCC_MAX_OUT,NORB) 1909* 1910* A CI space is defined by accumulated occations IOCC_MIN_IN, IOCC_MAX_IN. 1911* Apply NEXCIT excitations to this space to obtain IOCC_MIN_OUT,IOCC_MAX_OUT 1912* 1913* Jeppe Olsen, June 2011 1914* 1915 INCLUDE 'implicit.inc' 1916*. Input 1917 INTEGER IOCC_MIN_IN(NORB),IOCC_MAX_IN(NORB) 1918*. Output 1919 INTEGER IOCC_MIN_OUT(NORB),IOCC_MAX_OUT(NORB) 1920* 1921 NTEST = 00 1922* 1923 NELEC = IOCC_MIN_IN(NORB) 1924 DO IORB = 1, NORB 1925 IOCC_MIN_OUT(IORB) = 1926 & MAX(0,IOCC_MIN_IN(IORB)-NEXCIT,NELEC-2*(NORB-IORB)) 1927 IOCC_MAX_OUT(IORB) = MIN(2*IORB,NELEC,IOCC_MAX_IN(IORB)+NEXCIT) 1928 END DO 1929* 1930 IF(NTEST.GE.100) THEN 1931 WRITE(6,*) ' Info from MINMAX_EXCIT ' 1932 WRITE(6,*) ' ====================== ' 1933 WRITE(6,*) ' allowed excitation level = ', NEXCIT 1934 WRITE(6,*) ' Input occupation constraints ' 1935 CALL WRT_MINMAX_OCC(IOCC_MIN_IN,IOCC_MAX_IN,NORB) 1936 WRITE(6,*) ' Output occupation constraints ' 1937 CALL WRT_MINMAX_OCC(IOCC_MIN_OUT,IOCC_MAX_OUT,NORB) 1938 END IF 1939* 1940 RETURN 1941 END 1942 SUBROUTINE WRT_MINMAX_OCC(IOCC_MIN,IOCC_MAX,NORB) 1943* 1944* Write min and max accumulated occupation arrays 1945* 1946*. Jeppe Olsen, June 2011 1947* 1948 INCLUDE 'implicit.inc' 1949*. Input 1950 INTEGER IOCC_MIN(NORB),IOCC_MAX(NORB) 1951* 1952 WRITE(6,*) ' Min and Max accumulated occupations: ' 1953 WRITE(6,*) 1954 WRITE(6,*) ' Orbital Min. occ Max. occ ' 1955 WRITE(6,*) ' ==========================' 1956 DO IORB = 1, NORB 1957 WRITE(6,'(3X,I4,2(4X,I4))') 1958 & IORB, IOCC_MIN(IORB), IOCC_MAX(IORB) 1959 END DO 1960* 1961 RETURN 1962 END 1963 SUBROUTINE PRECOND_NORTCI 1964* 1965* Jeppe Olsen, June 2011 1966* 1967 INCLUDE 'implicit.inc' 1968* 1969 WRITE(6,*) ' Dummy PRECOND_NORTCI entered' 1970 STOP ' Dummy PRECOND_NORTCI entered' 1971* 1972 1973 END 1974 SUBROUTINE GET_CBIO(C,CBIOMO,CBIOAO) 1975* A MO-AO transformation matrix, C, to a (non-orthogonal) basis is given. 1976* Obtain the corresponding bioorthogonal transformation matrix CBIOMO 1977* (Bio = > MO's in C) and CBIOAO (Bio => AO'S) 1978* 1979* Jeppe Olsen, July 2011 for the nonorthogonal CI work 1980* 1981 INCLUDE 'implicit.inc' 1982 INCLUDE 'mxpdim.inc' 1983 INCLUDE 'wrkspc-static.inc' 1984 INCLUDE 'orbinp.inc' 1985 INCLUDE 'lucinp.inc' 1986 INCLUDE 'glbbas.inc' 1987*. Input 1988 DIMENSION C(*) 1989*. Output 1990 DIMENSION CBIOMO(*), CBIOAO(*) 1991* 1992 NTEST = 00 1993* 1994 IDUM = 0 1995 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GET_CB') 1996* 1997C NDIM_1EL_MAT(IHSM,NRPSM,NCPSM,NSM,IPACK) 1998 LEN_M = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 1999 CALL MEMMAN(KLSAOE,LEN_M,'ADDL ',2,'SAO_E ') 2000 CALL MEMMAN(KLMSCR,LEN_M,'ADDL ',2,'MSCR ') 2001 CALL MEMMAN(KLSCR,2*LEN_M,'ADDL ',2,'SCR ') 2002*. Expand SAO 2003 CALL TRIPAK_AO_MAT(WORK(KLSAOE),WORK(KSAO),2) 2004 IF(NTEST.GE.1000) THEN 2005 WRITE(6,*) ' Expanded SAO ' 2006 CALL APRBLM2(WORK(KLSAOE),NTOOBS,NTOOBS,NSMOB,0) 2007 END IF 2008*. Obtain Metric in MO-basis, SMO, in CBIOAO 2009C TRAN_SYM_BLOC_MAT4(AIN,XL,XR,NBLOCK,LX_ROW,LX_COL,AOUT,SCR,ISYM) 2010 CALL TRAN_SYM_BLOC_MAT4(WORK(KLSAOE),C,C,NSMOB,NTOOBS,NTOOBS, 2011 &CBIOAO,WORK(KLSCR),0) 2012C CBIOMO = SMO ** -1 2013 IPROBLEM = 0 2014C INV_BLKMT(A,AINV,SCR,NBLK,LBLK,IPROBLEM) 2015 CALL INV_BLKMT(CBIOAO,CBIOMO,WORK(KLSCR),NSMOB,NTOOBS, 2016 & IPROBLEM) 2017 IF(IPROBLEM.NE.0) THEN 2018 WRITE(6,*) ' Problem inverting matrix C(T) S(AO) ' 2019 STOP ' Problem inverting matrix C(T) S(AO) ' 2020 END IF 2021 IF(NTEST.GE.1000) THEN 2022 WRITE(6,*) ' CBIOMO = SMO ** -1 ' 2023 CALL APRBLM2(CBIOMO,NTOOBS,NTOOBS,NSMOB,0) 2024 END IF 2025* CBIOAO = C * CBIOMO 2026 CALL MULT_BLOC_MAT(CBIOAO,C,CBIOMO, 2027 & NSMOB,NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,0) 2028* 2029* Check: Calculate C(T) S CBIO 2030C TRAN_SYM_BLOC_MAT4(AIN,XL,XR,NBLOCK,LX_ROW,LX_COL,AOUT,SCR,ISYM) 2031 I_DO_CHECK = 0 2032 IF(I_DO_CHECK.EQ.1) THEN 2033 CALL TRAN_SYM_BLOC_MAT4(WORK(KLSAOE),C,CBIOAO,NSMOB,NTOOBS, 2034 & NTOOBS, 2035 & WORK(KLMSCR),WORK(KLSCR),0) 2036 WRITE(6,*) ' C(T) S CBIO ' 2037 CALL APRBLM2(WORK(KLMSCR),NTOOBS,NTOOBS,NSMOB,0) 2038 END IF 2039* 2040 2041 IF(NTEST.GE.100) THEN 2042 WRITE(6,*) 2043 WRITE(6,*) ' Bioorthogonal MOAO expansion matrix ' 2044 WRITE(6,*) ' =================================== ' 2045 WRITE(6,*) 2046 CALL APRBLM2(CBIOAO,NTOOBS,NTOOBS,NSMOB,0) 2047 WRITE(6,*) 2048 WRITE(6,*) ' Bioorthogonal MOMO expansion matrix ' 2049 WRITE(6,*) ' =================================== ' 2050 WRITE(6,*) 2051 CALL APRBLM2(CBIOMO,NTOOBS,NTOOBS,NSMOB,0) 2052 END IF 2053* 2054 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GET_CB') 2055 RETURN 2056 END 2057 SUBROUTINE INV_BLKMT(A,AINV,SCR,NBLK,LBLK,IPROBLEM) 2058* 2059* Invert blocked matrix A to give AINV 2060* Problems with inversion is flagged by IPROBLEM.NE. 0 2061* IPROBLEM gives last block with problems 2062* 2063* SCR should at least be twice the size of the largest block 2064* 2065 INCLUDE 'implicit.inc' 2066*. Input 2067 DIMENSION A(*) 2068 INTEGER LBLK(NBLK) 2069*. Output 2070 DIMENSION AINV(*) 2071*Scratch 2072 DIMENSION SCR(*) 2073* 2074 NTEST = 000 2075* 2076 IPROBLEM = 0 2077 DO IBLK = 1, NBLK 2078 IF(IBLK.EQ.1) THEN 2079 IOFF = 1 2080 ELSE 2081 IOFF = IOFF + LBLK(IBLK-1)**2 2082 END IF 2083 LEN_BLK = LBLK(IBLK) 2084 CALL COPVEC(A(IOFF),SCR,LEN_BLK**2) 2085 IF(NTEST.GE.1000) THEN 2086 WRITE(6,*) ' Matrix to be inverted ' 2087 CALL WRTMAT(SCR,LEN_BLK,LEN_BLK,LEN_BLK,LEN_BLK) 2088 END IF 2089C INVMAT(A,B,MATDIM,NDIM,ISING) 2090 CALL INVMAT(SCR,SCR(1+LEN_BLK**2),LEN_BLK,LEN_BLK,ISING) 2091 IF(ISING.NE.0) IPROBLEM = IBLK 2092 CALL COPVEC(SCR,AINV(IOFF),LEN_BLK**2) 2093 END DO 2094* 2095 IF(IPROBLEM.NE.0) THEN 2096 WRITE(6,*) 2097 & ' Problem in INV_BLKMAT, number of last singular block =', 2098 & IPROBLEM 2099 WRITE(6,*) ' Complete input block matrix ' 2100 CALL APRBLM2(A,LBLK,LBLK,NBLK,0) 2101 END IF 2102* 2103 IF(NTEST.GE.100) THEN 2104 WRITE(6,*) ' Inverted block matrix:' 2105 CALL APRBLM2(AINV,LBLK,LBLK,NBLK,0) 2106C APRBLM2(A,LROW,LCOL,NBLK,ISYM) 2107 END IF 2108* 2109 RETURN 2110 END 2111 SUBROUTINE COMHAM_HS_GEN(MSTV,NDIM) 2112* 2113* Set up Complete Hamiltonian matrices using external 2114* routine MSTV 2115* 2116* Jeppe Olsen, July 2011 2117* 2118 INCLUDE 'implicit.inc' 2119 INCLUDE 'mxpdim.inc' 2120 INCLUDE 'clunit.inc' 2121* 2122 PARAMETER(MXLDIM = 200) 2123 DIMENSION H(MXLDIM*MXLDIM), S(MXLDIM*MXLDIM) 2124 DIMENSION VEC1(MXLDIM),VEC2(MXLDIM),VEC3(MXLDIM) 2125 DIMENSION SCR(5*MXLDIM**2+2*MXLDIM), EIGVEC(MXLDIM**2) 2126 COMMON/SCRFILES_MATVEC/LUSCR1,LUSCR2,LUSCR3, 2127 & LUCBIO_SAVE, LUHCBIO_SAVE 2128* 2129 EXTERNAL MSTV 2130* 2131 LUSCR1 = LUSC34 2132 LUSCR2 = LUSC35 2133 LUSCR3 = LUSC36 2134 LUCBIOSAVE = 0 2135 LUHCBIOSAVE = 0 2136* 2137 NTEST = 1000 2138 IF(NDIM.GT.MXLDIM) THEN 2139 WRITE(6,*) 2140 & ' COMHAM_HS_GEN called with larger dimension than allowed ' 2141 WRITE(6,*) ' ALlowed (MXLDIM) and actual (NDIM) dimensions ', 2142 & MXLDIM, NDIM 2143 WRITE(6,*) 'LUCIA suggests that you increase MXLDIM ' 2144 STOP 2145 & ' COMHAM_HS_GEN called with larger dimension than allowed ' 2146 END IF 2147*. Restrict 2148 NDIML = NDIM 2149* 2150 ZERO = 0.0D0 2151 ONE = 1.0D0 2152 DO IVEC = 1, NDIML 2153 CALL SETVEC(VEC1,ZERO,NDIM) 2154 VEC1(IVEC) = ONE 2155 CALL MSTV(VEC1,VEC2,VEC3,1,1) 2156* 2157 IOFF = (IVEC-1)*NDIML+1 2158 CALL COPVEC(VEC2,H(IOFF),NDIML) 2159 CALL COPVEC(VEC3,S(IOFF),NDIML) 2160 END DO 2161* 2162 IF(NTEST.GE.1000) THEN 2163 WRITE(6,*) ' matrices from COMHAM_HS_GEN' 2164 CALL WRTMAT(H,NDIML,NDIML,NDIML,NDIML) 2165 CALL WRTMAT(S,NDIML,NDIML,NDIML,NDIML) 2166 END IF 2167* 2168 I_DO_DIAG = 1 2169 IF(I_DO_DIAG.EQ.1) THEN 2170C GENEIG_WITH_SING_CHECK(A,S,EIGVEC,EIGVAL,NVAR,NSING, 2171C & WORK,IASPACK) 2172 CALL GENEIG_WITH_SING_CHECK(H,S,EIGVEC,VEC1,NDIML, 2173 & NSING,SCR,0) 2174 END IF 2175* 2176 RETURN 2177 END 2178 SUBROUTINE EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT 2179 & (A,AGAS,IGAS,JGAS,I_EX_OR_CP) 2180* 2181* A symmetryblocked (not lower half packed) matrix A over orbitals is given 2182* Extract blocks referring to GASpaCE IGAS, JGAS 2183* 2184* I_EX_OR_CP = 1 => Extract from A to IGAS 2185* I_EX_OR_CP = 1 => Copy from IGAS to A 2186* 2187*. Jeppe Olsen, July 2011 2188* 2189 INCLUDE 'implicit.inc' 2190 INCLUDE 'mxpdim.inc' 2191 INCLUDE 'orbinp.inc' 2192 INCLUDE 'lucinp.inc' 2193*. Specific input or output 2194 DIMENSION A(*), AGAS(*) 2195*. Scratch- for output 2196 DIMENSION IDIM(MXPNGAS), JDIM(MXPNGAS) 2197* 2198 DO ISYM = 1, NSMOB 2199 IF(ISYM.EQ.1) THEN 2200 IOFF_IN = 1 2201 IOFF_OUT = 1 2202 ELSE 2203 IOFF_IN = IOFF_IN + NTOOBS(ISYM-1)**2 2204 IOFF_OUT = 2205 & IOFF_OUT + NOBPTS_GN(IGAS,ISYM-1)*NOBPTS_GN(JGAS,ISYM-1) 2206 END IF 2207* 2208 IIOFF = 1 2209 DO IIGAS = 0, IGAS -1 2210 IIOFF = IIOFF + NOBPTS_GN(IIGAS,ISYM) 2211 END DO 2212* 2213 IJOFF = 1 2214 DO IIGAS = 0, JGAS -1 2215 IJOFF = IJOFF + NOBPTS_GN(IIGAS,ISYM) 2216 END DO 2217* 2218 NI = NOBPTS_GN(IGAS,ISYM) 2219 NJ = NOBPTS_GN(JGAS,ISYM) 2220 NIS = NTOOBS(ISYM) 2221 NJS = NTOOBS(ISYM) 2222 DO J = 1, NJ 2223 DO I = 1, NI 2224 IJ_OUT = IOFF_OUT -1 + (J-1)*NI + I 2225 IJ_IN = IOFF_IN -1 2226 & + (IJOFF+J-1-1)*NIS + IIOFF+I-1 2227 IF(I_EX_OR_CP.EQ.1) THEN 2228 AGAS(IJ_OUT) = A(IJ_IN) 2229 ELSE 2230 A(IJ_IN) = AGAS(IJ_OUT) 2231 END IF 2232 END DO 2233 END DO 2234 END DO ! End of loop over symmetries 2235* 2236 NTEST = 00 2237 IF(NTEST.GE.100) THEN 2238 WRITE(6,*) ' Submatrix with IGAS, JGAS = ', 2239 & IGAS, JGAS 2240 CALL EXTRROW(NOBPTS_GN,IGAS+1,7+MXPR4T,NSMOB,IDIM) 2241 CALL EXTRROW(NOBPTS_GN,JGAS+1,7+MXPR4T,NSMOB,JDIM) 2242C EXTRROW(INMAT,IROW,NROW,NCOL,IOUTVEC) 2243C APRBLM2(A,LROW,LCOL,NBLK,ISYM) 2244 CALL APRBLM2(AGAS,IDIM,JDIM,NSMOB,0) 2245 WRITE(6,*) ' Full matrix ' 2246 CALL APRBLM2(A,NTOOBS,NTOOBS,NSMOB,0) 2247 END IF 2248* 2249 RETURN 2250 END 2251 SUBROUTINE PREPARE_CMOAO_INI 2252 &(INI_MO_TP, CMOAO_OUT,CMOAO_IN,IVBGAS) 2253* 2254* Obtain initial orbitals for Lucia calculation 2255* 2256* INI_MO_TP = 1 => CMOAO_OUT = 1 2257* = 2 => Transform MO's so diagonal block IVBGAS is a unit matrix 2258* = 3 => CMOAO_OUT = CMOAO_IN 2259* = 4 => from fragment MO's 2260* Jeppe Olsen, July 2011 2261* 2262 INCLUDE 'implicit.inc' 2263 INCLUDE 'mxpdim.inc' 2264 INCLUDE 'wrkspc-static.inc' 2265 INCLUDE 'orbinp.inc' 2266 INCLUDE 'lucinp.inc' 2267 INCLUDE 'cgas.inc' 2268*. Input 2269 DIMENSION CMOAO_IN(*) 2270*. Output 2271 DIMENSION CMOAO_OUT(*) 2272*. Local scratch 2273 DIMENSION IDIMV(MXPOBS), IDIMI(MXPOBS) 2274* 2275 IDUM = 0 2276 NTEST = 10 2277* 2278 IF(NTEST.GE.10) 2279 &WRITE(6,*) ' PREPARE..., INI_MO_TP = ', INI_MO_TP 2280* 2281 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'PREPMO') 2282* 2283 IF(INI_MO_TP.EQ.1) THEN 2284* 2285*. CMOAO_OUT = 1 2286* 2287 ONE = 1.0D0 2288 CALL SETDIA_BLM(CMOAO_OUT,ONE,NSMOB,NTOOBS,0) 2289 ELSE IF ( INI_MO_TP.EQ.2) THEN 2290* 2291* Rotate orbitals in GASpace IVBGAS, so the diagonal IVBGAS block 2292* become diagonal- could require pivoting 2293* 2294 LEN1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 2295C NDIM_1EL_MAT(IHSM,NRPSM,NCPSM,NSM,IPACK) 2296 CALL MEMMAN(KLMO1,LEN1_F,'ADDL ',2,'MO1 ') 2297 CALL MEMMAN(KLMO2,LEN1_F,'ADDL ',2,'MO2 ') 2298 CALL MEMMAN(KLSCR,2*LEN1_F,'ADDL ',2,'SCR ') 2299* 2300 CALL COPVEC(CMOAO_IN,CMOAO_OUT,LEN1_F) 2301*. Extract block (IVBGAS,IVBGAS) of CMO 2302C EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT 2303C & (A,AGAS,IGAS,JGAS,I_EX_OR_CP) 2304 CALL EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT 2305 & (CMOAO_IN,WORK(KLMO1),IVBGAS,IVBGAS,1) 2306*. Number of orbitals per sym in this space 2307 CALL EXTRROW(NOBPTS_GN,IVBGAS+1,7+MXPR4T,NSMOB,IDIMV) 2308*. Invert block and save in KLMO2 2309C INV_BLKMT(A,AINV,SCR,NBLK,LBLK,IPROBLEM) 2310 CALL INV_BLKMT(WORK(KLMO1),WORK(KLMO2),WORK(KLSCR),NSMOB, 2311 & IDIMV,IPROBLEM) 2312 IF(NTEST.GE.1000) THEN 2313 WRITE(6,*) ' Inverted diagonal GAS block' 2314 CALL APRBLM2(WORK(KLMO2),IDIMV,IDIMV,NSMOB,0) 2315 END IF 2316*. Multiply inverted block on ini MO's in space IVBGAS 2317 DO IGAS = 0, NGAS +1 2318*. Extract block (IGAS,IVBGAS) in KLMO1 2319 CALL EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT 2320 & (CMOAO_IN,WORK(KLMO1),IGAS,IVBGAS,1) 2321*. Dimensions of block IGAS 2322 CALL EXTRROW(NOBPTS_GN,IGAS+1,7+MXPR4T,NSMOB,IDIMI) 2323* CMOAO_IN(IGAS,IVBGAS)*CMOAO_IN(IGAS,IGAS)**(-1) 2324 IF(NTEST.GE.1000) THEN 2325 WRITE(6,*) ' C(IGAS,IVGAS) block ' 2326 CALL APRBLM2(WORK(KLMO1),IDIMI,IDIMV,NSMOB,0) 2327 WRITE(6,*) ' C(IVGAS,IVGAS)** (-1) block' 2328 CALL APRBLM2(WORK(KLMO2),IDIMV,IDIMV,NSMOB,0) 2329 END IF 2330C MULT_BLOC_MAT(C,A,B,NBLOCK,LCROW,LCCOL, 2331C & LAROW,LACOL,LBROW,LBCOL,ITRNSP) 2332 CALL MULT_BLOC_MAT(WORK(KLSCR),WORK(KLMO1),WORK(KLMO2), 2333 & NSMOB,IDIMI,IDIMV, IDIMI,IDIMV,IDIMV,IDIMV,0) 2334 IF(NTEST.GE.1000) THEN 2335 WRITE(6,*) 2336 & ' C(IGAS,IVGAS)*C**(-1)(IVGAS,IVGAS) for IGAS = ', IGAS 2337 CALL APRBLM2(WORK(KLSCR),IDIMI,IDIMV,NSMOB,0) 2338 END IF 2339 2340*. And copy to CMOAO_OUT 2341 CALL EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT 2342 & (CMOAO_OUT,WORK(KLSCR),IGAS,IVBGAS,2) 2343 END DO 2344* 2345 ELSE IF(INI_MO_TP.EQ.3.OR.INI_MO_TP.EQ.5) THEN 2346* 2347* CMOAO_OUT = CMOAO_IN 2348* 2349 LEN1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 2350 CALL COPVEC(CMOAO_IN,CMOAO_OUT,LEN1_F) 2351 ELSE IF(INI_MO_TP.EQ.4) THEN 2352* obtain MO's from Fragment AO's 2353 CALL GET_CMO_FROM_FRAGMENTS(CMOAO_OUT) 2354 END IF 2355* 2356 IF(NTEST.GE.100) THEN 2357 WRITE(6,*) ' Output from PREPARE CMOAO_INI_NORTCI' 2358 WRITE(6,*) ' =====================================' 2359 WRITE(6,*) 2360 WRITE(6,*) ' INI_MO_TP = ', INI_MO_TP 2361 END IF 2362 IF(NTEST.GE.100) THEN 2363 WRITE(6,*) ' Output set of MOs ' 2364 CALL APRBLM2(CMOAO_OUT,NTOOBS,NTOOBS,NSMOB,0) 2365 END IF 2366* 2367 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'PREPMO') 2368* 2369 RETURN 2370 END 2371 SUBROUTINE GET_CMO_FROM_FRAGMENTS(CMO) 2372* Obtain MOAO coefficients CMO from fragments as specified by 2373* N_GS_SM_BAS_FRAG 2374* 2375*. Jeppe Olsen, July 2011 2376* 2377 INCLUDE 'implicit.inc' 2378 INCLUDE 'mxpdim.inc' 2379 INCLUDE 'wrkspc-static.inc' 2380 INCLUDE 'cgas.inc' 2381 INCLUDE 'lucinp.inc' 2382 INCLUDE 'fragmol.inc' 2383 INCLUDE 'glbbas.inc' 2384 INCLUDE 'orbinp.inc' 2385*. Molecule to fragment symmetry 2386 INTEGER LSYMEXP(8) 2387*. Output 2388 DIMENSION CMO(*) 2389* 2390 NTEST = 10 2391* 2392* 2393* 1: Check information in fragments with total number of orbitals 2394* and basis functions 2395* 2396* 2397*. Total number of orbitals per symmetry 2398 NERROR = 0 2399 DO ISYM = 1, NSMOB 2400 NNTOOBS = 0 2401*. Loop over equivalent groups of atoms 2402 DO IEQV = 1, NEQVGRP_FRAG 2403 IFRAG = IEQVGRP_FRAG(1,IEQV) 2404 IF(NTEST.GE.1000) THEN 2405 WRITE(6,*) ' IEQV, IFRAG = ', IEQV, IFRAG 2406 WRITE(6,*) ' LEQVGRP_FRAG(IEQV) = ', LEQVGRP_FRAG(IEQV) 2407 END IF 2408 IF(LEQVGRP_FRAG(IEQV).EQ.1) THEN 2409*. No expansion of symmetries 2410 DO JSYM = 1, NSMOB 2411 LSYMEXP(JSYM) = JSYM 2412 END DO 2413 ELSE IF(LEQVGRP_FRAG(IEQV).EQ.2) THEN 2414 IF(NSMOB.EQ.4) THEN 2415*. Assumed expansion from Cs to C2V 2416 LSYMEXP(1) = 1 2417 LSYMEXP(2) = 2 2418 LSYMEXP(3) = 1 2419 LSYMEXP(4) = 2 2420 ELSE IF(NSMOB.EQ.8) THEN 2421*. Assumed expansion from C2V to D2H 2422 LSYMEXP(1) = 1 2423 LSYMEXP(2) = 2 2424 LSYMEXP(3) = 3 2425 LSYMEXP(4) = 4 2426 LSYMEXP(5) = 1 2427 LSYMEXP(6) = 2 2428 LSYMEXP(7) = 3 2429 LSYMEXP(8) = 4 2430 ELSE 2431 WRITE(6,*) ' Combination not programmed(2) ' 2432 WRITE(6,*) ' IEQV, LEQVGRP_FRAG, NSMOB = ', 2433 & IEQV, LEQVGRP_FRAG(IEQV), NSMOB 2434 STOP ' Combination not programmed ' 2435 END IF 2436 ELSE IF(LEQVGRP_FRAG(IEQV).EQ.4) THEN 2437 IF(NSMOB.EQ.8) THEN 2438*. Assumed expansion from CS to D2H 2439 LSYMEXP(1) = 1 2440 LSYMEXP(2) = 2 2441 LSYMEXP(3) = 3 2442 LSYMEXP(4) = 4 2443 LSYMEXP(5) = 1 2444 LSYMEXP(6) = 2 2445 LSYMEXP(7) = 3 2446 LSYMEXP(8) = 4 2447 ELSE 2448 WRITE(6,*) ' Combination not programmed(3) ' 2449 WRITE(6,*) ' LEQVGRP_FRAG, NSMOB = ', LEQVGRP_FRAG, NSMOB 2450 STOP ' Combination not programmed ' 2451 END IF 2452 END IF ! Switch between dimension of equivalence class 2453 NNTOOBS = NNTOOBS + NBAS_FRAG(LSYMEXP(ISYM),IFRAG) 2454 IF(NTEST.GE.1000) WRITE(6,*) ' ISYM, LSYM, IFRAG, NBAS = ', 2455 & ISYM,LSYMEXP(ISYM),IFRAG,NBAS_FRAG(LSYMEXP(ISYM),IFRAG) 2456 END DO ! Loop over equivalent groups of atoms 2457* 2458 IF(NNTOOBS.NE.NTOOBS(ISYM)) THEN 2459 WRITE(6,*) 2460 & ' Number of basisfunctions from fragments is not correct ' 2461 WRITE(6,'(A,3I3)') ' ISYM, NTOOBS, Sum of fragments: ', 2462 & ISYM, NTOOBS(ISYM),NNTOOBS 2463 NERROR = NERROR + 1 2464 END IF 2465 END DO 2466*. Check internal consistency for each fragment 2467 DO IIFRAG = 1, NFRAG_MOL 2468 IFRAG = IFRAG_MOL(IIFRAG) 2469 NSMOB_L = NSMOB_FRAG(IFRAG) 2470 DO ISYM = 1, NSMOB_L 2471 NNTOOBS_FRAG = 0 2472 DO IGAS = 0, NGAS + 1 2473 NNTOOBS_FRAG = 2474 & NNTOOBS_FRAG + N_GS_SM_BAS_FRAG(IGAS,ISYM,IFRAG) 2475 END DO 2476 IF(NNTOOBS_FRAG.NE.NBAS_FRAG(ISYM,IFRAG)) THEN 2477 WRITE(6,*) 2478 & ' Inconsistency between N_GS_SM_BAS_FRAG and NBAS_FRAG' 2479 WRITE(6,'(A,4I3)') 2480 & ' IFRAG, ISYM, Sum over gaspaces and Required ', 2481 & IFRAG, ISYM, NNTOOBS_FRAG, NBAS_FRAG(ISYM,IFRAG) 2482 NERRROR = NERROR + 1 2483 END IF 2484 END DO 2485 END DO 2486*. Check consistency for each GASpace and symmetry 2487 WRITE(6,*) ' Warning: some consistency checks skipped ' 2488 WRITE(6,*) ' Warning: some consistency checks skipped ' 2489 WRITE(6,*) ' Warning: some consistency checks skipped ' 2490 WRITE(6,*) ' Warning: some consistency checks skipped ' 2491 WRITE(6,*) ' Warning: some consistency checks skipped ' 2492 WRITE(6,*) ' Warning: some consistency checks skipped ' 2493 WRITE(6,*) ' Warning: some consistency checks skipped ' 2494CTEMP DO IGAS = 0, NGAS + 1 2495CTEMP DO ISYM = 1, NSMOB 2496CTEMP NNTOOBS_GS_SM = 0 2497CTEMP DO IIFRAG =1, NFRAG_MOL 2498CTEMP IFRAG = IFRAG_MOL(IIFRAG) 2499CTEMP NNTOOBS_GS_SM = 2500CTEMP& NNTOOBS_GS_SM + N_GS_SM_BAS_FRAG(IGAS,ISYM,IFRAG) 2501CTEMP END DO 2502* 2503CTEMP IF(NNTOOBS_GS_SM.NE.NOBPTS_GN(IGAS,ISYM)) THEN 2504CTEMP WRITE(6,*) 2505CTEMP& ' Inconsistency in number of orbitals of given SYM and GAS' 2506CTEMP WRITE(6,'(A,4I4)') ' ISYM, IGAS, Sum over fragments, Total ', 2507CTEMP& ISYM, IGAS, NNTOOBS_GS_SM, NOBPTS_GN(IGAS,ISYM) 2508CTEMP NERROR = NERROR + 1 2509CTEMP END IF 2510CTEMP END DO 2511CTEMP END DO 2512* 2513 IF(NERROR.NE.0) THEN 2514 WRITE(6,*) 2515 & ' Inconsistency between info on fragments and molecule ' 2516C! STOP 2517C! & ' Inconsistency between info on fragments and molecule ' 2518 END IF 2519* 2520* 2: And then set up the CMO matrix from fragment info 2521* 2522 IF(NTEST.GE.100) THEN 2523 WRITE(6,*) ' ================================== ' 2524 WRITE(6,*) ' CMO(FRAGMENTS) => CMO(MOLECULE)(1) ' 2525 WRITE(6,*) ' ================================== ' 2526 END IF 2527* 2528 DO ISYM = 1, NSMOB 2529 IF(NTEST.GE.1000) WRITE(6,*) ' ISYM = ', ISYM 2530 IF(ISYM.EQ.1) THEN 2531 IB_CMOL = 1 2532 ELSE 2533 IB_CMOL = IB_CMOL + NTOOBS(ISYM-1)**2 2534 END IF 2535 NOB_SM = NTOOBS(ISYM) 2536 ZERO = 0.0D0 2537 CALL SETVEC(CMO(IB_CMOL),ZERO,NOB_SM**2) 2538 IOFF_ORB = 1 2539 IOFF_BAS = 1 2540 JMO = 0 2541 DO IGAS = 0, NGAS + 1 2542 IB_BAS_MOL = 1 2543 IF(NTEST.GE.1000) WRITE(6,*) ' IGAS = ', IGAS 2544*. Loop over equivalent set of fragment orbitals 2545 DO IEQV = 1, NEQVGRP_FRAG 2546* First fragment of class 2547 IFRAG = IEQVGRP_FRAG(1,IEQV) 2548 IF(NTEST.GE.1000) 2549 & WRITE(6,*) ' IEQV, IFRAG = ', IEQV, IFRAG 2550* 2551 XL = DFLOAT(LEQVGRP_FRAG(IEQV)) 2552 SCALE = 1.0D0/SQRT(XL) 2553*. Symmetry in fragment 2554 2555 IF(LEQVGRP_FRAG(IEQV).EQ.1) THEN 2556 ISYML = ISYM 2557 ELSE IF (LEQVGRP_FRAG(IEQV).EQ.2) THEN 2558 IF(NSMOB.EQ.8) THEN 2559 ISYML = ISYM 2560 IF(ISYM.GT.4) ISYML = ISYM-4 2561 ELSE 2562 WRITE(6,*) ' Symmetry reduction not programmed(1) ' 2563 WRITE(6,*) ' ISYM, NSMOB, LEQVGRP_FRAG = ', 2564 & ISYM, NSMOB, LEQVGRP_FRAG(IEQV) 2565 STOP ' Symmetry reduction not programmed ' 2566 END IF 2567 END IF 2568 IF(NTEST.GE.1000) 2569 & WRITE(6,*) ' ISYM,ISYML = ', ISYM,ISYML 2570*. Address of symmetryblock in C for fragment 2571 IB_C_FRAG = 1 2572 DO JSYM = 1, ISYML-1 2573 IB_C_FRAG = IB_C_FRAG + NBAS_FRAG(JSYM,IFRAG)**2 2574 END DO 2575*. Start and number of orbitals in input fragment 2576 IB_OB_FRAG = 1 2577 DO JGAS = 0, IGAS - 1 2578 IB_OB_FRAG = IB_OB_FRAG 2579 & + N_GS_SM_BAS_FRAG(JGAS,ISYML,IFRAG) 2580 END DO 2581 IF(NTEST.GE.1000) WRITE(6,*) ' IB_OB_FRAG = ', 2582 & IB_OB_FRAG 2583 N_OB_GS_SM_FRAG = N_GS_SM_BAS_FRAG(IGAS,ISYML,IFRAG) 2584 N_OB_SM_FRAG = NBAS_FRAG(ISYML,IFRAG) 2585 DO JJMO = 1, N_OB_GS_SM_FRAG 2586 JMO = JMO + 1 2587 IF(NTEST.GE.1000) WRITE(6,*) ' Info for Orbital ', JMO 2588 DO IIMO = 1, N_OB_SM_FRAG 2589 IF(NTEST.GE.1000) WRITE(6,*) ' JJMO, IIMO = ', 2590 & JJMO, IIMO 2591 IF(NTEST.GE.1000) WRITE(6,*) ' IB_BAS_MOL = ', 2592 & IB_BAS_MOL 2593 IADR_OUT = IB_CMOL-1+(JMO-1)*NOB_SM +IB_BAS_MOL-1 + IIMO 2594 IADR_IN = IB_C_FRAG-1 2595 & + (JJMO+IB_OB_FRAG-1-1)*N_OB_SM_FRAG 2596 & + IIMO 2597 IF(NTEST.GE.1000) WRITE(6,*) ' IADR_IN, IADR_OUT ', 2598 & IADR_IN, IADR_OUT 2599 CMO(IADR_OUT) = WORK(KCMOAO_FRAG(IFRAG)-1+IADR_IN)*SCALE 2600 END DO !loop over IIMO 2601 END DO !loop over JJMO 2602*. Start of basis functions for given sym and fragment in molecule 2603 IB_BAS_MOL = IB_BAS_MOL + N_OB_SM_FRAG 2604 IF(NTEST.GE.1000) 2605 & WRITE(6,*) ' IB_BAS_MOL, N_OB_SM_FRAG', 2606 & IB_BAS_MOL, N_OB_SM_FRAG 2607 END DO ! End of loop over fragments 2608 END DO ! End of loop over GAspaces 2609 END DO ! End of loop over Symmetries 2610* 2611 IF(NTEST.GE.100) THEN 2612 WRITE(6,*) 2613 WRITE(6,*) ' CMO matrix from fragments(not orthogonalized) ' 2614 WRITE(6,*) ' ==============================================' 2615 WRITE(6,*) 2616 CALL APRBLM_F7(CMO,NTOOBS,NTOOBS,NSMOB,0) 2617 END IF 2618* 2619COLD STOP ' Jeppe enforced me to stop after CMO ' 2620* 2621 RETURN 2622 END 2623C ORT_ORB(WORK(KLCMOAO1),CMOAO_OUT,INTER_ORT, 2624C & INTERGAS_ORT,INTRAGAS_OUT,IORT_VB) 2625 SUBROUTINE ORT_ORB(CMOAO_IN, CMOAO_OUT, 2626 & INTER_ORT,INTERGAS_ORT, 2627 & INTRAGAS_ORT,IORT_VB) 2628* 2629* Two parts 2630* 1: Inter Gas orthogonaliztion 2631* 2: Intra Gas orthonormalization: 2632* 2633*. The inter gas orthogonalization: CMOAO_IN => CMOAO_OUT 2634* ================================== 2635* INTER_ORT = 1 => All GA Spaces are orthogonalized to inactive and 2636* secondary space 2637* 2638* INTERGAS_ORT = 1 => Gaspaces are orthogonalized to each other 2639* 2640*. The Intra gas orthonormalization: CMOAO_OUT => CMOAO_OUT 2641* ==================================== 2642* INTRAGAS_ORT = 0 => no Intra gas orthogonalization 2643* = 1 => Intra gas orthogonalization using symmetric orthog 2644* = 2 => Intra gas orthogonalization using orthog by diag 2645* IORT_VB = 0 => No orthogonalization of space VB space 2646* = 1 => orthog using method specified by INTRAGAS_ORT 2647* 2648* Note: If INTRAGAS_ORT = 1, then the VB orb space is left untouched, 2649* irrespectively of IORT_VB 2650*. Jeppe Olsen, July 2011 2651* 2652 INCLUDE 'implicit.inc' 2653 INCLUDE 'mxpdim.inc' 2654 INCLUDE 'wrkspc-static.inc' 2655 INCLUDE 'orbinp.inc' 2656 INCLUDE 'cgas.inc' 2657 INCLUDE 'glbbas.inc' 2658 INCLUDE 'lucinp.inc' 2659 INCLUDE 'crun.inc' 2660*. Input 2661 DIMENSION CMOAO_IN(*) 2662*. Output 2663 DIMENSION CMOAO_OUT(*) 2664*. Local scratch 2665 INTEGER IDIM(MXPOBS) 2666* 2667 IDUM = 0 2668 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ORTOBV') 2669* 2670 NTEST = 00 2671 IF(NTEST.GE.100) THEN 2672 WRITE(6,*) 2673 WRITE(6,*) ' Info from ORT_ORB ' 2674 WRITE(6,*) ' =====================' 2675 WRITE(6,*) 2676 WRITE(6,'(A,2I4)') 2677 & ' INTER_ORT, INTERGAS_ORT = ', 2678 & INTER_ORT, INTERGAS_ORT 2679 WRITE(6,'(A,2I4)') 2680 & ' INTRAGAS_ORT, IORT_VB ', 2681 & INTRAGAS_ORT, IORT_VB 2682 END IF 2683 IF(NTEST.GE.1000) THEN 2684 WRITE(6,*) ' Input CMO coefficients ' 2685 CALL APRBLM2(CMOAO_IN,NTOOBS,NTOOBS,NSMOB,0) 2686 END IF 2687* 2688 IDUM = 0 2689*. Obtain metric over molecular orbitals 2690 LEN_1F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 2691C NDIM_1EL_MAT(IHSM,NRPSM,NCPSM,NSM,IPACK) 2692 CALL MEMMAN(KLSMO,LEN_1F,'ADDL ',2,'SMO ') 2693 CALL MEMMAN(KLCMOAO2,LEN_1F,'ADDL ',2,'MOAO2 ') 2694*. Obtain metric in MO basis in SMO 2695 IPACK_OUT = 0 2696 CALL GET_SMO(CMOAO_IN,WORK(KLSMO),IPACK_OUT) 2697 IF(NTEST.GE.1000) THEN 2698 WRITE(6,*) ' Overlap matrix for initial orbitals ' 2699 CALL APRBLM2(WORK(KLSMO),NTOOBS,NTOOBS,NSMOB,0) 2700 END IF 2701* 2702* ============================== 2703* The intergas orthogonalization 2704* ============================== 2705* 2706*. Resulting MOAO transformation will be saved in CMOAO_OUT 2707 CALL COPVEC(CMOAO_IN,CMOAO_OUT,LEN_1F) 2708 CALL COPVEC(CMOAO_IN,WORK(KLCMOAO2),LEN_1F) 2709C? WRITE(6,*) ' INTRAGAS_ORT after COPVEC(1)', INTRAGAS_ORT 2710* 2711 IF(INTER_ORT.EQ.1) THEN 2712* 2713*. Orthogonalize GAS spaces for inactive 2714* 2715 IF(NINOB.NE.0) THEN 2716 DO IGAS = 1, NGAS+1 2717*. Orthogonalize GAS IGAS to inactive 2718C ORT_GAS_TO_GAS(IGAS,JGAS,SIN,CIN,COUT) 2719 CALL ORT_GAS_TO_GAS(0,IGAS,WORK(KLSMO),WORK(KLCMOAO2), 2720 & CMOAO_OUT) 2721*. Test.. 2722CT CALL ORT_GAS_TO_GAS(IGAS,0,WORK(KLSMO),WORK(KLCMOAO2), 2723CT & CMOAO_OUT) 2724 CALL COPVEC(CMOAO_OUT,WORK(KLCMOAO2),LEN_1F) 2725 CALL COPVEC(CMOAO_OUT,WORK(KLCMOAO2),LEN_1F) 2726*. Update metric 2727 CALL GET_SMO(CMOAO_OUT,WORK(KLSMO),IPACK_OUT) 2728 END DO 2729 END IF 2730* 2731CM IF(NSCOB.NE.0) THEN 2732* 2733*. Orthogonalize Secondary space to GASpaces 2734* 2735CM DO IGAS = 1, NGAS 2736*. Orthogonalize Secondary to GAS IGAS 2737CM CALL ORT_GAS_TO_GAS(IGAS,NGAS+1,WORK(KLSMO),WORK(KLCMOAO2), 2738CM & CMOAO_OUT) 2739CM CALL COPVEC(CMOAO_OUT,WORK(KLCMOAO2),LEN_1F) 2740*. Update metric 2741CM CALL GET_SMO(CMOAO_OUT,WORK(KLSMO),IPACK_OUT) 2742CM END DO 2743CM END IF 2744* 2745C? WRITE(6,*) ' INTRAGAS_ORT after INTER(1)', INTRAGAS_ORT 2746 IF(INTERGAS_ORT.EQ.1) then 2747* Orthogonalize JGAS to IGAS with JGAS > IGAS 2748 IF(NTEST.GE.10000) THEN 2749 WRITE(6,*) ' SMO before GAS GAS orthog' 2750 CALL APRBLM2(WORK(KLSMO),NTOOBS,NTOOBS,NSMOB,0) 2751 WRITE(6,*) ' MOAO2 before GAS GAS orthog ' 2752 CALL APRBLM2(WORK(KLCMOAO2),NTOOBS,NTOOBS,NSMOB,0) 2753 END IF 2754 DO JGAS = 2, NGAS 2755 DO IGAS = 1, JGAS -1 2756 IF(NTEST.GE.1000) THEN 2757 WRITE(6,*) 2758 & ' InterGAS orthogonalization for IGAS, JGAS ', 2759 & IGAS, JGAS 2760 END IF 2761 CALL ORT_GAS_TO_GAS(IGAS,JGAS,WORK(KLSMO),WORK(KLCMOAO2), 2762 & CMOAO_OUT) 2763C ORT_GAS_TO_GAS(IGAS,JGAS,SIN,CIN,COUT) 2764 CALL COPVEC(CMOAO_OUT,WORK(KLCMOAO2),LEN_1F) 2765*. Update metric 2766 CALL GET_SMO(CMOAO_OUT,WORK(KLSMO),IPACK_OUT) 2767 END DO 2768 END DO 2769 END IF ! End if intergas orthogonalization was called 2770* 2771 IF(NSCOB.NE.0) THEN 2772* 2773*. Orthogonalize Secondary space to GASpaces 2774* 2775 DO IGAS = 1, NGAS 2776*. Orthogonalize Secondary to GAS IGAS 2777 CALL ORT_GAS_TO_GAS(IGAS,NGAS+1,WORK(KLSMO),WORK(KLCMOAO2), 2778 & CMOAO_OUT) 2779 CALL COPVEC(CMOAO_OUT,WORK(KLCMOAO2),LEN_1F) 2780*. Update metric 2781 CALL GET_SMO(CMOAO_OUT,WORK(KLSMO),IPACK_OUT) 2782 END DO 2783 END IF 2784 END IF ! End if interspace orthogonalization was called 2785* 2786 IF(NTEST.GE.1000) THEN 2787 WRITE(6,*) ' MOAO transformation matrix after INTERORT' 2788 CALL APRBLM2(CMOAO_OUT,NTOOBS,NTOOBS,NSMB,0) 2789 END IF 2790 2791* 2792* 2793* ============================== 2794* The intragas orthogonalization 2795* ============================== 2796* 2797* 2798 IF(NTEST.GE.1000) 2799 &WRITE(6,*) ' INTRAGAS_ORT after INTERORT', INTRAGAS_ORT 2800 IF(INTRAGAS_ORT .NE.0) THEN 2801*. Space for Metric in MO basis MO-MO transformation, blocks of S and C, 2802*. and scratch 2803 CALL MEMMAN(KLSMO,LEN_1F,'ADDL ',2,'SAOE ') 2804 CALL MEMMAN(KLCMOMO,LEN_1F,'ADDL ',2,'CMOMO ') 2805 CALL MEMMAN(KLSBLK,MXTOB**2,'ADDL ',2,'SBLK ') 2806 CALL MEMMAN(KLCBLK,MXTOB**2,'ADDL ',2,'CBLK ') 2807 LSCR = 2*LEN_1F + 6*MXTOB**2 2808 CALL MEMMAN(KLSCR,LSCR,'ADDL ',2,'SCRORT') 2809*. Initialize MOMO- transformation matrix to 1 2810 ZERO = 0.0D0 2811 CALL SETVEC(WORK(KLCMOMO),ZERO,LEN_1F) 2812 ONE = 1.0D0 2813 CALL SETDIA_BLM(WORK(KLCMOMO),ONE,NSMOB,NTOOBS,0) 2814C SETDIA_BLM(B,VAL,NBLK,LBLK,IPCK) 2815*. Obtain metric in MO basis 2816 IPACK_OUT = 0 2817 CALL GET_SMO(CMOAO_OUT,WORK(KLSMO),IPACK_OUT) 2818*. Loop over gas-spaces 2819 IF(NTEST.GE.1000) THEN 2820 WRITE(6,*) ' Information from GAS-GAS orthog ' 2821 WRITE(6,*) ' Metric in MO basis after INTERGAS part' 2822 CALL APRBLM2(WORK(KLSMO),NTOOBS,NTOOBS,NSMOB,0) 2823 END IF 2824 DO IGAS = 0, NGAS+1 2825*. Number of orbitals per sym of this GASpace 2826 CALL EXTRROW(NOBPTS_GN,IGAS+1,7+MXPR4T,NSMOB,IDIM) 2827 NTOB = IELSUM(IDIM,NSMOB) 2828 IF(NTOB.NE.0) THEN 2829 IF(NTEST.GE.1000) 2830 & WRITE(6,*) ' Orthonormalization of GAS space = ', IGAS 2831*. Extract block (IGAS,IGAS) of S-matrix and save in KLSBLK 2832C EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT(A,AGAS,IGAS,JGAS,I_EX_OR_CP) 2833 CALL EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT 2834 & (WORK(KLSMO),WORK(KLSBLK),IGAS,IGAS,1) 2835*. And obtain transformation matrix giving othogonal basis 2836*. Orthogonalization method defined differently in ORTHGNORM.. 2837 IF(IGAS.NE.NORTCIX_SCVB_SPACE) THEN 2838 IORTMET_L = INTRAGAS_ORT 2839 ELSE 2840 IF(IORT_VB.EQ.0) THEN 2841 IORTMET_L = 0 2842 ELSE 2843 IORTMET_L = INTRAGAS_ORT 2844 END IF 2845 END IF 2846* 2847C? WRITE(6,*) ' IORTMET_L = ', IORTMET_L 2848 IF(IORTMET_L.NE.0) THEN 2849 CALL ORTHNORM_BLKMT(WORK(KLSBLK),WORK(KLCBLK),NSMOB,IDIM, 2850 & WORK(KLSCR),IORTMET_L) 2851C ORTHNORM_BLKMT(S,C,NBLK,LBLK,SCR,IORTMET) 2852*. Copy transformation matrix to complete matrix 2853C EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT(A,AGAS,IGAS,JGAS,I_EX_OR_CP) 2854 CALL EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT 2855 & (WORK(KLCMOMO),WORK(KLCBLK),IGAS,IGAS,2) 2856 END IF ! IORTMET_L .ne. 0 2857 END IF ! transformation should be done 2858 END DO ! loop over GASpaces 2859* 2860 IF(NTEST.GE.1000) THEN 2861 WRITE(6,*) 2862 & ' Intra-gas MO-MO transformation matrix ' 2863 CALL APRBLM2(WORK(KLCMOMO),NTOOBS,NTOOBS,NSMOB,0) 2864 END IF 2865* CMOAO_OUT = "CMOAO_IN " * CMOMO 2866C MULT_BLOC_MAT 2867C (C,A,B,NBLOCK,LCROW,LCCOL,LAROW,LACOL,LBROW,LBCOL,ITRNSP) 2868 CALL COPVEC(CMOAO_OUT,WORK(KLCMOAO2),LEN_1F) 2869 CALL MULT_BLOC_MAT(CMOAO_OUT,WORK(KLCMOAO2),WORK(KLCMOMO), 2870 & NSMOB,NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,0) 2871 END IF ! End if intragas orthogonalization was required. 2872* 2873 IF(NTEST.GE.100) THEN 2874 WRITE(6,*) ' MO-AO transformation matrix ' 2875 CALL APRBLM2(CMOAO_OUT,NTOOBS,NTOOBS,NSMOB,0) 2876 END IF 2877* 2878 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ORTOBV') 2879* 2880 RETURN 2881 END 2882 SUBROUTINE GET_SMO(CMO,SMO,IPACK_OUT) 2883* 2884*. Obtain Metric, SMO, over a set of orbitals, CMO. 2885*. Metric is given in packed form if IPACK_OUT = 1 2886* 2887*. Jeppe Olsen, July 2011 2888* 2889 INCLUDE 'implicit.inc' 2890 INCLUDE 'mxpdim.inc' 2891 INCLUDE 'wrkspc-static.inc' 2892 INCLUDE 'lucinp.inc' 2893 INCLUDE 'orbinp.inc' 2894 INCLUDE 'glbbas.inc' 2895#include "errquit.fh" 2896#include "mafdecls.fh" 2897#include "global.fh" 2898*. Specific input 2899 DIMENSION CMO(*) 2900*. Output 2901 DIMENSION SMO(*) 2902* 2903 NTEST = 000 2904 IF(NTEST.GE.100) THEN 2905 WRITE(6,*) 2906 WRITE(6,*) ' Info from GET_SMO' 2907 WRITE(6,*) ' =================' 2908 WRITE(6,*) 2909 END IF 2910 IF(NTEST.GE.1000) THEN 2911 WRITE(6,*) ' Input CMO basis ' 2912 CALL APRBLM2(CMO,NTOOBS,NTOOBS,NSMOB,0) 2913 END IF 2914* 2915 IDUM = 0 2916 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GETSMO') 2917* 2918C NDIM_1EL_MAT(IHSM,NRPSM,NCPSM,NSM,IPACK) 2919 LEN_M = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 2920 CALL MEMMAN(KLSAOE,LEN_M,'ADDL ',2,'SAO_E ') 2921 CALL MEMMAN(KLSCR,2*LEN_M,'ADDL ',2,'SCR ') 2922*. Expand SAO 2923 CALL TRIPAK_AO_MAT(dbl_mb(KLSAOE),dbl_mb(KSAO),2) 2924 IF(NTEST.GE.1000) THEN 2925 WRITE(6,*) ' Expanded SAO ' 2926 CALL APRBLM2(dbl_mb(KLSAOE),NTOOBS,NTOOBS,NSMOB,0) 2927 END IF 2928*. Obtain Metric in MO-basis, SMO = CMO(T) SAO CMO 2929C TRAN_SYM_BLOC_MAT4(AIN,XL,XR,NBLOCK,LX_ROW,LX_COL,AOUT,SCR,ISYM) 2930 CALL TRAN_SYM_BLOC_MAT4(dbl_mb(KLSAOE),CMO,CMO, 2931 & NSMOB,NTOOBS,NTOOBS,SMO,dbl_mb(KLSCR),0) 2932* 2933 IF(IPACK_OUT.EQ.1) THEN 2934*. Pack output matrix 2935 CALL COPVEC(SMO,dbl_mb(KLSAOE),LEN_M) 2936 CALL TRIPAK_AO_MAT(dbl_mb(KLSAOE),SMO,1) 2937 END IF 2938* 2939 IF(NTEST.GE.100) THEN 2940 WRITE(6,*) ' Metric in MO basis ' 2941 CALL APRBLM2(SMO,NTOOBS,NTOOBS,NSMOB,IPACK_OUT) 2942 END IF 2943* 2944 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GETSMO') 2945* 2946 RETURN 2947 END 2948 SUBROUTINE ORTHNORM_BLKMT(S,C,NBLK,LBLK,SCR,IORTMET) 2949* 2950* Obtain transformation matrix that orthonormalizes basis 2951* defined by blocked metric S 2952* 2953* IMET = 1: Symmetric orthonormalization 2954* IMET = 2: Orthonormalize by diagonalization 2955* 2956*. Jeppe Olsen, July 2011 2957* 2958 INCLUDE 'implicit.inc' 2959*. Input: S is given in packed form 2960 INTEGER LBLK(NBLK) 2961 DIMENSION S(*) 2962*. Output 2963 DIMENSION C(*) 2964*. Scratch: Should atleast be: 2* Dimension of matrix + 6 times largest block 2965 DIMENSION SCR(*) 2966* 2967 NTEST = 00 2968 IF(NTEST.GE.100) THEN 2969 WRITE(6,*) ' Info from ORTHNORM_BLKMT ' 2970 WRITE(6,*) ' =========================' 2971 WRITE(6,*) ' Number of elements per block ' 2972 CALL IWRTMA(LBLK,1,NBLK,1,NBLK) 2973 IF(IORTMET.EQ.1) THEN 2974 WRITE(6,*) ' Symmetric orthogonalization ' 2975 ELSE IF (IORTMET.EQ.2) THEN 2976 WRITE(6,*) ' Orthonormalization by diagonalization of metric' 2977 END IF 2978 WRITE(6,*) ' (IORTMET = ', IORTMET 2979 END IF 2980 IF(NTEST.GE.1000) THEN 2981 WRITE(6,*) ' Input metric: ' 2982 CALL APRBLM2(S,LBLK,LBLK,NBLK,0) 2983 END IF 2984* 2985 LEN_MAT = LEN_BLMAT(NBLK,LBLK,LBLK,0) 2986 IF(IORTMET.EQ.1) THEN 2987*. Obtain S ** (-1/2) 2988 KLSQRT = 1 2989 KLSCR = KLSQRT + LEN_MAT 2990 CALL SQRT_BLMAT(S,NBLK,LBLK,2,SCR(1),C,SCR(KLSCR),0) 2991C SQRT_BLMAT(A,NBLK,LBLK,ITASK,ASQRT,AMSQRT,SCR,ISYM) 2992 ELSE 2993 CALL GET_ON_BASIS_BY_DIAG_BLKMT(S,NBLK,LBLK,C,SCR,1) 2994 END IF 2995* 2996 IF(NTEST.GE.1000) THEN 2997 WRITE(6,*) 2998 WRITE(6,*) 2999 & ' ORTHNORM_BLKMT: Matrix defining orthonormal basis ' 3000 WRITE(6,*) 3001 & ' ===================================================' 3002 WRITE(6,*) 3003 CALL APRBLM2(C,LBLK,LBLK,NBLK,0) 3004 END IF 3005* 3006 RETURN 3007 END 3008 SUBROUTINE GET_ON_BASIS_BY_DIAG_BLKMT(S,NBLK,LBLK,C,SCR,IPACK) 3009* 3010* A blocked metric S is given (lower half packed if IPACK = 1) 3011* Obtain block form of transformation matrix giving the orthonormal basis 3012* that is obtained by diagonalization 3013* S = U(T) Sigma U, C = U Sigma**(-1/2) 3014* 3015*. Jeppe Olsen, July 2011 3016* 3017 INCLUDE 'implicit.inc' 3018*. Input 3019 INTEGER LBLK(NBLK) 3020 DIMENSION S(*) 3021*. Output 3022 DIMENSION C(*) 3023*. Scratch: Should at least be of length L**2 + 2L, where L is dimension 3024* of largest block 3025 DIMENSION SCR(*) 3026* 3027 NTEST = 0 3028* 3029 NSING = 0 3030*. To get rid of compiler warninf 3031 IOFF = 0 3032 DO IBLK = 1, NBLK 3033 IF(IBLK.EQ.1) THEN 3034 IOFF = 1 3035 IOFFS = 1 3036 ELSE 3037 IOFF = IOFF + LBLK(IBLK-1)**2 3038 IF(IPACK.EQ.0) THEN 3039 IOFFS = IOFF 3040 ELSE 3041 IOFFS = IOFFS + LBLK(IBLK-1)*(LBLK(IBLK-1)-1)/2 3042 END IF 3043 END IF 3044* 3045 KLS = 1 3046 KLVEC1 = KLS + LBLK(IBLK)**2 3047 KLVEC2= KLVEC1 + LBLK(IBLK) 3048*. Obtain unpacked, but blocked, matrix in SCR(KLS) 3049 IF(IPACK.EQ.0) THEN 3050 LL = LBLK(IBLK)**2 3051 CALL COPVEC(S(IOFFS),SCR(KLS),LL) 3052 ELSE 3053 CALL TRIPAK_BLKM(SCR(KLS),S,2,LBLK,NBLK) 3054 END IF 3055*. And obtain orthonormal basis 3056 THRES_SINGU = 1.0D-14 3057C GET_ON_BASIS2(S,NVEC,NSING,X,SCRVEC1,SCRVEC2,THRES_SINGU) 3058 CALL GET_ON_BASIS2(SCR(KLS),LBLK(IBLK),NSING_BLK,C(IOFF), 3059 & SCR(KLVEC1),SCR(KLVEC2), THRES_SINGU) 3060 NSING = NSING + NSING_BLK 3061 IF(NSING_BLK.NE.0) THEN 3062 WRITE(6,*) ' Singularities in metric block ', IBLK 3063 WRITE(6,*) ' Number of singularities ', NSING_BLK 3064 END IF 3065 END DO 3066* 3067 IF(NTEST.GE.100) THEN 3068 WRITE(6,*) ' Orthonormalization matrix from diagonalization' 3069 CALL APRBLM2(C,LBLK,LBLK,NBLK,0) 3070 END IF 3071* 3072 IF(NSING.NE.0) THEN 3073 WRITE(6,*) ' Singularities in metric ' 3074 WRITE(6,*) ' Number of singularities in metric ', NSING 3075 STOP ' Singularities in metric ' 3076 END IF 3077* 3078 RETURN 3079 END 3080 FUNCTION LEN_BLMAT(NBLK,LROW,LCOL,IPACK) 3081* 3082* Determine number of elements in packed matrix with NBLK blocks 3083* with dimensions LROW, LCOL. 3084* IPACK = 1 => matrix is packed 3085* 3086* Jeppe Olsen, July 2011 3087* 3088 INCLUDE 'implicit.inc' 3089*. Input 3090 INTEGER LROW(NBLK),LCOL(NBLK) 3091* 3092 LEN = 0 3093 IF(IPACK.EQ.0) THEN 3094 DO IBLK = 1, NBLK 3095 LEN = LEN + LROW(IBLK)*LCOL(IBLK) 3096 END DO 3097 ELSE 3098 DO IBLK = 1, NBLK 3099 LEN = LEN + LROW(IBLK)*(LROW(IBLK)+1)/2 3100 END DO 3101 END IF 3102* 3103 LEN_BLMAT = LEN 3104* 3105 NTEST = 0 3106 IF(NTEST.GE.100) THEN 3107 WRITE(6,*) ' Dimension of block matrix ', LEN 3108 END IF 3109* 3110 RETURN 3111 END 3112 SUBROUTINE ORT_GAS_TO_GAS(IGAS,JGAS,SIN,CIN,COUT) 3113* 3114* Orthogonalize Orbitals in space JGAS to orbitals in space IGAS, i.e. 3115* modify orbitals in space JGAS so they are orthogonal to 3116* orbitals in space IGAS 3117* 3118* Jeppe Olsen, July 2011 3119* 3120 INCLUDE 'implicit.inc' 3121 INCLUDE 'mxpdim.inc' 3122 INCLUDE 'orbinp.inc' 3123 INCLUDE 'cgas.inc' 3124 INCLUDE 'lucinp.inc' 3125 INCLUDE 'wrkspc-static.inc' 3126*. Specific Input: Expansion of input MO's in AO's 3127 DIMENSION CIN(*),SIN(*) 3128*. Output: Expansion of output MO's in AO's 3129 DIMENSION COUT(*) 3130*. Local scratch 3131 INTEGER IDIM(MXPOBS),JDIM(MXPOBS) 3132* 3133 NTEST = 000 3134 IF(NTEST.GE.100) THEN 3135 WRITE(6,*) ' Info from ORT_GAS_TO_GAS' 3136 WRITE(6,*) ' =======================' 3137 WRITE(6,*) ' IGAS, JGAS = ', IGAS, JGAS 3138 END IF 3139 IF(NTEST.GE.10000) THEN 3140 WRITE(6,*) ' CIN entering ORT_GAS_TO_GAS ' 3141 CALL APRBLM2(CIN,NTOOBS,NTOOBS,NSMOB,0) 3142 END IF 3143* 3144 IDUM = 0 3145 CALL MEMMAN(IDUM,IDUM,'MARK ',2,'ORTGAS') 3146*. A bit of scratch 3147 LSCR = 2 * MXTOB **2 3148C? WRITE(6,*) ' Test: MXTOB = ',MXTOB 3149 CALL MEMMAN(KLSCR,LSCR, 'ADDL ', 2, 'SCRORT') 3150* 3151 CALL MEMMAN(KLSII, MXTOB**2, 'ADDL ',2,'SJJ ') 3152 CALL MEMMAN(KLSIJ, MXTOB**2, 'ADDL ',2,'SJI ') 3153 CALL MEMMAN(KLC, MXTOB**2, 'ADDL ',2,'SJI ') 3154* 3155 MXSOB = IMNMX(NTOOBS,NSMOB,2) 3156 LSCR = MXTOB*MXSOB 3157 CALL MEMMAN(KLCI, LSCR, 'ADDL ',2,'CIMOAO') 3158 CALL MEMMAN(KLCJ, LSCR, 'ADDL ',2,'CJMOAO') 3159 CALL MEMMAN(KLCJT, LSCR, 'ADDL ',2,'CJMOAO') 3160* 3161*. Dimensions of IGAS, JGAS (over symmetries) 3162* 3163 CALL EXTRROW(NOBPTS_GN,IGAS+1,7+MXPR4T,NSMOB,IDIM) 3164 CALL EXTRROW(NOBPTS_GN,JGAS+1,7+MXPR4T,NSMOB,JDIM) 3165 IF(NTEST.GE.1000) THEN 3166 WRITE(6,*) ' Number of orbitals per sym in IGAS = ', IGAS 3167 CALL IWRTMA(IDIM,1,NSMOB,1,NSMOB) 3168 WRITE(6,*) ' Number of orbitals per sym in JGAS = ', JGAS 3169 CALL IWRTMA(JDIM,1,NSMOB,1,NSMOB) 3170 END IF 3171* 3172*. Extract S(IGAS,IGAS),S(IGAS,JGAS) 3173* 3174C EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT(A,AGAS,IGAS,JGAS,I_EX_OR_CP) 3175 CALL EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT(SIN,WORK(KLSII),IGAS,IGAS,1) 3176 CALL EXTR_OR_CP_GAS_BLKS_FROM_ORBMAT(SIN,WORK(KLSIJ),IGAS,JGAS,1) 3177 IF(NTEST.GE.1000) THEN 3178 WRITE(6,*) ' S(IGAS,IGAS) for IGAS = ', IGAS 3179 CALL APRBLM2(WORK(KLSII),IDIM,IDIM,NSMOB,0) 3180 WRITE(6,*) ' S(IGAS,JGAS) for IGAS, JGAS = ', IGAS, JGAS 3181 CALL APRBLM2(WORK(KLSIJ),IDIM,JDIM,NSMOB,0) 3182 END IF 3183* 3184*. Obtain coefficient matrix of I-vectors to obtain orthogonality 3185* 3186C ORT_SPCY_TO_SPCX_BLK(NX,NY,NBLK,SXX,SXY,C,SCR) 3187 CALL ORT_SPCY_TO_SPCX_BLK(IDIM,JDIM,NSMOB, 3188 & WORK(KLSII), WORK(KLSIJ),WORK(KLC),WORK(KLSCR)) 3189* 3190*. Obtain MO-orbitals of space I and J 3191* 3192 CALL EX_OR_CP_MO_FOR_GAS(CIN,WORK(KLCI),IGAS,1) 3193 CALL EX_OR_CP_MO_FOR_GAS(CIN,WORK(KLCJ),JGAS,1) 3194* 3195*. Update MO- coefficients for JGAS 3196* 3197C MULT_BLOC_MAT 3198C (C,A,B,NBLOCK,LCROW,LCCOL,LAROW,LACOL,LBROW,LBCOL,ITRNSP) 3199* C(JGAS) = C(IGAS)*C 3200 CALL MULT_BLOC_MAT(WORK(KLCJT),WORK(KLCI),WORK(KLC),NSMOB, 3201 & NTOOBS,JDIM,NTOOBS,IDIM,IDIM,JDIM,0) 3202 IF(NTEST.GE.1000) THEN 3203 WRITE(6,*) ' Correction to Y_j = sum_k X_k C(k,j) ' 3204 CALL APRBLM2(WORK(KLCJT),NTOOBS,JDIM,NSMOB,0) 3205 END IF 3206 LEN = LEN_BLMAT(NSMOB,JDIM,NTOOBS,0) 3207C LEN_BLMAT(NBLK,LROW,LCOL,IPACK) 3208 ONE = 1.0D0 3209 IF(NTEST.GE.1000) THEN 3210 WRITE(6,*) ' Input block CIN for JGAS = ', JGAS 3211 CALL APRBLM2(WORK(KLCJ),NTOOBS,JDIM,NSMOB,0) 3212 END IF 3213 CALL VECSUM(WORK(KLCJ),WORK(KLCJ),WORK(KLCJT),ONE,ONE,LEN) 3214 IF(NTEST.GE.1000) THEN 3215 WRITE(6,*) ' Updated matrix C(JGAS) ' 3216 CALL APRBLM2(WORK(KLCJ),NTOOBS,JDIM,NSMOB,0) 3217 END IF 3218* 3219*. And transfer to COUT 3220* 3221 LEN_1F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 3222 CALL COPVEC(CIN,COUT,LEN_1F) 3223 CALL EX_OR_CP_MO_FOR_GAS(COUT,WORK(KLCJ),JGAS,2) 3224* 3225 IF(NTEST.GE.100) THEN 3226 WRITE(6,*) 3227 & ' MO expansion after orthogonalization of GAS ', JGAS , ' TO ', 3228 & IGAS 3229 CALL APRBLM2(COUT,NTOOBS,NTOOBS,NSMOB,0) 3230 END IF 3231* 3232 CALL MEMMAN(IDUM,IDUM,'FLUSM ',2,'ORTGAS') 3233* 3234 RETURN 3235 END 3236 SUBROUTINE ORT_SPCY_TO_SPCX_BLK(NX,NY,NBLK,SXX,SXY,C,SCR) 3237* A space X with metric SXX 3238* and a space Y with overlap SXY with X 3239* is given. The space and metrics are divided into NBLK blocks. 3240* 3241* Obtain the matrix C so (Y_ai + sum_k C_ki X_ak) is 3242* orthogonal to space X 3243* 3244* C(IBLK) = -SXX(IBLK)(-1) SXY(IBLK) 3245* 3246*. Jeppe Olsen, July 2011 3247* 3248 INCLUDE 'implicit.inc' 3249*. Input 3250 INTEGER NX(NBLK),NY(NBLK) 3251 DIMENSION SXX(*),SXY(*) 3252*. Output 3253 DIMENSION C(*) 3254*. Scratch: Should be length 2*NXM*NXM where NX is dim of largest block 3255 DIMENSION SCR(*) 3256* 3257 NTEST = 000 3258 IF(NTEST.GE.100) THEN 3259 WRITE(6,*) 3260 WRITE(6,*) ' Info from ORT_SPCY_TO_SPCX_BLK ' 3261 WRITE(6,*) ' ============================== ' 3262 WRITE(6,*) 3263 END IF 3264 IF(NTEST.GE.1000) THEN 3265 WRITE(6,*) ' Input matrix SXX ' 3266 CALL APRBLM2(SXX,NX,NX,NBLK,0) 3267 WRITE(6,*) ' Input matrix SXY ' 3268 CALL APRBLM2(SXY,NX,NY,NBLK,0) 3269 END IF 3270* 3271 NXM = IMNMX(NX,NBLK,2) 3272 KLS = 1 3273 KLSCR = KLS + NXM*NXM 3274* 3275 DO IBLK = 1, NBLK 3276 IF(IBLK.EQ.1) THEN 3277 IOFFXX = 1 3278 IOFFXY = 1 3279 ELSE 3280 IOFFXX = IOFFXX + NX(IBLK-1)**2 3281 IOFFXY = IOFFXY + NX(IBLK-1)*NY(IBLK-1) 3282 END IF 3283 NNX = NX(IBLK) 3284 NNY = NY(IBLK) 3285 IF(NTEST.GE.1000) 3286 & WRITE(6,*) ' IBLK, NNX, NNY = ', IBLK, NNX, NNY 3287*. Obtain SXX(IBLK) (-1) 3288 CALL COPVEC(SXX(IOFFXX),SCR(KLS),NNX**2) 3289 IF(NTEST.GE.1000) THEN 3290 WRITE(6,*) ' BLOCK SXX: ' 3291 CALL WRTMAT(SCR(KLS),NNX,NNX,NNX,NNX) 3292 END IF 3293 ISING = 0 3294 CALL INVMAT(SCR(KLS),SCR(KLSCR),NNX,NNX,ISING) 3295 IF(NTEST.GE.1000) THEN 3296 WRITE(6,*) ' Inverted SXX block' 3297 CALL WRTMAT(SCR(KLS),NNX,NNX,NNX,NNX) 3298 END IF 3299 IF(ISING.GT.0) THEN 3300 WRITE(6,*) ' Problem inverting SXX ' 3301 END IF 3302*. And multiply 3303C MATML7(C,A,B,NCROW,NCCOL,NAROW,NACOL, 3304C & NBROW,NBCOL,FACTORC,FACTORAB,ITRNSP ) 3305 FACTORC = 0.0D0 3306 FACTORAB = -1.0D0 3307 CALL MATML7(C(IOFFXY),SCR(KLS),SXY(IOFFXY), 3308 & NNX,NNY,NNX,NNX,NNX,NNY,FACTORC, FACTORAB,0) 3309 END DO! End of loop over blocks 3310* 3311 IF(NTEST.GE.100) THEN 3312 WRITE(6,*) ' C matrix for space-space orthogonalization ' 3313 CALL APRBLM2(C,NX,NY,NBLK,0) 3314 END IF 3315* 3316 RETURN 3317 END 3318C CALL EX_OR_CP_MO_FOR_GAS(CMO,WORK(KLCI),IGAS,I_EX_OR_CP) 3319 SUBROUTINE EX_OR_CP_MO_FOR_GAS(CMO_TOT, CMO_GAS, IGAS, 3320 & I_EX_OR_CP) 3321* 3322* Extract from or copy to CMO_TOT orbitals belonging to GASpace IGAS 3323* to/from CMO_GAS 3324* 3325*. Jeppe Olsen, July 2011 3326* 3327 INCLUDE 'implicit.inc' 3328 INCLUDE 'mxpdim.inc' 3329 INCLUDE 'orbinp.inc' 3330 INCLUDE 'lucinp.inc' 3331*. Input 3332 DIMENSION CMO_TOT(*) 3333*. Output 3334 DIMENSION CMO_GAS(*) 3335*. Local scratch 3336 DIMENSION IDIM(MXPOBS) 3337* 3338 NTEST = 000 3339 IF(NTEST.GE.100) THEN 3340 WRITE(6,*) ' Info from EX_OR_CP_MO_FOR_GAS' 3341 WRITE(6,*) ' =============================' 3342 WRITE(6,*) ' I_EX_OR_CP = ', I_EX_OR_CP 3343 WRITE(6,*) ' IGAS = ',IGAS 3344 END IF 3345 IF(NTEST.GE.10000) THEN 3346 WRITE(6,*) ' Input complete matrix ' 3347 CALL APRBLM2(CMO_TOT,NTOOBS,NTOOBS,NSMOB,0) 3348 END IF 3349* 3350 DO ISM = 1, NSMOB 3351*. Start of symmetry block 3352 IF(ISM .EQ. 1 ) THEN 3353 IOFF_TOT = 1 3354 IOFF_GAS = 1 3355 ELSE 3356 IOFF_TOT = IOFF_TOT + NTOOBS(ISM-1)**2 3357 IOFF_GAS = IOFF_GAS + NTOOBS(ISM-1)*NOBPTS_GN(IGAS,ISM-1) 3358 END IF 3359*. First orbital in GASpace IGAS in sym ISM - relative to start of sym 3360 IOFF_REL = 1 3361 DO JGAS = 0, IGAS-1 3362 IOFF_REL = IOFF_REL + NOBPTS_GN(JGAS,ISM) 3363 END DO 3364 NOB_GAS = NOBPTS_GN(IGAS,ISM) 3365 NOB_SM = NTOOBS(ISM) 3366 IF(I_EX_OR_CP.EQ.1) THEN 3367 CALL COPVEC(CMO_TOT(IOFF_TOT-1+(IOFF_REL-1)*NOB_SM+1), 3368 & CMO_GAS(IOFF_GAS),NOB_GAS*NOB_SM) 3369 ELSE 3370 CALL COPVEC(CMO_GAS(IOFF_GAS), 3371 & CMO_TOT(IOFF_TOT-1+(IOFF_REL-1)*NOB_SM+1), 3372 & NOB_GAS*NOB_SM) 3373 END IF 3374 END DO 3375* 3376 IF(NTEST.GE.1000) THEN 3377 CALL EXTRROW(NOBPTS_GN,IGAS+1,7+MXPR4T,NSMOB,IDIM) 3378 IF(I_EX_OR_CP.EQ.1) THEN 3379 WRITE(6,*) ' Extracted MO coefficients for IGAS = ', IGAS 3380 CALL APRBLM2(CMO_GAS,NTOOBS,IDIM,NSMOB,0) 3381 ELSE 3382 WRITE(6,*) ' Updated matrix of MO coefficients ' 3383 CALL APRBLM2(CMO_TOT,NTOOBS,NTOOBS,NSMOB,0) 3384 END IF 3385 END IF 3386* 3387 RETURN 3388 END 3389 SUBROUTINE INI_CSFEXP(CINI) 3390* 3391* Obtain initial CI expansion in terms of the CSF expansion CINI 3392* Configuration space is specified as ICSPC_CN 3393* 3394*. Jeppe Olsen, July 2011 3395* 3396 INCLUDE 'implicit.inc' 3397 INCLUDE 'mxpdim.inc' 3398 INCLUDE 'glbbas.inc' 3399 INCLUDE 'cands.inc' 3400 INCLUDE 'crun.inc' 3401 INCLUDE 'spinfo.inc' 3402*. Output 3403 DIMENSION CINI(*) 3404* 3405*. If an initial configuration has been specified use thus 3406* 3407 IDUM = 0 3408 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'INICSF') 3409* 3410 NTEST = 1000 3411 IF(NTEST.GE.10) THEN 3412 WRITE(6,*) ' INI_CSFEXP reporting ' 3413 WRITE(6,*) ' ====================' 3414 WRITE(6,*) ' I_HAVE_INI_CONF = ', I_HAVE_INI_CONF 3415 END IF 3416* 3417 NCSF_TOT = NCSF_PER_SYM_GN(ICSM, ICSPC_CN) 3418*. Initialize by zero 3419 ZERO = 0.0D0 3420 CALL SETVEC(CINI,ZERO,NCSF_TOT) 3421* 3422 IF(I_HAVE_INI_CONF.EQ.1) THEN 3423 WRITE(6,*) ' Initial configuration used as initial guess ' 3424* 3425*. Find address of configuration 3426C ILEX_FOR_CONF_G(ICONF,NOCC_ORB,ICONF_SPC,IDOREO) 3427 ILEX = ILEX_FOR_CONF_G(INI_CONF,NOB_INI_CONF,ICSPC_CN,1) 3428 IF(NTEST.GE.1000) WRITE(6,*) ' Address of config = ', ILEX 3429*. Number of CSF's for this configuration 3430 IOPEN = 2*NOB_INI_CONF-N_EL_CONF 3431*. Address in CSFVEC of first CSF with this number of open orbitals 3432 IB_OPEN = IB_OPEN_CSF(IOPEN+1,ICSM,ICSPC_CN) 3433 IF(NTEST.GE.1000) WRITE(6,*) ' IB_OPEN = ', IB_OPEN 3434*. Address of first configuration with this number of open orbitals 3435 IB_CONF = IB_CONF_REO_GN(IOPEN+1,ICSM,ICSPC_CN) 3436 IF(NTEST.GE.1000) WRITE(6,*) ' IB_CONF = ', IB_CONF 3437*. Address of first CSF belonging to this configuration 3438 IADDR = IB_OPEN + (ILEX-IB_CONF)*NPCSCNF(IOPEN+1) 3439 IF(NTEST.GE.1000) WRITE(6,*) ' IADDR = ', IADDR 3440 3441*. Equal contribution to all CSF's of config 3442 NCSF_CONF = NPCSCNF(IOPEN+1) 3443 XNCSF_CONF = DFLOAT(NCSF_CONF) 3444C? WRITE(6,*) ' IOPEN, NPCSCNF(IOPEN+1) = ', 3445C? & IOPEN, NPCSCNF(IOPEN+1) 3446 FACTOR = 1.0D0/SQRT(XNCSF_CONF) 3447C? WRITE(6,*) ' XNCSF_CONF, FACTOR = ', 3448C? & XNCSF_CONF, FACTOR 3449 CALL SETVEC(CINI(IADDR),FACTOR,NCSF_CONF) 3450 ELSE 3451*. Set configuration one to 1 3452 IF(NCSF_TOT.GE.7) THEN 3453 CINI(7) = 1.0D0 3454 WRITE(6,*) ' Initial guess set to CSF 7 !!!! ' 3455 ELSE 3456 CINI(1) = 1.0D0 3457 WRITE(6,*) ' Initial guess set to CSF 1 ' 3458 END IF 3459 END IF 3460* 3461 IF(NTEST.GE.1000) THEN 3462 WRITE(6,*) ' Initial CI vector ' 3463 WRITE(6,*) ' =================' 3464 CALL WRTMAT(CINI,1,NCSF_TOT,1,NCSF_TOT) 3465 END IF 3466* 3467 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'INICSF') 3468* 3469 RETURN 3470 END 3471 FUNCTION NEL_IN_COMPACT_CONF(ICONF,NOCOB) 3472* 3473*. Number of electrons in configuration, compact form 3474* 3475* Jeppe Olsen, July 2011 3476* 3477 INCLUDE 'implicit.inc' 3478 INTEGER ICONF(NOCOB) 3479* 3480 NEL = 0 3481 DO IORB = 1, NOCOB 3482 IF(ICONF(IORB).GT.0) THEN 3483 NEL = NEL + 1 3484 ELSE 3485 NEL = NEL + 2 3486 END IF 3487 END DO 3488* 3489 NEL_IN_COMPACT_CONF = NEL 3490* 3491 NTEST = 100 3492 IF(NTEST.GE.100) THEN 3493 WRITE(6,*) ' Output from NEL_IN_COMPACT_CONF ' 3494 WRITE(6,*) ' Configuration: ' 3495 CALL IWRTMA(ICONF,1,NOCOB,1,NOCOB) 3496 WRITE(6,*) ' Number of electrons = ', NEL 3497 END IF 3498* 3499 RETURN 3500 END 3501 SUBROUTINE SIGMA_CONF(C,HC,LUC,LUHC) 3502* 3503* Configuration driven Sigma routine 3504* Jeppe Olsen, July 2011 3505* 3506*. The input and output CI spaces in action are defined by the 3507* ICPSC_CN, ISSPC_CN parameters in cands 3508* 3509* 3510 INCLUDE 'implicit.inc' 3511 INCLUDE 'mxpdim.inc' 3512 INCLUDE 'wrkspc-static.inc' 3513 INCLUDE 'glbbas.inc' 3514 INCLUDE 'cands.inc' 3515 INCLUDE 'crun.inc' 3516 INCLUDE 'spinfo.inc' 3517* 3518 IDUM = 0 3519 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'SIGCNF') 3520* 3521 NTEST = 1000 3522 IF(NTEST.GE.10) THEN 3523 WRITE(6,*) ' Info from SIGMA_CONF ' 3524 WRITE(6,*) ' ===================== ' 3525 WRITE(6,'(A,2I3)') ' Config space and sym for C ', ICSPC_CN,ICSM 3526 WRITE(6,'(A,2I3)') ' Config space and sym for S ', ISSPC_CN,ISSM 3527 END IF 3528*. 3529 NCONF_C = NCONF_PER_SYM_GN(ICSM,ICSPC_CN) 3530 NSD_C = NSD_PER_SYM_GN(ICSM,ICSPC_CN) 3531 NCSF_C = NCSF_PER_SYM_GN(ICSM,ICSPC_CN) 3532* 3533 NCONF_S = NCONF_PER_SYM_GN(ISSM,ISSPC_CN) 3534 NSD_S = NSD_PER_SYM_GN(ISSM,ISSPC_CN) 3535 NCSF_S = NCSF_PER_SYM_GN(ISSM,ISSPC_CN) 3536* 3537 NCONF_MAX = MAX(NCONF_C,NCONF_S) 3538* 3539 IF(NTEST.GE.100) THEN 3540 WRITE(6,'(A,3I8)') ' Number of confs, SDs and CSFs for C ', 3541 & NCONF_C, NSD_C, NCSF_C 3542 WRITE(6,'(A,3I8)') ' Number of confs, SDs and CSFs for S ', 3543 & NCONF_S, NSD_S, NCSF_S 3544 END IF 3545* 3546*. Number of batches for configuration expansions (each batch atmost dim LCSBLK) 3547* ================================================================================ 3548* 3549*. Allowed length of batch: 3550* ========================== 3551*. IF LCSBLK has not been specified, a default batch size is used 3552* 3553 LCSBLK_L = LCSBLK 3554 IF(LCSBLK_L.LE.0) THEN 3555 WRITE(6,*) ' SIGMA_CONF will define length of batch ' 3556 LCSBLK_DEFAULT = 2000000 3557*. Compare with dimension of largest single configuration 3558 LCONF_MAX = IMNMX(NPCSCNF,MAXOP+1,2) 3559 IF(LCONF_MAX.GT.LCSBLK_DEFAULT) LCSBLK_DEFAULT = LCONF_MAX 3560 LCSBLK_L = LCSBLK_DEFAULT 3561 END IF 3562*. If ICISTR = 1, vectors are stored in one batch, so 3563 IF(ICISTR.EQ.1) LCSBLK_L = MAX(NCSF_S,NCSF_S) 3564 3565 IF(NTEST.GE.1000) WRITE(6,*) ' Allowed size of batch ', LCSBLK_L 3566*. Batches of C 3567*. ============== 3568*. One could here either use CSF's or SD's. As memory maybe the defining parameter, 3569* I opt for CSF's and will then expand/contract each configuration when needed. 3570*. Length of each configuration 3571 CALL MEMMAN(KLLCNFEXP,NCONF_MAX,'ADDL ',1,'LCNFEX') 3572*. For C 3573C CONF_EXP_LEN_LIST(ILEN,NCONF_PER_OPEN,NELMNT_PER_OPEN,MAXOP) 3574 CALL CONF_EXP_LEN_LIST(WORK(KLLCNFEXP), 3575 & NCONF_PER_OPEN_GN(1,ICSM,ICSPC_CN),NPCSCNF,MAXOP) 3576C PART_VEC(LBLK,NBLK,MAXSTR,LBAT,NBAT,IONLY_NBAT) 3577 CALL PART_VEC(WORK(KLLCNFEXP),NCONF_C,LCSBLK_L,IDUM,NBAT_C,1) 3578 CALL MEMMAN(KLLBAT_C,NBAT_C,'ADDL ',1,'LBAT_C') 3579 CALL PART_VEC(WORK(KLLCNFEXP),NCONF_C,LCSBLK_L,WORK(KLLBAT_C), 3580 & NBAT_C,0) 3581*. And for Sigma 3582C CONF_EXP_LEN_LIST(ILEN,NCONF_PER_OPEN,NELMNT_PER_OPEN,MAXOP) 3583 CALL CONF_EXP_LEN_LIST(WORK(KLLCNFEXP), 3584 & NCONF_PER_OPEN_GN(1,ISSM,ISSPC_CN),NPCSCNF,MAXOP) 3585C PART_VEC(LBLK,NBLK,MAXSTR,LBAT,NBAT,IONLY_NBAT) 3586 CALL PART_VEC(WORK(KLLCNFEXP),NCONF_S,LCSBLK_L,IDUM,NBAT_S,1) 3587 CALL MEMMAN(KLLBAT_S,NBAT_S,'ADDL ',1,'LBAT_S') 3588 CALL PART_VEC(WORK(KLLCNFEXP),NCONF_S,LCSBLK_L,WORK(KLLBAT_S), 3589 & NBAT_S,0) 3590* 3591 IF(NTEST.GE.1000) THEN 3592 WRITE(6,*) ' Number of batches for C and S ', NBAT_C, NBAT_S 3593 END IF 3594*. Largest number of configurations in a given batch 3595 MAX_CONF_BATCH_C = IMNMX(WORK(KLLBAT_C),NBAT_C,2) 3596 MAX_CONF_BATCH_S = IMNMX(WORK(KLLBAT_S),NBAT_S,2) 3597 MAX_CONF_BATCH = MAX(MAX_CONF_BATCH_C,MAX_CONF_BATCH_S) 3598* 3599 IF(NTEST.GE.100) 3600 &WRITE(6,*) ' Largest number of configs in batch ', MAX_CONF_BATCH 3601 CALL MEMMAN(KLLBLK_BAT_C,MAX_CONF_BATCH ,'ADDL ',2,'LBLBTC') 3602 CALL MEMMAN(KLLBLK_BAT_S,MAX_CONF_BATCH ,'ADDL ',2,'LBLBTS') 3603*. Two vectors for holding expansion in SD of given config 3604 LEN_SD_CONF_MAX = IMNMX(NPDTCNF,MAXOP+1,2) 3605 CALL MEMMAN(KLCONF_SD_C,LEN_SD_CONF_MAX,'ADDL ',2,'CN_SDC') 3606 CALL MEMMAN(KLCONF_SD_S,LEN_SD_CONF_MAX,'ADDL ',2,'CN_SDS') 3607*. Scratch space in routine for evuluating H for configurations (allowing combs) 3608*. Scratch: Length: INTEGER: (NDET_C + NDET_S)*N_EL_CONF + NDET_C + 6*NORB 3609 L_CNHCN = LEN_SD_CONF_MAX*(1+2*N_EL_CONF) + 6*N_ORB_CONF 3610 CALL MEMMAN(KL_CNHCN, L_CNHCN,'ADDL ',1,'LCNHCN') 3611*. Space for two integers arrays for signs 3612 CALL MEMMAN(KLISIGNC,LEN_SD_CONF_MAX,'ADDL ',1,'ISIGNC') 3613 CALL MEMMAN(KLISIGNS,LEN_SD_CONF_MAX,'ADDL ',1,'ISIGNS') 3614* 3615C? WRITE(6,*) ' KDFTP, KL_CNHCN = ', KDFTP, KL_CNHCN 3616C? WRITE(6,*) ' KLLBLK_BAT_C, KLLBLK_BAT_S = ', 3617C? & KLLBLK_BAT_C, KLLBLK_BAT_S 3618C? WRITE(6,*) ' KLCONF_SD_C, KLCONF_SD_S = ', 3619C? & KLCONF_SD_C, KLCONF_SD_S 3620C? WRITE(6,*) ' KLLBAT_C, KLLBAT_S = ', 3621C? & KLLBAT_C, KLLBAT_S 3622* 3623 IADOB = IB_ORB_CONF - 1 3624 CALL SIGMA_CONF_SLAVE(C,HC,LUC,LUHC,ICISTR, 3625 & NCONF_PER_OPEN_GN(1,ICSM,ICSPC_CN), 3626 & NCONF_PER_OPEN_GN(1,ISSM,ISSPC_CN), 3627 & NBAT_C,WORK(KLLBAT_C), 3628 & NBAT_S,WORK(KLLBAT_S), 3629 & WORK(KLLBLK_BAT_C),WORK(KLLBLK_BAT_S), 3630 & WORK(KLCONF_SD_C),WORK(KLCONF_SD_S), 3631 & IADOB,WORK(KDFTP),WORK(KL_CNHCN), 3632 & WORK(KLISIGNC),WORK(KLISIGNS)) 3633* 3634 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'SIGCNF') 3635* 3636 IF(NTEST.GE.100) THEN 3637 WRITE(6,*) ' Final sigma-vector from SIGMA_CONF' 3638 CALL WRTMAT(HC,1,NCSF_S,1,NCSF_S) 3639 END IF 3640 3641 IF(NTEST.GE.1000) WRITE(6,*) ' SIGMA_CONF finished ' 3642 RETURN 3643 END 3644 SUBROUTINE SIGMA_CONF_SLAVE(C,S,LUC,LUS,ICISTR, 3645 & NCONF_PER_OPEN_C,NCONF_PER_OPEN_S, 3646 & NBAT_C,LBAT_C,NBAT_S,LBAT_S, 3647 & LBLK_BAT_C,LBLK_BAT_S, 3648 & CONF_SD_C,CONF_SD_S,IADOB,IPRODT, 3649 & ISCR_CNHCN,ISIGN_C,ISIGN_S) 3650* 3651* Inner (aka slave) routine for direct CI in configuration based methodsø 3652* 3653*. Jeppe Olsen,July 2011 3654* 3655 INCLUDE 'implicit.inc' 3656 INCLUDE 'mxpdim.inc' 3657 INCLUDE 'spinfo.inc' 3658 INCLUDE 'cands.inc' 3659 INCLUDE 'cecore.inc' 3660*. Input 3661*. C-vector or space for batch of C-vector 3662 DIMENSION C(*) 3663*. Info on the two configuration expansions 3664 INTEGER NCONF_PER_OPEN_C(*), NCONF_PER_OPEN_S(*) 3665*. Number of blocks in the batches of C and S 3666 INTEGER LBAT_C(*), LBAT_S(*) 3667*. Scratch for Info on batches of C and S: Length of each block (configuration in batch) 3668 INTEGER LBLK_BAT_C(*),LBLK_BAT_S(*) 3669*. Space for SD expansion of single configurations 3670 DIMENSION CONF_SD_C(*), CONF_SD_S(*) 3671*. Space for signs for phase change for dets of a configurations 3672 INTEGER ISIGN_C(*),ISIGN_S(*) 3673*. CSF info: proto type dets 3674 INTEGER IPRODT(*) 3675 3676*. Output 3677 DIMENSION S(*) 3678*. Scratch transferred through to CNHCN 3679 INTEGER ISCR_CNHCN(*) 3680*. Local scratch 3681 INTEGER IOCC_C(MXPORB),IOCC_S(MXPORB) 3682* 3683 NTEST = 000 3684* 3685 IDUM = 0 3686 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'SIGCNI') 3687*. Initialization of some parameters for controlling loop over configurations 3688 IOPEN_S = 0 3689 INUM_OPS = 0 3690 IOPEN_C = 0 3691 INUM_OPC = 0 3692 IB_CSF_C = 1 3693 IB_CSF_S = 1 3694* 3695 CALL MEMCHK2('INISIG') 3696* 3697*. Loop over batches of S 3698 INI_S = 1 3699 IF(NTEST.GE.1000) WRITE(6,*) ' NBAT_C, NBAT_S = ', 3700 &NBAT_C, NBAT_S 3701 DO IBAT_S = 1, NBAT_S 3702 IF(NTEST.GE.1000) 3703 & WRITE(6,'(A,I3)') ' >>> Start of sigma batch ', IBAT_S 3704* 3705 IF(IBAT_S.EQ.1) THEN 3706 IB_CONF_S = 1 3707 IB_CSF_S = 1 3708 ELSE 3709 IB_CONF_S = IB_CONF_S + LBAT_S(IBAT_S-1) 3710 END IF 3711C? WRITE(6,*) ' LBAT_S(1) = ', LBAT_S(1) 3712 N_CONF_S = LBAT_S(IBAT_S) 3713*. Number of CSF's per config in S-batch 3714C GET_LBLK_CONF_BATCH(ICNF_INI,NCNF,LBLK_BAT,ISYM,ISPC, 3715C & NSD_BAT_TOT,NCSF_BAT_TOT) 3716 CALL GET_LBLK_CONF_BATCH(IB_CONF_S,N_CONF_S,LBLK_BAT_S,ISSM, 3717 & ISSPC_CN,NSD_BAT_TOT_S,NCSF_BAT_TOT_S) 3718 CALL MEMCHK2('AFGTL1') 3719 IF(NTEST.GE.100) THEN 3720 WRITE(6,'(A,2I9)') 3721 & ' Number of CSFs and SDs in S-batch ', NCSF_BAT_TOT_S, 3722 & NSD_BAT_TOT_S 3723 END IF 3724*. Initialize sigma batch 3725 ZERO = 0.0D0 3726C? WRITE(6,*) ' IB_CSF_S, NCSF_BAT_TOT_S = ', 3727C? & IB_CSF_S, NCSF_BAT_TOT_S 3728 CALL SETVEC(S(IB_CSF_S),ZERO,NCSF_BAT_TOT_S) 3729*. Loop over batches of C 3730C IF(ICISTR.NE.1) REWIND LUHC 3731 INI_C = 1 3732*. First time in this batch 3733 ISBAT_FIRST_TIME =1 3734 DO IBAT_C = 1, NBAT_C 3735 IF(NTEST.GE.1000) 3736 & WRITE(6,'(A,I3)') ' >>> Start of C batch ', IBAT_C 3737 CALL MEMCHK2('STCBAT') 3738 IF(IBAT_C.EQ.1) THEN 3739 IB_CONF_C = 1 3740 IB_CSF_C = 1 3741 ELSE 3742 IB_CONF_C = IB_CONF_C + LBAT_C(IBAT_C-1) 3743 END IF 3744 N_CONF_C = LBAT_C(IBAT_C) 3745*. Number of configs per config in S-batch 3746 CALL GET_LBLK_CONF_BATCH(IB_CONF_C,N_CONF_C,LBLK_BAT_C,ICSM, 3747 & ICSPC_CN,NSD_BAT_TOT_C,NCSF_BAT_TOT_C) 3748 IF(NTEST.GE.100) THEN 3749 WRITE(6,'(A,2I9)') 3750 & ' Number of CSFs and SDs in C-batch ', NCSF_BAT_TOT_C, 3751 & NSD_BAT_TOT_C 3752 END IF 3753 CALL MEMCHK2('AFGTLB') 3754*. Read, if required, next batch of C- Each configuration stored in a record by itself 3755 IF(ICISTR.NE.1) THEN 3756 CALL FRMDSCN(C,N_CONF_C,-1,LUC) 3757C FRMDSCN(VEC,NREC,LBLK,LU) 3758 END IF 3759*. And then to the configurations of the C and sigma 3760*. First time in this batch 3761 IF(ISBAT_FIRST_TIME.EQ.1) THEN 3762* Save pointers to start of configuration 3763 IOPEN_S_SAVE = IOPEN_S 3764 INUM_OPS_SAVE = INUM_OPS 3765 IB_CSF_S_SAVE = IB_CSF_S 3766 INI_S_SAVE = INI_S 3767 ELSE 3768 IOPEN_S = IOPEN_S_SAVE 3769 INUM_OPS = INUM_OPS 3770 IB_CSF_S = IB_CSF_S_SAVE 3771 INI_S = INI_S_SAVE 3772 END IF 3773 ISBAT_FIRST_TIME = 0 3774* 3775 ICBAT_FIRST_TIME =1 3776 DO ICONF_S = IB_CONF_S, IB_CONF_S + N_CONF_S -1 3777*. Obtain occupation in IOCC_S and iopen for this sigma-configuration 3778C NEXT_CONF_IN_CONFSPC(IOCC,IOPEN,INUM_OP,INI,ISYM,ISPC,NEW) 3779 IF(NTEST.GE.1000) WRITE(6,*) ' Requesting next S-conf: ' 3780 CALL NEXT_CONF_IN_CONFSPC(IOCC_S,IOPEN_S,INUM_OPS,INI_S, 3781 & ISSM,ISSPC_CN,NEW_S) 3782 INI_S = 0 3783 IOCOB_S = (IOPEN_S + N_EL_CONF)/2 3784*. Signs for going between configuration and interaction order of dets 3785C SIGN_CONF_SD(ICONF,NOB_CONF,IOP,ISGN,IPDET_LIST,ISCR) 3786 CALL SIGN_CONF_SD(IOCC_S,IOCOB_S,IOPEN_S,ISIGN_S,IPRODT, 3787 & ISCR_CNHCN) 3788 CALL MEMCHK2('AFSIGN') 3789* 3790 IF(NTEST.GE.100) THEN 3791 WRITE(6,*) ' Sigma configuration number ', ICONF_S 3792 CALL IWRTMA(IOCC_S,1,IOCOB_S,1,IOCOB_S) 3793 END IF 3794 NCSF_S = NPCSCNF(IOPEN_S+1) 3795 NSD_S = NPDTCNF(IOPEN_S+1) 3796* 3797 ZERO = 0.0D0 3798*. The contribution to a given sigma conf from all C-conf in C-batch 3799* will be stored in CONF_SD_S(1) 3800 CALL SETVEC(CONF_SD_S,ZERO,NSD_S) 3801* 3802 IF( ICBAT_FIRST_TIME .EQ. 1) THEN 3803 IOPEN_C_SAVE = IOPEN_C 3804 INUM_OPC_SAVE = INUM_OPC 3805 IB_CSF_C_SAVE = IB_CSF_C 3806 ELSE 3807 IOPEN_C = IOPEN_C_SAVE 3808 INUM_OPC = INUM_OPC_SAVE 3809 IB_CSF_C = IB_CSF_C_SAVE 3810 END IF 3811 ICBAT_FIRST_TIME = 0 3812 DO ICONF_C = IB_CONF_C, IB_CONF_C + N_CONF_C -1 3813*. Obtain occupation in IOCC_C and iopen for this C-configuration 3814C NEXT_CONF_IN_CONFSPC(IOCC,IOPEN,INUM_OP,INI,ISYM,ISPC,NEW) 3815 IF(NTEST.GE.1000) WRITE(6,*) ' Requesting next C-conf: ' 3816 CALL NEXT_CONF_IN_CONFSPC(IOCC_C,IOPEN_C,INUM_OPC,INI_C, 3817 & ICSM,ICSPC_CN,NEW_C) 3818*. Signs for going between configuration and interaction order of dets 3819C SIGN_CONF_SD(ICONF,NOB_CONF,IOP,ISGN,IPDET_LIST,ISCR) 3820 IOCOB_C = (IOPEN_C + N_EL_CONF)/2 3821 CALL SIGN_CONF_SD(IOCC_C,IOCOB_C,IOPEN_C,ISIGN_C,IPRODT, 3822 & ISCR_CNHCN) 3823 INI_C = 0 3824 IF(NTEST.GE.1000) THEN 3825 WRITE(6,*) ' C configuration number ', ICONF_C 3826 IOCOB_C = (IOPEN_C + N_EL_CONF)/2 3827 CALL IWRTMA(IOCC_C,1,IOCOB_C,1,IOCOB_C) 3828 END IF 3829*. Expand coefficients for configuration from CSF to SD basis 3830 NCSF_C = NPCSCNF(IOPEN_C+1) 3831 NSD_C = NPDTCNF(IOPEN_C+1) 3832C CSDTVC_CONF(C_SD,C_CSF,NOPEN,ISIGN,IAC,IWAY) 3833 CALL CSDTVC_CONF(CONF_SD_C,C(IB_CSF_C),IOPEN_C,ISIGN_C,2,1) 3834 IF(NTEST.GE.1000) THEN 3835 WRITE(6,*) ' C(ICONF_C) in SD' 3836 CALL WRTMAT(CONF_SD_C,1,NSD_C,1,NSD_C) 3837 END IF 3838 IF(NTEST.GE.1000) THEN 3839 WRITE(6,'(A,2I6)') 3840 & ' Info on sigma for ICONF_C, ICONF_S = ', 3841 & ICONF_C, ICONF_S 3842 END IF 3843*. Core energy is pt added in DIHDJ2, so the code below is outcommented 3844C! IF(ICONF_C.EQ.ICONF_S) THEN 3845*. Add core energy 3846C! ONE = 1.0D0 3847C! CALL VECSUM(CONF_SD_S,CONF_SD_S,CONF_SD_C, 3848C! & ONE,ECORE,NSD_C) 3849C! END IF 3850*. Update: S(I) = S(I) + Sum(J) <I!H!J> C(J) 3851C CNHCN_LUCIA(ICNL,IOPL,ICNR,IOPR,C,SIGMA, 3852C & IADOB,IPRODT,I12OP,IORBTRA,IORB,IAB,ISCR) 3853 I12OP = 2 3854 I_DO_ORBTRA = 0 3855 IORB = 0 3856C CNHCN_LUCIA(ICNL,IOPL,ICNR,IOPR,C,CNHCNM,SIGMA, 3857C & IADOB,IPRODT,I12OP,I_DO_ORBTRA,IORBTRA, 3858C & ECORE,ISCR) 3859 CALL CNHCN_LUCIA(IOCC_S,IOPEN_S,IOCC_C,IOPEN_C, 3860 & CONF_SD_C,XDUM,CONF_SD_S,IADOB, 3861 & IPRODT,I12OP,I_DO_ORBTRA,IORB, 3862 & ECORE,2,0,RJ,RK, ISCR_CNHCN) 3863C CNHCN_LUCIA(ICNL,IOPL,ICNR,IOPR,C,CNHCNM,SIGMA, 3864C & IADOB,IPRODT,I12OP,I_DO_ORBTRA,IORBTRA, 3865C & ECORE,IHORS,ISYM,RJ,RK,ISCR) 3866*. Update address of C in action 3867 IB_CSF_C = IB_CSF_C + NCSF_C 3868 IF(NTEST.GE.1000) THEN 3869 WRITE(6,*) ' Updated Sigma(ICONF_S) in SD' 3870 CALL WRTMAT(CONF_SD_S,1,NSD_S,1,NSD_S) 3871 END IF 3872 END DO ! over configs in batch of C 3873*. And transform sigma part to CSF and update sigma vector 3874 CALL CSDTVC_CONF(CONF_SD_S,S(IB_CSF_S),IOPEN_S,ISIGN_S,1,2) 3875 IB_CSF_S = IB_CSF_S + NCSF_S 3876 IF(NTEST.GE.1000) WRITE(6,*) ' End of conf for S-batch ' 3877 END DO ! over configs in batch of S 3878 IF(NTEST.GE.1000) WRITE(6,*) ' End of C-batch ' 3879 END DO ! Over batches of C 3880 IF(NTEST.GE.1000) WRITE(6,*) ' End of S-batch ' 3881 END DO ! over batches of Sigma 3882* 3883 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'SIGCNI') 3884 IF(NTEST.GE.1000) WRITE(6,*) 'SIGMA_CONF_SLAVE finished' 3885 RETURN 3886 END 3887 SUBROUTINE PART_VEC(LBLK,NBLK,MAXSTR,LBAT,NBAT,IONLY_NBAT) 3888* 3889* A vector consists of NBLK BLocks with lengths given by LBLK(IBLK). 3890* Partition the vector into batches of blocks, so each batch has atmost 3891* length MAXSTR. 3892* IF IONLY_NBAT = 1, then only the number of batches is calculated 3893* 3894* Jeppe Olsen, July 2011 3895* 3896 INCLUDE 'implicit.inc' 3897*. Input 3898 INTEGER LBLK(NBLK) 3899*.Output 3900 DIMENSION LBAT(*) 3901* 3902 NBAT = 1 3903 NBLK_B = 0 3904 LBLK_B = 0 3905 DO IBLK = 1, NBLK 3906 IF(LBLK(IBLK)+LBLK_B.LE.MAXSTR) THEN 3907*. Can be included in current batch 3908 NBLK_B = NBLK_B + 1 3909 LBLK_B = LBLK_B + LBLK(IBLK) 3910 ELSE 3911 IF(IONLY_NBAT.EQ.0) LBAT(NBAT) = NBLK_B 3912*. Start new batch 3913 NBAT = NBAT + 1 3914 LBLK_B = LBLK(IBLK) 3915 NBLK_B = 1 3916 END IF 3917 END DO 3918*. Save last Batch 3919 IF(IONLY_NBAT.EQ.0) LBAT(NBAT) = NBLK_B 3920 3921* 3922 NTEST = 00 3923 IF(NTEST.GE.100) THEN 3924 WRITE(6,*) ' Output from PART_VEC ' 3925 WRITE(6,*) ' ==================== ' 3926 WRITE(6,*) ' Largest allowed batchsize ', MAXSTR 3927 WRITE(6,*) ' Number of batches ', NBAT 3928 IF(IONLY_NBAT.EQ.0) THEN 3929 WRITE(6,*) ' Number of blocks in each batch ' 3930 CALL IWRTMA(LBAT,1,NBAT,1,NBAT) 3931 END IF 3932 END IF 3933* 3934 RETURN 3935 END 3936 SUBROUTINE MATVCC2(A,VIN,VOUT,NROW,NCOL,ITRNS,FACIN) 3937* 3938* ITRNS = 0 : VOUT(I) = FACIN*VOUT(I) + A(I,J)*VIN(J) 3939* ITRNS = 1 : VOUT(I) = FACIN*VOUT(I) + A(J,I)*VIN(J) 3940* 3941* NROW, NCOL are rows and column of input matrix (not transposed) 3942 INCLUDE 'implicit.inc' 3943*. Input 3944 DIMENSION A(NROW,NCOL) 3945 DIMENSION VIN(*) 3946*. Output 3947 DIMENSION VOUT(*) 3948* 3949 IF(ITRNS.EQ.0) THEN 3950* 3951 IF(FACIN.EQ.0.0D0) THEN 3952 ZERO = 0.0D0 3953 CALL SETVEC(VOUT,ZERO,NROW) 3954 ELSE 3955 CALL SCALVE(VOUT,FACIN,NROW) 3956 END IF 3957* 3958 DO J = 1, NCOL 3959 VINJ = VIN(J) 3960 DO I = 1, NROW 3961 VOUT(I) = VOUT(I) + A(I,J)*VINJ 3962 END DO 3963 END DO 3964* 3965 ELSE IF( ITRNS.EQ.1) THEN 3966* 3967 DO I = 1, NCOL 3968 IF(FACIN.EQ.0.0D0) THEN 3969 X = 0.0D0 3970 ELSE 3971 X = FACIN*VOUT(I) 3972 END IF 3973* 3974 DO J = 1, NROW 3975 X = X + A(J,I)*VIN(J) 3976 END DO 3977 VOUT(I) = X 3978 END DO 3979 END IF 3980* 3981 NTEST = 000 3982 IF(NTEST.GE.100) THEN 3983 IF(ITRNS.EQ.0) THEN 3984 WRITE(6,*) ' Vectorout = matrix * vectorin (MATVCC) ' 3985 WRITE(6,*) ' Input and output vectors ' 3986 CALL WRTMAT(VIN,1,NCOL,1,NCOL) 3987 CALL WRTMAT(VOUT,1,NROW,1,NROW) 3988 WRITE(6,*) ' Matrix ' 3989 CALL WRTMAT(A,NROW,NCOL,NROW,NCOL) 3990 ELSE 3991 WRITE(6,*) ' Vectorout = matrix(T) * vectorin (MATVCC) ' 3992 WRITE(6,*) ' Input and output vectors ' 3993 CALL WRTMAT(VIN,1,NROW,1,NROW) 3994 CALL WRTMAT(VOUT,1,NCOL,1,NCOL) 3995 WRITE(6,*) ' Matrix (untransposed)' 3996 CALL WRTMAT(A,NROW,NCOL,NROW,NCOL) 3997 END IF 3998 END IF 3999 4000* 4001 RETURN 4002 END 4003 SUBROUTINE ISIGN_TIMES_REAL(ISIGN,VEC,NDIM) 4004* 4005* VEC(I) = ISIGN(I)*VEC(I) 4006* 4007* X X 4008* 4009 INCLUDE 'implicit.inc' 4010*. Input and output 4011 INTEGER ISIGN(*) 4012 DIMENSION VEC(*) 4013* 4014 DO I = 1, NDIM 4015 IF(ISIGN(I).EQ.-1) VEC(I) = -VEC(I) 4016 END DO 4017*. (No NTEST here, as it could identify programmer....) 4018 RETURN 4019 END 4020 SUBROUTINE MINMAX_FOR_ORBTRA(MIN_IN,MAX_IN,MIN_OUT,MAX_OUT, 4021 & MIN_INTM,MAX_INTM,MIN_INTMS,MAX_INTMS,ISYM,IDODIM, 4022 & NCONF_INTM,NCSF_INTM,NSD_INTM) 4023* 4024* Obtain intermediate MINMAX spaces for transforming between 4025* initial (MIN/MAX_IN) and final (MIN/MAX_OUT) spaces. 4026* 4027* Two intermediate spaces are produced 4028* 4029* _INTM: Just overall occupations are considered 4030* _INTMS: Also occupations in each orbital symmetry is 4031* considered 4032* (INTMS arrays not activated yet...) 4033* 4034* IF IDODIM.EQ.1, the number of configs, CSF's and SD's 4035* is calculated for the various spaces and SYM ISYM. 4036* 4037* IP_SPC is the first space in MIN 4038* 4039* 4040* Jeppe Olsen, July 16 2011 (55 years birthday- still programming) 4041* 4042* No distinction is made here of the two operators used to 4043* transform a given orbital. The IORB array should be 4044* used as final space for both operators for this orbital 4045 INCLUDE 'implicit.inc' 4046 INCLUDE 'mxpdim.inc' 4047 INCLUDE 'orbinp.inc' 4048 INCLUDE 'lucinp.inc' 4049 INCLUDE 'spinfo.inc' 4050*. Input 4051 INTEGER MIN_IN(MXPORB), MAX_IN(MXPORB) 4052 INTEGER MIN_OUT(MXPORB), MAX_OUT(MXPORB) 4053*. Output 4054 INTEGER MIN_INTM(MXPORB,N_ORB_CONF), 4055 & MAX_INTM(MXPORB,N_ORB_CONF) 4056 INTEGER MIN_INTMS(MXPORB,N_ORB_CONF), 4057 & MAX_INTMS(MXPORB,N_ORB_CONF) 4058* 4059 INTEGER NCONF_INTM(N_ORB_CONF) 4060 INTEGER NCSF_INTM(N_ORB_CONF) 4061 INTEGER NSD_INTM(N_ORB_CONF) 4062*. Local scratch 4063 INTEGER NOCPSM_IN(MXPOBS,2),NOCPSM_INTM(MXPOBS,2), 4064 & NOCPSM_OUT(MXPOBS,2), NREM(MXPOBS) 4065* 4066* The occupations of the intermediate codes is based on the 4067* following considerations: 4068* In each step of the transformation one orbital is transformed 4069* from initial to final basis. In step IORB, electrons in 4070* orbitals 1 - IORB may this be added, but never removed 4071* Note also that the transformation is symmetry conserving. 4072* So restrictions does not only hold for complete 4073* electron occupations, but also for occupations in each 4074* orbital symmetry 4075* 4076*. Note that MINMAX_INTM(*,*,IORB) refers to the occupations 4077* after orbital IORB has been transformed 4078* 4079 NTEST = 1000 4080 IF(NTEST.GE.1000) THEN 4081 WRITE(6,*) ' Info from MINMAX_FOR_ORBTRA ' 4082 WRITE(6,*) ' ============================ ' 4083 WRITE(6,*) 4084 WRITE(6,*) ' MINMAX for IN: ' 4085 CALL WRT_MINMAX_OCC(MIN_IN,MAX_IN,N_ORB_CONF) 4086 WRITE(6,*) ' MINMAX for OUT: ' 4087 CALL WRT_MINMAX_OCC(MIN_OUT,MAX_OUT,N_ORB_CONF) 4088 END IF 4089* 4090 IZERO = 0 4091* 4092*. Number of electrons per symmetry in IN and OUT 4093* 4094C MINMAX_PER_SYM(MIN_OCC,MAX_OCC,MIN_PER_SYM,MAX_PER_SYM) 4095 CALL MINMAX_PER_SYM(MIN_IN,MAX_IN, 4096 & NOCPSM_IN(1,1),NOCPSM_IN(1,2)) 4097 CALL MINMAX_PER_SYM(MIN_OUT,MAX_OUT, 4098 & NOCPSM_OUT(1,1),NOCPSM_OUT(1,2)) 4099* 4100* 4101* For convenience, during debugging 4102 INUM = -55 4103 DO IORB = 1, N_ORB_CONF-1 4104 CALL ISETVC(MIN_INTM(1,IORB),INUM,N_ORB_CONF) 4105 CALL ISETVC(MAX_INTM(1,IORB),INUM,N_ORB_CONF) 4106 END DO 4107*. Loop over orbitals to be transformed 4108 DO ITORB = 1, N_ORB_CONF 4109 IF(NTEST.GE.100) THEN 4110 WRITE(6,*) ' Orbital to be transformed ', ITORB 4111 END IF 4112 IF(ITORB.EQ.N_ORB_CONF) THEN 4113*. Just copy final list 4114 N = N_ORB_CONF 4115 CALL ICOPVE(MIN_OUT(1),MIN_INTM(1,N),N) 4116 CALL ICOPVE(MAX_OUT(1),MAX_INTM(1,N),N) 4117 ELSE IF(ITORB.EQ.1) THEN 4118*. The number of electrons in orbital 1 cannot be increased 4119 MAX_INTM(1,ITORB) = MAX_IN(1) 4120 MIN_INTM(1,ITORB) = 0 4121*. The accumulated occupation for the remaining orbitals may be decreased by 4122*. the number of electrons in orbital 1 4123 MAX_AC = MAX_IN(1) 4124 MIN_AC = MIN_IN(1) 4125 DO IORB = ITORB+1, N_ORB_CONF 4126 MIN_INTM(IORB,ITORB) = 4127 & MAX(0,MIN_IN(IORB)-MAX_AC) 4128 END DO 4129*. In the untransformed orbitals: Never less in IORB-N_ORB_CONF than in INI 4130 DO IORB = ITORB+1, N_ORB_CONF 4131 MAX_INTM(IORB,ITORB) = MAX_IN(IORB) 4132 END DO 4133 ELSE 4134*. Max in ITORB 4135 MAX_AC = 4136 & MIN((MAX_INTM(ITORB,ITORB-1) - MIN_INTM(ITORB-1,ITORB-1)),2) 4137*. Orbital IORB .le. ITORB: Never more in these orbitals than in the end 4138*. Occupations once created are never annihilated 4139 DO IORB = 1, ITORB-1 4140 MAX_INTM(IORB,ITORB) = MAX_OUT(IORB) 4141 MIN_INTM(IORB,ITORB) = MAX(0,MIN_INTM(IORB,ITORB-1)-MAX_AC) 4142 END DO 4143*. Orbital ITORB: Accumulated in 1 - ITORB can never be more than 4144* in the initial space 4145 MAX_INTM(ITORB,ITORB) = MAX_IN(ITORB) 4146 MIN_INTM(ITORB,ITORB) = MAX(0,MIN_INTM(ITORB,ITORB-1)-MAX_AC) 4147 4148*. Orbital IORB .gt. ITORB: Never less in orbitals IORB- N_ORB_CONF than in INI 4149 DO IORB = ITORB+1, N_ORB_CONF 4150 MAX_INTM(IORB,ITORB) = MAX_IN(IORB) 4151 MIN_INTM(IORB,ITORB) = MAX(0,MIN_INTM(IORB,ITORB-1)-MAX_AC) 4152 END DO 4153 END IF ! switch between orbitals 4154 END DO ! loop over orbitals to be transformed 4155* 4156*. Ensure that the MINMAX arrays are consistent with atmost 4157*. two electrons in each orb 4158* 4159 IZEROSPC = 0 4160 DO ITORB = 1, N_ORB_CONF 4161 CALL CHECK_MINMAX(MIN_INTM(1,ITORB),MAX_INTM(1,ITORB), 4162 & N_ORB_CONF,IZEROSPC) 4163C CHECK_MINMAX(MIN_OCC,MAX_OCC,NORB,IZEROSPC) 4164 IF(IZEROSPC.EQ.1) THEN 4165 WRITE(6,*) ' Vanishing space detected by CHECK_MINMAX' 4166 STOP ' Vanishing space detected by CHECK_MINMAX' 4167 END IF 4168 END DO 4169* 4170* 4171* Test: Set evrything to Max space 4172* 4173 IFUSK = 0 4174 IF(IFUSK .EQ.1) THEN 4175 DO I = 1, 100 4176 WRITE(6,*) ' MINMAX spaces set to largest possible space' 4177 END DO 4178 NELECT = MAX_IN(N_ORB_CONF) 4179 DO ITORB = 1, N_ORB_CONF 4180 DO IORB = 1, N_ORB_CONF 4181 MIN_INTM(IORB,ITORB) = 0 4182 MAX_INTM(IORB,ITORB) = NELECT 4183 END DO 4184 CALL CHECK_MINMAX(MIN_INTM(1,ITORB),MAX_INTM(1,ITORB), 4185 & N_ORB_CONF,IZEROSPC) 4186 END DO 4187 END IF ! FUSK 4188* 4189 IF(IDODIM.EQ.1) THEN 4190 DO IORB = 0, N_ORB_CONF 4191C GET_DIM_MINMAX_SPACE(MIN_OCC,MAX_OCC,NORB,ISYM, 4192 CALL GET_DIM_MINMAX_SPACE(MIN(1,IORB),MAX(1,IORB), 4193 & IREO_MNMX_OB_NO,N_ORB_CONF,ISYM,NCONFL,NCSFL,NSDL) 4194 NCONF_INTM(IORB) = NCONFL 4195 NCSF_INTM(IORB) = NCSFL 4196 NSD_INTM(IORB) = NSDL 4197 END DO 4198 END IF 4199* 4200 IF(NTEST.GE.100) THEN 4201 WRITE(6,*) 4202 WRITE(6,*) ' ========================================' 4203 WRITE(6,*) ' MINMAX arrays for orbital transformation' 4204 WRITE(6,*) ' ========================================' 4205 WRITE(6,*) 4206 DO IORB = 1, N_ORB_CONF 4207 WRITE(6,'(A,I4)') ' After transforming orbital ', IORB 4208 WRITE(6,*) ' ==================================' 4209 WRITE(6,*) 4210 CALL WRT_MINMAX_OCC( 4211 & MIN_INTM(1,IORB),MAX_INTM(1,IORB),N_ORB_CONF) 4212 IF(IDODIM.EQ.1) WRITE(6,'(A,3I9)') 4213 & ' Number Confs, CSFs, SDs ', 4214 & NCONF_INTM(IORB),NCSF_INTM(IORB),NSD_INTM(IORB) 4215 END DO 4216 END IF 4217* 4218 RETURN 4219 END 4220 SUBROUTINE CHECK_MINMAX(MIN_OCC,MAX_OCC,NORB,IZEROSPC) 4221* 4222* Accumulated occupations for configuration space is 4223* given in the form or a min max space. Ensure that the space 4224* is physically reasonable: 4225* 1: each orbital may contain atmost two electrons 4226* 4227* The spaces are corrected to produce the same space as input 4228* Therefore: Min_occ may be increased and max_occ may be decreased 4229* 4230* A vanisning space is flagged by IZEROSPC = 1 4231* 4232*. Jeppe Olsen, July 2011 4233* 4234 INCLUDE 'implicit.inc' 4235*. Input and output 4236 INTEGER MIN_OCC(NORB),MAX_OCC(NORB) 4237* 4238 NTEST = 1000 4239 IF(NTEST.GE.100) THEN 4240 WRITE(6,*) 4241 WRITE(6,*) ' Info from CHECK_MINMAX ' 4242 WRITE(6,*) ' =======================' 4243 WRITE(6,*) 4244 WRITE(6,*) ' MINMAX to be examined ' 4245 CALL WRT_MINMAX_OCC(MIN_OCC,MAX_OCC,NORB) 4246 END IF 4247* 4248 IZEROSPC = 0 4249*. Check that MAX is larger to or equal to MIN 4250 DO IORB = 1, NORB 4251 IF(MIN_OCC(IORB).GT. MAX_OCC(IORB)) IZEROSPC = 1 4252 END DO 4253*. Ensure that lower bounds are non-negative 4254 DO IORB = 1, NORB 4255 IF(MIN_OCC(IORB).LT.0) MIN_OCC(IORB) = 0 4256 END DO 4257*. Upper bound negative => vanishing space 4258 DO IORB = 1, NORB 4259 IF(MAX_OCC(IORB).LT.0) IZEROSPC = 1 4260 END DO 4261*. Upper bound .le. number of electrons 4262 NELEC = MAX_OCC(NORB) 4263 DO IORB = 1, NORB 4264 IF(MAX_OCC(IORB).GT.NELEC) MAX_OCC(IORB) = NELEC 4265 END DO 4266*. Ensure non-decreasing upper and lowe bounds 4267 DO IORB = NORB, 2, -1 4268 IF(MAX_OCC(IORB-1).GT.MAX_OCC(IORB)) 4269 & MAX_OCC(IORB-1) = MAX_OCC(IORB) 4270 END DO 4271 DO IORB = 2, NORB 4272 IF(MIN_OCC(IORB-1).GT.MIN_OCC(IORB)) 4273 & MIN_OCC(IORB) = MIN_OCC(IORB-1) 4274 END DO 4275*. Atmost two electrons may be added in each orbital 4276 DO IORB =1, NORB 4277 IF(MAX_OCC(IORB).GT.2*IORB) MAX_OCC(IORB) = 2*IORB 4278 IF(MIN_OCC(IORB).GT.2*IORB) IZEROSPC = 1 4279 END DO 4280*. Atleast two electrons may be added in each of the remaining orbitals 4281 DO IORB = NORB,1,-1 4282 MAXLEFT = (NORB-IORB)*2 4283 IF(MIN_OCC(IORB).LE.NELEC-MAXLEFT) MIN_OCC(IORB) = NELEC-MAXLEFT 4284 END DO 4285* 4286 IF(NTEST.GE.100.OR.IZEROSPC.EQ.1) THEN 4287 IF(IZEROSPC.EQ.1) THEN 4288 WRITE(6,*) ' CHECK_MINMAX was presented for a vanishing space' 4289 WRITE(6,*) ' Space, perhaps partly cleaned up' 4290 ELSE 4291 WRITE(6,*) ' MINMAX space after shaving by CHECK_MINMAX' 4292 END IF 4293 CALL WRT_MINMAX_OCC(MIN_OCC,MAX_OCC,NORB) 4294 END IF 4295* 4296 RETURN 4297 END 4298 FUNCTION IINPROD(IA,IB,NDIM) 4299* 4300* Inner product of two integer arrays IA, IB 4301* 4302* Jeppe Olsen, July 16, 2011 4303* 4304 INCLUDE 'implicit.inc' 4305 INTEGER IA(NDIM), IB(NDIM) 4306* 4307 IPROD = 0 4308 DO I = 1, NDIM 4309 IPROD = IPROD + IA(I)*IB(I) 4310 END DO 4311* 4312 IINPROD = IPROD 4313* 4314 RETURN 4315 END 4316 SUBROUTINE TRACI_CONF(C,S,LUC,LUHC) 4317* 4318*. Perform orbital transformation in the configuration approach 4319*. Initial version some 40 hours before take of to WATOC 2011 4320* 4321* Note: Routine uses C as scratch so this is modified during calc. 4322* 4323*. The MO-MO transformation matrix is stored in KCBIO 4324*. The spaces defining the in and out spaces are defined by 4325* 4326* ICPSC_CN, ISSPC_CN parameters in cands 4327* 4328* 4329*. Last modification; Jeppe Olsen; June 18, 2013; Allowing inactive orbitals 4330*. and several symmetries(sic) 4331 INCLUDE 'implicit.inc' 4332 REAL*8 INPROD 4333 INCLUDE 'mxpdim.inc' 4334 INCLUDE 'wrkspc-static.inc' 4335 INCLUDE 'glbbas.inc' 4336 INCLUDE 'cands.inc' 4337 INCLUDE 'crun.inc' 4338 INCLUDE 'spinfo.inc' 4339 INCLUDE 'orbinp.inc' 4340 INCLUDE 'vb.inc' 4341 INCLUDE 'lucinp.inc' 4342*. Input and scratch 4343 DIMENSION C(*) 4344*. Output 4345 DIMENSION S(*) 4346*. Local scratch 4347 DIMENSION FUSK(1000) 4348* 4349 IDUM = 0 4350 CALL LUCIAQENTER('TRACNF') 4351 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'TRACNF') 4352* 4353 NTEST = 100 4354 IF(NTEST.GE.100) THEN 4355 WRITE(6,*) ' Info from TRACI_CONF ' 4356 WRITE(6,*) ' ===================== ' 4357 WRITE(6,*) ' LUC, LUHC = ', LUC, LUHC 4358 WRITE(6,*) ' ICISTR = ', ICISTR 4359 WRITE(6,*) ' ICSM, ISSM = ',ICSM, ISSM 4360 END IF 4361 IF(NTEST.GE.10000) THEN 4362 WRITE(6,*) ' Initial vector to be transformed' 4363 NCSF_C = NCSF_PER_SYM_GN(ICSM,ICSPC_CN) 4364 CALL WRTMAT(C,1,NCSF_C,1,NCSF_C) 4365 END IF 4366* 4367* 1: Obtain the matrix T defining the steps of the orbital transformation 4368* using the approach of PAM 4369* T 4370 CALL MEMMAN(KLT,NTOOB**2,'ADDL ',2,'TMAT ') 4371 CALL MEMMAN(KLTB,NTOOB**2,'ADDL ',2,'TMATBL') 4372*. Scratch in PAMTMT 4373 LSCR = NTOOB**2 +NTOOB*(NTOOB+1)/2 4374 CALL MEMMAN(KLSCR,LSCR,'ADDL ',2,'KLSCR ') 4375*. Each symmetry separate 4376 DO ISM = 1, NSMOB 4377 IF(ISM.EQ.1) THEN 4378 IOFF = 1 4379 ELSE 4380 IOFF = IOFF + NTOOBS(ISM-1)**2 4381 END IF 4382 IF(NTOOBS(ISM).GT.0) 4383 & CALL PAMTMT(WORK(KCBIO-1+IOFF),WORK(KLT-1+IOFF), 4384 & WORK(KLSCR),NTOOBS(ISM)) 4385 END DO 4386* 4387 IF(NTEST.GE.100) THEN 4388 WRITE(6,*) ' The T-matrix for the orbital trans ' 4389 CALL APRBLM2(WORK(KLT),NTOOBS,NTOOBS,NSMOB,0) 4390 END IF 4391*. LUCIA will use space for one-electron integrals for orbital transformation. 4392*. save a copy of original KINT1 4393 LEN_1F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 4394 CALL MEMMAN(KLINT1_ORIG,LEN_1F,'ADDL ',2,'INT1_O') 4395 CALL COPVEC(WORK(KINT1),WORK(KLINT1_ORIG),LEN_1F) 4396*. Default block size 4397 LCSBLK_L = LCSBLK 4398 IF(LCSBLK_L.LE.0) THEN 4399 WRITE(6,*) ' SIGMA_CONF will define length of batch ' 4400 LCSBLK_DEFAULT = 2000000 4401*. Compare with dimension of largest single configuration 4402 LCONF_MAX = IMNMX(NPCSCNF,MAXOP+1,2) 4403 IF(LCONF_MAX.GT.LCSBLK_DEFAULT) LCSBLK_DEFAULT = LCONF_MAX 4404 LCSBLK_L = LCSBLK_DEFAULT 4405 END IF 4406 IF(NTEST.GE.100) THEN 4407 WRITE(6,*) ' LCSBLK_L = ', LCSBLK_L 4408 END IF 4409* 4410 ICSPC_CN_SAVE = ICSPC_CN 4411 ISSPC_CN_SAVE = ISSPC_CN 4412* 4413*. Now do the transformation for each orbital 4414* 4415 4416 DO IORB = 1, N_ORB_CONF 4417*. We are looping over orbitals in the configurations, i.e. 4418*. in type-order 4419 IIORB = IB_ORB_CONF -1 + IORB 4420 IIORB_SO = IREOTS(IIORB) 4421 IF(NTEST.GE.1000) THEN 4422 WRITE(6,'(A,I2,I3) ') 4423 & ' >>>> Info for orb. transformation for orbital', 4424 & IORB 4425 END IF 4426 IF(NTEST.GE.100) THEN 4427 WRITE(6,*) ' IORB, IIORB,IIORB_SO = ', 4428 & IORB, IIORB,IIORB_SO 4429 END IF 4430* For each orbital I we will calculate 4431*( 1+ \hat T(I) + 1/2\hat T(I)^2)) TII^\hat N_I C(I-1), 4432* where C(I-1) is result of all previous transformations. 4433*. We will collect the contributions for each orb in KLCSFVC 4434*. At start we have the transformed operator so far in C 4435* 4436* Prepare for transforming orbital IORB 4437* 4438*. Place (T(P,I)/S(I,I) in one-electron integral list 4439C T_ROW_TO_H(T,H,K) 4440 CALL T_ROW_TO_H(WORK(KLT),WORK(KINT1),IIORB_SO,TII) 4441*. T_{II}^Ni C in ICSPC_CN, save in C 4442C T_TO_NK_T_VEC_CONF(T,K,VEC,ISPC,ISYM) 4443 CALL T_TO_NK_T_VEC_CONF(TII,IORB,C,ICSPC_CN,ICSM) 4444* 4445 ICSPC_CN = IORBTRA_SPC_IN(IORB) 4446 ISSPC_CN = IORBTRA_SPC_OUT(IORB) 4447 NCSF_C = NCSF_PER_SYM_GN(ICSM,ICSPC_CN) 4448 NCSF_S = NCSF_PER_SYM_GN(ISSM,ISSPC_CN) 4449 NCSF_CS = MAX(NCSF_S,NCSF_C) 4450*. A scratch CSF vector 4451 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'TRACNI') 4452 CALL MEMMAN(KLCSFVC,NCSF_MNMX_MAX,'ADDL ',2,'CSFVC ') 4453*. Loop over the two operators needed for each orbitaltransf 4454 DO IPOT = 1, 2 4455 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'TRACNI') 4456* The input (C) and output spaces 4457 IF(IPOT.EQ.1) THEN 4458 ICSPC_CN = IORBTRA_SPC_IN(IORB) 4459 ISSPC_CN = IORBTRA_SPC_OUT(IORB) 4460 ELSE 4461 ICSPC_CN = IORBTRA_SPC_OUT(IORB) 4462 ISSPC_CN = IORBTRA_SPC_OUT(IORB) 4463 END IF 4464 IF(NTEST.GE.100) 4465 & WRITE(6,*) ' ICSPC_CN, ISSPC_CN = ', ICSPC_CN, ISSPC_CN 4466 IF(IPOT.EQ.1) THEN 4467*. Expand TII^\hat N_I C(I-1) in CSFVC 4468C REF_CNFVEC(VECIN,ISPCIN,VECOUT,ISPCOUT,ISYM) 4469 CALL REF_CNFVEC(C,ICSPC_CN,WORK(KLCSFVC),ISSPC_CN,ICSM) 4470 END IF 4471* 4472 NCONF_C = NCONF_PER_SYM_GN(ICSM,ICSPC_CN) 4473 NSD_C = NSD_PER_SYM_GN(ICSM,ICSPC_CN) 4474 NCSF_C = NCSF_PER_SYM_GN(ICSM,ICSPC_CN) 4475* 4476 NCONF_S = NCONF_PER_SYM_GN(ISSM,ISSPC_CN) 4477 NSD_S = NSD_PER_SYM_GN(ISSM,ISSPC_CN) 4478 NCSF_S = NCSF_PER_SYM_GN(ISSM,ISSPC_CN) 4479* 4480 NCONF_MAX = MAX(NCONF_C,NCONF_S) 4481* 4482 IF(NTEST.GE.1000) THEN 4483 WRITE(6,'(A,3I8)') 4484 & ' Number of confs, SDs and CSFs for C ', 4485 & NCONF_C, NSD_C, NCSF_C 4486 WRITE(6,'(A,3I8)') 4487 & ' Number of confs, SDs and CSFs for S ', 4488 & NCONF_S, NSD_S, NCSF_S 4489 END IF 4490* 4491* 4492*. If ICISTR = 1, vectors are stored in one batch, so 4493 IF(ICISTR.EQ.1) LCSBLK_L = MAX(NCSF_C,NCSF_S) 4494 IF(NTEST.GE.100) WRITE(6,*) ' Size of batch ', LCSBLK_L 4495*. Batches of C 4496*. ============== 4497*. One could here either use CSF's or SD's. As memory maybe the defining parameter, 4498* I opt for CSF's and will then expand/contract each configuration when needed. 4499*. Length of each configuration 4500 CALL MEMMAN(KLLCNFEXP,NCONF_MAX,'ADDL ',1,'LCNFEX') 4501*. For C 4502C CONF_EXP_LEN_LIST(ILEN,NCONF_PER_OPEN,NELMNT_PER_OPEN,MAXOP) 4503 CALL CONF_EXP_LEN_LIST(WORK(KLLCNFEXP), 4504 & NCONF_PER_OPEN_GN(1,ICSM,ICSPC_CN),NPCSCNF,MAXOP) 4505C PART_VEC(LBLK,NBLK,MAXSTR,LBAT,NBAT,IONLY_NBAT) 4506 CALL PART_VEC(WORK(KLLCNFEXP),NCONF_C,LCSBLK_L,IDUM,NBAT_C,1) 4507 CALL MEMMAN(KLLBAT_C,NBAT_C,'ADDL ',1,'LBAT_C') 4508 CALL PART_VEC(WORK(KLLCNFEXP),NCONF_C,LCSBLK_L,WORK(KLLBAT_C), 4509 & NBAT_C,0) 4510*. And for Sigma 4511C CONF_EXP_LEN_LIST(ILEN,NCONF_PER_OPEN,NELMNT_PER_OPEN,MAXOP) 4512 CALL CONF_EXP_LEN_LIST(WORK(KLLCNFEXP), 4513 & NCONF_PER_OPEN_GN(1,ISSM,ISSPC_CN),NPCSCNF,MAXOP) 4514C PART_VEC(LBLK,NBLK,MAXSTR,LBAT,NBAT,IONLY_NBAT) 4515 CALL PART_VEC(WORK(KLLCNFEXP),NCONF_S,LCSBLK_L,IDUM,NBAT_S,1) 4516 CALL MEMMAN(KLLBAT_S,NBAT_S,'ADDL ',1,'LBAT_S') 4517 CALL PART_VEC(WORK(KLLCNFEXP),NCONF_S,LCSBLK_L,WORK(KLLBAT_S), 4518 & NBAT_S,0) 4519* 4520 IF(NTEST.GE.1000) THEN 4521 WRITE(6,*) ' Number of batches for C and S ', NBAT_C, NBAT_S 4522 END IF 4523*. Largest number of configurations in a given batch 4524 MAX_CONF_BATCH_C = IMNMX(WORK(KLLBAT_C),NBAT_C,2) 4525 MAX_CONF_BATCH_S = IMNMX(WORK(KLLBAT_S),NBAT_S,2) 4526 MAX_CONF_BATCH = MAX(MAX_CONF_BATCH_C,MAX_CONF_BATCH_S) 4527* 4528 IF(NTEST.GE.1000) 4529 & WRITE(6,*) ' Largest number of configs in batch ', 4530 & MAX_CONF_BATCH 4531 CALL MEMMAN(KLLBLK_BAT_C,MAX_CONF_BATCH ,'ADDL ',2,'LBLBTC') 4532 CALL MEMMAN(KLLBLK_BAT_S,MAX_CONF_BATCH ,'ADDL ',2,'LBLBTS') 4533*. Two vectors for holding expansion in SD of given config 4534 LEN_SD_CONF_MAX = IMNMX(NPDTCNF,MAXOP+1,2) 4535 CALL MEMMAN(KLCONF_SD_C,LEN_SD_CONF_MAX,'ADDL ',2,'CN_SDC') 4536 CALL MEMMAN(KLCONF_SD_S,LEN_SD_CONF_MAX,'ADDL ',2,'CN_SDS') 4537*. Scratch space in routine for evuluating H for configurations (allowing combs) 4538*. Scratch: Length: INTEGER: (NDET_C + NDET_S)*N_EL_CONF + NDET_C + 6*NORB 4539 L_CNHCN = LEN_SD_CONF_MAX*(1+2*N_EL_CONF) + 6*N_ORB_CONF 4540 CALL MEMMAN(KL_CNHCN, L_CNHCN,'ADDL ',1,'LCNHCN') 4541*. Space for two integers arrays for signs 4542 CALL MEMMAN(KLISIGNC,LEN_SD_CONF_MAX,'ADDL ',1,'ISIGNC') 4543 CALL MEMMAN(KLISIGNS,LEN_SD_CONF_MAX,'ADDL ',1,'ISIGNS') 4544* 4545 ZERO = 0.0D0 4546 CALL SETVEC(S,ZERO,NCSF_S) 4547* 4548 IADOB = IB_ORB_CONF - 1 4549 CALL MEMCHK2('BETRAC') 4550 IF(IPOT.EQ.1) THEN 4551 XXNORM = INPROD(C,C,NCSF_C) 4552 WRITE(6,*) ' Norm**2 C(ini) = ', XXNORM 4553 END IF 4554 CALL TRACI_CONF_SLAVE(C,S,LUC,LUHC,ICISTR, 4555 & NCONF_PER_OPEN_GN(1,ICSM,ICSPC_CN), 4556 & NCONF_PER_OPEN_GN(1,ISSM,ISSPC_CN), 4557 & NBAT_C,WORK(KLLBAT_C), 4558 & NBAT_S,WORK(KLLBAT_S), 4559 & WORK(KLLBLK_BAT_C),WORK(KLLBLK_BAT_S), 4560 & WORK(KLCONF_SD_C),WORK(KLCONF_SD_S), 4561 & IADOB,WORK(KDFTP),WORK(KL_CNHCN), 4562 & WORK(KLISIGNC),WORK(KLISIGNS),IORB) 4563 CALL MEMCHK2('AFTRAC') 4564* 4565*. And copy output to input for next round.. 4566* 4567 ONE = 1.0D0 4568 IF(IPOT.EQ.1) THEN 4569*. Collecting (1 + T ) !C(K-1)> in KLCSFVC 4570 FACTOR = 1.0D0 4571 CALL VECSUM(WORK(KLCSFVC),WORK(KLCSFVC),S,ONE,FACTOR,NCSF_S) 4572 XXNORM = INPROD(WORK(KLCSFVC),WORK(KLCSFVC),NCSF_S) 4573 WRITE(6,*) ' Norm**2 (1+T)!Prev> = ', XXNORM 4574CD IF(NTEST.GE.1000) THEN 4575CD WRITE(6,*) ' Fusk Updated Sigma vector (1+T)!Prev> ' 4576CD WRITE(6,*) ' Fusk Updated Sigma vector (1+T)!Prev> ' 4577CD CALL CSDTVC_CONFSPACE(NCONF_S,WORK(KLCSFVC), 4578CD & FUSK,ISSM,ISSPC_CN,1) 4579CD END IF 4580*. And prepare for next op 4581 CALL COPVEC(S,C,NCSF_S) 4582 ELSE 4583*. Collecting (1 + T + 1/2T^2) !C(K-1)> in KLCSFVC 4584 FACTOR = 0.5D0 4585 ONE = 1.0D0 4586 CALL VECSUM(WORK(KLCSFVC),WORK(KLCSFVC),S,ONE,FACTOR,NCSF_S) 4587 CALL COPVEC(WORK(KLCSFVC),C,NCSF_S) 4588 CALL COPVEC(WORK(KLCSFVC),S,NCSF_S) 4589 XXNORM = INPROD(WORK(KLCSFVC),WORK(KLCSFVC),NCSF_S) 4590 WRITE(6,*) ' Norm**2 (1+T+1/2 T^2)!Prev> = ', XXNORM 4591* 4592CD WRITE(6,*) ' Fusk, (1 + T + 1/2T^2) !C(K-1)> SD basis ' 4593CD WRITE(6,*) ' Fusk, (1 + T + 1/2T^2) !C(K-1)> SD basis ' 4594CD CALL CSDTVC_CONFSPACE(NCONF_S,S,FUSK,ISSM,ISSPC_CN,1) 4595 END IF 4596 CALL MEMCHK2('AFTSUM') 4597* 4598* 4599 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'TRACNI') 4600 END DO !End of loop over the two powers of the operator 4601* 4602 IF(NTEST.GE.1000) THEN 4603 WRITE(6,*) ' Updated TRACI vector after a orbtrans' 4604 CALL WRTMAT(S,1,NCSF_S,1,NCSF_S) 4605 END IF 4606 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'TRACNI') 4607 END DO ! Loop over orbitals to be transformed 4608*. and restors defs 4609 ICSPC_CN = ICSPC_CN_SAVE 4610 ISSPC_CN = ISSPC_CN_SAVE 4611 CALL COPVEC(WORK(KLINT1_ORIG),WORK(KINT1),LEN_1F) 4612* 4613 IF(NTEST.GE.10000) THEN 4614 WRITE(6,*) ' Final PAM transformed CI vector ' 4615 WRITE(6,*) ' ================================' 4616 NCSF_S = NCSF_PER_SYM_GN(ISSM,ISSPC_CN) 4617 CALL WRTMAT(S,1,NCSF_S,1,NCSF_S) 4618 END IF 4619* 4620 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'TRACNF') 4621 CALL LUCIAQEXIT('TRACNF') 4622 RETURN 4623 END 4624 SUBROUTINE TRACI_CONF_SLAVE(C,S,LUC,LUS,ICISTR, 4625 & NCONF_PER_OPEN_C,NCONF_PER_OPEN_S, 4626 & NBAT_C,LBAT_C,NBAT_S,LBAT_S, 4627 & LBLK_BAT_C,LBLK_BAT_S, 4628 & CONF_SD_C,CONF_SD_S,IADOB,IPRODT, 4629 & ISCR_CNHCN,ISIGN_C,ISIGN_S,IORB) 4630* 4631* Inner (aka slave) routine for orbital transformation in configuration based methods 4632* 4633* Transform Orbital IORB 4634* 4635*. Jeppe Olsen,July 2011 4636* 4637 INCLUDE 'implicit.inc' 4638 INCLUDE 'mxpdim.inc' 4639 INCLUDE 'spinfo.inc' 4640 INCLUDE 'cands.inc' 4641 INCLUDE 'cecore.inc' 4642*. Input 4643*. C-vector or space for batch of C-vector 4644 DIMENSION C(*) 4645*. Info on the two configuration expansions 4646 INTEGER NCONF_PER_OPEN_C(*), NCONF_PER_OPEN_S(*) 4647*. Number of blocks in the batches of C and S 4648 INTEGER LBAT_C(*), LBAT_S(*) 4649*. Scratch for Info on batches of C and S: Length of each block (configuration in batch) 4650 INTEGER LBLK_BAT_C(*),LBLK_BAT_S(*) 4651*. Space for SD expansion of single configurations 4652 DIMENSION CONF_SD_C(*), CONF_SD_S(*) 4653*. Space for signs for phase change for dets of a configurations 4654 INTEGER ISIGN_C(*),ISIGN_S(*) 4655*. CSF info: proto type dets 4656 INTEGER IPRODT(*) 4657 4658*. Output 4659 DIMENSION S(*) 4660*. Scratch transferred through to CNHCN 4661 INTEGER ISCR_CNHCN 4662*. Local scratch 4663 INTEGER IOCC_C(MXPORB),IOCC_S(MXPORB) 4664* 4665*. TEMP SCRATCH 4666 DIMENSION SFUSK(2000), SFUSK2(2000) 4667* 4668 NTEST = 0010 4669 IF(NTEST.GE.10) THEN 4670 WRITE(6,*) ' Output from TRACI_CONF_SLAVE ' 4671 WRITE(6,*) ' =============================' 4672 WRITE(6,*) 4673 WRITE(6,*) ' ICISTR = ', ICISTR 4674 WRITE(6,'(A,I4)') ' IORB = ', IORB 4675 END IF 4676* 4677 IDUM = 0 4678 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'TRACNI') 4679*. Initialization of some parameters for controlling loop over configurations 4680 IOPEN_S = 0 4681 INUM_OPS = 0 4682 IOPEN_C = 0 4683 INUM_OPC = 0 4684 IB_CSF_C = 1 4685 IB_CSF_S = 1 4686* 4687 CALL MEMCHK2('INISIG') 4688* 4689*. Loop over batches of S 4690 INI_S = 1 4691C? WRITE(6,*) ' NBAT_S = ', NBAT_S 4692 DO IBAT_S = 1, NBAT_S 4693 IF(NTEST.GE.1000) 4694 & WRITE(6,'(A,I3)') ' >>> Start of sigma batch ', IBAT_S 4695* 4696 IF(IBAT_S.EQ.1) THEN 4697 IB_CONF_S = 1 4698 IB_CSF_S = 1 4699 ELSE 4700 IB_CONF_S = IB_CONF_S + LBAT_S(IBAT_S-1) 4701 END IF 4702C? WRITE(6,*) ' LBAT_S(1) = ', LBAT_S(1) 4703 N_CONF_S = LBAT_S(IBAT_S) 4704*. Number of CSF's per config in S-batch 4705C GET_LBLK_CONF_BATCH(ICNF_INI,NCNF,LBLK_BAT,ISYM,ISPC, 4706C & NSD_BAT_TOT,NCSF_BAT_TOT) 4707 CALL GET_LBLK_CONF_BATCH(IB_CONF_S,N_CONF_S,LBLK_BAT_S,ISSM, 4708 & ISSPC_CN,NSD_BAT_TOT_S,NCSF_BAT_TOT_S) 4709 CALL MEMCHK2('AFGTL1') 4710 IF(NTEST.GE.100) THEN 4711 WRITE(6,'(A,2I9)') 4712 & ' Number of CSFs and SDs in S-batch ', NCSF_BAT_TOT_S, 4713 & NSD_BAT_TOT_S 4714 END IF 4715*. Initialize sigma batch 4716 ZERO = 0.0D0 4717C? WRITE(6,*) ' IB_CSF_S, NCSF_BAT_TOT_S = ', 4718C? & IB_CSF_S, NCSF_BAT_TOT_S 4719 CALL SETVEC(S(IB_CSF_S),ZERO,NCSF_BAT_TOT_S) 4720*. Loop over batches of C 4721 IF(ICISTR.NE.1) REWIND LUS 4722 INI_C = 1 4723*. First time in this batch 4724 ISBAT_FIRST_TIME =1 4725 DO IBAT_C = 1, NBAT_C 4726 IF(NTEST.GE.1000) 4727 & WRITE(6,'(A,I3)') ' >>> Start of C batch ', IBAT_C 4728 CALL MEMCHK2('STCBAT') 4729 IF(IBAT_C.EQ.1) THEN 4730 IB_CONF_C = 1 4731 IB_CSF_C = 1 4732 ELSE 4733 IB_CONF_C = IB_CONF_C + LBAT_C(IBAT_C-1) 4734 END IF 4735 N_CONF_C = LBAT_C(IBAT_C) 4736*. Number of configs per config in S-batch 4737 CALL GET_LBLK_CONF_BATCH(IB_CONF_C,N_CONF_C,LBLK_BAT_C,ICSM, 4738 & ICSPC_CN,NSD_BAT_TOT_C,NCSF_BAT_TOT_C) 4739 IF(NTEST.GE.100) THEN 4740 WRITE(6,'(A,2I9)') 4741 & ' Number of CSFs and SDs in C-batch ', NCSF_BAT_TOT_C, 4742 & NSD_BAT_TOT_C 4743 END IF 4744 CALL MEMCHK2('AFGTLB') 4745*. Read, if required, next batch of C- Each configuration stored in a record by itself 4746 IF(ICISTR.NE.1) THEN 4747 CALL FRMDSCN(C,N_CONF_C,-1,LUC) 4748C FRMDSCN(VEC,NREC,LBLK,LU) 4749 END IF 4750*. And then to the configurations of the C and sigma 4751*. First time in this batch 4752 IF(ISBAT_FIRST_TIME.EQ.1) THEN 4753* Save pointers to start of configuration 4754 IOPEN_S_SAVE = IOPEN_S 4755 INUM_OPS_SAVE = INUM_OPS 4756 IB_CSF_S_SAVE = IB_CSF_S 4757 ELSE 4758 IOPEN_S = IOPEN_S_SAVE 4759 INUM_OPS = INUM_OPS 4760 IB_CSF_S = IB_CSF_S_SAVE 4761 END IF 4762 ISBAT_FIRST_TIME = 0 4763* 4764 ICBAT_FIRST_TIME =1 4765 DO ICONF_S = IB_CONF_S, IB_CONF_S + N_CONF_S -1 4766*. Obtain occupation in IOCC_S and iopen for this sigma-configuration 4767C NEXT_CONF_IN_CONFSPC(IOCC,IOPEN,INUM_OP,INI,ISYM,ISPC,NEW) 4768 CALL NEXT_CONF_IN_CONFSPC(IOCC_S,IOPEN_S,INUM_OPS,INI_S, 4769 & ISSM,ISSPC_CN,NEW_S) 4770 INI_S = 0 4771 IOCOB_S = (IOPEN_S + N_EL_CONF)/2 4772*. Signs for going between configuration and interaction order of dets 4773C SIGN_CONF_SD(ICONF,NOB_CONF,IOP,ISGN,IPDET_LIST,ISCR) 4774 CALL SIGN_CONF_SD(IOCC_S,IOCOB_S,IOPEN_S,ISIGN_S,IPRODT, 4775 & ISCR_CNHCN) 4776 CALL MEMCHK2('AFSIGN') 4777* 4778 NCSF_S = NPCSCNF(IOPEN_S+1) 4779 NSD_S = NPDTCNF(IOPEN_S+1) 4780C? IF(NSD_S.EQ.6) THEN 4781C? WRITE(6,*) ' Fusk NTEST increased ' 4782C? WRITE(6,*) ' Fusk NTEST increased ' 4783C? WRITE(6,*) ' Fusk NTEST increased ' 4784C? NTEST = 10000 4785C? END IF 4786* 4787 IF(NTEST.GE.100) THEN 4788 WRITE(6,*) ' Sigma configuration number ', ICONF_S 4789 CALL IWRTMA(IOCC_S,1,IOCOB_S,1,IOCOB_S) 4790 END IF 4791* 4792 ZERO = 0.0D0 4793*. The contribution to a given sigma conf from all C-conf in C-batch 4794* will be stored in CONF_SD_S(1) 4795 CALL SETVEC(CONF_SD_S,ZERO,NSD_S) 4796* 4797 IF( ICBAT_FIRST_TIME .EQ. 1) THEN 4798 IOPEN_C_SAVE = IOPEN_C 4799 INUM_OPC_SAVE = INUM_OPC 4800 IB_CSF_C_SAVE = IB_CSF_C 4801 ELSE 4802 IOPEN_C = IOPEN_C_SAVE 4803 INUM_OPC = INUM_OPC_SAVE 4804 IB_CSF_C = IB_CSF_C_SAVE 4805 END IF 4806 ICBAT_FIRST_TIME = 0 4807 DO ICONF_C = IB_CONF_C, IB_CONF_C + N_CONF_C -1 4808 IF(NTEST.GE.1000) THEN 4809 WRITE(6,*) ' ICONF_C, ICONF_S: ', ICONF_C, ICONF_S 4810 END IF 4811*. Obtain occupation in IOCC_C and iopen for this C-configuration 4812C NEXT_CONF_IN_CONFSPC(IOCC,IOPEN,INUM_OP,INI,ISYM,ISPC,NEW) 4813 CALL NEXT_CONF_IN_CONFSPC(IOCC_C,IOPEN_C,INUM_OPC,INI_C, 4814 & ICSM,ICSPC_CN,NEW_C) 4815*. Signs for going between configuration and interaction order of dets 4816C SIGN_CONF_SD(ICONF,NOB_CONF,IOP,ISGN,IPDET_LIST,ISCR) 4817 IOCOB_C = (IOPEN_C + N_EL_CONF)/2 4818 CALL SIGN_CONF_SD(IOCC_C,IOCOB_C,IOPEN_C,ISIGN_C,IPRODT, 4819 & ISCR_CNHCN) 4820 INI_C = 0 4821 IF(NTEST.GE.1000) THEN 4822 WRITE(6,*) ' C configuration number ', ICONF_C 4823 IOCOB_C = (IOPEN_C + N_EL_CONF)/2 4824 CALL IWRTMA(IOCC_C,1,IOCOB_C,1,IOCOB_C) 4825 END IF 4826*. Expand coefficients for configuration from CSF to SD basis 4827 NCSF_C = NPCSCNF(IOPEN_C+1) 4828 NSD_C = NPDTCNF(IOPEN_C+1) 4829C CSDTVC_CONF(C_SD,C_CSF,NOPEN,ISIGN,IAC,IWAY) 4830 CALL CSDTVC_CONF(CONF_SD_C,C(IB_CSF_C),IOPEN_C,ISIGN_C,2,1) 4831 IF(NTEST.GE.1000) THEN 4832 WRITE(6,*) ' C(ICONF_C) in SD' 4833 CALL WRTMAT(CONF_SD_C,1,NSD_C,1,NSD_C) 4834 END IF 4835 IF(NTEST.GE.1000) THEN 4836 WRITE(6,'(A,2I6)') 4837 & ' Info on sigma for ICONF_C, ICONF_S = ', 4838 & ICONF_C, ICONF_S 4839 END IF 4840*. Update: S(I) = S(I) + Sum(J) sum p <I!a+_(P,IAB)a_(IORB,IAB)!J> C(J) 4841 I12OP = 1 4842 I_DO_ORBTRA = 1 4843*. As want to add S(I), we set a local core-energy to one 4844 ECORE_L = 0.0D0 4845C CNHCN_LUCIA(ICNL,IOPL,ICNR,IOPR,CNHCNM,SIGMA, 4846C & IADOB,IPRODT,I12OP,IORBTRA,ECORE,ISCR) 4847 CALL CNHCN_LUCIA(IOCC_S,IOPEN_S,IOCC_C,IOPEN_C, 4848 & CONF_SD_C,XDUM,CONF_SD_S,IADOB, 4849 & IPRODT,I12OP, I_DO_ORBTRA, IORB, ECORE_L,2, 4850 & 0,RJ,RK,ISCR_CNHCN) 4851*. Update address of C in action 4852 IB_CSF_C = IB_CSF_C + NCSF_C 4853 IF(NTEST.GE.1000) THEN 4854 WRITE(6,*) ' Updated Sigma(ICONF_S) in SD' 4855 CALL WRTMAT(CONF_SD_S,1,NSD_S,1,NSD_S) 4856 END IF 4857 END DO ! over configs in batch of C 4858*. And transform sigma part to CSF and update sigma vector 4859 CALL CSDTVC_CONF(CONF_SD_S,S(IB_CSF_S),IOPEN_S,ISIGN_S,1,2) 4860 IB_CSF_S = IB_CSF_S + NCSF_S 4861 END DO ! over configs in batch of S 4862 END DO ! Over batches of C 4863 END DO ! over batches of Sigma 4864* 4865*. Test transformation back to CSF 4866* 4867C? WRITE(6,*) ' FUSK: back transf to SD basis at end of TRACI..' 4868* 4869C? INI_S = 1 4870C? IB_CSF = 1 4871C? IB_SD = 1 4872C? N_CONF_S = LBAT_S(1) 4873C? DO ICONF_S = 1, N_CONF_S 4874C? CALL NEXT_CONF_IN_CONFSPC(IOCC_S,IOPEN_S,INUM_OPS,INI_S, 4875C? & ISSM,ISSPC_CN,NEW_S) 4876C? INI_S = 0 4877C? IOCOB_S = (IOPEN_S + N_EL_CONF)/2 4878*. Signs for going between configuration and interaction order of dets 4879C? CALL SIGN_CONF_SD(IOCC_S,IOCOB_S,IOPEN_S,ISIGN_S,IPRODT, 4880C? & ISCR_CNHCN) 4881C? NCSF_S = NPCSCNF(IOPEN_S+1) 4882C? NSD_S = NPDTCNF(IOPEN_S+1) 4883C? CALL CSDTVC_CONF(SFUSK(IB_SD),S(IB_CSF),IOPEN_S,ISIGN_S,2,1) 4884C? IB_CSF = IB_CSF + NCSF_S 4885C? IB_SD = IB_SD + NSD_S 4886C? END DO 4887C? WRITE(6,*) ' Resulting vector transformed to SD''s ' 4888C? NSD_TOT = IB_SD - 1 4889C? CALL WRTMAT(SFUSK,1,NSD_TOT,1,NSD_TOT) 4890* 4891 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'TRACNI') 4892 IF(NTEST.GE.10) WRITE(6,*) ' Returning from TRACI_CONF_SLAVE ' 4893 RETURN 4894 END 4895 SUBROUTINE REF_CNFVEC(VECIN,ISPCIN,VECOUT,ISPCOUT,ISYM) 4896* 4897* A vector VECIN is given in configuration space IVECIN. 4898* Obtain corresponding vector in configuratin space ISPCOUT 4899* Terms that are in ISPCIN, but not in ISPCOUT are eliminated 4900* Terms that are in ISPCOUT, but not in ISPCIN are set to 0 4901* 4902* 4903*. Jeppe Olsen, July 17, 2011 4904* 4905 INCLUDE 'implicit.inc' 4906 INCLUDE 'mxpdim.inc' 4907 INCLUDE 'spinfo.inc' 4908 INCLUDE 'wrkspc-static.inc' 4909 INCLUDE 'vb.inc' 4910*. Input 4911 DIMENSION VECIN(*) 4912*. Output 4913 DIMENSION VECOUT(*) 4914*. Local scratch 4915 DIMENSION IOCC(MXPORB), IOCC2(MXPORB), IOCC3(MXPORB) 4916* 4917 NTEST = 000 4918 IF(NTEST.GE.100) THEN 4919 WRITE(6,*) ' Output from REF_CNFVEC ' 4920 WRITE(6,*) ' =======================' 4921 WRITE(6,*) 4922 WRITE(6,'(A,2I5)') ' In- and Out-spaces: ', ISPCIN,ISPCOUT 4923 WRITE(6,*) ' ISYM = ', ISYM 4924 END IF 4925* 4926 NCSF_IN = NCSF_PER_SYM_GN(ISYM,ISPCIN) 4927 NCSF_OUT = NCSF_PER_SYM_GN(ISYM,ISPCOUT) 4928 IF(NTEST.GE.100) THEN 4929 WRITE(6,*) ' NCSF_IN, NCSF_OUT = ', NCSF_IN, NCSF_OUT 4930 END IF 4931 ZERO = 0.0D0 4932 CALL SETVEC(VECOUT,ZERO,NCSF_OUT) 4933* 4934 INI = 1 4935 IB_IN = 1 4936 NEW = 1 4937 DO IOPEN = 0, MAXOP 4938 NCSF_PT = NPCSCNF(IOPEN+1) 4939 NCNF_OPEN_IN = NCONF_PER_OPEN_GN(IOPEN+1,ISYM,ISPCIN) 4940 NOCOBL = (IOPEN+N_EL_CONF)/2 4941*. First configuration in out space with given number of open orbs and sym 4942 IF_OPEN_OUT = IB_CONF_REO_GN(IOPEN+1,ISYM,ISPCOUT) 4943*. Offset in CSF vector to first elements with given sym and number of orbs 4944 IB_OPEN_OUT = IB_OPEN_CSF(IOPEN+1,ISYM,ISPCOUT) 4945 DO ICNF = 1, NCNF_OPEN_IN 4946*. Obtain occupation of configuration 4947C NEXT_CONF_IN_CONFSPC(IOCC,IOPEN,INUM_OP,INI,ISYM,ISPC,NEW) 4948 CALL NEXT_CONF_IN_CONFSPC(IOCC,IOPENX,INUM_OP_IN,INI,ISYM, 4949 & ISPCIN,NEW) 4950 IF(NTEST.GE.1000) THEN 4951 WRITE(6,*) ' Next config from NEXT_CONF.... ' 4952 NOCOBL = (N_EL_CONF + IOPEN)/2 4953 CALL IWRTMA(IOCC,1,NOCOBL,1,NOCOBL) 4954 END IF 4955 INI = 0 4956*.Is IOCC in output space? 4957* Reform from compact to occ number form 4958C REFORM_CONF_OCC2(ICONF_EXP,ICONF_PACK,NORBL,NOCOBL,IWAY) 4959 CALL REFORM_CONF_OCC2(IOCC2,IOCC,N_ORB_CONF,NOCOBL,2) 4960*.occ number to accumulated 4961C REFORM_CONF_ACCOCC(IACOCC,IOCC,IWAY,NORB) 4962 CALL REFORM_CONF_ACCOCC(IOCC3,IOCC2,2,N_ORB_CONF) 4963 IF(NTEST.GE.1000) THEN 4964 WRITE(6,*) ' Next configuration in accumulated form ' 4965 CALL IWRTMA(IOCC3,1,N_ORB_CONF,1,N_ORB_CONF) 4966 END IF 4967*. Check to see if configuration is within bounds 4968 IN_OUT = IS_IACC_CONF_IN_MINMAX_SPC(IOCC3, 4969 & IOCC_MIN_GN(1,ISPCOUT),IOCC_MAX_GN(1,ISPCOUT), 4970 & N_ORB_CONF) 4971 IF(IN_OUT.EQ.1) THEN 4972*. Find number of this configuration 4973C ILEX_FOR_CONF_G(ICONF,NOCC_ORB,ICONF_SPC,IDOREO) 4974 ILEX = ILEX_FOR_CONF_G(IOCC,NOCOBL,ISPCOUT,1) 4975 IB_OUT = IB_OPEN_OUT + (ILEX-IF_OPEN_OUT)*NCSF_PT 4976 CALL COPVEC(VECIN(IB_IN),VECOUT(IB_OUT),NCSF_PT) 4977 END IF ! conf was in out space 4978 IB_IN = IB_IN + NCSF_PT 4979 END DO ! End of loop over input configs with a given number of open orbs 4980 END DO ! End of loop over number of open orbitals 4981* 4982 IF(NTEST.GE.1000) THEN 4983 WRITE(6,*) ' Input and output vectors ' 4984 CALL WRTMAT(VECIN,1,NCSF_IN,1,NCSF_IN) 4985 WRITE(6,*) 4986 CALL WRTMAT(VECOUT,1,NCSF_OUT,1,NCSF_OUT) 4987 END IF 4988* 4989 RETURN 4990 END 4991 FUNCTION IS_IACC_CONF_IN_MINMAX_SPC(IOCC,MIN_OCC,MAX_OCC,NORB) 4992* 4993* An accumulated configuration IOCC is given. Check if this configuration 4994* in in space defined by MIN_OCC, MAX_OCC. 4995* Returns 1/0 as answer 4996* 4997*. Jeppe Olsen, July 2011 4998* 4999 INTEGER MIN_OCC(NORB),MAX_OCC(NORB) 5000 INTEGER IOCC(NORB) 5001* 5002 INBOUND = 1 5003 DO IORB = 1, NORB 5004 IF(MIN_OCC(IORB).GT.IOCC(IORB).OR. 5005 & IOCC(IORB).GT.MAX_OCC(IORB)) INBOUND = 0 5006 END DO 5007* 5008 IS_IACC_CONF_IN_MINMAX_SPC = INBOUND 5009* 5010 NTEST = 000 5011 IF(NTEST.GE.100) THEN 5012 WRITE(6,*) ' Configuration: ' 5013 CALL IWRTMA(IOCC,1,NORB,1,NORB) 5014 IF(INBOUND.EQ.1) THEN 5015 WRITE(6,*) ' Configuration is in space ' 5016 ELSE 5017 WRITE(6,*) ' Configuration is not in space ' 5018 END IF 5019 END IF 5020 IF(NTEST.GE.1000) THEN 5021 WRITE(6,*) ' Min Max space tested: ' 5022 CALL WRT_MINMAX_OCC(MIN_OCC,MAX_OCC,NORB) 5023 END IF 5024* 5025 RETURN 5026 END 5027 SUBROUTINE T_TO_NK_T_VEC_CONF(T,K,VEC,ISPC,ISYM) 5028* 5029* A vector VEC is given in CI space ISPC. 5030* Multiply with T^(\hat N_k), where \hat N_k is the 5031* number operator for orbital K 5032* 5033*. Jeppe Olsen, July 17, 2011 5034* 5035 INCLUDE 'implicit.inc' 5036 INCLUDE 'mxpdim.inc' 5037 INCLUDE 'spinfo.inc' 5038 INCLUDE 'wrkspc-static.inc' 5039 INCLUDE 'vb.inc' 5040*. Input and output 5041 DIMENSION VEC(*) 5042*. Local scratch 5043 INTEGER IOCC(MXPORB) 5044* 5045 NTEST = 00 5046 IF(NTEST.GE.100) THEN 5047 WRITE(6,*) ' Output from T_TO_NK_T_VEC_CONF ' 5048 WRITE(6,*) ' ===============================' 5049 WRITE(6,*) 5050 WRITE(6,'(A,I5)') ' Confspaces: ', ISPC 5051 WRITE(6,'(A,I3,2X,E13.7)') ' K and T ', K, T 5052 END IF 5053* 5054 IF(NTEST.GE.1000) THEN 5055 WRITE(6,*) ' Input vector to T_TO_NK_T_VEC_CONF ' 5056 NCSF = NCSF_PER_SYM_GN(ISYM,ISPC) 5057 CALL WRTMAT(VEC,1,NCSF,1,NCSF) 5058 END IF 5059* 5060 TT = T*T 5061* 5062 INI = 1 5063 IB = 1 5064 NEW = 1 5065 DO IOPEN = 0, MAXOP 5066 NCSF_PT = NPCSCNF(IOPEN+1) 5067 NCNF_FOR_IOPEN = NCONF_PER_OPEN_GN(IOPEN+1,ISYM,ISPC) 5068 NOCOBL = (IOPEN+N_EL_CONF)/2 5069 DO ICNF = 1, NCNF_FOR_IOPEN 5070*. Obtain occupation of next configuration 5071C NEXT_CONF_IN_CONFSPC(IOCC,IOPEN,INUM_OP,INI,ISYM,ISPC,NEW) 5072 CALL NEXT_CONF_IN_CONFSPC(IOCC,IOPENX,INUM_OP,INI,ISYM, 5073 & ISPC,NEW) 5074 INI = 0 5075* 5076 IF(NTEST.GE.1000) THEN 5077 WRITE(6,*) ' Next config from NEXT_CONF.... ' 5078 CALL IWRTMA(IOCC,1,NOCOBL,1,NOCOBL) 5079 END IF 5080* 5081*. Number of electrons in K 5082 NKOCC = 0 5083 DO IORB = 1, NOCOBL 5084 IF(IOCC(IORB).EQ.K) THEN 5085*. Singly occupied 5086 NKOCC = 1 5087 ELSE IF(IOCC(IORB).EQ.-K) THEN 5088*. Doubly occupied 5089 NKOCC = 2 5090 END IF 5091 END DO 5092* 5093 IF(NKOCC.EQ.1) THEN 5094 CALL SCALVE(VEC(IB),T,NCSF_PT) 5095 ELSE IF (NKOCC.EQ.2) THEN 5096 CALL SCALVE(VEC(IB),TT,NCSF_PT) 5097 END IF 5098* 5099 IB = IB + NCSF_PT 5100 END DO ! End of loop over input configs with a given number of open orbs 5101 END DO ! End of loop over number of open orbitals 5102* 5103 IF(NTEST.GE.100) THEN 5104 WRITE(6,*) ' Output vector from T_TO_NK_T_VEC_CONF ' 5105 NCSF = NCSF_PER_SYM_GN(ISYM,ISPC) 5106 CALL WRTMAT(VEC,1,NCSF,1,NCSF) 5107 END IF 5108* 5109 RETURN 5110 END 5111 SUBROUTINE GET_EXPMKS(EXPMKS,KAPPA_S, KAPPA_A,S,NOBPS,NSMOB) 5112* 5113* A symmetric and an antisymmetric kappa-matrix, KAPPA_S, KAPPA_A, 5114* respectively, are given for a orbital space, in complete form 5115* Obtain Exp (-Kappa_A S) Exp(-Kappa_S S) 5116* 5117* By varying the choice of NOBPS, the code can be used both for 5118* a complete and for a subspace matrix. 5119* 5120* Jeppe Olsen, July 19 in Santiago de COmpostela, 24 hours before talk 5121* (I decided on the plane to make a MCSCF program for the VB code ...) 5122* 5123 INCLUDE 'implicit.inc' 5124 INCLUDE 'mxpdim.inc' 5125 INCLUDE 'wrkspc-static.inc' 5126*. Input 5127 REAL*8 KAPPA_S(*), KAPPA_A(*), S(*) 5128 INTEGER NOBPS(NSMOB) 5129*. Output 5130 DIMENSION EXPMKS(*) 5131*. 5132 IDUM = 0 5133 CALL MEMMAN(IDUM,IDUM,'MARK ',2, 'GTEMKS') 5134* 5135 NTEST = 000 5136 IF(NTEST.GE.1000) THEN 5137 WRITE(6,*) ' Output from GET_EXPMKS ' 5138 WRITE(6,*) ' =======================' 5139 WRITE(6,*) 5140 WRITE(6,*) ' Input matrix KAPPA_A ' 5141 CALL APRBLM2(KAPPA_A,NOBPS,NOBPS,NSMOB,0) 5142 WRITE(6,*) ' Input matrix KAPPA_S ' 5143 CALL APRBLM2(KAPPA_S,NOBPS,NOBPS,NSMOB,0) 5144 END IF 5145* 5146* Exp (-Kappa_x S ) = S^(-1/2) Exp(-S^(1/2) Kappa_x S^1/2) S(-1/2) 5147*. Scratch: Should atleast be: 2* Dimension of matrix + 6 times largest block 5148* 5149*. Obtain S^1/2, S^-1/2 5150* 5151 LEN_1 = NDIM_1EL_MAT(1,NOBPS,NOBPS,NSMOB,0) 5152 CALL MEMMAN(KLSQRT,LEN_1,'ADDL ',2,'SQRT ') 5153 CALL MEMMAN(KLSQRTI,LEN_1,'ADDL ',2,'SQRTI ') 5154 CALL MEMMAN(KLMAT,LEN_1,'ADDL ',2,'MAT ') 5155 CALL MEMMAN(KLMAT2,LEN_1,'ADDL ',2,'MAT2 ') 5156 CALL MEMMAN(KLMAT3,LEN_1,'ADDL ',2,'MAT3 ') 5157 NOB_MAX = IMNMX(NOBPS,NSMOB,2) 5158 LSCR = 6*NOB_MAX**2 5159 CALL MEMMAN(KLSCR,LSCR,'ADDL ',2,'LSQRT ') 5160 CALL COPVEC(S,WORK(KLMAT),LEN_1) 5161C SQRT_BLMAT(A,NBLK,LBLK,ITASK,ASQRT,AMSQRT,SCR,ISYM) 5162 CALL SQRT_BLMAT(WORK(KLMAT),NSMOB,NOBPS,2, 5163 & WORK(KLSQRT),WORK(KLSQRTI),WORK(KLSCR),0) 5164* 5165* ========================================== 5166* Exp( S^1/2 Kappa A S^1/2) in WORK(KLMAT2) 5167* ========================================== 5168* 5169C TRAN_SYM_BLOC_MAT4(AIN,XL,XR,NBLOCK,LX_ROW,LX_COL,AOUT,SCR,ISYM) 5170 CALL TRAN_SYM_BLOC_MAT4(KAPPA_A,WORK(KLSQRT),WORK(KLSQRT), 5171 & NSMOB,NOBPS,NOBPS,WORK(KLMAT),WORK(KLSCR),0) 5172 IF(NTEST.GE.1000) THEN 5173 WRITE(6,*) ' The matrix S^1/2 Kappa A S^1/2 ' 5174 CALL APRBLM2(WORK(KLMAT),NOBPS,NOBPS,NSMOB,0) 5175 END IF 5176* Exp(S^1/2) Kappa A S^1/2) 5177 LSCR_EXP = 4*NOB_MAX**2 + 3*NOB_MAX 5178C? WRITE(6,*) ' LSCR_EXP, NOB_MAX = ', LSCR_EXP, NOB_MAX 5179 CALL MEMMAN(KLSCR_EXP,LSCR_EXP,'ADDL ',2,'SCR_EX') 5180 DO ISYM = 1, NSMOB 5181 IF(ISYM .EQ.1) THEN 5182 IOFF = 1 5183 ELSE 5184 IOFF = IOFF + NOBPS(ISYM-1)**2 5185 END IF 5186* Exp(S^1/2) Kappa A S^1/2) in KLMAT2 5187C EXPMA(EMA,A,NDIM,SCR,ISUB) 5188 CALL EXPMA(WORK(KLMAT2+IOFF-1),WORK(KLMAT+IOFF-1), 5189 & NOBPS(ISYM),WORK(KLSCR_EXP),0) 5190C? WRITE(6,*) ' After EXPMA ' 5191 END DO 5192 IF(NTEST.GE.1000) THEN 5193 WRITE(6,*) ' The matrix Exp( S^1/2 Kappa A S^1/2) ' 5194 CALL APRBLM2(WORK(KLMAT2),NOBPS,NOBPS,NSMOB,0) 5195 END IF 5196* 5197* =========================================== 5198* Exp( S^1/2 Kappa S S^1/2) in WORK(KLMAT3) 5199* =========================================== 5200* 5201C TRAN_SYM_BLOC_MAT4(AIN,XL,XR,NBLOCK,LX_ROW,LX_COL,AOUT,SCR,ISYM) 5202*. S^1/2 Kappa S S^1/2 in KLMAT 5203 CALL TRAN_SYM_BLOC_MAT4(KAPPA_S,WORK(KLSQRT),WORK(KLSQRT), 5204 & NSMOB,NOBPS,NOBPS,WORK(KLMAT),WORK(KLSCR),0) 5205C? WRITE(6,*) ' After TRAN_SYM_BLOC_MAT(2) ' 5206 IF(NTEST.GE.1000) THEN 5207 WRITE(6,*) ' The matrix S^1/2 Kappa S S^1/2 ' 5208 CALL APRBLM2(WORK(KLMAT),NOBPS,NOBPS,NSMOB,0) 5209 END IF 5210* 5211* Exp( S^1/2 Kappa S S^1/2) in KLMAT3 5212 DO ISYM = 1, NSMOB 5213 IF(ISYM .EQ.1) THEN 5214 IOFF = 1 5215 ELSE 5216 IOFF = IOFF + NOBPS(ISYM-1)**2 5217 END IF 5218C EXP_MAS(EMA,A,NDIM,SCR) 5219 CALL EXP_MAS(WORK(KLMAT3+IOFF-1),WORK(KLMAT+IOFF-1), 5220 & NOBPS(ISYM),WORK(KLSCR_EXP)) 5221C? WRITE(6,*) ' After EXP_MAS' 5222 END DO 5223* 5224 IF(NTEST.GE.100) THEN 5225 WRITE(6,*) ' The matrix Exp( S^1/2 Kappa S S^1/2) ' 5226 CALL APRBLM2(WORK(KLMAT3),NOBPS,NOBPS,NSMOB,0) 5227 END IF 5228* Exp( S^1/2) Kappa A S^1/2) Exp( S^1/2) Kappa S S^1/2) in KLMAT 5229C SUBROUTINE MULT_BLOC_MAT(C,A,B,NBLOCK,LCROW,LCCOL, 5230C & LAROW,LACOL,LBROW,LBCOL,ITRNSP) 5231 CALL MULT_BLOC_MAT(WORK(KLMAT),WORK(KLMAT2),WORK(KLMAT3), 5232 & NSMOB,NOBPS,NOBPS,NOBPS,NOBPS,NOBPS,NOBPS,0) 5233*. Premultipy with S^-1/2 and save on KLMAT3 5234 CALL MULT_BLOC_MAT(WORK(KLMAT3),WORK(KLSQRTI),WORK(KLMAT), 5235 & NSMOB,NOBPS,NOBPS,NOBPS,NOBPS,NOBPS,NOBPS,0) 5236*. Postmultiply with S^1/2 and save in EXPMKS 5237 CALL MULT_BLOC_MAT(EXPMKS,WORK(KLMAT3),WORK(KLSQRT), 5238 & NSMOB,NOBPS,NOBPS,NOBPS,NOBPS,NOBPS,NOBPS,0) 5239* 5240 IF(NTEST.GE.100) THEN 5241 WRITE(6,*) ' Matrix Exp(-K_A S) Exp(-K_S S) ' 5242 WRITE(6,*) ' ===============================' 5243 WRITE(6,*) 5244 CALL APRBLM2(EXPMKS,NOBPS,NOBPS,NSMOB,0) 5245 END IF 5246* 5247 CALL MEMMAN(IDUM,IDUM,'FLUSM ',2, 'GTEMKS') 5248* 5249 RETURN 5250 END 5251 SUBROUTINE EXP_MAS(EMA,A,NDIM,SCR) 5252* 5253* Expontial of minus a symmetric matrix A 5254* The matrix is given in complete form 5255* 5256*. Jeppe Olsen 5257* 5258 INCLUDE 'implicit.inc' 5259*. Input 5260 DIMENSION A(NDIM,NDIM) 5261*. Output 5262 DIMENSION EMA(NDIM,NDIM) 5263*. Scratch: Length should be 2*NDIM**2 + NDIM*(NDIM+1)/2+ NDIM 5264 DIMENSION SCR(*) 5265* 5266 NTEST = 000 5267 IF(NTEST.GE.100) THEN 5268 WRITE(6,*) ' Info from EXP_MAS ' 5269 WRITE(6,*) ' ================= ' 5270 END IF 5271 IF(NTEST.GE.1000) THEN 5272 WRITE(6,*) ' Symmetrix matrix to be exponentialized ' 5273 CALL WRTMAT(A,NDIM,NDIM,NDIM,NDIM) 5274 END IF 5275* 5276* Diagonalize matrix A 5277* 5278 KLX = 1 5279 KLSCR = KLX + NDIM**2 5280 KLMAT2 = KLSCR + NDIM*(NDIM+1)/2 5281 KLFREE = KLMAT2 + NDIM*NDIM 5282* 5283*. Obtain eigenvalues and eigenvectors of A 5284C DIAG_SYM_MAT(A,X,SCR,NDIM,ISYM) 5285 CALL DIAG_SYM_MAT(A,SCR(KLX),SCR(KLSCR),NDIM,0) 5286*. Eigenvalues have been returned in SCR(KLSCR) and the eigenvectors V 5287* in SCR(KLX) 5288*. The exponential of the eigenvalues -and remember the - from Exp(-A) 5289 DO I = 1, NDIM 5290 SCR(KLSCR-1+I) = EXP(-SCR(KLSCR-1+I)) 5291 END DO 5292* V Exp(eigenvalues) 5293 DO J = 1, NDIM 5294 EPSILJ = SCR(KLSCR-1+J) 5295 CALL COPVEC(SCR(KLX + (J-1)*NDIM), 5296 & SCR(KLMAT2+(J-1)*NDIM),NDIM) 5297 CALL SCALVE(SCR(KLMAT2+(J-1)*NDIM),EPSILJ,NDIM) 5298 END DO 5299* V Exp(eigenvalues) V+ 5300 FACTORC = 0.0D0 5301 FACTORAB = 1.0D0 5302 CALL MATML7(EMA,SCR(KLMAT2),SCR(KLX), 5303 & NDIM,NDIM,NDIM,NDIM,NDIM,NDIM, 5304 & FACTORC,FACTORAB,2) 5305* 5306 IF(NTEST.GE.100) THEN 5307 WRITE(6,*) ' Exponential of symmetrix matrix ' 5308 CALL WRTMAT(EMA,NDIM,NDIM,NDIM,NDIM) 5309 END IF 5310* 5311 RETURN 5312 END 5313 SUBROUTINE ORB_EXCIT_INT_SPACE(IORBSPC,ITOTSYM, 5314 & NOOEXC,IOOEXC,NUMONLY,IOFF_EXC, 5315 & I_RESTRICT_SUPSYM,MO_SUPSYM) 5316* 5317* Number of orbital excitations of symmetry ITOTSYM in orbitals space 5318* IORBSPC. 5319* NUMONLY = 1 => Only number is calculated 5320* = 0 => Also the excitations are set up, starting at IOFF_EXC 5321* 5322* Jeppe Olsen, July 19, 2011, the IOFF parameter added June 2012 5323* Last modification; Jeppe Olsen; June 3 2013; Supersymmetry added 5324* 5325 INCLUDE 'implicit.inc' 5326 INCLUDE 'mxpdim.inc' 5327 INCLUDE 'orbinp.inc' 5328 INCLUDE 'lucinp.inc' 5329 INCLUDE 'multd2h.inc' 5330*.Input 5331 INTEGER MO_SUPSYM(*) 5332*. Output 5333 INTEGER IOOEXC(2,*) 5334* 5335 NTEST = 10 5336 NOOEXC = 0 5337*. First orbital of space IORBSPC 5338 IOFF = NINOB + 1 5339 DO IGAS = 0, IORBSPC-1 5340 IOFF = IOFF + NOBPT(IGAS) 5341 END DO 5342 IF(NTEST.GE.100) WRITE(6,*) ' Offset for orbital excitations ', 5343 & IOFF 5344 NORB = NOBPT(IORBSPC) 5345 DO IORB = IOFF, IOFF + NORB - 1 5346 DO JORB = IOFF, IORB - 1 5347 ISM = ISMFTO(IORB) 5348 JSM = ISMFTO(JORB) 5349 IF(NTEST.GE.100) WRITE(6,*) ' IORB, JORB, ISM, JSM = ', 5350 & IORB, JORB, ISM, JSM 5351 IF(MULTD2H(ISM,JSM).EQ.ITOTSYM) THEN 5352 IMOKAY2 = 1 5353 IF(I_RESTRICT_SUPSYM.EQ.1) THEN 5354*. Check that supersymmetries are identical 5355 IF(MO_SUPSYM(IREOTS(IORB)).NE.MO_SUPSYM(IREOTS(JORB)))THEN 5356 IMOKAY2 = 0 5357 IF(NTEST.GE.10) THEN 5358 WRITE(6,*) 5359 & ' Excitation eliminated by supersym: IORB, JORB = ', 5360 & IORB, JORB 5361 END IF 5362 END IF 5363 END IF! Supersymmetry restrictions are active 5364 IF(IMOKAY2.EQ.1) THEN 5365 NOOEXC = NOOEXC + 1 5366 IF(NUMONLY.EQ.0) THEN 5367 IOOEXC(1,NOOEXC+IOFF_EXC-1) = IORB 5368 IOOEXC(2,NOOEXC+IOFF_EXC-1) = JORB 5369 END IF 5370 END IF 5371 END IF ! Symmetry was right 5372 END DO 5373 END DO 5374* 5375 IF(NTEST.GE.10) THEN 5376 WRITE(6,*) ' Number of active- active orbital excitations ', 5377 & NOOEXC 5378 END IF 5379 IF(NTEST.GE.100) THEN 5380 IF(NUMONLY.EQ.0) THEN 5381 WRITE(6,*) ' And the orbital excitations ' 5382 CALL IWRTMA(IOOEXC(1,IOFF_EXC),2,NOOEXC,2,NOOEXC) 5383 END IF 5384 END IF 5385* 5386 RETURN 5387 END 5388 SUBROUTINE E1_VB_FROM_ACTMAT(E1,IOOEXC,NOOEXC,E,RHOA,RHOB) 5389* 5390* Obtain VB gradient in active space from densities 5391* RHOB = <c!a+iaj!c(bio)>/<0!0>, RHOA = <c!a+aj!hc(bio)>/<0!0> 5392*. (note that the densities are in the original basis) 5393* 5394*. Jeppe Olsen, July19, 2011 5395* 5396* 5397 INCLUDE 'implicit.inc' 5398 INCLUDE 'mxpdim.inc' 5399 INCLUDE 'orbinp.inc' 5400*. Input 5401 INTEGER IOOEXC(2,NOOEXC) 5402 DIMENSION RHOA(NACOB,NACOB),RHOB(NACOB,NACOB) 5403*. Output 5404 DIMENSION E1(2*NOOEXC) 5405* 5406 NTEST = 000 5407 IF(NTEST.GE.100) THEN 5408 WRITE(6,*) 5409 WRITE(6,*) ' Info from E1_VB_FROM_ACTMAT ' 5410 WRITE(6,*) ' ============================' 5411 WRITE(6,*) 5412 WRITE(6,*) ' Energy = ', E 5413 END IF 5414 IF(NTEST.GE.1000) THEN 5415 WRITE(6,*) ' <0!E(ij)!H0>/<0!0> ' 5416 CALL WRTMAT(RHOA,NACOB,NACOB,NACOB,NACOB) 5417 WRITE(6,*) 5418 WRITE(6,*) ' <0!E(ij)!0>/<0!0> ' 5419 CALL WRTMAT(RHOB,NACOB,NACOB,NACOB,NACOB) 5420 WRITE(6,*) 5421 END IF 5422*. The antisymmetric part of the gradient 5423 DO JOO = 1, NOOEXC 5424 IORB = IOOEXC(1,JOO)-NINOB 5425 JORB = IOOEXC(2,JOO)-NINOB 5426 IF(NTEST.GE.1000) 5427 & WRITE(6,*) ' JOO, IORB, JORB = ', IORB, JORB 5428*. Antisymmetric part 5429 E1(JOO) = 2.0D0*(RHOA(IORB,JORB)-RHOA(JORB,IORB)) 5430*. Symmetric part 5431 E1(JOO+NOOEXC) = 5432 & -2.0D0* (RHOA(IORB,JORB)+RHOA(JORB,IORB) 5433 & -E*(RHOB(IORB,JORB)+RHOB(JORB,IORB))) 5434 END DO 5435* 5436 IF(NTEST.GE.100) THEN 5437* 5438 WRITE(6,*) ' Active-active gradient for nonorthogonal MCSCF ' 5439 WRITE(6,*) ' ===============================================' 5440 WRITE(6,*) 5441 CALL WRTMAT(E1,1,2*NOOEXC,1,2*NOOEXC) 5442 END IF 5443* 5444 RETURN 5445 END 5446 SUBROUTINE DO_ORBTRA(IDOTRA,IDOFI,IDOFA, 5447 & IE2LIST_IN,IOCOBTP_IN,INTSM_IN) 5448* 5449* Perform orbital transformations on integrals and Inactive/active Fock 5450* matrix 5451* 5452* IDOTRA = 1 => Transformed one- and two-electron integrals 5453* IDOFI = 1 => Inactive Fock-matrix 5454* IDOFA = 1 => Active Fock-matrix 5455* 5456* Jeppe Olsen, July 2011 - In a hotel room in Santiago de Compostella 5457* 5458 INCLUDE 'implicit.inc' 5459 INCLUDE 'mxpdim.inc' 5460 INCLUDE 'wrkspc-static.inc' 5461 INCLUDE 'glbbas.inc' 5462 INCLUDE 'cintfo.inc' 5463 INCLUDE 'cecore.inc' 5464 INCLUDE 'orbinp.inc' 5465 INCLUDE 'lucinp.inc' 5466#include "errquit.fh" 5467#include "mafdecls.fh" 5468#include "global.fh" 5469 5470* 5471 IDUM = 0 5472 CALL LUCIAQENTER('ORBTR') 5473 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'ORBTRA') 5474* 5475 NTEST = 0000 5476 IF(NTEST.GE.100.and.ga_nodeid().eq.0) THEN 5477 WRITE(6,*) ' Info from DO_ORBTRA ' 5478 WRITE(6,*) ' =====================' 5479 WRITE(6,*) 5480 WRITE(6,*) ' Tasks: IDOTRA, IDOFI, IDOFA = ', 5481 & IDOTRA, IDOFI, IDOFA 5482 IF(IDOTRA.EQ.1) THEN 5483 WRITE(6,*) ' IE2LIST_IN, IOCOBTP_IN, INTSM_IN = ', 5484 & IE2LIST_IN, IOCOBTP_IN, INTSM_IN 5485 END IF 5486 END IF! NTEST .ge. 100 5487* 5488 IE2LIST_A = IE2LIST_IN 5489 IOCOBTP_A = IOCOBTP_IN 5490 INTSM_A = INTSM_IN 5491* 5492 call ga_sync() 5493 IF(IDOTRA.EQ.1) THEN 5494*. Perform one- and two-electron transformations. 5495* The pointers to the mo-ao transformation matrices KKCMO_X, X=I,J,K,L 5496* must have been set up outside. 5497 CALL PREPARE_2EI_LIST 5498 CALL TRAINT 5499* 5500 IF(NTEST.GE.1000) THEN 5501 WRITE(6,*) ' one-electron transformed integrals' 5502 WRITE(6,*) ' =================================' 5503 IPACK_H1 = IE1_CCSM_G(IE2LIST_IN) 5504CNW CALL APRBLM2(WORK(KINT1),NTOOBS,NTOOBS,NSMOB,IPACK_H1) 5505 call ga_print(KINT1) 5506 END IF 5507* 5508 END IF! Integral transformation should be performed 5509* 5510 call ga_sync() 5511 IF(IDOFI.EQ.1) THEN 5512* 5513*. Calculate inactive Fock matrix in basis defined by KKCMI, KKCMJ 5514* ================================================================ 5515* 5516*. Use AO integrals in KINT_2EMO 5517* 5518 IE2ARR_F = IE2LIST_I(IE2LIST_IB(IE2LIST_FULL)) 5519 KINT2_FSAVE = KINT2_A(IE2ARR_F) 5520 KINT2_A(IE2ARR_F) = KINT_2EMO 5521*. The permutational symmetry of the inactive Fock-matrix is inherited from 5522*. the complex conjugation symmetry of the one-electron integrals 5523 IPACK_F = IE1_CCSM_G(IE2LIST_IN) 5524* 5525 CALL FI_FROM_INIINT_G(KFI,dbl_mb(KKCMO_I),dbl_mb(KKCMO_J), 5526 & KINT1,ECORE_HEX,3,IPACK_F) 5527 ECORE = ECORE_ORIG + ECORE_HEX 5528 IF(NTEST.GE.100) 5529 & WRITE(6,*) ' Updated core energy = ', ECORE 5530 IF(NTEST.GE.1000) THEN 5531 WRITE(6,*) ' Inactive Fock-matrix ' 5532 call ga_print(kfi) 5533CNW CALL APRBLM2(WORK(KFI),NTOOBS,NTOOBS,NSMOB,IPACK_F) 5534 END IF 5535*. And clean up 5536 KINT2_A(IE2ARR_F) = KINT2_FSAVE 5537 END IF ! FI should be calculated 5538* 5539 call ga_sync() 5540 IF(IDOFA.EQ.1) THEN 5541* 5542*. Calculate active Fock matrix in basis defined by KKCMI, KKCMJ 5543* ============================================================= 5544* 5545* 5546*. Use AO integrals in KINT_2EMO 5547* 5548 IE2ARR_F = IE2LIST_I(IE2LIST_IB(IE2LIST_FULL)) 5549 KINT2_FSAVE = KINT2_A(IE2ARR_F) 5550 KINT2_A(IE2ARR_F) = KINT_2EMO 5551*. The permutational symmetry of the inactive Fock-matrix is inherited from 5552*. the complex conjugation symmetry of the one-electron integrals 5553 IPACK_F = IE1_CCSM_G(IE2LIST_IN) 5554* 5555* A bit dirty: I will use IPACK_F to decide whether it is an 5556* normal or bio-calculation- will probably give my trouble later.. 5557 IF(IPACK_F.EQ.0) THEN 5558 IBIO_CALC = 1 5559 ELSE 5560 IBIO_CALC = 0 5561 END IF 5562* 5563C FA_FROM_INIINT(FA,CINI,CINIB,D,IPACK) 5564 IF(IBIO_CALC.EQ.1) THEN 5565*. transform RHO1 to bio-actual MO basis 5566* 5567*. Obtain first in symmetry block form 5568 LEN_R = NDIM_1EL_MAT(1,NACOBS,NACOBS,NSMOB,0) 5569 CALL MEMMAN(KLRHO1,NACOB**2,'ADDL ',2,'RHO1L ') 5570 CALL MEMMAN(KLRHO1B,NACOB**2,'ADDL ',2,'RHO1S ') 5571 CALL MEMMAN(KLCBIOA,LEN_R,'ADDL ',2,'CBIOAC') 5572C REORHO1(RHO1I,RHO1O,IRHO1SM) 5573 CALL REORHO1(dbl_mb(KRHO1),dbl_mb(KLRHO1),1,1) 5574*. Obtain CBIO over active orbitals only 5575C EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT(A,AGAS,I_EX_OR_CP) 5576 CALL EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT 5577 & (dbl_mb(KCBIO),dbl_mb(KLCBIOA),1) 5578 IF(NTEST.GE.1000) THEN 5579 WRITE(6,*) ' CBIO in active orbitals ' 5580 CALL APRBLM2(dbl_mb(KLCBIOA),NACOBS,NACOBS,NSMOB,0) 5581 END IF 5582 CALL TR_BIOMAT(dbl_mb(KLRHO1),dbl_mb(KLRHO1B),dbl_mb(KLCBIOA), 5583 & NACOBS,1,2,1,1) 5584*. Transfer back to full matrix over active orbitals 5585 CALL REORHO1(dbl_mb(KLRHO1),dbl_mb(KLRHO1B),1,2) 5586 ELSE 5587 KLRHO1 = KRHO1 5588 END IF 5589* 5590 CALL FA_FROM_INIINT(KFA,dbl_mb(KKCMO_I),dbl_mb(KKCMO_J), 5591 & dbl_mb(KLRHO1),IPACK_F) 5592*. And clean up 5593 KINT2_A(IE2ARR_F) = KINT2_FSAVE 5594 IF(NTEST.GE.1000) THEN 5595 WRITE(6,*) ' Active Fock-matrix ' 5596 call ga_print(kfa) 5597CNW CALL APRBLM2(WORK(KFA),NTOOBS,NTOOBS,NSMOB,IPACK_F) 5598 END IF 5599 END IF ! Active Fock matrix should be calculated 5600* 5601 call ga_sync() 5602 IF(NTEST.GE.100) WRITE(6,*) ' Leaving DO_ORBTRA ' 5603* 5604 CALL LUCIAQEXIT('ORBTR') 5605 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'ORBTRA') 5606* 5607 RETURN 5608 END 5609 SUBROUTINE GET_INIMO(CMO_INI) 5610* 5611* Obtain initial set of Molecular orbitals in CMO_INI as specified by 5612* parameters INI_MO_TP,INI_MO_ORT, INI_ORT_VBGAS in crun 5613* 5614* Two steps : 1) Obtain a set of (nonorthogonal) initial orbitals 5615* according to INI_MO_TP 5616* 2) Perform (partial) orthonormalization to obtain 5617* Final initial orbitals according to INI_MO_ORT, 5618* and INI_ORT_VBGAS,IGAS_SEL 5619* 5620* The INI_MO_TP parameter defines the raw (nonorthogonal) initial orbitals: 5621* 5622* INI_MO_TP = 1 => Unit matrix 5623* INI_MO_TP = 2 => Rotate orbitals from environment so 5624* Diagonal block in GAS IGAS_SEL is diagonal 5625* INI_MO_TP = 3 => Use orbitals read in from environment 5626* INI_MO_TP = 4 => Read in fragment orbitals 5627* INI_MO_TP = 5 => Read in from LUCINF_O 5628* 5629* 5630* INI_MO_ORT = 0 => No orthonormalization 5631* = 1 => symmetric orthogonalization 5632* = 2 => orthonormalization by biagonalization 5633* 5634* INI_ORT_VBGAS = 0 => No orthonormalization of VB gas space 5635* = 1 => Orthonornormalization of VB gas space according to 5636* INI_MO_ORT 5637* 5638* Jeppe Olsen, Restructuring some code in a Hotel room in Santiago De 5639* Compostella, July 2011 5640* June 2012, INI_MO_TP = 5 added 5641* 5642 INCLUDE 'implicit.inc' 5643 INCLUDE 'mxpdim.inc' 5644 INCLUDE 'wrkspc-static.inc' 5645 INCLUDE 'fragmol.inc' 5646 INCLUDE 'orbinp.inc' 5647 INCLUDE 'lucinp.inc' 5648 INCLUDE 'crun.inc' 5649 INCLUDE 'clunit.inc' 5650*. 5651 CHARACTER*6 CSAVE 5652*. Output 5653 DIMENSION CMO_INI(*) 5654* 5655 IDUM = 0 5656 NTEST = 0 5657 IF(NTEST.GE.100) THEN 5658 WRITE(6,*) 5659 WRITE(6,*) ' =====================' 5660 WRITE(6,*) ' Info from GET_INIMO: ' 5661 WRITE(6,*) ' =====================' 5662 WRITE(6,*) 5663 END IF 5664 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'INIMO ') 5665* 5666*. 0: Obtain some input information if required 5667* 5668 IF(INI_MO_TP.EQ.4) THEN 5669* 5670*. Set up fragment information 5671* 5672 IF(NFRAG_TP.EQ.0) THEN 5673 WRITE(6,*) 5674 & ' Input orbitals from fragment MOs requested(INI_MO_TP=4)' 5675 WRITE(6,*) 5676 & ' But no fragment information provided (keyword: MOFRAG)' 5677 WRITE(6,*) ' Specify keyword MOFRAG ' 5678 STOP ' Specify keyword MOFRAG ' 5679 ELSE 5680 CALL MOINF_FRAG 5681 END IF 5682 END IF ! Iform = 4 5683* 5684 LEN_1F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 5685 CALL MEMMAN(KLCMOAO1,LEN_1F,'ADDL ',2,'CMOAO1') 5686 CALL MEMMAN(KLCMOAO2,LEN_1F,'ADDL ',2,'CMOAO2') 5687* 5688 IF(INI_MO_TP.EQ.2.OR.INI_MO_TP.EQ.3) THEN 5689* 5690*. Obtain MOAO transformation matrix from environment 5691* 5692 CALL GET_CMOAO_ENV(WORK(KLCMOAO1)) 5693 END IF 5694* 5695 IF(INI_MO_TP.EQ.5) THEN 5696* 5697*. Read in from LUCINF_O which is a fort.91 output file, but 5698*. perhaps from another geometry. 5699* 5700*. a bit of dirty dancing: let LUCINF_O be the standard fort.91 5701*. for a few microseconds. 5702*. Obtain a free unit-number 5703 LU91_SAVE = LU91 5704 CALL FILEMAN_MINI(LU91,'ASSIGN') 5705 OPEN(LU91,STATUS='OLD',FORM='FORMATTED',FILE='LUCINF_O') 5706*. Fool also environment to think it is LUCIA 5707 CSAVE = ENVIRO 5708 ENVIRO(1:6) = 'LUCIA ' 5709*. Obtain CMO as usual from environment - with changed LU91 5710*. 5711 CALL GET_CMOAO_ENV(WORK(KLCMOAO1)) 5712 IF(NTEST.GE.1000) THEN 5713 WRITE(6,*) ' MOAO for INI_MO_TP = 5 ' 5714 CALL APRBLM2(WORK(KLCMOAO1),NTOOBS,NTOOBS,NSMOB,0) 5715 END IF 5716*. And restore order 5717 CLOSE(LU91,STATUS='KEEP') 5718 CALL FILEMAN_MINI(LU91,'FREE ') 5719 LU91 = LU91_SAVE 5720 ENVIRO = CSAVE 5721 END IF 5722* 5723* 5724*. 1: Generate/Read in the 'initial initial' orbitals and store in CMOAO2 5725* 5726*. The split of work between current routine and PREPARE_CMOAO_INI is 5727*. strange, but works.. 5728C PREPARE CMOAO_INI(INI_MO_TP_L, CMOAO_OUT,CMOAO_IN,IVBGAS) 5729 CALL PREPARE_CMOAO_INI 5730 & (INI_MO_TP,WORK(KLCMOAO2),WORK(KLCMOAO1), 5731 & NORTCIX_SCVB_SPACE) 5732 CALL COPVEC(WORK(KLCMOAO2),WORK(KLCMOAO1),LEN_1F) 5733* 5734*. 2. Orthonormalize parts of the orbital spaces 5735* 5736*. 5737*. Orthogonalize Active to inactive and secondary to active- always done 5738 INTER_ORT = 1 5739*. Between GA spaces 5740 IF(INI_MO_ORT.EQ.0) THEN 5741 INTERGAS_ORT = 0 5742 INI_ORT_VBGASL = 0 5743 ELSE 5744 INTERGAS_ORT = 1 5745 INI_ORT_VBGASL = INI_ORT_VBGAS 5746 END IF 5747*. Intragas orthogonalization 5748 INTRAGAS_ORT = INI_MO_ORT 5749*. Orthogonalization in VB space- defined by parameter INI_MO_ORT 5750 IF(NTEST.GE.100) THEN 5751 WRITE(6,'(A,4I4)') 5752 & ' INTER_ORT, INTERGAS_ORT, INTRAGAS_ORT, INI_ORT_VBGASL', 5753 & INTER_ORT, INTERGAS_ORT, INTRAGAS_ORT, INI_ORT_VBGASL 5754 END IF 5755C ORT_ORB(CMOAO_IN, CMOAO_OUT, INTER_ORT,INTERGAS_ORT, 5756C & INTRAGAS_ORT,IORT_VBSPC) 5757 CALL ORT_ORB(WORK(KLCMOAO1),CMO_INI,INTER_ORT, 5758 & INTERGAS_ORT,INTRAGAS_ORT,INI_ORT_VBGASL) 5759* 5760 IF(NTEST.GE.100) THEN 5761 WRITE(6,*) ' Expansion of final initial MOs in AOs ' 5762 WRITE(6,*) ' ======================================' 5763 CALL APRBLM_F7(CMO_INI,NTOOBS,NTOOBS,NSMOB,0) 5764C CALL PRINT_CMOAO(CMO_INI) 5765 END IF 5766* 5767 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'INIMO ') 5768* 5769 RETURN 5770 END 5771 SUBROUTINE BLK_CHECK_UNI_MAT 5772 & (UNI,NBLK,LBLK,XMAX_DIFF_DIAG,XMAX_DIFF_OFFD) 5773* 5774* A full blocked matrix UNI is given. Find largest deviation of 5775* matrix from unit matrix as 5776* The largest deviation of diagonal element from one 5777* The largest deviation of block-diagonal element from zero 5778* 5779* Jeppe Olsen, May 2012 5780* 5781 INCLUDE 'implicit.inc' 5782*. Input 5783 DIMENSION UNI(*) 5784 INTEGER LBLK(NBLK) 5785* 5786 NTEST = 100 5787 IF(NTEST.GE.100) THEN 5788 WRITE(6,*) ' ===========================' 5789 WRITE(6,*) ' Info from BLK_CHECK_UNI_MAT' 5790 WRITE(6,*) ' ===========================' 5791 END IF 5792* 5793 IB = 1 5794 XMAX_DIFF_DIAG = 0.0D0 5795 XMAX_DIFF_OFFD = 0.0D0 5796* 5797 DO IBLK = 1, NBLK 5798 L = LBLK(IBLK) 5799C CHECK_UNIT_MAT(UNI,NDIM,XMAX_DIFF_DIAG,XMAX_DIFF_OFFD) 5800 CALL CHECK_UNIT_MAT(UNI(IB),L,XDIAG_LOC, XOFFD_LOC,0) 5801 XMAX_DIFF_DIAG = MAX(XMAX_DIFF_DIAG,XDIAG_LOC) 5802 XMAX_DIFF_OFFD = MAX(XMAX_DIFF_OFFD,XOFFD_LOC) 5803 IB = IB + L**2 5804 END DO 5805* 5806 IF(NTEST.GE.100) THEN 5807 WRITE(6,*) ' Deviations of block matrix from unit matrix: ' 5808 WRITE(6,*) 5809 & ' Largest deviation of diagonal element from 1:', 5810 & XMAX_DIFF_DIAG 5811 WRITE(6,*) 5812 & ' Largest deviation of off-diagonal element from 1:', 5813 & XMAX_DIFF_OFFD 5814 END IF 5815* 5816 RETURN 5817 END 5818 SUBROUTINE CHECK_UNIT_MAT(UNI,NDIM,XMAX_DIFF_DIAG,XMAX_DIFF_OFFD, 5819 & ISYM) 5820* 5821* A matrix UNI is given. Check difference between UNI and UNIT matrix 5822* and report in: 5823* XMAX_DIFF_DIAG: Max absolute difference between between diagonal 5824* element and 1 5825* XMAX_DIFF_OFFD: Max absolute difference between off diagonal and zero 5826* 5827*. Jeppe Olsen, July 2011 (Thought I had written this routine before...) 5828* Last modification; Feb 27, 2013; Jeppe Olsen; ISYM added 5829* 5830 INCLUDE 'implicit.inc' 5831*. Input 5832 DIMENSION UNI(*) 5833*. Diagonal element 5834 XMAX_DIFF_DIAG = 0.0D0 5835 DO I = 1, NDIM 5836 IF(ISYM.EQ.0) THEN 5837 II = (I-1)*NDIM + I 5838 ELSE 5839 II = I*(I-1)/2 + I 5840 END IF 5841 XMAX_DIFF_DIAG = MAX(XMAX_DIFF_DIAG,ABS(UNI(II)-1.0D0)) 5842 END DO 5843*. Off diagonal elements 5844 XMAX_DIFF_OFFD = 0.0D0 5845 DO I = 1, NDIM 5846 DO J = 1, I-1 5847 IF(ISYM.EQ.0) THEN 5848 JI = (I-1)*NDIM + J 5849 IJ = (J-1)*NDIM + I 5850 XMAX_DIFF_OFFD = MAX(XMAX_DIFF_OFFD,ABS(UNI(IJ)),ABS(UNI(JI))) 5851 ELSE 5852 IJ = I*(I-1)/2 + J 5853 XMAX_DIFF_OFFD = MAX(XMAX_DIFF_OFFD,ABS(UNI(IJ))) 5854 END IF 5855 END DO 5856 END DO 5857* 5858 NTEST = 100 5859 IF(NTEST.GE.100) THEN 5860 WRITE(6,*) ' Comparison of matrix with unit matrix: ' 5861 WRITE(6,*) ' Largest deviation of diagonal elements ', 5862 & XMAX_DIFF_DIAG 5863 WRITE(6,*) ' Largest deviation of of-diagonal elements ', 5864 & XMAX_DIFF_OFFD 5865 END IF 5866* 5867 RETURN 5868 END 5869 SUBROUTINE TR_BIOMAT(XIN,XOUT,CBIO,NORB_PSM, 5870 & INB_IN,INB_OUT,JNB_IN,JNB_OUT) 5871* 5872* An orbital matrix XIN(I,J) is given in symmetry blocked form 5873* with NORB_PSM orbitals per symmetry 5874* INB_IN = 1 => I is in normal basis 5875* = 2 => I is in bioorthogonal basis 5876* JNB_IN = 1 => J is in normal basis 5877* = 2 => J is in bioorthogonal basis 5878* Obtain the matrix in the representation XOUT(I,J) defined by 5879* 5880* INB_OUT = 1 => I is in normal basis 5881* = 2 => I is in bioorthogonal basis 5882* JNB_OUT = 1 => J is in normal basis 5883* = 2 => J is in bioorthogonal basis 5884* The matrix CBIO giving the transformation from the normal to the 5885* bioorthogonal basis is in the same basis. 5886* 5887* Note: The use of locally defined NORB_PSM, allows the restriction 5888* of the matrice to for example the active orbitals. 5889* 5890*. Jeppe Olsen, July 2011 5891* 5892 INCLUDE 'implicit.inc' 5893 INCLUDE 'mxpdim.inc' 5894 INCLUDE 'wrkspc-static.inc' 5895 INCLUDE 'glbbas.inc' 5896 INCLUDE 'lucinp.inc' 5897 INCLUDE 'orbinp.inc' 5898*. Input 5899 DIMENSION XIN(*) 5900 DIMENSION NORB_PSM(NSMOB) 5901* 5902 NTEST = 00 5903 IF(NTEST.GE.100) THEN 5904 WRITE(6,*) ' Info form TR_BIOMAT ' 5905 WRITE(6,*) ' =================== ' 5906 WRITE(6,'(A,4I2)') ' INB_IN,INB_OUT,JNB_IN,JNB_OUT = ', 5907 & INB_IN,INB_OUT,JNB_IN,JNB_OUT 5908* 5909 WRITE(6,*) ' NORB_PSM = ' 5910 CALL IWRTMA3(NORB_PSM,1,NSMOB,1,NSMOB) 5911* 5912 WRITE(6,*) ' The Input Cbio matrix ' 5913 CALL APRBLM2(CBIO,NORB_PSM,NORB_PSM,NSMOB,0) 5914 END IF 5915* 5916*. Check that input parameters are in range 5917* 5918 INB_IN_OK = 1 5919 JNB_IN_OK = 1 5920 INB_OUT_OK = 1 5921 JNB_OUT_OK = 1 5922 IF(1.GT.INB_IN.OR.INB_IN.GT.2) INB_IN_OK = 0 5923 IF(1.GT.JNB_IN.OR.JNB_IN.GT.2) JNB_IN_OK = 0 5924 IF(1.GT.INB_OUT.OR.INB_OUT.GT.2) INB_OUT_OK = 0 5925 IF(1.GT.JNB_OUT.OR.JNB_OUT.GT.2) JNB_OUT_OK = 0 5926* 5927 IF(INB_IN_OK.EQ.0.OR.JNB_IN_OK.EQ.0.OR. 5928 & INB_OUT_OK.EQ.0.OR.JNB_OUT_OK.EQ.0) THEN 5929 WRITE(6,*) ' Error in input to TR_BIOMAT' 5930 WRITE(6,*) ' Input parameter out or range (1,2)' 5931 WRITE(6,'(A,4(2X,I2))') 5932 & ' INB_IN,JNB_IN,INB_OUT,JNB_OUT = ', 5933 & INB_IN,JNB_IN,INB_OUT,JNB_OUT 5934 STOP ' Error in input to TR_BIOMAT' 5935 END IF 5936* 5937 IDUM = 0 5938 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'TR_BIO') 5939* 5940 LEN_1F = NDIM_1EL_MAT(1,NORB_PSM,NORB_PSM,NSMOB,0) 5941*. Local copy of CBIO 5942 CALL MEMMAN(KLCBIO,LEN_1F,'ADDL ',2,'CBIOL ') 5943 CALL COPVEC(CBIO,WORK(KLCBIO),LEN_1F) 5944* 5945 NOBS_MX = IMNMX(NORB_PSM,NSMOB,2) 5946 LSCR = 2*NOBS_MX**2 5947 KLCBIOINV = 0 5948*. Obtain transformation from BIO to normal basis if required 5949 IF(INB_IN.EQ.2.AND.INB_OUT.EQ.1.OR. 5950 & JNB_IN.EQ.2.AND.JNB_OUT.EQ.1) THEN 5951 CALL MEMMAN(KLCBIOINV,LEN_1F,'ADDL ',2,'CBIINV') 5952 CALL MEMMAN(KLSCR,LSCR,'ADDL ',2,'CBIOSC') 5953* 5954C INV_BLKMT(A,AINV,SCR,NBLK,LBLK,IPROBLEM) 5955 CALL INV_BLKMT(WORK(KLCBIO),WORK(KLCBIOINV),WORK(KLSCR), 5956 & NSMOB,NORB_PSM,IPROBLEM) 5957 IF(NTEST.GE.1000) THEN 5958 WRITE(6,*) ' Inverted CBIO ' 5959 CALL APRBLM2(WORK(KLCBIOINV),NORB_PSM,NORB_PSM,NSMOB,0) 5960 END IF 5961 IF(IPROBLEM.NE.0) THEN 5962 WRITE(6,*) ' Problem inverting CBIO(MO,MO) ' 5963 END IF 5964 END IF 5965* 5966*. Local pointers to pointers to transformations matrices for I and J 5967* 5968 IF(INB_IN.EQ.INB_OUT) THEN 5969 KKLI = 0 5970 ELSE 5971 IF(INB_IN.EQ.1.AND.INB_OUT.EQ.2) THEN 5972* Normal => BIO 5973 KKLI = KLCBIO 5974 ELSE 5975 KKLI = KLCBIOINV 5976 END IF 5977 END IF 5978* 5979 IF(JNB_IN.EQ.JNB_OUT) THEN 5980 KKLJ = 0 5981 ELSE 5982 IF(JNB_IN.EQ.1.AND.JNB_OUT.EQ.2) THEN 5983* Normal => BIO 5984 KKLJ = KLCBIO 5985 ELSE 5986 KKLJ = KLCBIOINV 5987 END IF 5988 END IF 5989*. And do the transformation as requested 5990 IF(INB_IN.EQ.INB_OUT.AND.JNB_IN.EQ.JNB_OUT) THEN 5991* No transformation, just copy 5992 CALL COPVEC(XIN,XOUT,LEN_1F) 5993 ELSE IF( INB_IN.NE.INB_OUT.AND.JNB_IN.EQ.JNB_OUT) THEN 5994*. Transformation of first index I 5995C MULT_BLOC_MAT(C,A,B, 5996C NBLOCK,LCROW,LCCOL,LAROW,LACOL,LBROW,LBCOL,ITRNSP) 5997 CALL MULT_BLOC_MAT(XOUT,WORK(KKLI),XIN, 5998 & NSMOB,NORB_PSM,NORB_PSM,NORB_PSM,NORB_PSM,NORB_PSM, 5999 & NORB_PSM,1) 6000 ELSE IF(INB_IN.EQ.INB_OUT.AND.JNB_IN.NE.JNB_OUT) THEN 6001* Transformation of second index, J 6002 CALL MULT_BLOC_MAT(XOUT,XIN,WORK(KKLJ), 6003 & NSMOB,NORB_PSM,NORB_PSM,NORB_PSM,NORB_PSM,NORB_PSM, 6004 & NORB_PSM,0) 6005 ELSE 6006*. Transform both I and J indeces 6007C TRAN_SYM_BLOC_MAT4 6008C (AIN,XL,XR,NBLOCK,LX_ROW,LX_COL,AOUT,SCR,ISYM) 6009 CALL MEMMAN(KLSCRTRA,LSCR,'ADDL ',2,'SCRTRA') 6010 CALL TRAN_SYM_BLOC_MAT4(XIN,WORK(KKLI),WORK(KKLJ), 6011 & NSMOB,NORB_PSM,NORB_PSM,XOUT,WORK(KLSCRTRA),0) 6012 END IF 6013* 6014 IF(NTEST.GE.100) THEN 6015 WRITE(6,*) ' Output from TR_BIOMAT' 6016 WRITE(6,*) ' ====================== ' 6017 WRITE(6,*) 6018 WRITE(6,'(A,4(2X,I3))') ' INB_IN, JNB_IN, INB_OUT, JNB_OUT =', 6019 & INB_IN, JNB_IN, INB_OUT, JNB_OUT 6020 WRITE(6,*) ' Input matrix: ' 6021 CALL APRBLM2(XIN,NORB_PSM,NORB_PSM,NSMOB,0) 6022 WRITE(6,*) ' Output matrix: ' 6023 CALL APRBLM2(XOUT,NORB_PSM,NORB_PSM,NSMOB,0) 6024 END IF 6025* 6026 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'TR_BIO') 6027 RETURN 6028 END 6029 SUBROUTINE EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT 6030 & (A,AGAS,I_EX_OR_CP) 6031* 6032* A symmetryblocked (not lower half packed) matrix A over orbitals is given 6033* Extract all blocks referring to the GASpaces (i.e. 1-ngas) 6034* 6035* Matrix is assumed total symmetric wrt pointgroup 6036* 6037* I_EX_OR_CP = 1 => Extract from A to AGAS 6038* I_EX_OR_CP = 1 => Copy from AGAS to A 6039* 6040*. Jeppe Olsen, July 2011 6041* 6042 INCLUDE 'implicit.inc' 6043 INCLUDE 'mxpdim.inc' 6044 INCLUDE 'orbinp.inc' 6045 INCLUDE 'lucinp.inc' 6046*. Specific input or output 6047 DIMENSION A(*), AGAS(*) 6048* 6049 DO ISYM = 1, NSMOB 6050 IF(ISYM.EQ.1) THEN 6051 IOFF_IN = 1 6052 IOFF_OUT = 1 6053 ELSE 6054 IOFF_IN = IOFF_IN + NTOOBS(ISYM-1)**2 6055 IOFF_OUT = IOFF_OUT + NACOBS(ISYM-1)**2 6056 END IF 6057* 6058 IOFF = NINOBS(ISYM)+1 6059 NIA= NACOBS(ISYM) 6060 NIT= NTOOBS(ISYM) 6061* 6062 DO J = 1, NIA 6063 DO I = 1, NIA 6064 IJ_OUT = IOFF_OUT -1 + (J-1)*NIA + I 6065 IJ_IN = IOFF_IN -1 6066 & + (IOFF+J-1-1)*NIT + IOFF+I-1 6067 IF(I_EX_OR_CP.EQ.1) THEN 6068 AGAS(IJ_OUT) = A(IJ_IN) 6069 ELSE 6070 A(IJ_IN) = AGAS(IJ_OUT) 6071 END IF 6072 END DO 6073 END DO 6074 END DO ! End of loop over symmetries 6075* 6076 NTEST = 00 6077 IF(NTEST.GE.100) THEN 6078 WRITE(6,*) ' Submatrix Over active orbitals' 6079 CALL APRBLM2(AGAS,NACOBS,NACOBS,NSMOB,0) 6080 WRITE(6,*) ' Full matrix ' 6081 CALL APRBLM2(A,NTOOBS,NTOOBS,NSMOB,0) 6082 END IF 6083* 6084 RETURN 6085 END 6086 SUBROUTINE VB_GRAD_ORBVBSPC(NOOEXC_AA,IOOEXC_AA,E1,C, 6087 & VEC1_CSF,VEC2_CSF) 6088* 6089* Obtain gradient over orbitals in active space 6090* 6091* E1(A)(IJ) = 2 ( <0!(E(ij) - E(ji))H!0> 6092* E1(S)(IJ) =-2 ( <0!(E(ij) + E(ji))(H-E)!0> 6093* 6094* The number of active-active excitations is NOOEXC_AA 6095* and the corresponding excitations are IOOEXC_AA 6096* 6097* So to obtain gradient 6098* 1: construct bioorthogonal expansion of S = H!0> and !0> 6099* 2: Set up density matrices <0!E(ij)!s> <0!E(ij)!0> 6100* where i is in biobase and j in normal 6101* 3: Transform density matrices to standard basis 6102* To accomplish 1, the sigma routine is called with the current set of 6103* CI coefficients 6104* 6105* The current CI coefficients in the CSF basis are in C, where 6106* VEC1_CSF, VEC2_CSF, must be able to hold these expansions 6107* 6108* This is an initial version, for initial calculations and checks 6109* 6110* Jeppe Olsen, July 2011, for the initial NORTMCSCF program 6111* 6112 INCLUDE 'implicit.inc' 6113 INCLUDE 'mxpdim.inc' 6114 INCLUDE 'wrkspc-static.inc' 6115 INCLUDE 'lucinp.inc' 6116 INCLUDE 'orbinp.inc' 6117 INCLUDE 'clunit.inc' 6118 INCLUDE 'glbbas.inc' 6119 INCLUDE 'crun.inc' 6120 COMMON/SCRFILES_MATVEC/LUSCR1,LUSCR2,LUSCR3, 6121 & LUCBIO_SAVE, LUHCBIO_SAVE,LUC_SAVE 6122 REAL*8 INPRDD 6123*. Input 6124 DIMENSION C(*) 6125 INTEGER IOOEXC_AA(2,NOOEXC_AA) 6126*. Scratch 6127 DIMENSION VEC1_CSF(*), VEC2_CSF(*) 6128*. Output 6129 DIMENSION E1(2*NOOEXC_AA) 6130* 6131 NTEST = 000 6132*. CSFs are handled explicitly, so 6133 NOCSF = 1 6134* 6135 IF(NTEST.GE.100) THEN 6136 WRITE(6,*) 6137 WRITE(6,*) ' ===========================' 6138 WRITE(6,*) ' Input from VB_GRAD_ORBVBSPC' 6139 WRITE(6,*) ' ===========================' 6140 WRITE(6,*) 6141 WRITE(6,*) ' NOOEXC_AA = ', NOOEXC_AA 6142 WRITE(6,*) ' The active-active excitations ' 6143 CALL PRINT_ORBEXC_LIST(IOOEXC_AA,0,NOOEXC_AA) 6144 END IF 6145* 6146 IDUM = 0 6147 CALL MEMMAN(IDUM,IDUM,'MARK ',2,'VBGRAD') 6148* 6149 LUSCR1 = LUSC34 6150 LUSCR2 = LUSC35 6151 LUSCR3 = LUSC36 6152 LUCBIO_SAVE = 110 6153 LUHCBIO_SAVE = 111 6154 LUC_SAVE = 112 6155* 6156* A bit of scratch 6157* 6158 LEN_1A = NDIM_1EL_MAT(1,NACOBS,NACOBS,NSMOB,0) 6159 CALL MEMMAN(KLRHOA,NACOB**2,'ADDL ',2,'RHOA ') 6160 CALL MEMMAN(KLRHOB,NACOB**2,'ADDL ',2,'RHOB ') 6161 CALL MEMMAN(KLSCR ,NACOB**2,'ADDL ',2,'SCR ') 6162 CALL MEMMAN(KLCBIOA,LEN_1A,'ADDL ',2,'CBIOAC') 6163*. Preparation: Obtain CBIO over active orbitals only 6164C EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT(A,AGAS,I_EX_OR_CP) 6165 CALL EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT 6166 & (WORK(KCBIO),WORK(KLCBIOA),1) 6167 IF(NTEST.GE.1000) THEN 6168 WRITE(6,*) ' CBIO in active orbitals ' 6169 CALL APRBLM2(WORK(KLCBIOA),NACOBS,NACOBS,NSMOB,0) 6170 END IF 6171* 6172*. Sigma with the current C 6173* 6174C SIGMA_NORTCI(C,HC,SC,IDOHC,IDOSC) 6175 CALL SIGMA_NORTCI(C,VEC1_CSF,VEC2_CSF,1,1) 6176 IF(NTEST.GE.1000) WRITE(6,*) ' Back from SIGMA_NORTCI' 6177* calculate energy from vectors on file 6178 CHC = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUC_SAVE,LUHCBIO_SAVE,1,-1) 6179 CC = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUC_SAVE, LUCBIO_SAVE,1,-1) 6180 EVB = CHC/CC 6181 IF(NTEST.GE.10) WRITE(6,*) ' Energy is ', EVB 6182* 6183*. Set up density <0! a+i(bio) aj!0(bio)> in RHOB 6184* 6185 IF(NTEST.GE.1000) THEN 6186 WRITE(6,*) ' C in SD expansion ' 6187 CALL WRTVCD(WORK(KVEC1P),LUC_SAVE,1,-1) 6188 WRITE(6,*) ' C(bio) in SD expansion ' 6189 CALL WRTVCD(WORK(KVEC1P),LUCBIO_SAVE,1,-1) 6190 WRITE(6,*) ' HC(bio) in SD expansion ' 6191 CALL WRTVCD(WORK(KVEC1P),LUHCBIO_SAVE,1,-1) 6192 END IF 6193 XDUM = 0.0D0 6194 CALL DENSI2(1 ,WORK(KLRHOB),XDUM, 6195 &WORK(KVEC1P),WORK(KVEC2P),LUC_SAVE,LUCBIO_SAVE,EXPS2, 6196 &0,XDUM,XDUM,XDUM,XDUM,0) 6197*. Scale with 1/<0!0> 6198 FACTOR = 1.0D0/CC 6199 CALL SCALVE(WORK(KLRHOB),FACTOR,NACOB**2) 6200 IF(NTEST.GE.1000) THEN 6201 WRITE(6,*) ' Density matrix <0! a+i(bio) aj!bio 0>/<0!0> ' 6202 CALL WRTMAT(WORK(KLRHOB),NACOB,NACOB,NACOB,NACOB) 6203 END IF 6204*. Obtain density as blocked matrix over symmetry blocks of active orbitals 6205C REORHO1(RHO1I,RHO1O,IRHO1SM) 6206 CALL REORHO1(WORK(KLRHOB),WORK(KLSCR),1,1) 6207 CALL COPVEC(WORK(KLSCR),WORK(KLRHOB),LEN_1A) 6208*. Transform the densities from bio, normal to the normal, normal basis 6209C TR_BIOMAT(XIN,XOUT,CBIO,NORB_PSM, 6210C & INB_IN,INB_OUT,JNB_IN,JNB_OUT) 6211 CALL TR_BIOMAT(WORK(KLRHOB),WORK(KLSCR),WORK(KLCBIOA), 6212 & NACOBS,2,1,1,1) 6213*. Transfer back to full matrix over active orbitals 6214 CALL REORHO1(WORK(KLRHOB),WORK(KLSCR),1,2) 6215 IF(NTEST.GE.1000) THEN 6216 WRITE(6,*) ' Density matrix <0! a+i aj!bio 0> ' 6217 CALL WRTMAT(WORK(KLRHOB),NACOB,NACOB,NACOB,NACOB) 6218 END IF 6219* 6220*. Set up density <0! a+i(bio) aj!H0(bio)> in RHOA 6221* 6222 CALL DENSI2(1 ,WORK(KLRHOA),XDUM, 6223 & WORK(KVEC1P),WORK(KVEC2P),LUC_SAVE,LUHCBIO_SAVE,EXPS2, 6224 & 0,XDUM,XDUM,XDUM,XDUM,0) 6225*. Scale with 1/<0!0> 6226 FACTOR = 1.0D0/CC 6227 CALL SCALVE(WORK(KLRHOA),FACTOR,NACOB**2) 6228 IF(NTEST.GE.1000) THEN 6229 WRITE(6,*) ' Density matrix <0! a+i(bio) aj!bio H0>/<0!0> ' 6230 CALL WRTMAT(WORK(KLRHOA),NACOB,NACOB,NACOB,NACOB) 6231 END IF 6232*. Obtain density as blocked matrix over symmetry blocks of active orbitals 6233 CALL REORHO1(WORK(KLRHOA),WORK(KLSCR),1,1) 6234 CALL COPVEC(WORK(KLSCR),WORK(KLRHOA),LEN_1A) 6235*. Transform the densities from bio, normal to the normal, normal basis 6236 CALL TR_BIOMAT(WORK(KLRHOA),WORK(KLSCR),WORK(KLCBIOA), 6237 & NACOBS,2,1,1,1) 6238*. Transfer back to full matrix over active orbitals 6239 CALL REORHO1(WORK(KLRHOA),WORK(KLSCR),1,2) 6240*. and construct the gradient 6241C E1_VB_FROM_ACTMAT(E1,IOOEXC_S,NOOEXC_AA,E,RHOA,RHOB) 6242 CALL E1_VB_FROM_ACTMAT(E1,IOOEXC_AA, 6243 & NOOEXC_AA,EVB, WORK(KLRHOA),WORK(KLRHOB)) 6244* 6245 CALL MEMMAN(IDUM,IDUM,'FLUSM ',2,'VBGRAD') 6246 RETURN 6247 END 6248 SUBROUTINE GET_VB_VF_VBSPC_FROM_KAPPA(E1, 6249 & KAPPA_A,NOOEXC_A,IOOEXC_A, 6250 & KAPPA_S,NOOEXC_S,IOOEXC_S,CCI, 6251 & VEC1_CSF,VEC2_CSF) 6252* 6253* Obtain gradient-like Vector function E1 in VB orbital space from 6254* given Kappa and S 6255* 6256* Using method with expansion in complete VI space 6257* 6258*. It is assumed that the current MO-AO coefficients are in KMOAOIN. 6259* Integrals etc are overwritten, so the exit from this routine is 6260* not clean. 6261* 6262*. Jeppe Olsen, July 24 2011 6263* 6264 INCLUDE 'implicit.inc' 6265 INCLUDE 'mxpdim.inc' 6266 INCLUDE 'wrkspc-static.inc' 6267 INCLUDE 'glbbas.inc' 6268 INCLUDE 'lucinp.inc' 6269 INCLUDE 'orbinp.inc' 6270 INCLUDE 'cintfo.inc' 6271 INCLUDE 'spinfo.inc' 6272*. Specific input 6273 INTEGER IOOEXC_A(2,NOOEXC_A), IOOEXC_S(2,NOOEXC_S) 6274 REAL*8 KAPPA_A(*), KAPPA_S(*) 6275*. Scratch 6276 DIMENSION VEC1_CSF(*),VEC2_CSF(*) 6277*. Output 6278 DIMENSION E1(NOOEXC_S+NOOEXC_A) 6279* 6280 NTEST = 100 6281 IF(NTEST.GE.10) THEN 6282 WRITE(6,*) ' Input from GET_VB_VF_VBSPC_FROM_KAPPA ' 6283 WRITE(6,*) ' ======================================' 6284 WRITE(6,*) 6285 WRITE(6,*) ' Input Kappa_A, Kappa_S: ' 6286 CALL WRTMAT(KAPPA_A,1,NOOEXC_A,1,NOOEXC_A) 6287 WRITE(6,*) 6288 CALL WRTMAT(KAPPA_S,1,NOOEXC_S,1,NOOEXC_S) 6289 END IF 6290* 6291 IDUM = 0 6292 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GTVBVF') 6293* 6294*. Obtain New MO coefficients in MOAOUT: MOAOIN* Exp(-Kappa_A S) Exp(-Kappa_S S) 6295* 6296C NEWMO_FROM_KAPPA_NORT( 6297C & NOOEXC_A,IOOEXC_A,KAPPA_A, 6298C & NOOEXC_S,IOOEXC_S,KAPPA_S,CMOAO_IN,CMOAO_OUT) 6299 CALL NEWMO_FROM_KAPPA_NORT( 6300 & NOOEXC_A,IOOEXC_A,KAPPA_A,NOOEXC_S,IOOEXC_S,KAPPA_S, 6301 & WORK(KMOAOIN),WORK(KMOAOUT)) 6302* 6303* Obtain the set of biorthonormal orbitals 6304* 6305 CALL GET_CBIO(WORK(KMOAOIN),WORK(KCBIO),WORK(KCBIO2)) 6306* 6307* Biorthonormal integral transformaion 6308* 6309 IF(NTEST.GE.10) THEN 6310 WRITE(6,*) ' Bioorthogonal integral transformation ' 6311 END IF 6312* 6313 IE2LIST_A = IE2LIST_FULL_BIO 6314 IOCOBTP_A = 1 6315 INTSM_A = 1 6316 CALL PREPARE_2EI_LIST 6317* 6318 KKCMO_I = KMOAOUT 6319 KKCMO_J = KCBIO2 6320 KKCMO_K = KMOAOUT 6321 KKCMO_L = KCBIO2 6322* 6323C DO_ORBTRA(IDOTRA,IDOFI,IDOFA,IE2LIST_IN,IOCOBTP_IN,INTSM_IN) 6324 CALL DO_ORBTRA(1,1,1,IE2LIST_FULL_BIO,IOCOBTP_A,INTSM_A) 6325 NINT1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 6326 CALL COPVEC(WORK(KFI),WORK(KINT1),NINT1_F) 6327 CALL FLAG_ACT_INTLIST(IE2LIST_FULL_BIO) 6328*. The antisymmetric part of gradient 6329 CALL FOCK_MAT_NORT(WORK(KF),WORK(KF2),2,WORK(KFI),WORK(KFA)) 6330*. And the interspace gradient 6331C E1_FROM_F_NORT(E1,F1,F2,IOPSM,IOOEXC,IOOEXCC, 6332C & NOOEXC,NTOOB,NTOOBS,NSMOB,IBSO,IREOST) 6333 CALL E1_FROM_F_NORT(E1,WORK(KF),WORK(KF2),1, 6334 & WORK(KLOOEXC),WORK(KLOOEXCC),NOOEXC_A,NTOOB, 6335 & NTOOBS,NSMOB,IBSO,IREOST) 6336*. And add the active-active gradient 6337* The interspace excitations 6338C VB_GRAD_ORBVBSPC(NOOEXC,IOOEXC,E1,C,VEC1_CSF,VEC2_CSF) 6339 IF(NTEST.GE.1000) 6340 & WRITE(6,*) ' Active-active gradient will be calculated ' 6341 CALL VB_GRAD_ORBVBSPC(NOOEXC_S,WORK(KLOOEXCC_S), 6342 & WORK(KLE1+NOOEXC_IS), 6343 & WORK(KL_VEC1),WORK(KL_VEC2),WORK(KL_VEC3)) 6344 6345 6346C VB_GRAD_ORBVBSPC(NOOEXC,IOOEXC,E1,C, 6347C & VEC1_CSF,VEC2_CSF) 6348*. Assuming just optimization in the VB space, 6349 CALL VB_GRAD_ORBVBSPC(NOOEXC_S,IOOEXC_S,E1,CCI, 6350 & VEC1_CSF,VEC2_CSF) 6351* 6352 IF(NTEST.GE.100) THEN 6353 WRITE(6,*) 6354 & ' Orbital vector function from GET_VB_VF_VBSPC_FROM_KAPPA' 6355 WRITE(6,*) 6356 & ' =======================================================' 6357 WRITE(6,*) 6358 WRITE(6,*) ' Part referring to antisymmetric operators: ' 6359 CALL WRT_IOOEXCOP(E1,IOOEXC_S,NOOEXC_S) 6360 WRITE(6,*) ' Part referring to symmetric operators: ' 6361 CALL WRT_IOOEXCOP(E1(1+NOOEXC_S),IOOEXC_S,NOOEXC_S) 6362 END IF 6363* 6364 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GTVBVF') 6365 RETURN 6366 END 6367 SUBROUTINE NEWMO_FROM_KAPPA_NORT( 6368 & NOOEXC_A,IOOEXC_A,KAPPA_A, 6369 & NOOEXC_S,IOOEXC_S,KAPPA_S,CMOAO_IN,CMOAO_OUT) 6370* 6371* Obtain New MO coefficients from symmetric and anti-symmetric 6372* kappa for VB calculation: 6373* 6374* CMOAO_OUT = CMOAO_IN * Exp(-Kappa_A S) Exp(-Kappa_S S) 6375* 6376* Jeppe Olsen, July 24, 2011 6377* 6378 INCLUDE 'implicit.inc' 6379 INCLUDE 'mxpdim.inc' 6380 INCLUDE 'wrkspc-static.inc' 6381 INCLUDE 'lucinp.inc' 6382 INCLUDE 'orbinp.inc' 6383*. Input 6384 INTEGER IOOEXC_A(2,NOOEXC_A),IOOEXC_S(2,NOOEXC_S) 6385*. Antisymmetric and symmetric part of Kappa in packed form 6386 REAL*8 6387 &KAPPA_A(*),KAPPA_S(*) 6388 DIMENSION CMOAO_IN(*) 6389*. Output 6390 DIMENSION CMOAO_OUT(*) 6391* 6392 NTEST = 000 6393 IF(NTEST.GE.100) THEN 6394 WRITE(6,*) ' Output from NEWMO_FROM_KAPPA_NORT' 6395 WRITE(6,*) ' ================================ ' 6396 WRITE(6,*) 6397 END IF 6398 IF(NTEST.GE.100) THEN 6399 WRITE(6,*) ' Input KAPPA_A, KAPPA_S: ' 6400 CALL WRTMAT(KAPPA_A,1,NOOEXC_A,1,NOOEXC_A) 6401 WRITE(6,*) 6402 CALL WRTMAT(KAPPA_S,1,NOOEXC_S,1,NOOEXC_S) 6403 END IF 6404* 6405 IDUM = 0 6406 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'NWMONO') 6407* 6408* Obtain Kappa_A and Kappa_S in full form 6409* 6410 NDIM_1F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 6411 CALL MEMMAN(KLKAPPA_AE,NDIM_1F,'ADDL ',2,'KAPPAE') 6412 CALL MEMMAN(KLKAPPA_SE,NDIM_1F,'ADDL ',2,'KAPPSE') 6413C REF_GN_KAPPA(KAPPAP,KAPPAE,IAS,ISM,IWAY,IOOEX,NOOEX) 6414 CALL REF_GN_KAPPA(KAPPA_A,WORK(KLKAPPA_AE),1,1,1, 6415 & IOOEXC_A,NOOEXC_A) 6416 CALL REF_GN_KAPPA(KAPPA_S,WORK(KLKAPPA_SE),2,1,1, 6417 & IOOEXC_S,NOOEXC_S) 6418*, Obtain metric in MO basis 6419 CALL MEMMAN(KLS,NDIM_1F,'ADDL ',2,'SMOMO ') 6420 CALL GET_SMO(CMOAO_IN,WORK(KLS),0) 6421* 6422*. Obtain Exp (-Kappa_A S) Exp(-Kappa_S S) 6423* 6424 CALL MEMMAN(KLEXPMKS,NDIM_1F,'ADDL ',2,'SMOMO ') 6425C GET_EXPMKS(EXPMKS,KAPPA_S, KAPPA_A,S,NOBPS,NSMOB) 6426 CALL GET_EXPMKS(WORK(KLEXPMKS),WORK(KLKAPPA_SE), 6427 & WORK(KLKAPPA_AE),WORK(KLS), 6428 & NTOOBS,NSMOB) 6429* 6430* CMOAO_OUT = CMOAO_IN (-Kappa_A S) Exp(-Kappa_S S) 6431* 6432C MULT_BLOC_MAT(C,A,B,NBLOCK,LCROW,LCCOL,LAROW,LACOL,LBROW,LBCOL,ITRNSP) 6433 CALL MULT_BLOC_MAT(CMOAO_OUT,CMOAO_IN,WORK(KLEXPMKS),NSMOB, 6434 & NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,0) 6435* 6436 IF(NTEST.GE.1000) THEN 6437 WRITE(6,*) 6438 WRITE(6,*) 6439 WRITE(6,*) ' CMOAO_OUT: ' 6440 CALL APRBLM2(CMOAO_OUT,NTOOBS,NTOOBS,NSMOB,0) 6441 END IF 6442* 6443 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'NWMONO') 6444* 6445 RETURN 6446 END 6447 SUBROUTINE GENERIC_JAC_FROM_VF(JAC,NDIM,E1FUNC,E1,X,IDOSYM, 6448 & ISTART,ISTOP) 6449* 6450*. Obtain Jacobian around X using external gradient function E1FUNC 6451* 6452* The Jacobian is assumed full, but is only calculated for 6453* the Columns ISTART to ISTOP 6454* 6455*. Jeppe Olsen, July 2011 6456*. Last modification; Jeppe Olsen; June 2013; ISTART, ISTOP added 6457* 6458 INCLUDE 'implicit.inc' 6459*. Input 6460 DIMENSION X(NDIM) 6461*. Output 6462 REAL*8 JAC(NDIM,NDIM) 6463*. External 6464 EXTERNAL E1FUNC 6465* 6466* IORDER = 2: - second order formulae: 6467* 6468* J Delta X = E1(X+Delta X) - E1(X-Delta) 6469* 6470* IORDER = 4: Fourth order formulae: 6471* 6472* J Delta X = (-1/12) ( (E1(X+2Delta X) - E1(X-2Delta X)) 6473* -8.0D0*(E1(X+Delta X) - E1(X-Delta X) )) 6474* 6475* 6476* 6477 IORDER = 2 6478* 6479 NTEST = 10 6480 IF(NTEST.GE.10) THEN 6481 WRITE(6,*) 6482 WRITE(6,*) ' Info from GENERIC_JAC_FROM_VF ' 6483 WRITE(6,*) ' ==============================' 6484 WRITE(6,*) 6485 WRITE(6,*) ' Order of method in use ', IORDER 6486 END IF 6487 IF(NTEST.GE.1000) THEN 6488 WRITE(6,*) ' Initial set of parameters ' 6489 CALL WRTMAT(X,1,NDIM,1,NDIM) 6490 END IF 6491*Evaluate vector function at point of expansion for check 6492C? CALL E1FUNC(X,E1) 6493C? WRITE(6,*) ' Vector function at initial point' 6494C? CALL WRTMAT(E1,1,NDIM,1,NDIM) 6495C? STOP ' After initial test ' 6496* 6497 6498* 6499*. Shift and constants for finite difference 6500 IF(IORDER.EQ.2) THEN 6501 DELTA = 1.0D-4 6502 FAC1 = 0.5D0/DELTA 6503 ELSE IF (IORDER.EQ.4) THEN 6504 DELTA = 1.0D-2 6505 FAC1 = 1.0D0/(12.0D0*DELTA) 6506 FAC2 = 8.0D0/(12.0D0*DELTA) 6507 END IF 6508* 6509 IF(IORDER.EQ.2) THEN 6510 DO J = ISTART, ISTOP 6511* E1(X+Delta X) 6512 X(J) = X(J) + DELTA 6513 CALL E1FUNC(X,E1) 6514 CALL COPVEC(E1,JAC(1,J),NDIM) 6515 CALL SCALVE(JAC(1,J),FAC1,NDIM) 6516 IF(NTEST.GE.1000) THEN 6517 WRITE(6,*) ' E1(X+Delta)*FAC1: ' 6518 CALL WRTMAT(JAC(1,J),1,NDIM,1,NDIM) 6519 END IF 6520* E1(X-Delta X) 6521 X(J) = X(J) - DELTA - DELTA 6522 CALL E1FUNC(X,E1) 6523 ONE = 1.0D0 6524 FAC1M = -FAC1 6525 CALL VECSUM(JAC(1,J),JAC(1,J),E1,ONE,FAC1M,NDIM) 6526 IF(NTEST.GE.1000) THEN 6527 WRITE(6,*) ' (E1(X+Delta)-E1(X-Delta))*FAC1: ' 6528 CALL WRTMAT(JAC(1,J),1,NDIM,1,NDIM) 6529 END IF 6530*. Clean up 6531 X(J) = X(J) + DELTA 6532 END DO 6533 ELSE IF (IORDER.EQ.4) THEN 6534 DO J = 1, NDIM 6535* E1(X+2Delta X) 6536 X(J) = X(J) + 2.0D0*DELTA 6537 CALL E1FUNC(X,E1) 6538 CALL COPVEC(E1,JAC(1,J),NDIM) 6539 CALL SCALVE(JAC(1,J),-FAC1,NDIM) 6540* E1(X-2Delta X) 6541 X(J) = X(J) - 2.0D0*DELTA - 2.0D0*DELTA 6542 CALL E1FUNC(X,E1) 6543 ONE = 1.0D0 6544 CALL VECSUM(JAC(1,J),JAC(1,J),E1,ONE,FAC1,NDIM) 6545* E1(X+ Delta X) 6546 X(J) = X(J) + 2.0D0*DELTA + DELTA 6547 CALL E1FUNC(X,E1) 6548 ONE = 1.0D0 6549 CALL VECSUM(JAC(1,J),JAC(1,J),E1,ONE,FAC2,NDIM) 6550* E1(X- Delta X) 6551 X(J) = X(J) - DELTA - DELTA 6552 CALL E1FUNC(X,E1) 6553 ONE = 1.0D0 6554 CALL VECSUM(JAC(1,J),JAC(1,J),E1,ONE,-FAC2,NDIM) 6555*. Clean up 6556 X(J) = X(J) + DELTA 6557 END DO 6558 END IF !Switch between the two procedures 6559* 6560 IF(IDOSYM.EQ.1) THEN 6561*. Symmetrize Jacobian 6562 DO I = 1, NDIM 6563 DO J = 1, I 6564 JAC(I,J) = 0.5D0*(JAC(I,J) + JAC(J,I)) 6565 JAC(J,I) = JAC(I,J) 6566 END DO 6567 END DO 6568 END IF 6569* 6570 IF(NTEST.GE.100) THEN 6571 WRITE(6,*) ' Output from GENERIC_JAC_FROM_VF ' 6572 WRITE(6,*) ' =================================' 6573 WRITE(6,*) 6574 CALL WRTMAT(JAC,NDIM,NDIM,NDIM,NDIM) 6575 END IF 6576* 6577 RETURN 6578 END 6579 SUBROUTINE GENERIC_GRAD_FROM_F(GRAD,NDIM,EFUNC,X) 6580* 6581*. Obtain gradient around X using external function EFUNC 6582* 6583*. Jeppe Olsen, July 2011 6584* 6585 INCLUDE 'implicit.inc' 6586*. Input 6587 DIMENSION X(NDIM) 6588*. Output 6589 REAL*8 GRAD(NDIM) 6590*. External 6591 EXTERNAL EFUNC 6592*. The Gradient is obtained from finite difference using 6593* Gradient Delta X = (-1/12) ( (E(X+2Delta X) - E(X-2Delta X)) 6594* -8.0D0*(E(X+Delta X) - E(X-Delta X) )) 6595* 6596*. Shift for finite difference 6597 DELTA = 1.0D-3 6598* 6599 DO J = 1, NDIM 6600* E(X+2Delta X) 6601 X(J) = X(J) + 2.0D0*DELTA 6602 EP2D = EFUNC(X) 6603* E1(X-2Delta X) 6604 X(J) = X(J) - 2.0D0*DELTA - 2.0D0*DELTA 6605 EM2D = EFUNC(X) 6606* E(X+ Delta X) 6607 X(J) = X(J) + 2.0D0*DELTA + DELTA 6608 EP1D = EFUNC(X) 6609* E1(X- Delta X) 6610 X(J) = X(J) - DELTA - DELTA 6611 EM1D = EFUNC(X) 6612*. And the synthesis 6613 GRAD(J) = -1.0D0/(12.0D0*DELTA)*(EP2D-EM2D) 6614 & +8.0D0/(12.0D0*DELTA)*(EP1D-EM1D) 6615*. Clean up 6616 X(J) = X(J) + DELTA 6617 END DO 6618* 6619 NTEST = 100 6620 IF(NTEST.GE.100) THEN 6621 WRITE(6,*) ' Output from GENERIC_GRAD_FROM_F ' 6622 WRITE(6,*) ' =================================' 6623 WRITE(6,*) 6624 CALL WRTMAT(GRAD,1,NDIM,1,NDIM) 6625 END IF 6626* 6627 RETURN 6628 END 6629 FUNCTION E_VB_FROM_KAPPA_WRAP(KAPPA) 6630* 6631* Wrapper routine for calculating Valence bond energy 6632* from Kappa 6633* It is required that common /EVB_TRANS/ has been defined 6634* 6635*. Jeppe Olsen, July 25, 2011, on the train to Fjerritslev- cannot get the 6636* code out of my head.. 6637* 6638 INCLUDE 'implicit.inc' 6639 INCLUDE 'mxpdim.inc' 6640 INCLUDE 'wrkspc-static.inc' 6641 INCLUDE 'glbbas.inc' 6642 INCLUDE 'crun.inc' 6643 COMMON/EVB_TRANS/KLIOOEXC_A, KLKAPPA_A, 6644 & KLIOOEXC_S,KLKAPPA_S, 6645 & KL_C,KL_VEC2,KL_VEC3 6646*. Input 6647 REAL*8 KAPPA(*) 6648 NTEST = 00 6649 IF(NTEST.GE.100) THEN 6650 WRITE(6,*) ' Output from E_VB_FROM_KAPPA_WRAP' 6651 WRITE(6,*) ' ================================' 6652 WRITE(6,*) 6653 WRITE(6,*) ' Kappa_A, Kappa_S ' 6654 WRITE(6,*) 6655 CALL WRTMAT(KAPPA(1),NOOEXC_A,1,NOOEXC_A) 6656 WRITE(6,*) 6657 CALL WRTMAT(KAPPA(1+NOOEXC_A),1,NOOEXC_S,1,NOOEXC_S) 6658 END IF 6659* 6660 E_VB_FROM_KAPPA_WRAP = 6661 &E_VB_FROM_KAPPA(KAPPA,NOOEXC_A,WORK(KLIOOEXC_A), 6662 & KAPPA(1+NOOEXC_A),NOOEXC_S,WORK(KLIOOEXC_S), 6663 & WORK(KL_C),WORK(KL_VEC2),WORK(KL_VEC3)) 6664C E_VB_FROM_KAPPA( 6665C & KAPPA_A,NOOEXC_A,IOOEXC_A, 6666C & KAPPA_S,NOOEXC_S,IOOEXC_S,CCI, 6667C & VEC1_CSF,VEC2_CSF) 6668* 6669 IF(NTEST.GE.10) THEN 6670 WRITE(6,*) ' Energy from E_VB_FROM_KAPPA_WRAP ' 6671 WRITE(6,'(A,E15.8)') ' E = ', E_VB_FROM_KAPPA_WRAP 6672 END IF 6673* 6674 RETURN 6675 END 6676 FUNCTION E_VB_FROM_KAPPA( 6677 & KAPPA_A,NOOEXC_A,IOOEXC_A, 6678 & KAPPA_S,NOOEXC_S,IOOEXC_S,CCI, 6679 & VEC1_CSF,VEC2_CSF) 6680* 6681* Obtain Valence bond energy from Kappa_A, Kappa_S 6682* Using method with expansion in complete VI space 6683* 6684*. It is assumed that the current MO-AO coefficients are in KMOAOIN. 6685* Integrals etc are overwritten, so the exit from this routine is 6686* not clean. 6687* 6688*. Jeppe Olsen, July 24 2011 6689* 6690 INCLUDE 'implicit.inc' 6691 INCLUDE 'mxpdim.inc' 6692 INCLUDE 'wrkspc-static.inc' 6693 INCLUDE 'glbbas.inc' 6694 INCLUDE 'lucinp.inc' 6695 INCLUDE 'orbinp.inc' 6696 INCLUDE 'cintfo.inc' 6697 INCLUDE 'spinfo.inc' 6698*. Common block for communicating with sigma 6699 COMMON/SCRFILES_MATVEC/LUSCR1,LUSCR2,LUSCR3, 6700 & LUCBIO_SAVE, LUHCBIO_SAVE,LUC_SAVE 6701*. Specific input 6702 INTEGER IOOEXC_A(2,NOOEXC_A), IOOEXC_S(2,NOOEXC_S) 6703 REAL*8 KAPPA_A(*), KAPPA_S(*) 6704 DIMENSION CCI(*) 6705 REAL*8 INPRDD 6706*. Scratch 6707 DIMENSION VEC1_CSF(*),VEC2_CSF(*) 6708* 6709 NTEST = 00 6710 IF(NTEST.GE.100) THEN 6711 WRITE(6,*) ' info from E_VB_FROM_KAPPA ' 6712 WRITE(6,*) ' ==========================' 6713 END IF 6714 IF(NTEST.GE.100) THEN 6715 WRITE(6,*) 6716 WRITE(6,*) ' Input Kappa_A and Kappa_S ' 6717 CALL WRTMAT(KAPPA_A,1,NOOEXC_A,1,NOOEXC_A) 6718 WRITE(6,*) 6719 CALL WRTMAT(KAPPA_S,1,NOOEXC_S,1,NOOEXC_S) 6720 END IF 6721* 6722 IDUM = 0 6723 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'EVBFKA') 6724* 6725*. Obtain New MO coefficients in MOAOUT: MOAOIN* Exp(-Kappa_A S) Exp(-Kappa_S S) 6726* 6727C NEWMO_FROM_KAPPA_NORT( 6728C & NOOEXC_A,IOOEXC_A,KAPPA_A, 6729C & NOOEXC_S,IOOEXC_S,KAPPA_S,CMOAO_IN,CMOAO_OUT) 6730C? WRITE(6,*) ' NOOEXC_A, NOOEXC_S before call to NEWMO' , 6731C? & NOOEXC_A, NOOEXC_S 6732 CALL NEWMO_FROM_KAPPA_NORT( 6733 & NOOEXC_A,IOOEXC_A,KAPPA_A,NOOEXC_S,IOOEXC_S,KAPPA_S, 6734 & WORK(KMOAOIN),WORK(KMOAOUT)) 6735* 6736* Obtain the set of biorthonormal orbitals 6737* 6738 CALL GET_CBIO(WORK(KMOAOUT),WORK(KCBIO),WORK(KCBIO2)) 6739* 6740* Biorthonormal integral transformaion 6741* 6742 IF(NTEST.GE.10) THEN 6743 WRITE(6,*) ' Bioorthogonal integral transformation ' 6744 END IF 6745* 6746 IE2LIST_A = IE2LIST_FULL_BIO 6747 IOCOBTP_A = 1 6748 INTSM_A = 1 6749 CALL PREPARE_2EI_LIST 6750* 6751 KKCMO_I = KMOAOUT 6752 KKCMO_J = KCBIO2 6753 KKCMO_K = KMOAOUT 6754 KKCMO_L = KCBIO2 6755* 6756C DO_ORBTRA(IDOTRA,IDOFI,IDOFA,IE2LIST_IN,IOCOBTP_IN,INTSM_IN) 6757 CALL DO_ORBTRA(1,1,0,IE2LIST_FULL_BIO,IOCOBTP_A,INTSM_A) 6758 CALL FLAG_ACT_INTLIST(IE2LIST_FULL_BIO) 6759 NINT1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 6760 CALL COPVEC(WORK(KFI),WORK(KINT1),NINT1_F) 6761* 6762*. Sigma with the current C 6763* 6764C SIGMA_NORTCI(C,HC,SC,IDOHC,IDOSC) 6765 CALL SIGMA_NORTCI(CCI,VEC1_CSF,VEC2_CSF,1,1) 6766 IF(NTEST.GE.1000) WRITE(6,*) ' Back from SIGMA_NORTCI' 6767* calculate energy from vectors on file 6768 CHC = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUC_SAVE,LUHCBIO_SAVE,1,-1) 6769 CC = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUC_SAVE,LUCBIO_SAVE,1,-1) 6770 EVB = CHC/CC 6771* 6772 E_VB_FROM_KAPPA = EVB 6773* 6774 WRITE(6,'(A,3(2X,E14.8))') ' Energy: CHC, CC, CHC/CC ', 6775 & CHC,CC,EVB 6776* 6777 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'EVBFKA') 6778 RETURN 6779 END 6780 SUBROUTINE ORBHES_VB(E2,IFORM) 6781* 6782*Obtain complete or part of Orbital Hessian for VB approach 6783* 6784* IFORM = 1 => Complete orbital Hessian 6785* 6786*. Jeppe Olsen, July 26, 2011 6787* 6788 INCLUDE 'implicit.inc' 6789 INCLUDE 'mxpdim.inc' 6790 INCLUDE 'orbinp.inc' 6791 INCLUDE 'lucinp.inc' 6792 INCLUDE 'crun.inc' 6793 INCLUDE 'glbbas.inc' 6794 INCLUDE 'intform.inc' 6795 INCLUDE 'cintfo.inc' 6796 INCLUDE 'wrkspc-static.inc' 6797*. Output: Complete orbital Hessian in lower packed form 6798 DIMENSION E2(*) 6799 EXTERNAL VB_BR_FOR_KAPPA_WRAP 6800* 6801* Method for calculating orbital Hesssian 6802 I_ORBHES_MET = 2 6803* IORBHES_MET = 1 => Finite difference based on energy 6804* IORBHES_MET = 2 => Finite difference bases on Vector function 6805* IORBHES_MET = 2 => Analytic calc of antisym, FD calc of symmetric part 6806 NTEST = 000 6807 IF(NTEST.GE.10) THEN 6808 WRITE(6,*) ' Info from ORBHES_FD' 6809 WRITE(6,*) ' ================== ' 6810 WRITE(6,*) 6811 IF(I_ORBHES_MET.EQ.1) THEN 6812 WRITE(6,*) 6813 & ' Orbital Hessian obtained from energy finite difference' 6814 ELSE IF( I_ORBHES_MET.EQ.2) THEN 6815 WRITE(6,*) 6816 & ' Orbital Hessian obtained from gradient finite difference' 6817 END IF 6818 END IF 6819* 6820 IDUM = 0 6821 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'OBE2VB') 6822* 6823 KKCMO_I = KMOAOUT 6824 KKCMO_J = KCBIO2 6825 KKCMO_K = KMOAOUT 6826 KKCMO_L = KCBIO2 6827* 6828 NOOEXC_TOT = NOOEXC_A + NOOEXC_S 6829* 6830 IF(I_ORBHES_MET .EQ. 1) THEN 6831 CALL ORBHES_VB_FD(E2) 6832 ELSE 6833* A local copy of complete Hessian, BR-vector and kappa 6834 CALL MEMMAN(KLE2,NOOEXC_TOT**2,'ADDL ',2,'E2FULL') 6835 CALL MEMMAN(KLBR,NOOEXC_TOT,'ADDL ',2,'BRVEC ') 6836 CALL MEMMAN(KLKAP,NOOEXC_TOT,'ADDL ',2,'KLKAP ') 6837* 6838* We will evaluate Hessian at current expansion point, so 6839 ZERO = 0.0D0 6840 CALL SETVEC(WORK(KLKAP),ZERO,NOOEXC_TOT) 6841*. FUSK 6842 IREADJ = 0 6843 IF(IREADJ.EQ.1) THEN 6844*. Jacobian is read in rather than constructed ' 6845 WRITE(6,*) ' WARNING: JACO READ IN FROM LU95 ' 6846 LU95 = 95 6847 CALL REWINO(LU95) 6848 NELMNT = NOOEXC_TOT*(NOOEXC_TOT+1)/2 6849 READ(LU95,*) (E2(IJ), IJ = 1, NELMNT) 6850 ELSE 6851* 6852 CALL GENERIC_JAC_FROM_VF(WORK(KLE2),NOOEXC_TOT, 6853 & VB_BR_FOR_KAPPA_WRAP, WORK(KLBR),WORK(KLKAP),1, 6854 & 1, NOOEXC_TOT) 6855C GENERIC_JAC_FROM_VF(JAC,NDIM,E1FUNC,E1,X,IDOSYM) 6856C TRIPAK(AUTPAK,APAK,IWAY,MATDIM,NDIM) 6857 CALL TRIPAK(WORK(KLE2),E2,1,NOOEXC_TOT,NOOEXC_TOT) 6858 END IF ! JACO read in 6859 END IF ! I_ORBHES_MET = 1 6860* 6861 IDUMPJ = 1 6862 IF(IDUMPJ.EQ.1) THEN 6863 WRITE(6,*) ' Jacobian is dumped to file 95 ' 6864 LU95 = 95 6865 CALL REWINO(LU95) 6866 NELMNT = NOOEXC_TOT*(NOOEXC_TOT+1)/2 6867 WRITE(LU95,*) (E2(IJ), IJ = 1, NELMNT) 6868 END IF 6869 6870* 6871 IF(I_ORBHES_MET.LE.2) THEN 6872*. Restore order- and integrals 6873 IE2LIST_A = IE2LIST_FULL_BIO 6874 IOCOBTP_A = 1 6875 INTSM_A = 1 6876 CALL PREPARE_2EI_LIST 6877 CALL GET_CBIO(WORK(KMOAOIN),WORK(KCBIO),WORK(KCBIO2)) 6878* 6879 KKCMO_I = KMOAOIN 6880 KKCMO_J = KCBIO2 6881 KKCMO_K = KMOAOIN 6882 KKCMO_L = KCBIO2 6883* 6884C DO_ORBTRA(IDOTRA,IDOFI,IDOFA,IE2LIST_IN,IOCOBTP_IN,INTSM_IN) 6885 CALL DO_ORBTRA(1,1,0,IE2LIST_FULL_BIO,IOCOBTP_A,INTSM_A) 6886 NINT1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 6887 CALL COPVEC(WORK(KFI),WORK(KINT1),NINT1_F) 6888 CALL FLAG_ACT_INTLIST(IE2LIST_FULL_BIO) 6889 END IF 6890* 6891 IF(NTEST.GE.1000) THEN 6892 NOOEXC_TOT = NOOEXC_A + NOOEXC_S 6893 WRITE(6,*) ' Orbital Hessian ' 6894 CALL APRBLM2(E2,NOOEXC_TOT,NOOEXC_TOT,1,1) 6895 END IF 6896* 6897 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'OBE2VB') 6898 RETURN 6899 END 6900 SUBROUTINE ORBHES_VB_FD(E2) 6901* 6902*. Obtain Orbital Hessian for VB by energy Finite difference 6903* 6904*. Jeppe Olsen, July 28, 2011 6905* 6906 INCLUDE 'implicit.inc' 6907 INCLUDE 'mxpdim.inc' 6908 INCLUDE 'wrkspc-static.inc' 6909 INCLUDE 'crun.inc' 6910* EVB_TRANS must have been set outside 6911 COMMON/EVB_TRANS/KLIOOEXC_A, KLKAPPA_A, 6912 & KLIOOEXC_S,KLKAPPA_S, 6913 & KL_C,KL_VEC2,KL_VEC3 6914 EXTERNAL E_VB_FROM_KAPPA_WRAP 6915* 6916*. Output: Hessian in lower packed form 6917* 6918 DIMENSION E2(*) 6919* 6920 IDUM = 0 6921 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'OBE2FD') 6922*. Copy of Hessian in complete form 6923 NOOEXC_T = NOOEXC_A + NOOEXC_S 6924 CALL MEMMAN(KLE2F,NOOEXC_T**2,'ADDL ',2,'E2F ') 6925* 6926 CALL MEMMAN(KLE1,NOOEXC_T,'ADDL ',2,'KLE1') 6927C GENERIC_GRA_HES_FD(E0,E1,E2,X,NX,EFUNC) 6928 KLKAPPA = KLKAPPA_A 6929 ZERO = 0.0D0 6930 CALL SETVEC(WORK(KLKAPPA),ZERO,NOOEXC_T) 6931 CALL GENERIC_GRA_HES_FD(E0,WORK(KLE1),WORK(KLE2F),WORK(KLKAPPA), 6932 & NOOEXC_T,E_VB_FROM_KAPPA_WRAP) 6933*. Pack to lower half 6934 CALL TRIPAK(WORK(KLE2F),E2,1,NOOEXC_T,NOOEXC_T) 6935C TRIPAK(AUTPAK,APAK,IWAY,MATDIM,NDIM) 6936* 6937 NTEST = 1000 6938 IF(NTEST.GE.100) THEN 6939 WRITE(6,*) ' Output from ORBHES_VB_FD ' 6940 WRITE(6,*) ' =========================' 6941 WRITE(6,*) 6942 WRITE(6,'(A,E15.8)') ' Current energy = ', E0 6943 WRITE(6,'(A)') ' Gradient: ' 6944 CALL WRTMAT(WORK(KLE1),1,NOOEXC_T,1,NOOEXC_T) 6945 END IF 6946 IF(NTEST.GE.1000) THEN 6947 WRITE(6,'(A)') ' Hessian: ' 6948 CALL PRSYM(E2,NOOEXC_T) 6949C? CALL WRTMAT(E2,NOOEXC_T,NOOEXC_T,NOOEXC_T,NOOEXC_T) 6950 END IF 6951* 6952 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'OBE2FD') 6953 RETURN 6954 END 6955 SUBROUTINE GET_CMOINI_GEN(CINIAO_UT,CINIUT_INIIN,CINIAO_IN) 6956* 6957* Obtain starting set of orbitals. 6958* May be obtained from fragment orbitals 6959* 6960*. Output: 6961* Expansion of starting orbitals in AO: CINIAO_UT 6962* Expansion of starting orbitals in initial orbitals: CINIUT_INIIN 6963* Input: 6964* Expansion of initial initial orbitals: CINIAO_IN 6965 6966* 6967*. Jeppe Olsen, April 2012, extended June 2012 6968* March 2013, added a bit for supersymmetry 6969* 6970 INCLUDE 'implicit.inc' 6971 INCLUDE 'mxpdim.inc' 6972 INCLUDE 'wrkspc-static.inc' 6973 INCLUDE 'crun.inc' 6974 INCLUDE 'fragmol.inc' 6975 INCLUDE 'glbbas.inc' 6976 INCLUDE 'lucinp.inc' 6977 INCLUDE 'orbinp.inc' 6978 INCLUDE 'cgas.inc' 6979*. Input 6980 DIMENSION CINIAO_IN(*) 6981*. Output 6982 DIMENSION CINIAO_UT(*), CINIUT_INIIN(*) 6983* 6984 IDUM = 0 6985 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUN,'MOING') 6986 NTEST = 10 6987 IF(NTEST.GE.1000) THEN 6988 WRITE(6,*) ' Wellcome to GET_CMOINI_GEN' 6989 WRITE(6,*) ' ==========================' 6990 END IF 6991* 6992 IF(NTEST.GE.2) THEN 6993C WRITE(6,*) ' INI_MO_TP, INI_MO_ORT = ', INI_MO_TP, INI_MO_ORT 6994 WRITE(6,*) 6995 WRITE(6,*) ' ======================= ' 6996 WRITE(6,*) ' Initial set of orbitals ' 6997 WRITE(6,*) ' ======================= ' 6998 WRITE(6,*) 6999* 7000 IF(INI_MO_TP.EQ.1) THEN 7001 WRITE(6,'(4X,A)') ' Atomic orbitals will be used ' 7002 ELSE IF (INI_MO_TP.EQ.2) THEN 7003 WRITE(6,'(4X,A)') 7004 & ' Input MOs in VB space rotated to give diagonal block' 7005 ELSE IF (INI_MO_TP.EQ.3) THEN 7006 WRITE(6,'(4X,A)') 7007 & ' Initial MO orbitals from SIRIFC/91 will be used' 7008 ELSE IF (INI_MO_TP.EQ.4) THEN 7009 WRITE(6,'(4X,A)') 7010 & ' Constructed from fragment orbitals' 7011 ELSE IF (INI_MO_TP.EQ.5) THEN 7012 WRITE(6,'(4X,A)') 7013 & ' Initial MO orbitals from LUCINF_O will be used' 7014 END IF 7015* 7016 IF(INI_MO_TP.NE.3) THEN 7017 WRITE(6,'(4X,A)') 7018 & ' Orbitals in inactive and secondary space will be ort.' 7019 WRITE(6,'(4X,A)') ' Orbitals in GAS orbital spaces(.ne. VB ): ' 7020 IF(INI_MO_ORT.EQ.0) THEN 7021 WRITE(6,'(6X,A)') ' No orthogonalization ' 7022 ELSE IF (INI_MO_ORT.EQ.1) THEN 7023 WRITE(6,'(6X,A)') ' Orthogonalized' 7024 END IF 7025 WRITE(6,'(4X,A)') ' Orbitals in VB orbital space: ' 7026 IF(INI_ORT_VBGAS.EQ.0) THEN 7027 WRITE(6,'(6X,A)') ' No orthogonalization ' 7028 ELSE IF (INI_ORT_VBGAS.EQ.1) THEN 7029 WRITE(6,'(6X,A)') ' Orthogonalized' 7030 END IF 7031 END IF 7032* 7033*. In general, the output form of the orbitals are unknown 7034* 7035 CMO_ORD = 'UNK' 7036* 7037 IF(INI_MO_TP.EQ.4) THEN 7038 WRITE(6,*) ' Distribution of orbitals from fragments:' 7039 DO IFRAG = 1, NFRAG_MOL 7040 NSMOB_L = NSMOB_FRAG(IFRAG) 7041 WRITE(6,'(A,I3)') ' For fragment ', IFRAG 7042 WRITE(6,*) ' ====================' 7043 WRITE(6,*) ' Number of orbitals per GAS (row) and sym (col) ' 7044 CALL IWRTMA 7045 & (N_GS_SM_BAS_FRAG(0,1,IFRAG),NGAS+2,NSMOB_L,MXPNGAS+1,MXPOBS) 7046 END DO 7047 END IF ! End if INI_MO_TP.eq.4 7048 END IF !NTEST test 7049* 7050* Two steps : 0) Orthogonalize to frozen orbitals 7051* 1) Obtain a set of (nonorthogonal) initial orbitals 7052* 2) Perform (partial) orthonormalization to obtain 7053* Final initial orbitals 7054* 7055* Generate set of (nonorthogonal) initial orbitals 7056* 7057 CALL GET_INIMO(CINIAO_UT) 7058C GET_INIMO(CMO_INI) 7059* 7060* 7061 IF(NTEST.GE.100) THEN 7062 WRITE(6,*) ' Expansion of initial MOs in AOs ' 7063 WRITE(6,*) ' ================================' 7064 CALL APRBLM_F7(CINIAO_UT,NTOOBS,NTOOBS,NSMOB,0) 7065 END IF 7066*. MO_TP = 3 => we are done... 7067 IF(INI_MO_TP.EQ.3) GOTO 9999 7068* 7069*. Orthogonalize to frozen orbitals 7070*. Jeppe, I am not sure if this is working in connection with supersymmetry reordering... 7071*. (What are the numbers defining the localized orbitals?) 7072 IF(NFRZ_ORB.NE.0) THEN 7073 CALL ORT_CMO_TO_FROZEN_ORBITALS(CINIAO_UT) 7074 IF(NTEST.GE.100) THEN 7075 WRITE(6,*) ' Orbitals orthogonalized to frozen ' 7076 CALL APRBLM_F7(CINIAO_UT,NTOOBS,NTOOBS,NSMOB,0) 7077 END IF 7078 END IF 7079* 7080 CMO_ORD = 'UNK' 7081* 7082* New initial orbitals in terms of initial initial orbitals(KMOAOIN) 7083* 7084* CINIUT_INIIN = CINIAO_UT* CINIAO_IN**-1 7085* 7086*. Invert CINIAO_IN 7087 LMOMO = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 7088 CALL MEMMAN(KLCMOS,2*LMOMO,'ADDL ',2,'CMOS ') 7089 CALL MEMMAN(KLCMOI, LMOMO,'ADDL ',2,'CMOI ') 7090 IPROBLEM = 0 7091 CALL INV_BLKMT(CINIAO_IN,WORK(KLCMOI),WORK(KLCMOS),NSMOB, 7092 & NTOOBS,IPROBLEM) 7093C INV_BLKMT(A,AINV,SCR,NBLK,LBLK,IPROBLEM) 7094 IF(IPROBLEM.NE.0) THEN 7095 WRITE(6,*) ' Problem inverting CMOAOUT ' 7096 STOP ' Problem inverting CMOAOUT ' 7097 END IF 7098*. And multiply 7099C MULT_H1H2(H1,IH1SM,H2,IH2SM,H12,IH12SM) 7100 CALL MULT_H1H2(WORK(KLCMOI),1,CINIAO_UT,1,CINIUT_INIIN,IUTSM) 7101* 7102 IF(NTEST.GE.100) THEN 7103 WRITE(6,*) 7104 & ' Expansion of initial MOs in Initial initial MOs ' 7105 WRITE(6,*) ' =====================================' 7106 CALL APRBLM_F7(CINIUT_INIIN,NTOOBS,NTOOBS,NSMOB,0) 7107 END IF 7108* 7109* Check of orthogonality of reexpansion of initial orbitals 7110* 7111C MULT_BLOC_MAT(C,A,B,NBLOCK,LCROW,LCCOL, 7112C & LAROW,LACOL,LBROW,LBCOL,ITRNSP) 7113 CALL MULT_BLOC_MAT(WORK(KLCMOS),CINIUT_INIIN,CINIUT_INIIN,NSMOB, 7114 & NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,NTOOBS,1) 7115* 7116 IF(NTEST.GE.100) THEN 7117 WRITE(6,*) ' CINIUT_INIIN*CINIUT_INIIN(T) ' 7118 WRITE(6,*) ' =============================' 7119 CALL APRBLM2(WORK(KLCMOS),NTOOBS,NTOOBS,NSMOB,0) 7120 END IF 7121* 7122 9999 CONTINUE 7123* 7124 CALL MEMMAN(IDUM,IDUM,'FLUSM',IDUN,'MOING') 7125* 7126 RETURN 7127 END 7128 SUBROUTINE EXTR_SYMGAS_BLK_FROM_ORBMAT 7129 & (A,ABLK,ISM,IGAS,JSM,JGAS) 7130* 7131* A symmetryblocked (not lower half packed) matrix A over orbitals is given 7132* Extract block referring to GASpaCE IGAS, JGAS and symmetry ISM,JSM 7133* 7134* I_EX_OR_CP = 1 => Extract from A to IGAS 7135* I_EX_OR_CP = 1 => Copy from IGAS to A 7136* 7137*. Jeppe Olsen, May 2012 7138* 7139 INCLUDE 'implicit.inc' 7140 INCLUDE 'mxpdim.inc' 7141 INCLUDE 'orbinp.inc' 7142 INCLUDE 'lucinp.inc' 7143 INCLUDE 'multd2h.inc' 7144*. Specific input and output 7145 DIMENSION A(*), ABLK(*) 7146* 7147 NTEST = 00 7148 IF(NTEST.GE.100) THEN 7149 WRITE(6,*) ' EXTR_SYMGAS_BLK_FROM_ORBMAT ' 7150 WRITE(6,*) ' =========================== ' 7151 END IF 7152 7153*. Symmetry of matrix 7154 IJSM = MULTD2H(ISM,JSM) 7155*. Offsets to symmetry block in full matrix matrix 7156 IOFF_IN = 1 7157 DO IISM = 1, ISM-1 7158 JJSM = MULTD2H(IISM,IJSM) 7159 IOFF_IN = IOFF_IN + NTOOBS(IISM)*NTOOBS(JJSM) 7160 END DO 7161*. Offset to start of orbitals in given gas 7162 IOFF = 1 7163 DO IIGAS = 0, IGAS -1 7164 IOFF = IOFF + NOBPTS_GN(IIGAS,ISM) 7165 END DO 7166* 7167 JOFF = 1 7168 DO JJGAS = 0, JGAS -1 7169 JOFF = JOFF + NOBPTS_GN(JJGAS,JSM) 7170 END DO 7171* 7172 NI = NOBPTS_GN(IGAS,ISM) 7173 NJ = NOBPTS_GN(JGAS,JSM) 7174 NIS = NTOOBS(ISM) 7175 NJS = NTOOBS(JSM) 7176 DO J = 1, NJ 7177 DO I = 1, NI 7178 IJ_OUT = (J-1)*NI + I 7179 IJ_IN = IOFF_IN -1 + (JOFF+J-1-1)*NIS + IOFF+I-1 7180 ABLK(IJ_OUT) = A(IJ_IN) 7181 END DO 7182 END DO 7183* 7184 IF(NTEST.GE.100) THEN 7185 WRITE(6,*) ' Submatrix with ISM, JSM, IGAS, JGAS = ', 7186 & ISM, JSM, IGAS, JGAS 7187 CALL WRTMAT(ABLK,NI,NJ,NI,NJ) 7188 END IF 7189 IF(NTEST.GE.1000) THEN 7190 WRITE(6,*) ' Full matrix ' 7191 CALL APRBLM2(A,NTOOBS,NTOOBS,NSMOB,0) 7192 END IF 7193* 7194 RETURN 7195 END 7196 SUBROUTINE VB_DENSI(RHO1,RHO2,IR12,C,VEC1_CSF,VEC2_CSF) 7197* 7198* 7199* Obtain one-body density matrix over active space for VB function 7200* 7201* 7202* E(IJ) = <0!(E(ij))!0> /<0!0> 7203* 7204* and if IR12 = 2 also the two-body density matrix in mixed basis 7205* E(IJ,KL) = <0!\tilde a+i \sigma \tilde a+k sigma' a l sigma' a j sigma!0> 7206* 7207* Note that whereas the one-eletron density is transformed to the 7208* actual MO-basis, the two-body density is kept in the mixed basis 7209* 7210* So to obtain gradient 7211* 1: construct bioorthogonal expansion of !0> 7212* 2: Set up density matrices <0!E(ij)!0> 7213* where i is in biobase and j in normal 7214* 3: Transform density matrices to standard basis 7215* 7216* The current CI coefficients in the CSF basis are in C, where 7217* VEC1_CSF, VEC2_CSF, must be able to hold these expansions 7218* 7219* This is an initial version, for initial calculations and checks 7220* 7221* Jeppe Olsen, May 2012, for the initial NORTMCSCF program 7222* 7223* Sitting in Palermo, preparing for a talk ... 7224* 7225 INCLUDE 'implicit.inc' 7226 INCLUDE 'mxpdim.inc' 7227 INCLUDE 'wrkspc-static.inc' 7228 INCLUDE 'lucinp.inc' 7229 INCLUDE 'orbinp.inc' 7230 INCLUDE 'clunit.inc' 7231 INCLUDE 'glbbas.inc' 7232 INCLUDE 'crun.inc' 7233 COMMON/SCRFILES_MATVEC/LUSCR1,LUSCR2,LUSCR3, 7234 & LUCBIO_SAVE, LUHCBIO_SAVE,LUC_SAVE 7235 REAL*8 INPRDD 7236*. Input 7237 DIMENSION C(*) 7238*. Scratch 7239 DIMENSION VEC1_CSF(*), VEC2_CSF(*) 7240*. Output 7241 DIMENSION RHO1(*), RHO2(*) 7242* 7243 NTEST = 10 7244*. CSFs are handled explicitly, so 7245 NOCSF = 1 7246* 7247 IF(NTEST.GE.100) THEN 7248 WRITE(6,*) 7249 WRITE(6,*) ' ========' 7250 WRITE(6,*) ' VB_DENSI' 7251 WRITE(6,*) ' ========' 7252 WRITE(6,*) 7253 END IF 7254* 7255 IDUM = 0 7256 CALL MEMMAN(IDUM,IDUM,'MARK ',2,'VBDENS') 7257* 7258 LUSCR1 = LUSC34 7259 LUSCR2 = LUSC35 7260 LUSCR3 = LUSC36 7261 LUCBIO_SAVE = 110 7262 LUC_SAVE = 112 7263* 7264* A bit of scratch 7265* 7266 LEN_1A = NDIM_1EL_MAT(1,NACOBS,NACOBS,NSMOB,0) 7267 CALL MEMMAN(KLRHOB,NACOB**2,'ADDL ',2,'RHOB ') 7268 CALL MEMMAN(KLSCR ,NACOB**2,'ADDL ',2,'SCR ') 7269 CALL MEMMAN(KLCBIOA,LEN_1A,'ADDL ',2,'CBIOAC') 7270*. Preparation: Obtain CBIO over active orbitals only 7271C EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT(A,AGAS,I_EX_OR_CP) 7272 CALL EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT 7273 & (WORK(KCBIO),WORK(KLCBIOA),1) 7274 IF(NTEST.GE.1000) THEN 7275 WRITE(6,*) ' CBIO in active orbitals ' 7276 CALL APRBLM2(WORK(KLCBIOA),NACOBS,NACOBS,NSMOB,0) 7277 END IF 7278* 7279*. Biotransform C 7280* 7281C SIGMA_NORTCI(C,HC,SC,IDOHC,IDOSC) 7282 CALL SIGMA_NORTCI(C,VEC1_CSF,VEC2_CSF,0,1) 7283 IF(NTEST.GE.1000) WRITE(6,*) ' Back from SIGMA_NORTCI' 7284* calculate Overlap from vectors on file - for check 7285 CC = INPRDD(WORK(KVEC1P),WORK(KVEC2P),LUC_SAVE, LUCBIO_SAVE,1,-1) 7286 IF(NTEST.GE.100) WRITE(6,*) ' <0!0> =', CC 7287* 7288*. Set up density <0! a+i(bio) aj!0(bio)> in RHOB 7289* 7290 IF(NTEST.GE.1000) THEN 7291 WRITE(6,*) ' C in SD expansion ' 7292 CALL WRTVCD(WORK(KVEC1P),LUC_SAVE,1,-1) 7293 WRITE(6,*) ' C(bio) in SD expansion ' 7294 CALL WRTVCD(WORK(KVEC1P),LUCBIO_SAVE,1,-1) 7295 END IF 7296 XDUM = 0.0D0 7297 CALL DENSI2(IR12 ,WORK(KLRHOB),RHO2, 7298 &WORK(KVEC1P),WORK(KVEC2P),LUC_SAVE,LUCBIO_SAVE,EXPS2, 7299 &0,XDUM,XDUM,XDUM,XDUM,0) 7300* 7301 FACTOR = 1.0D0/CC 7302C? WRITE(6,*) ' CC = ', CC 7303 CALL SCALVE(WORK(KLRHOB),FACTOR,NACOB**2) 7304 IF(IR12.EQ.2) THEN 7305 LRHO2 = NACOB**2*(NACOB**2+1)/2 7306 CALL SCALVE(RHO2,FACTOR,LRHO2) 7307 END IF 7308 7309 IF(NTEST.GE.1000) THEN 7310 WRITE(6,*) ' Density matrix <0! a+i(bio) aj!bio 0>/<0!0> ' 7311 CALL WRTMAT(WORK(KLRHOB),NACOB,NACOB,NACOB,NACOB) 7312 END IF 7313*. Obtain density as blocked matrix over symmetry blocks of active orbitals 7314C REORHO1(RHO1I,RHO1O,IRHO1SM) 7315 CALL REORHO1(WORK(KLRHOB),WORK(KLSCR),1,1) 7316 CALL COPVEC(WORK(KLSCR),WORK(KLRHOB),LEN_1A) 7317*. Transform the densities from bio, normal to the normal, normal basis 7318C TR_BIOMAT(XIN,XOUT,CBIO,NORB_PSM, 7319C & INB_IN,INB_OUT,JNB_IN,JNB_OUT) 7320 CALL TR_BIOMAT(WORK(KLRHOB),WORK(KLSCR),WORK(KLCBIOA), 7321 & NACOBS,2,1,1,1) 7322*. Transfer back to full matrix over active orbitals 7323 CALL REORHO1(RHO1,WORK(KLSCR),1,2) 7324* 7325 IF(NTEST.GE.100) THEN 7326 WRITE(6,*) ' Density matrix <0! E(ij) !> ' 7327 CALL WRTMAT(RHO1,NACOB,NACOB,NACOB,NACOB) 7328 END IF 7329* 7330 CALL MEMMAN(IDUM,IDUM,'FLUSM ',2,'VBDENS') 7331 RETURN 7332 END 7333 SUBROUTINE GET_SACT(SACT,C) 7334* 7335*. Obtain the overlap matrix of the active orbitals for a MO-AO expansion 7336* given by the MO-AO expansion matric C 7337* 7338*. Jeppe Olsen, May 31 2012 7339* 7340 INCLUDE 'implicit.inc' 7341 INCLUDE 'mxpdim.inc' 7342 INCLUDE 'wrkspc-static.inc' 7343 INCLUDE 'orbinp.inc' 7344 INCLUDE 'lucinp.inc' 7345 INCLUDE 'glbbas.inc' 7346*. Specific input 7347 DIMENSION C(*) 7348*. Specific output: in symmetry-packed lower half form 7349 DIMENSION SACT(*) 7350*. Obtain expansion of active orbitals only 7351 7352 NTEST = 00 7353 IF(NTEST.GE.100) THEN 7354 WRITE(6,*) ' Info from SACT ' 7355 WRITE(6,*) ' ============== ' 7356 END IF 7357* 7358*. It is assumed that SAO resides in WORK(KSAO) 7359 IDUM = 0 7360 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'VB_SAC') 7361* 7362*. Two ways of which IWAY = 1 has a bug... 7363* 7364 LEN_CACT = LEN_BLMAT(NSMOB,NACOBS,NTOOBS,0) 7365 LEN_C = LEN_BLMAT(NSMOB,NTOOBS,NTOOBS,0) 7366* 7367 IWAY = 2 7368 IF(IWAY.EQ.1) THEN 7369 CALL MEMMAN(KLCACT,LEN_CACT,'ADDL ',2,'C_AC ') 7370 CALL MEMMAN(KLSCR ,2*LEN_C,'ADDL ',2,'SCR ') 7371*. Obtain C over active orbitals only 7372C EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT(A,AGAS,I_EX_OR_CP) 7373 CALL EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT 7374 & (C,WORK(KLCACT),1) 7375 IF(NTEST.GE.1000) THEN 7376 WRITE(6,*) ' C over active orbitals ' 7377 CALL APRBLM2(WORK(KLCACT),NACOBS,NACOBS,NSMOB,0) 7378 END IF 7379* 7380 CALL TRAN_SYM_BLOC_MAT4(WORK(KSAO),WORK(KLCACT),WORK(KLCACT), 7381 & NSMOB,NTOOBS,NACOBS,SACT,WORK(KLSCR),1) 7382C TRAN_SYM_BLOC_MAT4 7383C & (AIN,XL,XR,NBLOCK,LX_ROW,LX_COL,AOUT,SCR,ISYM) 7384 ELSE 7385*. Obtain full SMO and extract active blocks 7386 CALL MEMMAN(KLS1,LEN_C,'ADDL ',2,'S_FULL') 7387 CALL MEMMAN(KLS2,LEN_C,'ADDL ',2,'S2FULL') 7388 CALL GET_SMO(WORK(KMOAOUT),WORK(KLS1),0) 7389 IF(NTEST.GE.1000) THEN 7390 WRITE(6,*) ' Full S matrix ' 7391 CALL APRBLM2(WORK(KLS1),NTOOBS,NTOOBS,NSMOB,0) 7392 END IF 7393*. Extract active blocks 7394 CALL EXTR_OR_CP_ACT_BLKS_FROM_ORBMAT 7395 & (WORK(KLS1),WORK(KLS2),1) 7396 IF(NTEST.GE.1000) THEN 7397 WRITE(6,*) ' S matrix over activt orbitals' 7398 CALL APRBLM2(WORK(KLS2),NACOBS,NACOBS,NSMOB,0) 7399 END IF 7400*. And pack these 7401C TRIPAK_BLKM(AUTPAK,APAK,IWAY,LBLOCK,NBLOCK) 7402 CALL TRIPAK_BLKM(WORK(KLS2),SACT,1,NACOBS,NSMOB) 7403 END IF !switch between routes 7404* 7405 IF(NTEST.GE.100) THEN 7406 WRITE(6,*) ' Overlap matrix over active orbitals ' 7407 CALL APRBLM2(SACT,NACOBS,NACOBS,NSMOB,1) 7408 END IF 7409* 7410 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'VB_SAC') 7411* 7412 RETURN 7413 END 7414 SUBROUTINE NONORT_NATORB(SACT,RHO1) 7415 7416* Obtain natural orbitals for a density matrix in a 7417* nonorthogonal basis 7418* 7419*. Jeppe Olsen, May 2012 7420* 7421 INCLUDE 'implicit.inc' 7422 INCLUDE 'mxpdim.inc' 7423 INCLUDE 'wrkspc-static.inc' 7424 INCLUDE 'orbinp.inc' 7425 INCLUDE 'lucinp.inc' 7426*. Specific input: SACT in symmetry-blocked lower half packed form 7427*. and RHO1 over all active orbitals in standard type-symmetry order 7428* 7429 DIMENSION SACT(*),RHO1(NACOB,NACOB) 7430* 7431 NTEST = 10 7432 IF(NTEST.GE.100) THEN 7433 WRITE(6,*) 7434 WRITE(6,*) ' Info from NONORT_NATORB ' 7435 WRITE(6,*) ' ========================' 7436 WRITE(6,*) 7437 END IF 7438* 7439 IDUM = 0 7440 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'NORNAT') 7441* 7442*. Some scratch space 7443* ================== 7444*. Density matrix in symmetry-packed complete form 7445 LEN_CACT = LEN_BLMAT(NSMOB,NACOBS,NACOBS,0) 7446 CALL MEMMAN(KLRH_SYM,LEN_CACT,'ADDL ',2,'RH_SYM') 7447*. Unpacked overlap matrix 7448 CALL MEMMAN(KLSUNP,LEN_CACT,'ADDL ',2,'S_UNP ') 7449*. Expansion coefficient of natural orbitals 7450 CALL MEMMAN(KLCNAT,LEN_CACT,'ADDL ',2,'C_NAT ') 7451*. Matrix for going to orthonormal basis 7452 CALL MEMMAN(KLP,LEN_CACT,'ADDL ',2,'P_TRA ') 7453*. Natural occupation numbers 7454 CALL MEMMAN(KLOCC,NACOB,'ADDL ',2,'P_TRA ') 7455 7456*. Obtain density in blocks of symmetry 7457*. Loop over active orbitals in output order: symmetry type 7458 IOBOFF = 0 7459 IMTOFF = 0 7460 IADD_ST = 0 7461 IADD_TS = NINOB 7462 DO ISMOB = 1, NSMOB 7463 IF(ISMOB.EQ.1) THEN 7464 IOBOFF = 1 7465 IMTOFF = 1 7466 IADD_ST = NINOBS(1) 7467 ELSE 7468 IOBOFF = IOBOFF + NACOBS(ISMOB-1) 7469 IMTOFF = IMTOFF + NACOBS(ISMOB-1)**2 7470 IADD_ST = IADD_ST + NINOBS(ISMOB) + NSCOBS(ISMOB-1) 7471 END IF 7472 LOB = NACOBS(ISMOB) 7473C? WRITE(6,*) ' ISMOB, LOB, = ', ISMOB, LOB 7474C? WRITE(6,*) ' IADD_TS = ', IADD_TS 7475* 7476*. Extract symmetry block of density matrix 7477* 7478*. Loop over active orbitals of symmetry ISMOB in ST order 7479 DO IOB = IOBOFF,IOBOFF + LOB-1 7480 IOB_ABS = IOB + IADD_ST 7481C IOB_TS = ISTREO(IOB_ABS) - IADD_TS 7482 IOB_TS = IREOST(IOB_ABS) - IADD_TS 7483 IOB_REL = IOB - IOBOFF + 1 7484 DO JOB = IOBOFF,IOBOFF + LOB-1 7485 JOB_ABS = JOB + IADD_ST 7486 JOB_TS = IREOST(JOB_ABS) - IADD_TS 7487 JOB_REL = JOB - IOBOFF + 1 7488 IF(NTEST.GE.1000) THEN 7489 WRITE(6,*) ' JOB, JOB_ABS, JOB_TS, IREOST() = ', 7490 & JOB, JOB_ABS, JOB_TS, IREOST(JOB_ABS) 7491 WRITE(6,*) ' IOB_TS, JOB_TS = ', IOB_TS, JOB_TS 7492 WRITE(6,'(A,6I3)') 7493 & ' IOB_TS, JOB_TS, IOB, JOB, IOB_REL, JOB_REL = ', 7494 & IOB_TS, JOB_TS, IOB, JOB, IOB_REL, JOB_REL 7495 END IF 7496 WORK(KLRH_SYM-1+IMTOFF-1+(JOB_REL-1)*LOB+IOB_REL) 7497 & = RHO1(IOB_TS,JOB_TS) 7498 END DO !Job 7499 END DO ! Iob 7500 END DO! Loop over symmetries of orbitals 7501* 7502 IF(NTEST.GE.1000) THEN 7503 WRITE(6,*) ' One-body density matrix in symmetry-blocks ' 7504 CALL APRBLM2(WORK(KLRH_SYM),NACOBS,NACOBS,NSMOB,0) 7505 END IF 7506*. Unpack overlapmatrix 7507C TRIPAK_BLKM(AUTPAK,APAK,IWAY,LBLOCK,NBLOCK) 7508 CALL TRIPAK_BLKM(WORK(KLSUNP),SACT,2,NACOBS,NSMOB) 7509 IF(NTEST.GE.100) THEN 7510 WRITE(6,*) ' Overlap matrix in unpacked form ' 7511 CALL APRBLM2(WORK(KLSUNP),NACOBS,NACOBS,NSMOB,0) 7512 END IF 7513*. Multiply density with -1 to get highest occupation numbers first 7514 ONEM = -1.0D0 7515 CALL SCALVE(WORK(KLRH_SYM),ONEM,LEN_CACT) 7516*. Diagonalize 7517C GENDIA_BLMAT(HIN,SIN,C,E,PVEC,NBLK,LBLK,ISORT) 7518 CALL GENDIA_BLMAT(WORK(KLRH_SYM),WORK(KLSUNP),WORK(KLCNAT), 7519 & WORK(KLOCC),WORK(KLP),NACOBS,NSMOB,1) 7520*. Multiply occupation numbers with -1 to counteract previous multiply 7521 CALL SCALVE(WORK(KLOCC),ONEM,NACOB) 7522* 7523 WRITE(6,*) ' Natural occupation numbers: ' 7524 WRITE(6,*) ' =========================== ' 7525 WRITE(6,*) 7526* 7527 DO ISYM = 1, NSMOB 7528 IF(ISYM.EQ.1) THEN 7529 IOFF_I = 1 7530 IOFF_IJ = 1 7531 ELSE 7532 IOFF_I = IOFF_I + NACOBS(ISYM-1) 7533 IOFF_IJ = IOFF_IJ + NACOBS(ISYM-1)**2 7534 END IF 7535 WRITE(6,*) 7536 WRITE(6,*) 7537 & ' Natural occupation numbers for symmetry = ', ISYM 7538 WRITE(6,*) 7539 & ' ===================================================' 7540 L = NACOBS(ISYM) 7541 CALL WRTMAT(WORK(KLOCC-1+IOFF_I),1,L,1,L) 7542 WRITE(6,*) 7543 & ' Expansion of natural orbitals for symmetry = ', ISYM 7544 WRITE(6,*) 7545 & ' ===================================================' 7546 CALL WRTMAT(WORK(KLCNAT-1+IOFF_IJ),L,L,L,L) 7547 END DO! Loop over symmetries 7548* 7549 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'NORNAT') 7550 RETURN 7551 END 7552 SUBROUTINE VB_BR_FOR_KAPPA_WRAP(KAPPA,BR) 7553* 7554* Outer routine for obtaining generalized Brillouin vector 7555* at a given point 7556* 7557*. Jeppe Olsen, May 31, 2012 in Palermo, (18 hours to talk) 7558* 7559 INCLUDE 'implicit.inc' 7560 INCLUDE 'mxpdim.inc' 7561 INCLUDE 'orbinp.inc' 7562 INCLUDE 'wrkspc-static.inc' 7563 INCLUDE 'crun.inc' 7564* 7565 COMMON/EVB_TRANS/KLIOOEXC_A, KLKAPPA_A, 7566 & KLIOOEXC_S,KLKAPPA_S, 7567 & KL_C,KL_VEC2,KL_VEC3, 7568 & KLOOEXC 7569* 7570* 7571*. Input 7572 REAL*8 KAPPA(*) 7573*. And output 7574 DIMENSION BR(*) 7575 7576 NTEST = 01 7577 IF(NTEST.GE.1) WRITE(6,*) ' Entering VB_BR_FOR_KAPPA_WRAP' 7578* 7579 IF(NTEST.GE.100) THEN 7580 WRITE(6,*) ' Info from VB_BR_FOR_KAPPA_WRAP' 7581 WRITE(6,*) ' ==============================' 7582 WRITE(6,*) 7583 WRITE(6,*) ' Kappa_A, Kappa_S ' 7584 WRITE(6,*) 7585 WRITE(6,*) ' NOOEXC_A, NOOEXC_S = ', 7586 & NOOEXC_A, NOOEXC_S 7587 CALL WRTMAT(KAPPA(1),NOOEXC_A,1,NOOEXC_A) 7588 WRITE(6,*) 7589 CALL WRTMAT(KAPPA(1+NOOEXC_A),1,NOOEXC_S,1,NOOEXC_S) 7590 END IF 7591*. And call the routine that does the job 7592 CALL VB_BR_FROM_KAPPA(BR, 7593 & NOOEXC_A,WORK(KLIOOEXC_A),KAPPA(1), 7594 & NOOEXC_S,WORK(KLIOOEXC_S),KAPPA(1+NOOEXC_A), 7595 & WORK(KLOOEXC), 7596 & WORK(KL_C),WORK(KL_VEC2),WORK(KL_VEC3)) 7597* 7598 IF(NTEST.GE.100) THEN 7599 WRITE(6,*) ' Brillouin vector from VB_BR_FOR_KAPPA_WRAP' 7600 WRITE(6,*) ' ========================================= ' 7601 WRITE(6,*) 7602 N = NOOEXC_A + NOOEXC_S 7603 CALL WRTMAT(BR,1,N,1,N) 7604 END IF 7605* 7606 RETURN 7607 END 7608 SUBROUTINE VB_BR_FROM_KAPPA(BR, 7609 & NOOEXC_A,IOOEXC_A, KAPPA_A, 7610 & NOOEXC_S,IOOEXC_S, KAPPA_S, 7611 & IOOEXC, 7612 & C,VEC2,VEC3) 7613* 7614* Obtain VB Brillouin vector for a given set of Kappa parameters 7615* 7616*. Jeppe Olsen, May 31, Palermo - Finished June 3, Zurich 7617* 7618*.It is assumed that the current MO-AO coefficients are in KMOAOIN. 7619* Integrals etc are overwritten, so the exit from this routine is 7620* not clean. 7621* 7622 INCLUDE 'implicit.inc' 7623 INCLUDE 'mxpdim.inc' 7624 INCLUDE 'wrkspc-static.inc' 7625 INCLUDE 'glbbas.inc' 7626 INCLUDE 'lucinp.inc' 7627 INCLUDE 'orbinp.inc' 7628 INCLUDE 'cintfo.inc' 7629 INCLUDE 'spinfo.inc' 7630*. Explicit input 7631 REAL*8 KAPPA_A(NOOEXC_A),KAPPA_S(NOOEXC_S) 7632 INTEGER IOOEXC_A(2,NOOEXC_A), IOOEXC_S(2,NOOEXC_S), IOOEXC(*) 7633*. Coefficients 7634 DIMENSION C(*) 7635*. Output 7636 DIMENSION BR(*) 7637*. Scratch vectors 7638 DIMENSION VEC2(*),VEC3(*) 7639* 7640*. Common block for communicating with sigma 7641 COMMON/SCRFILES_MATVEC/LUSCR1,LUSCR2,LUSCR3, 7642 & LUCBIO_SAVE, LUHCBIO_SAVE,LUC_SAVE 7643* 7644 NTEST = 000 7645 IF(NTEST.GE.100) THEN 7646 WRITE(6,*) ' Info from VB_BR_FROM_KAPPA ' 7647 WRITE(6,*) ' ===========================' 7648 WRITE(6,*) ' NOOEXC_S, NOOEXC_A = ', 7649 & NOOEXC_S, NOOEXC_A 7650 END IF 7651 IF(NTEST.GE.1000) THEN 7652 WRITE(6,*) ' Antisymmetric and symmetric part of Kappa ' 7653 CALL WRTMAT(KAPPA_A,1,NOOEXC_A,1,NOOEXC_A) 7654 CALL WRTMAT(KAPPA_S,1,NOOEXC_S,1,NOOEXC_S) 7655* 7656 WRITE(6,*) ' IOOEXC: ' 7657 CALL IWRTMA3(IOOEXC,NTOOB,NTOOB,NTOOB,NTOOB) 7658 END IF 7659* 7660 IDUM = 0 7661 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'VBBRKA') 7662* 7663*. Obtain New MO coefficients in MOAOUT: MOAOIN* Exp(-Kappa_A S) Exp(-Kappa_S S) 7664* 7665 CALL NEWMO_FROM_KAPPA_NORT( 7666 & NOOEXC_A,IOOEXC_A,KAPPA_A,NOOEXC_S,IOOEXC_S,KAPPA_S, 7667 & WORK(KMOAOIN),WORK(KMOAOUT)) 7668* 7669* Obtain the set of biorthonormal orbitals 7670* 7671 CALL GET_CBIO(WORK(KMOAOUT),WORK(KCBIO),WORK(KCBIO2)) 7672* 7673* Biorthonormal integral transformaion 7674* 7675 IF(NTEST.GE.10) THEN 7676 WRITE(6,*) ' Bioorthogonal integral transformation ' 7677 END IF 7678* 7679C IE2LIST_A = IE2LIST_FULL_BIO 7680C IOCOBTP_A = 1 7681C INTSM_A = 1 7682 IE2LIST_A = IE2LIST_1G_BIO 7683C IOCOBTP_A = 2 7684 IOCOBTP_A = 1 7685 INTSM_A = 1 7686 CALL PREPARE_2EI_LIST 7687* 7688 KKCMO_I = KMOAOUT 7689 KKCMO_J = KCBIO2 7690 KKCMO_K = KMOAOUT 7691 KKCMO_L = KCBIO2 7692* 7693C DO_ORBTRA(IDOTRA,IDOFI,IDOFA,IE2LIST_IN,IOCOBTP_IN,INTSM_IN) 7694C CALL DO_ORBTRA(1,1,1,IE2LIST_FULL_BIO,IOCOBTP_A,INTSM_A) 7695C CALL FLAG_ACT_INTLIST(IE2LIST_FULL_BIO) 7696 CALL DO_ORBTRA(1,1,1,IE2LIST_1G_BIO,IOCOBTP_A,INTSM_A) 7697 CALL FLAG_ACT_INTLIST(IE2LIST_1G_BIO) 7698 7699 NINT1_F = NDIM_1EL_MAT(1,NTOOBS,NTOOBS,NSMOB,0) 7700 CALL COPVEC(WORK(KFI),WORK(KINT1),NINT1_F) 7701* 7702* And construct the one- and two-body density matrices 7703* 7704 CALL VB_DENSI(WORK(KRHO1),WORK(KRHO2),2,C,VEC2,VEC3) 7705*. Construct Active Fock-matrix 7706 CALL DO_ORBTRA(1,1,1,IE2LIST_FULL_BIO, 7707 & IOCOBTP_A,INTSM_A) 7708* 7709 CALL FOCK_MAT_NORT(WORK(KF),WORK(KF2),2,WORK(KFI),WORK(KFA)) 7710*. And the interspace gradient 7711C E1_FROM_F_NORT(E1,F1,F2,IOPSM,IOOEXC,IOOEXCC, 7712C & NOOEXC,NTOOB,NTOOBS,NSMOB,IBSO,IREOST) 7713 CALL E1_FROM_F_NORT(BR,WORK(KF),WORK(KF2),1, 7714 & IOOEXC,IOOEXC_A,NOOEXC_A,NTOOB, 7715 & NTOOBS,NSMOB,IBSO,IREOST) 7716*. And add the active-active gradient 7717* The interspace excitations 7718C VB_GRAD_ORBVBSPC(NOOEXC,IOOEXC,E1,C,VEC1_CSF,VEC2_CSF) 7719 IF(NTEST.GE.1000) 7720 & WRITE(6,*) ' Active-active gradient will be calculated ' 7721 CALL VB_GRAD_ORBVBSPC(NOOEXC_S,IOOEXC_S, 7722 & BR(1+NOOEXC_A-NOOEXC_S),C,VEC2,VEC3) 7723 7724* And calculate gradient 7725C VB_GRAD_ORBVBSPC(NOOEXCA,IOOEXC,E1,C, 7726C & VEC1_CSF,VEC2_CSF) 7727COLD CALL VB_GRAD_ORBVBSPC(NOOEXC_A,IOOEXC_A,BR,C,VEC2,VEC3) 7728* 7729 IF(NTEST.GE.100) THEN 7730 WRITE(6,*) ' The Brilloin vector as delivered by VEC_BR_FRO..' 7731 WRITE(6,*) ' =================================================' 7732 CALL WRTMAT(BR,NOOEXC_A+NOOEXC_S,1,NOOEXC_A+NOOEXC_S,1) 7733 END IF 7734* 7735 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'VBBRKA') 7736 RETURN 7737 END 7738 SUBROUTINE CSDTVC_CONFSPACE(NCONF,VCSF,VSD,ISYM,ISPC,IWAY) 7739* 7740* Transform a CI vector between CSF and SD form for configuration 7741* expansion using on-flight generation of info 7742* 7743*. Jeppe Olsen, Kristiansand, June 11, 2013 7744* 7745 INCLUDE 'implicit.inc' 7746 INCLUDE 'mxpdim.inc' 7747 INCLUDE 'wrkspc-static.inc' 7748 INCLUDE 'glbbas.inc' 7749 INCLUDE 'spinfo.inc' 7750* 7751 PARAMETER (LSCR = 1000) 7752*. Input / output 7753 DIMENSION VCSF(*), VSD(*) 7754* 7755*. Local scratch - is not general pt.... 7756* 7757 DIMENSION IOCC(LSCR), ISIGN(LSCR), ISCR(LSCR) 7758* 7759 NTEST = 100 7760* 7761 WRITE(6,*) ' CSDTVC_CONFSPACE, Preliminary version ' 7762 IF(NTEST.GE.100) THEN 7763 WRITE(6,*) ' Output from CSDTVC_CONFSPACE ' 7764 WRITE(6,*) ' ============================ ' 7765 WRITE(6,*) 7766 WRITE(6,*) ' Space and sym: ', ISPC, ISYM 7767 WRITE(6,*) ' IWAY = ', IWAY 7768 END IF 7769* 7770 INI = 1 7771 IB_CSF = 1 7772 IB_SD = 1 7773* 7774 DO ICONF = 1, NCONF 7775C NEXT_CONF_IN_CONFSPC(IOCC,IOPEN,INUM_OP,INI,ISYM,ISPC,NEW) 7776 CALL NEXT_CONF_IN_CONFSPC(IOCC,IOPEN,INUM_OP,INI,ISYM,ISPC,NEW) 7777 INI = 0 7778 IOCOB = (IOPEN + N_EL_CONF)/2 7779*. Signs for going between configuration and interaction order of dets 7780C SIGN_CONF_SD(ICONF,NOB_CONF,IOP,ISGN,IPDET_LIST,ISCR) 7781 CALL SIGN_CONF_SD(IOCC,IOCOB,IOPEN,ISIGN,WORK(KDFTP),ISCR) 7782 NCSF = NPCSCNF(IOPEN+1) 7783 NSD = NPDTCNF(IOPEN+1) 7784C CSDTVC_CONF(C_SD,C_CSF,NOPEN,ISIGN,IAC,IWAY) 7785 CALL CSDTVC_CONF(VSD(IB_SD),VCSF(IB_CSF),IOPEN,ISIGN,2,IWAY) 7786 IB_CSF = IB_CSF + NCSF 7787 IB_SD = IB_SD + NSD 7788 END DO 7789* 7790 IF(NTEST.GE.100) THEN 7791 WRITE(6,*) ' Output from CSDTVC_CONFSPACE:' 7792 NCSFT = IB_CSF-1 7793 NSDT = IB_SD - 1 7794 WRITE(6,*) ' CSF expansion: ' 7795 CALL WRTMAT(VCSF,1,NCSFT,1,NCSFT) 7796 WRITE(6,*) ' SD expansion ' 7797 CALL WRTMAT(VSD,1,NSDT,1,NSDT) 7798 END IF 7799* 7800 RETURN 7801 END 7802 7803c $Id$ 7804