1************************************************************************ 2 subroutine lucia_gtbce(irefspace,itrefspc,maxit_gtbce) 3************************************************************************ 4* 5* Master routine for Generalized Two-Body operator Cluster Expansion, 6* i.e. CC expansions which allow excitations of rank +2,+1,0,-1,-2 7* 8************************************************************************ 9c include 'implicit.inc' 10c include 'mxpdim.inc' 11 include 'wrkspc.inc' 12 include 'crun.inc' 13 include 'cstate.inc' 14 include 'cgas.inc' 15 include 'ctcc.inc' 16 include 'gasstr.inc' 17 include 'strinp.inc' 18 include 'orbinp.inc' 19 include 'cprnt.inc' 20 include 'corbex.inc' 21 include 'csm.inc' 22 include 'clunit.inc' 23 include 'glbbas.inc' 24 include 'cands.inc' 25 include 'cecore.inc' 26 include 'cc_exc.inc' 27 include 'cicisp.inc' 28 include 'cintfo.inc' 29 include 'gtbce.inc' 30 include 'lucinp.inc' 31 include 'csmprd.inc' 32 include 'multd2h.inc' 33 include 'frorbs.inc' 34 35************************************************************************ 36 integer*8 n_ci_det 37 character*8 cctype 38 dimension icascr(mxpngas) 39 dimension ioccun(100) 40 dimension ioff(8) 41************************************************************************ 42 43 ntest = 5 44 i_spin_adapt = 0 45 i_do_newccv=0 46 icc_exc = 0 47 irefspc = irefspace 48 49c now defined via lucia.f or input: 50c expg_thrsh = 1d-20 51c mxterm_expg = 200 52 53 if (ntest.ge.5) then 54 write(6,'(/,2(x,a,/),2(x,a,i3,/),x,a,3i2,/x,a,5i2)') 55 & 'Generalized Two-Body operator Cluster Expansion at work', 56 & '=======================================================', 57 & ' reference space = ', irefspc, 58 & ' space defining operators = ', itrefspc, 59 & ' SING = ', inc_sing(1:3), 60 & ' DOUB = ', inc_doub(1:5) 61 if (i_mode_gtbce.eq.0) then 62 write(6,'(2x,a,/,2x,a,i6)') 63 & 'Trying to solve the Nakasuji-equations', 64 & 'max. iterations = ',maxit_gtbce 65 else if (i_mode_gtbce.eq.1) then 66 write(6,'(2x,a,/,2x,a,i6)') 67 & 'Trying to minimize the E-expectation value directly', 68 & 'max. iterations = ',maxit_gtbce 69 else 70 write(6,'(2x,a,i3)') 71 & 'Beeing a bit surprised by i_mode_gtbce = ', i_mode_gtbce 72 end if 73 if (igtbmod.eq.0) write(6,*) '*** exp(G) expansion ***' 74 if (igtbmod.eq.1) write(6,*) '*** exp(G^2) expansion ***' 75 if (igtbmod.eq.2) write(6,*) 76 & '*** exp(G) expansion with G=LL ***' 77 if (igtbmod.eq.3) write(6,*) 78 & '*** exp(G) expansion with G=U Omega U ***' 79 end if 80 81 82* currently hard wired specifications: 83 ionly_excop = 0 84 i_ign_ovl = 1 85c icexc_rank_min = -4 ! allow rank -2 to +2 (multipl. by 2) 86c inc_sing = (/0, 0, 0/) 87c inc_doub = (/1, 1, 1, 1, 1/) 88 ! Hermitian or unitary operators requested? - 89 if (igtbcs.eq.-1.or.igtbcs.eq.+1) then 90 ! --> then generate only operators with positive rank 91 inc_sing(3) = 0 92 inc_doub(4:5) = 0 93 end if 94 mn_crea = 1 95 mn_anni = 1 96 97* set mark in memory manager 98 call memman(idum,idum,'MARK ',idum,'GTBCE ') 99* expand reference wave-function to FCI space 100 isym = IREFSM 101 icopy = 1 102 lblk = -1 103 104 call expciv(isym,irefspc,luc, 105 & itrefspc,lusc1,lblk, 106 & lusc2,nroot,icopy,idc,ntest) 107 108 ! regenerate Fock matrix 109 call copvec(work(kint1o),work(kint1),nint1) 110 icc_exc = 0 111 i_use_simtrh = 0 112 call fi(work(kint1),eccx,1) 113 ecore = ecore_ini 114 115* define C and Sigma space for mv7 and sigden_cc 116 icsm = irefsm ! the symmetry of the reference ... 117 issm = irefsm ! ... is also the symmetry of the wavefunction 118 icspc = itrefspc 119 isspc = itrefspc 120 121 call cc_ac_spaces(irefspc,ireftyp) 122 nael = nelec(1) 123 nbel = nelec(1) 124 125 iadd_uni = 0 126 127 call gen_ic_orbop2(1,nobex_tp,idummy, 128 & inc_sing,inc_doub, 129 & ionly_excop,i_ign_ovl, 130 & irefspc,itrefspc,iadd_uni) 131*. and the orbital excitations 132 call memman(kobex_tp,2*ngas*nobex_tp,'ADDL ',2,'GTBOBX') 133 klobex = kobex_tp 134 call gen_ic_orbop2(2,nobex_tp,work(kobex_tp), 135 & inc_sing,inc_doub, 136 & ionly_excop,i_ign_ovl, 137 & irefspc,itrefspc,iadd_uni) 138 nobex_tpe = nobex_tp+1 139* 140 if(i_spin_adapt.eq.1) then 141* 142*. excitation operators will be spin adapted 143* 144 do jobex_tp = 1, nobex_tp 145 write(6,*) ' constructing ca confs for jobex_tp = ', jobex_tp 146*. integer arrays for creation and annihilation part 147 call icopve2(work(kobex_tp),1+(jobex_tp-1)*2*ngas,2*ngas, 148 & icascr) 149 nop_c = ielsum(icascr,ngas) 150 nop_a = ielsum(icascr(1+ngas),ngas) 151 nop_ca = nop_c + nop_a 152 call get_ca_conf_for_orbex(icascr,icascr(1+ngas), 153 & ncoc_fsm(1,jobex_tp),naoc_fsm(1,jobex_tp), 154 & ibcoc_fsm(1,jobex_tp),ibaoc_fsm(1,jobex_tp), 155 & kcoc(jobex_tp),kaoc(jobex_tp), 156 & kzc(jobex_tp),kza(jobex_tp), 157 & kcreo(jobex_tp),kareo(jobex_tp)) 158 write(6,*) ' ncoc_fsm and naoc_fsm after get_ca ... ' 159 call iwrtma(ncoc_fsm,1,nsmst,1,nsmst) 160 call iwrtma(naoc_fsm,1,nsmst,1,nsmst) 161 162*. offsets in ca block for given symmetry of creation occ 163c ioff_symblk_mat(nsmst,na,nb,itotsm,ioff,irestrict 164 call ioff_symblk_mat(nsmst,ncoc_fsm(1,jobex_tp), 165 & naoc_fsm(1,jobex_tp),1,ibcaoc_fsm(1,jobex_tp),0) 166c ndim_1el_mat(ihsm,nrpsm,ncpsm,nsm,ipack) 167 ncaoc(jobex_tp) = ndim_1el_mat(1,ncoc_fsm(1,jobex_tp), 168 & naoc_fsm(1,jobex_tp),nsmst,0) 169*. and the actual configurations 170 call memman(kcaoc(jobex_tp),nop_ca*ncaoc(jobex_tp),'ADDL ', 171 & 2,'CA_OC ') 172c get_conf_for_orbex(ncoc_fsm,naoc_fsm,icoc,iaoc, 173c & nop_c,nop_a, ibcoc_fsm,ibaoc_fsm,nsmst,iopsm, 174c & icaoc) 175 call get_conf_for_orbex( 176 & ncoc_fsm(1,jobex_tp),naoc_fsm(1,jobex_tp), 177 & work(kcoc(jobex_tp)),work(kaoc(jobex_tp)), 178 & nop_c, nop_a, 179 & ibcoc_fsm(1,jobex_tp),ibaoc_fsm(1,jobex_tp), 180 & nsmst,1,work(kcaoc(jobex_tp)) ) 181 end do 182 end if ! i_spin_adapt 183*. number of creation and annihilation operators per op 184 call memman(klcobex_tp,nobex_tpe,'ADDL ',1,'COBEX ') 185 call memman(klaobex_tp,nobex_tpe,'ADDL ',1,'AOBEX ') 186 call get_nca_for_orbop(nobex_tp,work(kobex_tp), 187 & work(klcobex_tp),work(klaobex_tp),ngas) 188*. number of spinorbital excitations 189 izero = 0 190 mxspox = 0 191 iact_spc = 0 192 iaaexc_typ = 3 193 irefspcx = 0 194 call obex_to_spobex2(1,work(kobex_tp),work(klcobex_tp), 195 & work(klaobex_tp),nobex_tp,idummy,nspobex_tp,ngas, 196 & nobpt,0,izero ,iaaexc_typ,iact_spc,iprcc,idummy, 197 & mxspox,work(knsox_for_ox), 198 & work(kibsox_for_ox),work(kisox_for_ox),nael,nbel,irefspcx, 199 & mn_crea,mn_anni) 200 nspobex_tpe = nspobex_tp + 1 201*. and the actual spinorbital excitations 202 call memman(klsobex,4*ngas*nspobex_tpe,'ADDL ',1,'SPOBEX') 203*. map spin-orbital exc type => orbital exc type 204 call memman(klsox_to_ox,nspobex_tpe,'ADDL ',1,'SPOBEX') 205*. first sox of given ox ( including zero operator ) 206 call memman(kibsox_for_ox,nobex_tpe,'ADDL ',1,'IBSOXF') 207*. number of sox's for given ox 208 call memman(knsox_for_ox,nobex_tpe,'ADDL ',1,'IBSOXF') 209*. sox for given ox 210 call memman(kisox_for_ox,nspobex_tpe,'ADDL ',1,'IBSOXF') 211* 212 call obex_to_spobex2(2,work(kobex_tp),work(klcobex_tp), 213 & work(klaobex_tp),nobex_tp,work(klsobex),nspobex_tp,ngas, 214 & nobpt,0,mscomb_cc,iaaexc_typ,iact_spc,iprcc, 215 & work(klsox_to_ox),mxspox,work(knsox_for_ox), 216 & work(kibsox_for_ox),work(kisox_for_ox),nael,nbel,irefspcx, 217 & mn_crea,mn_anni) 218* 219* 220 write(6,*) 'Generated excitations:' 221 write(6,*) '======================' 222 call wrt_spox_tp(work(klsobex),nspobex_tp) 223 224* 225* dimension and offsets of ic operators 226* 227 call memman(kllsobex,nspobex_tpe,'ADDL ',1,'LSPOBX') 228 call memman(klibsobex,nspobex_tpe,'ADDL ',1,'LSPOBX') 229 call memman(klspobex_ac,nspobex_tpe,'ADDL ',1,'SPOBAC') 230*. all spinorbital excitations are initially active 231 ione = 1 232 call isetvc(work(klspobex_ac),ione,nspobex_tpe) 233* 234 itop_sm = 1 235 write(6,*) ' irefspc before idim.. ', irefspc 236 call idim_tcc(work(klsobex),nspobex_tp,itop_sm, 237 & mx_st_tsoso,mx_st_tsoso_blk,mx_tblk, 238 & work(kllsobex),work(klibsobex),len_t_vec, 239 & mscomb_cc,mx_tblk_as, 240 & work(kisox_for_occls),noccls,work(kibsox_for_occls), 241 & ntconf,iprcc) 242 243 ! set up nfrobs 244 call set_frobs(nfrob,nfrobs) 245 ntaobs(1:nsmob) = ntoobs(1:nsmob)-nfrobs(1:nsmob) 246 ntaob = ntoob-nfrob 247 248 n_cc_amp = len_t_vec 249 n_ci_det = xispsm(1,itrefspc) 250 n_ci_csf = ncsf_for_cispace(itrefspc,irefsm) 251 252 i12loc = 1 253 i34loc = 1 254 i1234loc = 1 255 256 imode = 0 257 call pnt4dm2(nh2elm_p11,imode, 258 & nsmob,nsmsx,mxpobs,ntaobs,ntaobs,ntaobs,ntaobs, 259 & itsdx,adsxa,sxdxsx,i12loc,i34loc,i1234loc, 260 & idum,idum,adasx) 261 262 i12loc = 1 263 i34loc = 1 264 i1234loc = -1 265 266 imode = 0 267 call pnt4dm2(nh2elm_m11,imode, 268 & nsmob,nsmsx,mxpobs,ntaobs,ntaobs,ntaobs,ntaobs, 269 & itsdx,adsxa,sxdxsx,i12loc,i34loc,i1234loc, 270 & idum,idum,adasx) 271 272 i12loc = -1 273 i34loc = -1 274 i1234loc = 1 275 276 imode = 0 277 call pnt4dm2(nh2elm_p33,imode, 278 & nsmob,nsmsx,mxpobs,ntaobs,ntaobs,ntaobs,ntaobs, 279 & itsdx,adsxa,sxdxsx,i12loc,i34loc,i1234loc, 280 & idum,idum,adasx) 281 282 i12loc = -1 283 i34loc = -1 284 i1234loc = -1 285 286 imode = 0 287 call pnt4dm2(nh2elm_m33,imode, 288 & nsmob,nsmsx,mxpobs,ntaobs,ntaobs,ntaobs,ntaobs, 289 & itsdx,adsxa,sxdxsx,i12loc,i34loc,i1234loc, 290 & idum,idum,adasx) 291 292c call num_ssaa2op(nndiag,ndiag) 293 294 write(6,*) 295 & '======================================================' 296 write(6,'(x,a,i20)') 297 & ' number of amplitudes: ', 298 & n_cc_amp 299 write(6,'(x,a,2(/,x,a,2i20))') 300 & ' number of indep. two-body parameters', 301 & ' eff H (non-diagonal/diagonal): ', 302 & nh2elm_m11,nh2elm_p11-nh2elm_m11, 303 & ' G (non-diagonal/diagonal): ', 304 & nh2elm_m11+nh2elm_m33,nh2elm_p11+nh2elm_p33 305 & -nh2elm_m11-nh2elm_m33 306 write(6,'(x,a,/,x,a,i20)') 307 & ' number of determinants/combinations ', 308 & ' in the underlying CI-Space: ', 309 & n_ci_det 310 write(6,'(x,a,/,x,a,i20)') 311 & ' number of CSFs ', 312 & ' in the underlying CI-Space: ', 313 & n_ci_csf 314 write(6,*) 315 & '======================================================' 316 317 if (nh2elm_m11+nh2elm_m33.gt.n_ci_csf) then 318 write(6,*) 319 & ' Well, the number of non-linear parameters is larger than the' 320 write(6,*) 321 & ' the number of CI-paramters! This appears rather silly to me!' 322 do ii = 1, 30 323 write(6,*) ' ???????????? silly calculation ????????????' 324 end do 325 end if 326 327 write(6,*) ' dimension of the various types ' 328 call iwrtma(work(kllsobex),1,nspobex_tp,1,nspobex_tp) 329 write(6,*) ' offsets of the various types ' 330 call iwrtma(work(klibsobex),1,nspobex_tp,1,nspobex_tp) 331* 332 mx_st_tsoso_mx = mx_st_tsoso 333 mx_st_tsoso_blk_mx = mx_st_tsoso_blk 334 mx_tblk_mx = mx_tblk 335 mx_tblk_as_mx = mx_tblk_as 336 len_t_vec_mx = len_t_vec 337*. some more scratch etc 338*. alpha- and beta-excitations constituting the spinorbital excitations 339*. number 340 341 call spobex_to_abobex(work(klsobex),nspobex_tp,ngas, 342 & 1,naobex_tp,nbobex_tp,idummy,idummy) 343*. and the alpha-and beta-excitations 344 lena = 2*ngas*naobex_tp 345 lenb = 2*ngas*nbobex_tp 346 call memman(klaobex,lena,'ADDL ',2,'IAOBEX') 347 call memman(klbobex,lenb,'ADDL ',2,'IAOBEX') 348 call spobex_to_abobex(work(klsobex),nspobex_tp,ngas, 349 & 0,naobex_tp,nbobex_tp,work(klaobex),work(klbobex)) 350*. max dimensions of ccop !kstr> = !istr> maps 351*. for alpha excitations 352 iatp = 1 353 ioctpa = ibspgpftp(iatp) 354 noctpa = nspgpftp(iatp) 355 call len_genop_str_map( 356 & naobex_tp,work(klaobex),noctpa,nelfspgp(1,ioctpa), 357 & nobpt,ngas,maxlena) 358 ibtp = 2 359 ioctpb = ibspgpftp(ibtp) 360 noctpb = nspgpftp(ibtp) 361 call len_genop_str_map( 362 & nbobex_tp,work(klbobex),noctpb,nelfspgp(1,ioctpb), 363 & nobpt,ngas,maxlenb) 364 maxlen_i1 = max(maxlena,maxlenb) 365 if(ntest.ge.5) write(6,*) ' maxlen_i1 = ', maxlen_i1 366 367c get work space: 368c get dimensions for FCI (wow) behind the curtains 369 call get_3blks_gcc(kvec1,kvec2,kvec3,mxcj) 370 kc2=kvec3 371 write(6,*) 'max block length from get_3blks: ', mxcj 372*. and two CC vectors 373c n_sd_int = 1 374 lenny = n_cc_amp ! + n_sd_int 375 call memman(kcc1,lenny,'ADDL ',2,'CC1_VE') 376 call memman(kcc2,lenny,'ADDL ',2,'CC2_VE') 377* 378 if (igtbcs.eq.1.or.igtbcs.eq.-1.or.isymmet_G.ne.0) 379 & call memman(kcc3,lenny,'ADDL ',2,'CC3_VE') 380 if (isymmet_G.ne.0) 381 & call memman(kiccvec,lenny,'ADDL ',1,'ICCVEC') 382*. and the cc diagonal 383 if (igtbmod.eq.2.or.igtbmod.eq.3) lenny = max(lenny,(2*ntoob)**2) 384 call memman(kdia,lenny,'ADDL ',2,'CC_DIA') 385 386 if (igtbmod.lt.2) then 387 imod = 1 ! Fock-matrix based on rho1 388 call gencc_f_diag_m(imod,work(klsobex),nspobex_tp,work(kdia),1, 389 & xdum,idum,idum,0, 390 & work(kvec1),work(kvec2),mx_st_tsoso_mx, 391 & mx_st_tsoso_blk_mx) 392c the approximate Hessian is two times the diagonal! 393 call scalve(work(kdia),2d0,n_cc_amp) 394 ! well, at the moment I do not know better than removing 395 ! all negative and small stuff: 396 if (isymmet_G.ne.0) then 397 do ii = 1, n_cc_amp 398 work((kdia-1)+ii) = abs(work((kdia-1)+ii)) 399 end do 400 end if 401 xmin = 100d0 402 do ii = 1, n_cc_amp 403 xmin = min(xmin,work((kdia-1)+ii)) 404 end do 405 write(6,*) 'diagonal: lowest element = ',xmin 406 xsh = max(0d0,0.01d0-xmin) 407 write(6,*) 'shift diagonal by ',xsh 408 do ii = 1, n_cc_amp 409 work((kdia-1)+ii) = work((kdia-1)+ii) + xsh 410 end do 411 412 if (igtb_closed.eq.0) then 413 call vec_to_disc(work(kdia),n_cc_amp,1,lblk,ludia) 414 else 415 416 call memman(kpamp, 2*nsmob**3,'ADDL ',1,'PSMTR ') 417 call memman(kpamp2,2*nsmob**3,'ADDL ',1,'PSMTR2') 418 419 call setup4idx(isymmet_G,n11amp,n33amp, 420 & work(kpamp),work(kpamp2),ntaobs) 421 422 namp_packed = n11amp + n33amp 423 424c TESTING 425c work(kcc3:kcc3-1+namp_packed) = 0d0 426c idx = 0 427cc do isymq = 1, nsmob 428cc do isymp = 1, isymq 429cc isymrs = multd2h(isymp,isumq) 430cc do isymr = 1, nsmob 431cc isyms = multd2h(isymr,isymrs) 432c 433c do idxs = nfrob+1, ntoob 434c do idxr = nfrob+1, ntoob 435c do idxq = nfrob+1, ntoob 436c do idxp = nfrob+1, ntoob 437cc idxsr = (idxs-1)*ntoob + idxr 438cc if (idxpq.ge.idxrs) cycle 439cc if (idxpq.gt.idxsr) cycle 440c iadr = i2addr2( idxp,idxq,idxr,idxs, 441c & work(kpamp),1,1,-1) 442c if (iadr.eq.-2) cycle 443c idx = idx+1 444c 445c print *,'-----------------------------------------' 446c print '(a,i5,a,4i5)', 447c & ' INDEX: ',idx,' ',idxp,idxq,idxr,idxs 448c print *,'SINGLET-SINGLET' 449c iadr = i2addr2( idxp,idxq,idxr,idxs, 450c & work(kpamp),1,1,-1) 451c print '(4i5,a,i5,x,"S")', 452c & idxp,idxq,idxr,idxs,' --> ',iadr 453c if (iadr.lt.1.or.iadr.gt.n11amp) then 454c print *,'EVIL RANGE ERROR: ',1,iadr,namp_packed 455c else 456c if (work(kcc3-1+iadr).eq.0d0) then 457c work(kcc3-1+iadr) = dble(idx) 458c else 459c print *,'EIEIEI, wer hat auf meinem Plaetzchen'// 460c & ' gesessen?', 461c & work(kcc3-1+iadr) 462c end if 463c end if 464c 465c print *,'TRIPLET-TRIPLET' 466c iadr = i2addr2( idxp,idxq,idxr,idxs, 467c & work(kpamp+nsmob**3),-1,-1,-1) 468c print '(4i5,a,i5,x,"T")', 469c & idxp,idxq,idxr,idxs,' --> ',iadr 470c if (iadr.lt.1.or.iadr.gt.n33amp) then 471c print *,'EVIL RANGE ERROR: ',1,iadr,namp_packed 472c else 473c iadr = iadr+n11amp 474c if (work(kcc3-1+iadr).eq.0d0) then 475c work(kcc3-1+iadr) = dble(idx) 476c else 477c print *,'EIEIEI, wer hat auf meinem Plaetzchen'// 478c & ' gesessen?', 479c & work(kcc3-1+iadr) 480c end if 481c end if 482c 483cc if (idxp.ne.idxq) then 484cc print *,'+ INDEX: ',idx 485cc idx = idx+1 486cc iadr3 = i2addr2( idxp,idxq,idxs,idxr, 487cc & work(kpamp),1,0,-1) 488cc print '(4i5,a,i5)',idxp,idxq,idxs,idxr,' --> ',iadr3 489cc if (iadr3.lt.1.or.iadr3.gt.namp_packed) 490cc & print *,'RANGE ERROR: ',1,iadr3,namp_packed 491cc end if 492c 493cc iadr1 = i2addr2( idxr,idxs,idxp,idxq, 494cc & work(kpamp),1,0,-1) 495cc print '(4i5,a,i5)',idxr,idxs,idxp,idxq,' --> ',iadr1 496cc if (iadr1.ne.iadr) 497cc & print *,'SYM. ERROR' 498cc 499cc iadr2 = i2addr2( idxq,idxp,idxr,idxs, 500cc & work(kpamp),1,0,-1) 501cc print '(4i5,a,i5)',idxq,idxp,idxr,idxs,' --> ',iadr2 502cc if (iadr2.lt.1.or.iadr2.gt.namp_packed) 503cc & print *,'RANGE ERROR: ',1,iadr2,namp_packed 504cc 505cc iadr4 = i2addr2( idxq,idxp,idxs,idxr, 506cc & work(kpamp),1,0,-1) 507cc print '(4i5,a,i5)',idxq,idxp,idxs,idxr,' --> ',iadr4 508cc if (iadr4.ne.iadr) 509cc & print *,'SYM. ERROR' 510cc 511c end do 512c end do 513c end do 514c end do 515c 516cc end do 517cc end do 518cc end do 519c print *,'-----------------------------------------' 520c 521cc call wrtmat(work(kcc3),namp_packed,1,namp_packed,1) 522c do ii = 1, namp_packed 523c if (work(kcc3-1+ii).eq.0d0) then 524c print *,ii,work(kcc3-1+ii),' <--' 525c else 526c print *,ii,work(kcc3-1+ii) 527c end if 528c end do 529c 530c stop 'testing' 531c TESTING 532 533 534 iway = 1 ! pack (no symmetrizing, would result in 0d0's) 535 idual = 3 536 call pack_g(iway,idual,isymmet_G,work(kcc1),work(kdia), 537 & nspobex_tp,work(klsobex),work(klibsobex),n11amp,n33amp, 538 & work(kpamp),n_cc_amp) 539 call vec_to_disc(work(kcc1),namp_packed,1,lblk,ludia) 540 end if 541 542 if (ntest.gt.100) then 543 write(6,*) 'the preconditioner: ' 544 cctype='GEN_CC' 545 call wrt_cc_vec2(work(kdia),6,cctype) 546 end if 547 548 else if (igtmode.eq.2) then 549c some init for G=LL 550 551 idx = 0 552 do ism = 1, nsmob 553 ioff(ism) = idx 554 idx = idx + (ntoobs(ism)+1)*ntoobs(ism)/2 555 end do 556 557 do ii = 1, ntoob 558 do jj = 1, ntoob 559 ism = ismfto(ii) 560 jsm = ismfto(jj) 561 idx = ireots(ii) - ibso(ism) + 1 562 jdx = ireots(jj) - ibso(jsm) + 1 563 564 iidx = ioff(ism) + (idx+1)*idx/2 565 jjdx = ioff(jsm) + (jdx+1)*jdx/2 566 567 work(kdia-1+(ii-1)*ntoob+jj) = 568 & work(kfiz-1+iidx)-work(kfiz-1+jjdx) 569 570 print *,ii,jj,'->',work(kfiz-1+iidx),work(kfiz-1+jjdx) 571 572 end do 573 end do 574 575 do ii = 1, ntoob**2 576 work(kdia-1+ii) = max(.1d0,work(kdia-1+ii)) 577 end do 578 call vec_to_disc(work(kdia),ntoob**2,1,lblk,ludia) 579 else if (igtbmod.eq.3) then 580 581 ! get memory for G= U Om U variant 582 nlen = ntoob**2*4 583 call memman(komvec,nlen,'ADDL ',2,'OMVEC ') 584 call memman(kurvec,nlen,'ADDL ',2,'URVEC ') 585 call memman(kuivec,nlen,'ADDL ',2,'UIVEC ') 586 call memman(komgrd,nlen,'ADDL ',2,'OMGRD ') 587 call memman(kurgrd,nlen,'ADDL ',2,'URGRD ') 588 call memman(kuigrd,nlen,'ADDL ',2,'UIGRD ') 589 590 end if 591 592 i_test_fock = 0 593 594 if (i_test_fock.ne.1) then 595 596 call gtbce_opt(maxit_gtbce,irefspc,itrefspc, 597 & work(kcc1),work(kcc2),work(kdia),work(kcc3), 598 & work(kvec1),work(kvec2),work(kc2), 599 & nspobex_tp,work(klsobex), 600 & work(kllsobex),work(klibsobex), 601 & igtbcs,mxcj, 602 & n11amp,n33amp,work(kpamp), 603 & work(komvec),work(kurvec),work(kuivec), 604 & work(komgrd),work(kurgrd),work(kuigrd), 605 & work(kiccvec), 606 & luc,lu_ccamp,lu_ccvecf,ludia, 607 & lusc3,luhc) 608 609 else 610 611 call gucc_fock(irefspc,itrefspc, 612 & work(kcc1),work(kcc2),work(kdia),work(kcc3), 613 & work(kvec1),work(kvec2),work(kc2), 614 & nspobex_tp,work(klsobex), 615 & work(kllsobex),work(klibsobex), 616 & igtbcs,mxcj, 617 & luc,lu_ccamp,lu_ccvecf,ludia, 618 & lusc3,luhc) 619 620 end if 621 622c TESTING: copy exp(G)|ref> to |ref> 623 call copvcd(lusc3,luc,work(kvec1),1,lblk) 624 625 call memman(idum,idum,'FLUSM ',idum,'GTBCE ') 626 627 return 628 629 end 630************************************************************************ 631 subroutine setup4idx(isymmet_G,n11amp,n33amp, 632 & ioff_amp,isy_amp,ntaobs) 633* little slave routine to address parts of work(kpamp), 634* the curse of using self-made allocation 635* routines .... 636 637 include 'implicit.inc' 638 include 'mxpdim.inc' 639 include 'lucinp.inc' 640 include 'csm.inc' 641 include 'csmprd.inc' 642 643 dimension ioff_amp(nsmob*nsmob*nsmob,2) 644 dimension isy_amp(nsmob*nsmob*nsmob,2) 645 dimension ntaobs(*) 646 647 ! singlet-singlet amplitudes 648 i12loc = 1 649 i34loc = 1 650 i1234loc = isymmet_G ! antisymmetry between 12 and 34 651 652 imode = 1 653 call pnt4dm2(n11amp,imode, 654 & nsmob,nsmsx,mxpobs,ntaobs,ntaobs,ntaobs,ntaobs, 655 & itsdx,adsxa,sxdxsx,i12loc,i34loc,i1234loc, 656 & ioff_amp(1,1),isy_amp(1,1),adasx) 657 658 ! triplet-triplet amplitudes 659 i12loc = -1 660 i34loc = -1 661 i1234loc = isymmet_G ! antisymmetry between 12 and 34 662 663 imode = 1 664 call pnt4dm2(n33amp,imode, 665 & nsmob,nsmsx,mxpobs,ntaobs,ntaobs,ntaobs,ntaobs, 666 & itsdx,adsxa,sxdxsx,i12loc,i34loc,i1234loc, 667 & ioff_amp(1,2),isy_amp(1,2),adasx) 668 669 return 670 end 671************************************************************************ 672* DECK: gtbce_opt 673************************************************************************ 674 subroutine gtbce_opt(maxiter,irefspc,itrefspc, 675 & ccvec1,ccvec2,ccvec3,ccvec4, 676 & civec1,civec2,c2vec, 677 & n_cc_typ,i_cc_typ, 678 & namp_cc_typ,ioff_cc_typ, 679 & iopsym,mxb_ci, 680 & n11amp,n33amp,iamp_packed, 681 & omvec,urvec,uivec, 682 & omgrd,urgrd,uigrd, 683 & iccvec, 684 & luc,luamp,luomg,ludia, 685 & luec,luhc) 686************************************************************************ 687* 688* purpose : driver for the optimization of the Generalize TwoBody 689* operator Cluster Expansion wavefunction (if it works at all) 690* 691* ak, early 2004 692* 693************************************************************************ 694* 695* units: 696* luc = definition of reference function 697* luamp = amplitude vectors (also output for most recent vector) 698* luampold = scratch containing old vectors from previous iterations 699* (on input it may also be a first trial vector) 700* luomg = error vectors 701* ludia = diagonal preconditioner 702* luec = scratch for exp(G)|ref> 703* luhc = scratch for H exp(G)|ref> 704 705* diverse inludes with commons and paramters 706c include 'implicit.inc' 707c include 'mxpdim.inc' 708 include 'wrkspc.inc' 709 include 'crun.inc' 710 include 'cstate.inc' 711 include 'cgas.inc' 712 include 'ctcc.inc' 713 include 'gasstr.inc' 714 include 'strinp.inc' 715 include 'orbinp.inc' 716 include 'lucinp.inc' 717 include 'cprnt.inc' 718 include 'corbex.inc' 719 include 'csm.inc' 720 include 'cecore.inc' 721 include 'gtbce.inc' 722 include 'opti.inc' 723 include 'glbbas.inc' 724 include 'cintfo.inc' 725* constants 726 integer, parameter :: 727 & ntest = 5 728 729* arrays 730 integer :: 731 & ioff_cc_typ(n_cc_typ), namp_cc_typ(n_cc_typ), 732 & i_cc_typ(4*ngas,n_cc_typ), iccvec(n_cc_amp) 733 real*8 :: 734 & ccvec1(n_cc_amp), ccvec2(n_cc_amp), ccvec3(n_cc_amp), 735 & omvec(ntoob,ntoob,2,2),urvec(ntoob,ntoob,2,2), 736 & uivec(ntoob,ntoob,2,2), 737 & omgrd(ntoob,ntoob,2,2),urgrd(ntoob,ntoob,2,2), 738 & uigrd(ntoob,ntoob,2,2) 739* local 740 logical :: 741 & calc_Omg, calc_gradE, tstgrad, tst_hss, comm_ops, 742 & do_eag, do_foo, do_hss, do_rdvec, did_rdvec, do_h0 743 character*8 cctype 744 integer :: 745 & ictp(n_cc_typ) 746* external functions 747 real*8, external :: inprod, inprdd 748 749* ============================================================ 750* initialize : restart, set coefs to zero 751* ============================================================ 752 753 call atim(cpu0,wall0) 754 755 nprint = 1 756 lblk = -1 757 758 if (ntest.ge.5) then 759 write(6,*) '=======================' 760 write(6,*) 'entered gtbce_opt with:' 761 write(6,*) '=======================' 762 write(6,*) ' iopsym = ',iopsym 763 end if 764 765 calc_gradE = .true. 766 calc_Omg = .true. 767 768* unit init 769 lusc1 = iopen_nus('GTBSCR1') 770 lusc2 = iopen_nus('GTBSCR2') 771 lusc3 = iopen_nus('GTBSCR3') 772 lusc4 = iopen_nus('GTBSCR4') 773 lusc5 = iopen_nus('GTBSCR5') 774 lusc6 = iopen_nus('GTBSCR6') 775 lusc7 = iopen_nus('GTBSCR7') 776 lusc8 = iopen_nus('GTBSCR8') 777 lusc9 = iopen_nus('GTBSCR9') 778 779 luhss = iopen_nus('GTBHESS') 780 luh0 = iopen_nus('GTBH0') 781 lufoo = iopen_nus('GTBFOO') 782 783 lutrvec = iopen_nus('GTBTRVC') 784 lusig = iopen_nus('GTBSIG') 785 786 lurdvec = iopen_nus('GTBRDVEC') 787 788 ! our functional is variational: 789 ivar = 1 790 if (igtbfusk.gt.50) then 791c preliminary: set common opti 792 iorder = 1 793 iprecnd = 1 794 isubsp = 1 795 ilsrch = 2 796 icnjgrd = 1 797 mxsp_sbspja = 10 798 isbspjatyp = 1 799 isbspja_start = 2 ! lowest possible iteration! 800 thr_sbspja = 1d-1 801 mxsp_diis = 10 802 idiistyp = 2 803 idiis_start = 0 804 thr_diis = 1d-1 805 trini = 0.140d0 806 trmin = 0.025d0 807 trmax = 0.5d0 808 trthr1l = 0.8d0 809 trthr1u = 1.2d0 810 trthrfac1 = 1.2d0 811 trthr2l = 0.4d0 812 trthr2u = 1.6d0 813 trfac1 = 1.2d0 814 trfac2 = 0.8d0 815 trfac3 = 0.3d0 816 thrstp = 1d-5 817 thrgrd = 1d-5 818 thr_de = 1d-8 819 end if 820 maxmacit = maxiter 821 micifac = 20 822 maxmicit = maxmacit*micifac 823* 824 if (igtbmod.eq.2) then 825 len = ntoob*ntoob ! very simple, to be adapted for frozen orbitals 826 n_l_amp = len 827c if ((len*len+1)/2.gt.n_cc_amp) then 828c write(6,*) ' ',(len+1)*len/2,' <---> ',n_cc_amp 829c write(6,*) 'input not appropriate for this test!' 830c stop 'ihtest' 831c end if 832 call memman(khvec1,len,'ADDL ',2,'HTEST1 ') 833 call memman(khvec2,len,'ADDL ',2,'HTEST2 ') 834 do ii = 1, 30 835 write(6,*) ' !!!!!!!!!!! G = LL test active !!!!!!!!!!!' 836 end do 837 end if 838 839* 840* set initial G 841* 842 if (igtbmod.eq.0) then 843 844c imode = -1 845c for the moment better: 846 imode = 1 847 luinp = luamp 848 849 nwfpar = n_cc_amp 850 if (igtb_closed.eq.1) then 851 imode = 1 852 namp_packed = n11amp + n33amp 853 nwfpar = namp_packed 854 end if 855 856 call gtbce_initG(ccvec1, 857 & imode,luinp, 858 & ccvec2, 859 & ngas,igsoccx(1,1,itrefspc), 860 & ihpvgas,nwfpar,i_cc_typ,n_cc_typ, 861 & namp_cc_typ,ioff_cc_typ) 862 863 if (igtb_disptt.eq.1) then 864 write(6,*) ' ACCORDING TO YOUR WISHES I DISPOSE THE '// 865 & 'ANTISYMMETRIC PART OF G !!!' 866 ccvec1(n11amp+1:n11amp+n33amp) = 0d0 867 end if 868 869 870 ! not necessary for igtb_closed.eq.1 871 if (isymmet_G.ne.0 872! & .and.igtb_closed.eq.0 873 & ) then 874 call conj_t_pairs(ictp,ierr, 875 & i_cc_typ,n_cc_typ,ngas) 876 if (ierr.ne.0) then 877 write(6,*) 878 & 'The definition of the G operator is not compatible '// 879 & 'with the symmetrizing option!' 880 stop 'symmetrizing problem' 881 end if 882 if (igtb_closed.eq.0) then 883 call symmet_t(isymmet_G,1, 884 & ccvec1,ccvec2, 885 & ictp,i_cc_typ,n_cc_typ, 886 & namp_cc_typ,ioff_cc_typ,ngas) 887 end if 888 end if 889 890c ! project out redundant components: 891c call prjout_red(ccvec1,ccvec2,nspobex_tp,work(klsobex), 892c & work(klibsobex)) 893 894 call vec_to_disc(ccvec1,nwfpar,1,lblk,luamp) 895 896 else if (igtbmod.eq.1) then 897 imode = -1 898 luinp = luamp 899 ! well, at the moment there are problems, so ... 900 imode = 0 901 902 call gtbce_initG(ccvec1, 903 & imode,luinp, 904 & ccvec2, 905 & ngas,igsoccx(1,1,itrefspc), 906 & ihpvgas,n_cc_amp,i_cc_typ,n_cc_typ, 907 & namp_cc_typ,ioff_cc_typ) 908 909 if (igtbfusk.ge.5) then 910 call memman(kcan,2*ntoob**2,'ADDS ',2,'OPCAN ') 911* fusk init of operator in canonical symmetry blocked form: 912 913c work(kcan:kcan+2*ntoob**2-1) = 0.0d0 914 915c for testing the gradient 916c do ii = 1, ntoob**2 917c work(kcan:kcan+2*ntoob**2-1) = 1.d0/(dble(ii)+4d0) 918c end do 919 920c some info on occ/virt orbital per symmetry would be nice here: 921 922cc ! init for CH2 923 ioff = 0 924 do ism = 1, nsmst 925 if (ism.eq.1) then 926 do ii = 2,3 927 do jj = 4,7 928 idx = ioff+(ii-1)*ntoobs(ism)+jj 929 work(kcan+idx-1) = 0.2d0 930c idx = ioff+(jj-1)*ntoobs(ism)+ii 931c work(kcan+idx-1) = -0.05d0 932 end do 933 end do 934 end if 935 if (ism.eq.2) then 936 do ii = 1, 1 937 do jj = 2,4 938 idx = ioff+(ii-1)*ntoobs(ism)+jj 939 work(kcan+idx-1) = 0.2d0 940c idx = ioff+(jj-1)*ntoobs(ism)+ii 941c work(kcan+idx-1) = -0.025d0 942 end do 943 end do 944 end if 945 ioff = ioff + ntoobs(ism)*ntoobs(ism) 946 end do 947 948c a routine to get from the usual (I called it "canonical") symmetry blocked 949c form to LUCIA's string ordering; just for convenience ... 950 call can2str(1,work(kcan),ccvec1, 951 & nspobex_tp,i_cc_typ,ioff_cc_typ) 952 953 call vec_to_disc(ccvec1,n_cc_amp,1,lblk,luamp) 954 955 end if 956 957 call vec_to_disc(ccvec1,n_cc_amp,1,lblk,luamp) 958 959 960 else if (igtbmod.eq.2) then 961 if (igtbfusk.ge.10) then 962 ! just something but different for each element (for testing purps) 963 do ii = 1, n_l_amp 964 work(khvec1+ii-1) = 1d0/(dble(ii)+4d0) ! 0d0 965 end do 966 else 967 ! hm, everything set to a small value: 968 do ii = 1, n_l_amp 969 work(khvec1+ii-1) = 0.01d0 970 end do 971 end if 972 973c ! init for CH2 974c do ii = 2, 4 975c do jj = 5, 8 976c work(khvec1+(ii-1)*ntoob+jj) = 0.05d0 977c work(khvec1+(jj-1)*ntoob+ii) = 0.05d0 978c end do 979c end do 980 981 call vec_to_disc(work(khvec1),n_l_amp,1,lblk,luamp) 982c testing 983c call l2g(work(khvec1),ccvec1,nspobex_tp,work(klsobex),0,ntoob) 984c call wrt_cc_vec2(ccvec1,6,'GEN_CC') 985c stop 'brute force' 986c testing 987 else if (igtbmod.eq.3) then 988 989 nlen = ntoob**2*4 990 991 ! we need three files: 992 luom = iopen_nus('OMEGA_VEC') 993 luur = iopen_nus('UREAL_VEC') 994 luui = iopen_nus('UIMAG_VEC') 995 996 luomgr = iopen_nus('OMEGA_GRD') 997 luurgr = iopen_nus('UREAL_GRD') 998 luuigr = iopen_nus('UIMAG_GRD') 999 1000 ! find out how to set up the preconditioner::: 1001 call memman(idum,idum,'MARK ',idum,'LOCAL ') 1002c call memman(kfdia,nacob,'ADDL ',2,'KFDIA ') 1003c CALL GT1DIS(WORK(KFDIA),IREOTS,WORK(KPINT1), 1004c & WORK(KFI),ISMFTO,IBSO,NACOB) 1005c 1006c ! Ur with diagonal 1d0 1007c do imp = 1,2 1008c do imq = 1,2 1009c do ip = 1, ntoob 1010c do iq = 1, ntoob 1011c urvec(iq,ip,imq,imp) = 1012c & abs(2d0*( work(kfdia + ip) - work(kfdia + iq))) 1013c if (urvec(iq,ip,imq,imp).lt.1d-3) 1014c & urvec(iq,ip,imq,imp) = 10d0 1015c end do 1016c end do 1017c end do 1018c end do 1019c 1020 ! well no, take only 1d0 1021 urvec(1:ntoob,1:ntoob,1:2,1:2) = 1d0 1022 1023 call memman(idum,idum,'FLUSM ',idum,'LOCAL ') 1024 1025 call vec_to_disc(urvec,nlen,1,-1,luom) 1026 call vec_to_disc(urvec,nlen,1,-1,luur) 1027 call vec_to_disc(urvec,nlen,1,-1,luui) 1028 1029 imode = 11 1030 call cmbamp(imode,luom,luur,luui,ludia, 1031 & omvec,nlen,nlen,nlen) 1032 1033 ! try to restart, if file luamp is present 1034 write(6,*) ' testing unit ',luamp 1035 rewind(luamp,err=100) 1036 read(luamp,err=100,end=100) namp_read 1037 if (namp_read.eq.nlen) then 1038 imode = 01 1039 call cmbamp(imode,luom,luur,luui,luamp, 1040 & omvec,nlen,nlen,nlen) 1041 write(6,*) '=================' 1042 write(6,*) ' RESTART SUCCESS' 1043 write(6,*) '=================' 1044 goto 200 1045 end if 1046 1047 100 continue 1048 ! else: we init 1049 1050 ! Omega with zero 1051 omvec(1:ntoob,1:ntoob,1:2,1:2) = 0.d0 1052c do im = 1,2 1053c do ii = 1, ntoob 1054c omvec(ii,ii,im,im) = 1d0 1055c end do 1056c end do 1057 1058 ! Ur and Ui with diagonal 1d0 1059c urvec(1:ntoob,1:ntoob,1,1) = 1d-3 1060c urvec(1:ntoob,1:ntoob,1,2) = 0d0 1061c urvec(1:ntoob,1:ntoob,2,1) = 0d0 1062c urvec(1:ntoob,1:ntoob,2,2) = 1d-3 1063c test 1064 fac = 1d0/sqrt(dble(ntoob)) 1065 1066 urvec(1:ntoob,1:ntoob,1:2,1:2) = 0d0 1067 do im = 1,2 1068 do ii = 1, ntoob 1069c fusk for 1 frozen orbital: 1070 if (ii.eq.1) then 1071 urvec(ii,ii,im,im) = fac 1072 else 1073 do jj = ii,ntoob 1074 urvec(jj,ii,im,im) = fac 1075 end do 1076 end if 1077 end do 1078 end do 1079 1080c do im = 1,2 1081c do ii = 1, ntoob 1082c urvec(ii,ii,im,im) = 1d0/sqrt(2d0) 1083c end do 1084c end do 1085 1086c uivec(1:ntoob,1:ntoob,1,1) = -1d-3 1087c uivec(1:ntoob,1:ntoob,1,2) = 0d0 1088c uivec(1:ntoob,1:ntoob,2,1) = 0d0 1089c uivec(1:ntoob,1:ntoob,2,2) = -1d-3 1090 1091 uivec(1:ntoob,1:ntoob,1:2,1:2) = 0d0 1092 do im = 1,2 1093 do ii = 1, ntoob 1094c fusk for 1 frozen orbital: 1095 if (ii.gt.1) then 1096 do jj = 1, ii-1 1097 uivec(jj,ii,im,im) = -fac 1098 end do 1099 end if 1100 uivec(ii,ii,im,im) = fac 1101 end do 1102 end do 1103c do im = 1,2 1104c do ii = 1, ntoob 1105c uivec(ii,ii,im,im) = 1d0/sqrt(2d0) 1106c end do 1107c end do 1108 1109c fusk 1110c ihom = 2 1111c ilum = 3 1112c urvec(ihom,ihom,1,1) = 1d0/2d0 1113c urvec(ihom,ilum,1,1) = 1d0/sqrt(2d0) 1114c urvec(ilum,ihom,1,1) = 0d0 1115c urvec(ilum,ilum,1,1)= 1d0/2d0 1116c urvec(ihom,ihom,2,2) = 1d0/2d0 1117c urvec(ihom,ilum,2,2) = 1d0/sqrt(2d0) 1118c urvec(ilum,ihom,2,2) = 0d0 1119c urvec(ilum,ilum,2,2)= 1d0/2d0 1120c 1121c uivec(ihom,ihom,1,1) = 1d0/2d0 1122c uivec(ihom,ilum,1,1) = 0d0 1123c uivec(ilum,ihom,1,1) = -1d0/sqrt(2d0) 1124c uivec(ilum,ilum,1,1)= 1d0/2d0 1125c uivec(ihom,ihom,2,2) = 1d0/2d0 1126c uivec(ihom,ilum,2,2) = 0d0 1127c uivec(ilum,ihom,2,2) = -1d0/sqrt(2d0) 1128c uivec(ilum,ilum,2,2)= 1d0/2d0 1129 1130c urvec(3,3,1,1) = 1d0/2d0 1131c urvec(3,6,1,1) = 1d0/sqrt(2d0) 1132c urvec(6,3,1,1) = 0d0 1133c urvec(6,6,1,1)= 1d0/2d0 1134c urvec(3,3,2,2) = 1d0/2d0 1135c urvec(3,6,2,2) = 1d0/sqrt(2d0) 1136c urvec(6,3,2,2) = 0d0 1137c urvec(6,6,2,2)= 1d0/2d0 1138c 1139c uivec(3,3,1,1) = 1d0/2d0 1140c uivec(3,6,1,1) = 0d0 1141c uivec(6,3,1,1) = -1d0/sqrt(2d0) 1142c uivec(6,6,1,1)= 1d0/2d0 1143c uivec(3,3,2,2) = 1d0/2d0 1144c uivec(3,6,2,2) = 0d0 1145c uivec(6,3,2,2) = -1d0/sqrt(2d0) 1146c uivec(6,6,2,2)= 1d0/2d0 1147 1148c do im = 1,2 1149c do ii = 1, ntoob 1150c do jj = 1, ntoob 1151c urvec(ii,jj,im,im) = 0.1d0 * 1152c & sqrt(abs((ii-1.5d0*jj)/(ii+1.5d0*jj))) 1153c end do 1154c end do 1155c end do 1156c do im = 1,2 1157c do ii = 1, ntoob 1158c do jj = 1, ntoob 1159c uivec(ii,jj,im,im) = 0.1d0*(ii-2d0*jj)/(ii+2d0*jj) 1160c end do 1161c end do 1162c end do 1163 1164 call vec_to_disc(omvec,nlen,1,-1,luom) 1165 call vec_to_disc(urvec,nlen,1,-1,luur) 1166 call vec_to_disc(uivec,nlen,1,-1,luui) 1167 1168 ! 1169 imode = 11 1170 call cmbamp(imode,luom,luur,luui,luamp, 1171 & omvec,nlen,nlen,nlen) 1172 1173 200 continue 1174 1175 end if 1176 1177 ! Header for iteration info 1178 if (calc_Omg.and.calc_gradE) then 1179 write (6,'(">>>",2a/,">>>",2a)') 1180 & ' iter energy variance norm(G) ', 1181 & ' norm(dE/dG) norm(Omega)', 1182 & '--------------------------------------------------', 1183 & '--------------------------' 1184 else if (calc_Omg) then 1185 write (6,'(">>>",2a/,">>>",2a)') 1186 & ' iter energy variance norm(G) ', 1187 & ' norm(Omega)', 1188 & '--------------------------------------------------', 1189 & '--------------' 1190 else if (calc_gradE) then 1191 write (6,'(">>>",2a/,">>>",2a)') 1192 & ' iter energy variance norm(G) ', 1193 & ' norm(dE/dG)', 1194 & '--------------------------------------------------', 1195 & '--------------' 1196 end if 1197 1198 xngrad = 1000 1199 xnomg = 1000 1200 itask = 0 1201 imacit = 0 1202 imicit = 0 1203 imicit_tot = 0 1204 energy = 0d0 1205 itask = 0 1206 nrdvec = 0 1207 did_rdvec = .false. 1208 do while (itask.lt.8) 1209 1210 call atim(cpu0i,wall0i) 1211 1212 call memchk2('b optc') 1213 1214 if (igtbmod.ne.2) then 1215 ! usual route: 1216 nwfpar = n_cc_amp 1217 if (igtb_closed.eq.1) nwfpar = namp_packed 1218 call optcont(imacit,imicit,imicit_tot,iprint, 1219 & itask,iconv, 1220 & luamp,lutrvec, 1221 & energy, 1222 & ccvec1,ccvec2,nwfpar, 1223 & luomg,lusig,ludia, 1224 & nrdvec,lurdvec) 1225 else 1226 call optcont(imacit,imicit,imicit_tot,iprint, 1227 & itask,iconv, 1228 & luamp,lutrvec, 1229 & energy, 1230 & work(khvec1),work(khvec2),n_l_amp, 1231 & luomg,lusig,ludia, 1232 & 0,lurdvec) 1233 end if 1234 call memchk2('a optc') 1235 1236 if (igtbmod.lt.2) then 1237 ! the usual route: 1238 if (igtb_closed.eq.0) then 1239 call vec_from_disc(ccvec1,n_cc_amp,1,lblk,luamp) 1240 xnamp = sqrt(inprod(ccvec1,ccvec1,n_cc_amp)) 1241 else if (igtb_closed.eq.1) then 1242 ! expand to full spin-orbital basis, if necessary 1243 call vec_from_disc(ccvec2,namp_packed,1,lblk,luamp) 1244 xnamp = sqrt(inprod(ccvec2,ccvec2,namp_packed)) 1245 iway = -1 ! unpack 1246 idual = 3 1247 call pack_g(iway,idual,isymmet_G,ccvec2,ccvec1, 1248 & n_cc_typ,i_cc_typ,ioff_cc_typ, 1249 & n11amp,n33amp,iamp_packed,n_cc_amp) 1250 else 1251 write(6,*) 'igtb_closed has strange value' 1252 stop 'gtbce' 1253 end if 1254 1255 1256 if (isymmet_G.ne.0) then 1257 write(6,*) 'checking new T:' 1258c call vec_from_disc(ccvec1,n_cc_amp,1,lblk,luamp) 1259 call chksym_t(isymmet_G,1, 1260 & ccvec1,ccvec2, 1261 & ictp,i_cc_typ,n_cc_typ, 1262 & namp_cc_typ,ioff_cc_typ,ngas) 1263 end if 1264 1265 1266 if (ntest.ge.1000) then 1267 write(6,*) 'The new operator:' 1268 call wrt_cc_vec2(ccvec1,6,'GEN_CC') 1269 end if 1270 1271 else if (igtbmod.eq.2) then 1272 call vec_from_disc(work(khvec1),n_cc_amp,1,lblk,luamp) 1273 xnamp = sqrt(inprod(work(khvec1),work(khvec1),n_l_amp)) 1274 ! the '0' actually means, that we have so far identical 1275 ! alpha and beta parts for L 1276 call l2g(work(khvec1),ccvec1,nspobex_tp, 1277 & work(klsobex),work(klibsobex), 1278 & 0 ,ntoob) 1279 else if (igtbmod.eq.3) then 1280 imode=01 1281 call cmbamp(imode,luom,luur,luui,luamp, 1282 & omvec,nlen,nlen,nlen) 1283 call vec_from_disc(omvec,nlen,1,-1,luom) 1284 call vec_from_disc(urvec,nlen,1,-1,luur) 1285 call vec_from_disc(uivec,nlen,1,-1,luui) 1286 1287 call uou2g(omvec,urvec,uivec,ccvec1, 1288 & nspobex_tp, 1289 & work(klsobex),work(klibsobex),ntoob) 1290 1291 write(6,*) 1292 & '==============================================' 1293 write(6,*) 'calling chksym_t for the new variant:' 1294 1295c call chksym_t(isymmet_G,1, 1296c & ccvec1,ccvec2, 1297c & ictp,i_cc_typ,n_cc_typ, 1298c & namp_cc_typ,ioff_cc_typ,ngas) 1299 1300 write(6,*) 1301 & '==============================================' 1302 1303 1304 end if 1305 if (isymmet_G.ne.0) then 1306 call chksym_t(isymmet_G,1, 1307 & ccvec1,ccvec2, 1308 & ictp,i_cc_typ,n_cc_typ, 1309 & namp_cc_typ,ioff_cc_typ,ngas) 1310 end if 1311 1312 1313 if (iand(itask,1).eq.1) then 1314* calculate energy ... 1315 call gtbce_E(igtbmod,elen,variance,ovl, 1316 & ecore, 1317 & ccvec1,iopsym,ccvec4, 1318 & civec1,civec2,c2vec, 1319 & n_cc_amp,mxb_ci, 1320 & luc,luec,luhc,lusc1,lusc2) 1321 end if 1322 1323 if (iand(itask,2).eq.2) then 1324 if (calc_Omg) then 1325* ... and vector function (Nakasuji CSE residual) ... 1326 call gtbce_Omg(ccvec2,xnomg, 1327 & elen,ovl,iopsym, 1328 & civec1,civec2,c2vec, 1329 & n_cc_amp,mxb_ci, 1330 & luec,luhc,lusc1,lusc2) 1331 end if 1332 1333 ! we currently overwrite Omega if gradient is calculated 1334 ! ... I know, the usage of files to pass vectors would be 1335 ! more appropriate, but for the moment it is as it is 1336 if (calc_gradE) then 1337 inumint=1 1338 igrdmod=1 1339 npts=5 1340 call gtbce_gradE( 1341 & isymmet_G,ccvec2,xngrad,igrdmod, 1342 & inumint,npts, 1343 & elen,ovl, 1344 & ccvec1,iopsym,ccvec3,ccvec4, 1345 & civec1,civec2,c2vec, 1346 & n_cc_typ,i_cc_typ,ictp, 1347 & namp_cc_typ,ioff_cc_typ, 1348 & n_cc_amp,mxb_ci,nprint, 1349 & luamp,luc,luec,luhc, 1350 & lusc1,lusc2,lusc3,lusc4,lusc5,lusc6) 1351 if (igtbmod.eq.2) then 1352 ! transform into L-gradient 1353 call ggrad2lgrad(ccvec2,work(khvec2),work(khvec1), 1354 & nspobex_tp,work(klsobex),0,ntoob) 1355 xngrad = sqrt(inprod(work(khvec2),work(khvec2),n_l_amp)) 1356 else if (igtbmod.eq.3) then 1357 ! transform into Om-gradient 1358 call ggrad2omgrad(ccvec2,omgrd,omvec,urvec,uivec, 1359 & nspobex_tp,work(klsobex),ntoob) 1360 ! transform into Ur-gradient 1361 irmod = 1 1362 call ggrad2ugrad(ccvec2,urgrd,omvec,urvec,uivec, 1363 & nspobex_tp,work(klsobex),ntoob,irmod) 1364 ! transform into Ui-gradient 1365 irmod = 2 1366 call ggrad2ugrad(ccvec2,uigrd,omvec,uivec,urvec, 1367 & nspobex_tp,work(klsobex),ntoob,irmod) 1368 1369 xnom = sqrt(inprod(omgrd,omgrd,4*ntoob**2)) 1370 xnur = sqrt(inprod(urgrd,urgrd,4*ntoob**2)) 1371 xnui = sqrt(inprod(uigrd,uigrd,4*ntoob**2)) 1372 1373 write (6,'(">>>",i6," |grd|: ",3(2x,e10.4))') 1374 & imacit,xnom,xnur,xnui 1375 xnom = sqrt(inprod(omvec,omvec,4*ntoob**2)) 1376 xnur = sqrt(inprod(urvec,urvec,4*ntoob**2)) 1377 xnui = sqrt(inprod(uivec,uivec,4*ntoob**2)) 1378 1379 write (6,'(">>>",i6," |vec|: ",3(2x,e10.4))') 1380 & imacit,xnom,xnur,xnui 1381 1382 if (mod(imacit,10).eq.0.or. 1383 & imacit.eq.1.or. 1384 & imacit.eq.maxmacit) then 1385 write(6,*) 'Information on vectors in iteration ',imacit 1386 write(6,*) 'Omega:' 1387 do ii = 1,2 1388 do jj = 1,2 1389 xnrm = sqrt(inprod(omvec(1,1,jj,ii), 1390 & omvec(1,1,jj,ii),ntoob**2)) 1391 write(6,*)'spin case ',ii,jj,xnrm 1392 call wrtmat2(omvec(1,1,jj,ii),ntoob,ntoob, 1393 & ntoob,ntoob) 1394 end do 1395 end do 1396 write(6,*) 'U(Re):' 1397 do ii = 1,2 1398 xnrm = sqrt(inprod(urvec(1,1,ii,ii), 1399 & urvec(1,1,ii,ii),ntoob**2)) 1400 write(6,*)'spin case ',ii,ii,xnrm 1401 call wrtmat2(urvec(1,1,ii,ii),ntoob,ntoob, 1402 & ntoob,ntoob) 1403 end do 1404 write(6,*) 'U(Im):' 1405 do ii = 1,2 1406 xnrm = sqrt(inprod(uivec(1,1,ii,ii), 1407 & uivec(1,1,ii,ii),ntoob**2)) 1408 write(6,*)'spin case ',ii,ii,xnrm 1409 call wrtmat2(uivec(1,1,ii,ii),ntoob,ntoob, 1410 & ntoob,ntoob) 1411 end do 1412 1413 write(6,*) 'dE/dOmega:' 1414 do ii = 1,2 1415 do jj = 1,2 1416 xnrm = sqrt(inprod(omgrd(1,1,jj,ii), 1417 & omgrd(1,1,jj,ii),ntoob**2)) 1418 write(6,*)'spin case ',ii,jj,xnrm 1419 call wrtmat2(omgrd(1,1,jj,ii),ntoob,ntoob, 1420 & ntoob,ntoob) 1421 end do 1422 end do 1423 write(6,*) 'dE/dU(Re):' 1424 do ii = 1,2 1425 xnrm = sqrt(inprod(urgrd(1,1,ii,ii), 1426 & urgrd(1,1,ii,ii),ntoob**2)) 1427 write(6,*)'spin case ',ii,ii,xnrm 1428 call wrtmat2(urgrd(1,1,ii,ii),ntoob,ntoob, 1429 & ntoob,ntoob) 1430 end do 1431 write(6,*) 'dE/dU(Im):' 1432 do ii = 1,2 1433 xnrm = sqrt(inprod(uigrd(1,1,ii,ii), 1434 & uigrd(1,1,ii,ii),ntoob**2)) 1435 write(6,*)'spin case ',ii,ii,xnrm 1436 call wrtmat2(uigrd(1,1,ii,ii),ntoob,ntoob, 1437 & ntoob,ntoob) 1438 end do 1439 1440 end if 1441 1442 end if 1443 1444 end if ! calc_gradE 1445 1446 1447 ! save gradient/omega 1448c call vec_to_disc(ccvec1,n_cc_amp,1,lblk,luamp) 1449 if (igtbmod.lt.2) then 1450 ! the usual route: 1451 if (igtb_closed.eq.0) then 1452 call vec_to_disc(ccvec2,n_cc_amp,1,lblk,luomg) 1453 else 1454 iway = 2 ! pack and symmetrize 1455 idual = 3 1456 call pack_g(iway,idual,isymmet_G,ccvec1,ccvec2, 1457 & n_cc_typ,i_cc_typ,ioff_cc_typ, 1458 & n11amp,n33amp,iamp_packed,n_cc_amp) 1459 1460 if (igtb_disptt.eq.1) then 1461 write(6,*) ' ACCORDING TO YOUR WISHES I DISPOSE THE '// 1462 & 'ANTISYMMETRIC PART OF dE/dG !!!' 1463 ccvec1(n11amp+1:n11amp+n33amp) = 0d0 1464 end if 1465 xngrad = sqrt(inprod(ccvec1,ccvec1,namp_packed)) 1466 call vec_to_disc(ccvec1,namp_packed,1,lblk,luomg) 1467 end if 1468 else if (igtbmod.eq.2) then 1469 call vec_to_disc(work(khvec2),n_l_amp,1,lblk,luomg) 1470 else if (igtbmod.eq.3) then 1471 call vec_to_disc(omgrd,nlen,1,-1,luomgr) 1472 call vec_to_disc(urgrd,nlen,1,-1,luurgr) 1473 call vec_to_disc(uigrd,nlen,1,-1,luuigr) 1474 imode = 11 1475 call cmbamp(imode,luomgr,luurgr,luuigr,luomg, 1476 & omvec,nlen,nlen,nlen) 1477 1478 end if 1479 1480c test and analysis routines follow: 1481 if (calc_gradE) then 1482 tstgrad = .false. !imacit.eq.3 1483 if (tstgrad.and.igtbmod.lt.2) then 1484 if (igtb_close.eq.0) then 1485 call copvec(ccvec2,ccvec3,n_cc_amp) 1486 else 1487 call copvec(ccvec1,ccvec3,n_cc_amp) 1488 end if 1489 1490 ! vector is reloaded from luamp inside 1491 call gtbce_testgradE(igtbmod, 1492 & isymmet_G,igtb_closed, 1493 & ccvec3,ccvec2,xngrad, 1494 & ecore, 1495 & ccvec1,iopsym,ccvec4, 1496 & civec1,civec2,c2vec, 1497 & n_cc_typ,i_cc_typ,namp_cc_typ,ioff_cc_typ, 1498 & n_cc_amp,mxb_ci, 1499 & n11amp,n33amp,iamp_packed,ictp, 1500 & luamp,luomg, 1501 & luc,luec,luhc, 1502 & lusc1,lusc2) 1503 stop 'stop after testgradE' 1504 else if (tstgrad.and.igtbmod.eq.2) then 1505 call gtbce_testgradE_L( 1506 & work(khvec2),work(khvec1), 1507 & ecore, 1508 & ccvec1,iopsym,ccvec4, 1509 & civec1,civec2,c2vec, 1510 & n_cc_amp,n_l_amp,mxb_ci, 1511 & luc,luec,luhc, 1512 & lusc1,lusc2) 1513 stop 'stop after testgradE_L' 1514 else if (tstgrad.and.igtbmod.eq.3.and.imacit.eq.5) then 1515 imode = 1 1516 write(6,*) 'calling test for Omega gradient' 1517 namp = 4*ntoob**2 1518 call gtbce_testgradE_UOU(imode, 1519 & omgrd,omvec,urvec,uivec, 1520 & elen,ecore, 1521 & ccvec1,iopsym,ccvec4, 1522 & civec1,civec2,c2vec, 1523 & n_cc_amp,namp,mxb_ci, 1524 & luc,luec,luhc, 1525 & lusc1,lusc2) 1526 imode = 2 1527 write(6,*) 'calling test for U(R) gradient' 1528 namp = 50 !4*ntoob**2 1529 call gtbce_testgradE_UOU(imode, 1530 & urgrd,omvec,urvec,uivec, 1531 & elen,ecore, 1532 & ccvec1,iopsym,ccvec4, 1533 & civec1,civec2,c2vec, 1534 & n_cc_amp,namp,mxb_ci, 1535 & luc,luec,luhc, 1536 & lusc1,lusc2) 1537 imode = 3 1538 write(6,*) 'calling test for U(I) gradient' 1539 namp = 50 !4*ntoob**2 1540 call gtbce_testgradE_UOU(imode, 1541 & uigrd,omvec,urvec,uivec, 1542 & elen,ecore, 1543 & ccvec1,iopsym,ccvec4, 1544 & civec1,civec2,c2vec, 1545 & n_cc_amp,namp,mxb_ci, 1546 & luc,luec,luhc, 1547 & lusc1,lusc2) 1548 stop 'stop after testgradE_L' 1549 end if 1550 end if ! calc_gradE (analysis mode) 1551 1552 end if ! iand(itask,2) 1553 1554 if (iand(itask,4).eq.4) then 1555 imode=1 1556 iomg =1 1557 inumint=1 1558 npnts = 5 1559 call gtbce_num2drv(igtbmod,imode,iomg, 1560 & igtb_closed,isymmet_G, 1561 & inumint,npnts, 1562 & ecore, 1563 & iccvec,nSdim, 1564 & ccvec1,iopsym,ccvec2,ccvec3,ccvec4, 1565 & civec1,civec2,c2vec, 1566 & n_cc_typ,i_cc_typ,ictp, 1567 & namp_cc_typ,ioff_cc_typ, 1568 & n_cc_amp,mxb_ci, 1569 & n11amp,n33amp,iamp_packed, 1570 & lusig, 1571 & luamp,lutrvec,luc,luec,luhc, 1572 & lusc1,lusc2,lusc3,lusc4,lusc5,lusc6,lusc7) 1573 1574 end if 1575 1576 do_rdvec = .false. 1577 if (igtb_prjout.eq.1.and. 1578 & xnamp.gt.1d-6.and..not.did_rdvec 1579 & .and.imicit.eq.0) do_rdvec=.true. 1580 1581 if (do_rdvec) then 1582 did_rdvec = .true. 1583 if (igtbmod.ne.0) stop 'does not work' 1584 inumint=1 1585 npnts = 5 1586 comm_ops = .false. 1587c test 1588 irestart = 1 1589 if (irestart.ne.0) then 1590 iramp = irestart 1591 call mk_iccvec(isymmet_G,lufoo,iramp, 1592 & iccvec,nSdim,ccvec1,ccvec2, 1593 & n_cc_typ,i_cc_typ,ictp, 1594 & namp_cc_typ,ioff_cc_typ,ngas, 1595 & n_cc_amp) 1596 end if 1597 imode = 0 1598 call gtbce_h0(imode,igtb_closed,isymmet_G, 1599 & iccvec,nSdim, 1600 & ccvec1,ccvec2,ccvec3, 1601 & civec1,civec2,c2vec, 1602 & n_cc_amp,mxb_ci, 1603 & n_cc_typ,i_cc_typ,ioff_cc_typ, 1604 & n11amp,n33amp,iamp_packed, 1605 & lufoo,ludum, 1606 & luamp,luec,luhc, 1607 & lusc1,lusc2) 1608c if (iramp.lt.nsdim) then 1609c 1610c call gtbce_foo( isymmet_G,iramp, 1611c & inumint,npnts, 1612c & ovl, 1613c & iccvec,nSdim, 1614c & ccvec1,iopsym,comm_ops, 1615c & ccvec2,ccvec3, 1616c & civec1,civec2,c2vec, 1617c & n_cc_typ,i_cc_typ,ictp, 1618c & namp_cc_typ,ioff_cc_typ, 1619c & n_cc_amp,mxb_ci, 1620c & lufoo, 1621c & luamp,luc,luec,luhc, 1622c & lusc1,lusc2,lusc3,lusc4, 1623c & lusc5,lusc6,lusc7,lusc8, 1624c & lusc9,lusc10) 1625c end if 1626 call memman(idum,idum,'MARK ',2,'FOO MA') 1627 lenhss=nSdim*nSdim 1628 call memman(khss,lenhss,'ADDL ',2,'HSSIAN') 1629 istmode = 2 1630 call gtbce_getrdvec(isymmet_G,work(khss),lufoo,lurdvec,nrdvec, 1631 & nSdim,n_cc_amp,iccvec, 1632 & ccvec1,ccvec2) 1633 idum = 0 1634 call memman(idum,idum,'FLUSM ',2,'FOO MA') 1635 end if 1636 1637 if (nrdvec.gt.0.and.iand(itask,2).eq.2) then 1638 call gtbce_prjout_rdvec(nrdvec,lurdvec,luomg, 1639 & n_cc_amp,ccvec1,ccvec2) 1640 xngrad = sqrt(inprod(ccvec1,ccvec1,n_cc_amp)) 1641 if (isymmet_G.ne.0) then 1642 write(6,*) 'checking projected gradient:' 1643 call chksym_t(isymmet_G,1, 1644 & ccvec1,ccvec2, 1645 & ictp,i_cc_typ,n_cc_typ, 1646 & namp_cc_typ,ioff_cc_typ,ngas) 1647 end if 1648 1649 end if 1650 1651* minimal output 1652 energy = elen + ecore 1653 if (imicit.eq.0.and..not.iand(itask,8).eq.8) then 1654 if (calc_Omg.and.calc_gradE) then 1655 write (6,'(">>>",i6,f21.12,4(2x,e10.4))') 1656 & imacit,energy,variance,xnamp,xngrad,xnomg 1657 else if (calc_Omg) then 1658 write (6,'(">>>",i6,f21.12,3(2x,e10.4))') 1659 & imacit,energy,variance,xnamp,xnomg 1660 else if (calc_gradE) then 1661 write (6,'(">>>",i6,f21.12,3(2x,e10.4))') 1662 & imacit,energy,variance,xnamp,xngrad 1663 end if 1664 call flush(6) 1665 end if 1666 1667* analysis section: 1668 do_eag = .false. 1669 do_foo = .false. 1670 do_hss = .false. 1671 1672 if (imicit.eq.0) then 1673 do ii = 1, n_eag 1674 if (it_eag(ii).eq.imacit) do_eag = .true. 1675 end do 1676 1677 do ii = 1, n_foo 1678 if (it_foo(ii).eq.imacit) do_foo = .true. 1679 end do 1680 1681 do ii = 1, n_hss 1682 if (it_hss(ii).eq.imacit) do_hss = .true. 1683 end do 1684 end if 1685 1686c tst_hss = .false. 1687 if (do_eag) then 1688 if (igtbmod.ne.0) stop 'does not work' 1689 do ii = 1, nn_eag 1690 1691c reload amplitudes: 1692 if (igtb_closed.eq.0) then 1693 call vec_from_disc(ccvec1,n_cc_amp,1,-1,luamp) 1694 else 1695 call vec_from_disc(ccvec3,namp_packed,1,-1,luamp) 1696 iway = -1 1697 idual = 0 1698 call pack_g(iway,idual,isymmet_G,ccvec3,ccvec1, 1699 & n_cc_typ,i_cc_typ,ioff_cc_typ, 1700 & n11amp,n33amp,iamp_packed,n_cc_amp) 1701 end if 1702 1703 write(6,'("@p",a,i4)') 'printout for amplitude ', ng_eag(ii) 1704 if (igtb_closed.eq.0) then 1705 ccvec2(1:n_cc_amp) = 0d0 1706 ccvec2(ng_eag(ii)) = 1d0 1707 if (isymmet_G.ne.0) then 1708 stop 'adapt this section' 1709 end if 1710 else 1711 ccvec3(1:n11amp+n33amp) = 0d0 1712 if (ng_eag(ii).ge.-1) then 1713 if (ng_eag(ii).ge.1) then 1714 ccvec3(ng_eag(ii)) = 1d0 1715 else if(ng_eag(ii).eq.-1) then 1716 ccvec3(1:n11amp+n33amp) = 1d0 1717 end if 1718 iway = -1 1719 idual = 0 1720 call pack_g(iway,idual,isymmet_G,ccvec3,ccvec2, 1721 & n_cc_typ,i_cc_typ,ioff_cc_typ, 1722 & n11amp,n33amp,iamp_packed,n_cc_amp) 1723 else if (ng_eag(ii).eq.-2) then 1724 ccvec2(1:n_cc_amp) = ccvec1(1:n_cc_amp) 1725 else if (ng_eag(ii).eq.-3) then 1726 stop 'not impl.' 1727c no no no 1728c iramp = 0 1729c call mk_iccvec(isymmet_G,lufoo,iramp, 1730c & iccvec,nSdim,ccvec1,ccvec2, 1731c & n_cc_typ,i_cc_typ,ictp, 1732c & namp_cc_typ,ioff_cc_typ,ngas, 1733c & n_cc_amp) 1734c do iamp = 1, n_cc_amp 1735c if (iccvec(iamp).lt.1) then 1736c ccvec2(iamp) = -1d0 1737c else 1738c ccvec2(iamp) = 1d0 1739c end if 1740c end do 1741 1742 end if 1743 end if 1744 from_g = st_eag(ii) 1745 to_g = en_eag(ii) 1746 npnts = np_eag(ii) 1747 1748 call gtbce_EalongG(ccvec2,npnts,from_g,to_g, 1749 & ecore, 1750 & ccvec1,iopsym,ccvec3,ccvec4, 1751 & civec1,civec2,c2vec, 1752 & n_cc_amp,mxb_ci, 1753 & luc,luec,luhc,lusc1,lusc2) 1754 end do 1755 end if 1756 1757 if (do_foo) then 1758 if (igtbmod.ne.0) stop 'does not work' 1759 inumint=1 1760 npnts = 5 1761 comm_ops = .false. 1762c call gtbce_foo_old(inumint,npnts, 1763c & ovl, 1764c & ccvec1,iopsym,comm_ops, 1765c & ccvec2,ccvec3, 1766c & civec1,civec2,c2vec, 1767c & n_cc_amp,mxb_ci, 1768c & lufoo, 1769c & luamp,luc,luec,luhc, 1770c & lusc1,lusc2,lusc3,lusc4, 1771c & lusc5,lusc6,lusc7,lusc8) 1772c 1773c stop 'test foo' 1774 call gtbce_foo( isymmet_G,0, 1775 & inumint,npnts, 1776 & ovl, 1777 & iccvec,nSdim, 1778 & ccvec1,iopsym,comm_ops, 1779 & ccvec2,ccvec3, 1780 & civec1,civec2,c2vec, 1781 & n_cc_typ,i_cc_typ,ictp, 1782 & namp_cc_typ,ioff_cc_typ, 1783 & n_cc_amp,mxb_ci, 1784 & lufoo, 1785 & luamp,luc,luec,luhc, 1786 & lusc1,lusc2,lusc3,lusc4, 1787 & lusc5,lusc6,lusc7,lusc8, 1788 & lusc9,lusc10) 1789 call memman(idum,idum,'MARK ',2,'FOO MA') 1790 lenhss=nSdim*nSdim 1791 call memman(khss,lenhss,'ADDL ',2,'HSSIAN') 1792 istmode = 2 1793 call gtbce_anahss(work(khss),lufoo,ludum,istmode, 1794 & nSdim,n_cc_typ,i_cc_typ, 1795 & namp_cc_typ,ioff_cc_typ,iopsym) 1796 idum = 0 1797 call memman(idum,idum,'FLUSM ',2,'FOO MA') 1798 end if 1799 1800 do_h0 = 1801 & i_do_h0.ne.0.and.(xnamp.gt.1d-6) 1802 & .and.(imacit.eq.2.or.mod(imacit,30).eq.0) 1803 & .and.imicit.eq.0 1804 1805 if (do_h0) then 1806 if (isymmet_G.ne.0.and.igtb_closed.eq.0) then 1807 iramp = 0 1808 call mk_iccvec(isymmet_G,lufoo,iramp, 1809 & iccvec,nSdim,ccvec1,ccvec2, 1810 & n_cc_typ,i_cc_typ,ictp, 1811 & namp_cc_typ,ioff_cc_typ,ngas, 1812 & n_cc_amp) 1813 else if (igtb_closed.eq.1) then 1814 nSdim = namp_packed 1815 else 1816 nSdim = n_cc_amp 1817 end if 1818 1819 imode = 2 1820 call gtbce_h0(imode,igtb_closed,isymmet_G, 1821 & iccvec,nSdim, 1822 & ccvec1,ccvec2,ccvec3, 1823 & civec1,civec2,c2vec, 1824 & n_cc_amp,mxb_ci, 1825 & n_cc_typ,i_cc_typ,ioff_cc_typ, 1826 & n11amp,n33amp,iamp_packed, 1827 & luh0,ludia, 1828 & luamp,luec,luhc, 1829 & lusc1,lusc2) 1830 1831c idum = 0 1832c call memman(idum,idum,'MARK ',2,'HESSMA') 1833c lenhss=nSdim*nSdim 1834c call memman(khss,lenhss,'ADDL ',2,'HSSIAN') 1835c istmode = 3 1836c call gtbce_anahss(work(khss),luh0,ludia,istmode, 1837c & nSdim,n_cc_typ,i_cc_typ, 1838c & namp_cc_typ,ioff_cc_typ,iopsym) 1839c 1840c idum = 0 1841c call memman(idum,idum,'FLUSM ',2,'HESSMA') 1842c 1843 end if 1844 1845c call rewino(lufoo) 1846c call rewino(luhss) 1847c do ii = 1, n_cc_amp 1848c print *,'column ',ii 1849c call cmp2vcd(ccvec2,ccvec3,lufoo,luhss,1d-10,0,lblk) 1850c end do 1851 if (do_hss) then 1852 if (igtbmod.ne.0.and.igtbmod.ne.2) stop 'does not work' 1853 if (isymmet_G.ne.0.and.igtb_closed.eq.0) then 1854 iramp = 0 1855 call mk_iccvec(isymmet_G,lufoo,iramp, 1856 & iccvec,nSdim,ccvec1,ccvec2, 1857 & n_cc_typ,i_cc_typ,ictp, 1858 & namp_cc_typ,ioff_cc_typ,ngas, 1859 & n_cc_amp) 1860 else if (igtb_closed.eq.1) then 1861 nSdim = n11amp+n33amp 1862 else 1863 nSdim = n_cc_amp 1864 end if 1865 1866c test h0 1867c call gtbce_h0(isymmet_G, 1868c & iccvec,nSdim, 1869c & ccvec1,ccvec2, 1870c & civec1,civec2,c2vec, 1871c & n_cc_amp,mxb_ci, 1872c & luh0, 1873c & luamp,luec,luhc, 1874c & lusc1,lusc2) 1875c idum = 0 1876c call memman(idum,idum,'MARK ',2,'HESSMA') 1877c lenhss=nSdim*nSdim 1878c call memman(khss,lenhss,'ADDL ',2,'HSSIAN') 1879c istmode = 3 1880c call gtbce_anahss(work(khss),luh0,ludum,istmode, 1881c & nSdim,n_cc_typ,i_cc_typ, 1882c & namp_cc_typ,ioff_cc_typ,iopsym) 1883c 1884c idum = 0 1885c call memman(idum,idum,'FLUSM ',2,'HESSMA') 1886 1887 imode=2 1888 iomg =1 1889 inumint=1 1890 npnts = 5 1891 call gtbce_num2drv(igtbmod,imode,iomg, 1892 & igtb_closed,isymmet_G, 1893 & inumint,npnts, 1894 & ecore, 1895 & iccvec,nSdim, 1896 & ccvec1,iopsym,ccvec2,ccvec3,ccvec4, 1897 & civec1,civec2,c2vec, 1898 & n_cc_typ,i_cc_typ,ictp, 1899 & namp_cc_typ,ioff_cc_typ, 1900 & n_cc_amp,mxb_ci, 1901 & n11amp,n33amp,iamp_packed, 1902 & luhss, 1903 & luamp,luleq,luc,luec,luhc, 1904 & lusc1,lusc2,lusc3,lusc4,lusc5,lusc6,lusc7) 1905 1906 idum = 0 1907 call memman(idum,idum,'MARK ',2,'HESSMA') 1908 lenhss=nSdim*nSdim 1909 call memman(khss,lenhss,'ADDL ',2,'HSSIAN') 1910 istmode = 1 1911 call gtbce_anahss(work(khss),luhss,ludum,istmode, 1912 & nSdim,n_cc_typ,i_cc_typ, 1913 & namp_cc_typ,ioff_cc_typ,iopsym) 1914 1915 idum = 0 1916 call memman(idum,idum,'FLUSM ',2,'HESSMA') 1917 1918 1919 end if 1920 1921 call memchk2('afcalc') 1922 1923 call atim(cpui,walli) 1924 call prtim(6,'time for current iteration', 1925 & cpui-cpu0i,walli-wall0i) 1926 1927 end do ! optimization loop 1928 1929 call atim(cpu,wall) 1930 call prtim(6,'time in GTBCE optimization', 1931 & cpu-cpu0,wall-wall0) 1932 1933 1934 ! somewhat unmotivated here, actually just for looking at 1935 ! the amplitudes in another way: 1936 if (igtbmod.eq.1) then 1937 call can2str(2,work(kcan),ccvec1, 1938 & nspobex_tp,i_cc_typ,ioff_cc_typ) 1939 end if 1940 1941 write (6,*) ' ANALYSIS: ' 1942 if (igtb_closed.eq.0) then 1943 call vec_from_disc(ccvec1,n_cc_amp,1,-1,luamp) 1944 call ana_gencc(ccvec1,1) 1945 else 1946 write(6,*) ' ANALYSIS in spin-adapted basis: ' 1947 call vec_from_disc(ccvec2,namp_packed,1,-1,luamp) 1948 call ana_gucc(ccvec2,n11amp,n33amp,iamp_packed, 1949 & ireost,nsmob,ntoob) 1950 iway = -1 1951 idual = 3 1952 call pack_g(iway,idual,isymmet_G,ccvec2,ccvec1, 1953 & n_cc_typ,i_cc_typ,ioff_cc_typ, 1954 & n11amp,n33amp,iamp_packed,n_cc_amp) 1955 write(6,*) ' ANALYSIS in spin-orbital basis: ' 1956 call ana_gencc(ccvec1,1) 1957 end if 1958 1959 idum = 0 1960 call memman(idum,idum,'FLUSH ',idum,'GTBCOP') 1961 1962 return 1963 end 1964********************************************************************** 1965********************************************************************** 1966* DECK: gtbce_initG 1967********************************************************************** 1968 subroutine gtbce_initG(ccamp, 1969 & imode,luamp, 1970 & ccscr, 1971 & ngas_,iocc,ihpv,n_cc_amp,i_cc_typ,n_cc_typ, 1972 & namp_cc_typ,ioff_cc_typ) 1973********************************************************************** 1974* 1975* purpose: initialize G (depending on imode) with 1976* 1977* -1 : automatic 1978* 0 : zero 1979* 1 : a full previous G vector on luamp 1980* 2 : a singles and doubles vector on luamp 1981* 3 : a doubles vectors on luamp 1982* 1983* ak, early 2004 1984* 1985********************************************************************** 1986 include 'implicit.inc' 1987 include 'mxpdim.inc' 1988 include 'cc_exc.inc' 1989 include 'orbinp.inc' 1990 include 'cgas.inc' 1991 include 'csm.inc' 1992* input 1993 integer, intent(in) :: 1994 & ihpv(ngas), iocc(mxpngas,2), i_cc_typ(ngas,4,n_cc_typ), 1995 & ioff_cc_typ(n_cc_typ), namp_cc_typ(n_cc_typ) 1996* output 1997 real*8, intent(out) :: 1998 & ccamp(n_cc_amp), ccscr(n_cc_amp) 1999* constants 2000 integer, parameter :: 2001 & ntest = 00 2002* local scratch 2003 logical :: 2004 & dont, not_possible 2005 integer :: 2006 & ioff_sing(2), ilen_sing(2), ioff_doub(3), ilen_doub(3), 2007 & nph(nsmst,2) 2008 character*8 cctype 2009 2010 if (ntest.ge.5) then 2011 write(6,*) '===========' 2012 write(6,*) 'gtbce_initG' 2013 write(6,*) '===========' 2014 write(6,*) ' imode = ',imode 2015 write(6,*) ' luamp = ',luamp 2016 write(6,*) ' mscomb_cc = ',mscomb_cc 2017 end if 2018 2019 nsing = 2 2020 ndoub = 3 2021 if (mscomb_cc.ne.0) then 2022 nsing = 1 ! only alpha part 2023 ndoub = 2 ! only alpha and alpha/beta part 2024 end if 2025 2026 imode_ = imode 2027 ! test for existence of file 2028 if (imode.gt.0.or.imode.eq.-1) then 2029 rewind(luamp,err=100) 2030 read(luamp,err=100,end=100) namp_read 2031 if (namp_read.gt.0.and.namp_read.le.n_cc_amp) goto 200 2032 2033 100 write(6,*) 'no proper amplitudes found to restart from' 2034 imode_ = 0 2035 2036 200 continue 2037 2038 end if 2039 2040 2041 if (imode_.eq.2.or.imode_.eq.3.or.imode_.eq.-1) then 2042 ! get the D or SD vector 2043 lblk = -1 2044 call vec_from_disc(ccscr,n_cc_amp,1,lblk,luamp) 2045 ! find the matching blocks in G 2046 ! and hope that LUCIA keeps the ordering of the blocks 2047 ioff_sing(1:2) = 0 !(alpha / beta) 2048 ioff_doub(1:3) = 0 !(alpha-beta / alpha-alpha / beta-beta) 2049 not_possible = .true. 2050 do itp = 1, n_cc_typ 2051 nca = 0 2052 ncb = 0 2053 naa = 0 2054 nab = 0 2055 dont = .false. 2056 do igs = 1, ngas 2057 if (ihpv(igs).eq.1) then ! hole space 2058 naa = naa + i_cc_typ(igs,3,itp) 2059 nab = nab + i_cc_typ(igs,4,itp) 2060 if (i_cc_typ(igs,1,itp).gt.0.or. 2061 & i_cc_typ(igs,2,itp).gt.0 ) then 2062 dont = .true. 2063 end if 2064 else if(ihpv(igs).eq.2) then ! particle space 2065 nca = nca + i_cc_typ(igs,1,itp) 2066 ncb = ncb + i_cc_typ(igs,2,itp) 2067 if (i_cc_typ(igs,3,itp).gt.0.or. 2068 & i_cc_typ(igs,4,itp).gt.0 ) then 2069 dont = .true. 2070 end if 2071 else if(ihpv(igs).eq.3) then ! valence space 2072 not_possible = .true. ! we cannot handle this currently 2073 stop 'valence spaces are too difficult for me!' 2074 else 2075 stop'ihpv is inconsistent in init_gtbce' 2076 end if 2077 end do 2078 2079 if (ntest.ge.100) then 2080 write(6,*) 'ityp = ',itp 2081 write(6,*) ' nca, ncb ', nca, ncb 2082 write(6,*) ' naa, nab ', naa, nab 2083 write(6,*) ' dont ',dont 2084 end if 2085 2086 if (.not.dont) then 2087 if (nca.eq.1.and.ncb.eq.0.and. 2088 & naa.eq.1.and.nab.eq.0 ) then 2089 ioff_sing(1) = ioff_cc_typ(itp) 2090 ilen_sing(1) = namp_cc_typ(itp) 2091 else if (nca.eq.0.and.ncb.eq.1.and. 2092 & naa.eq.0.and.nab.eq.1 ) then 2093 ioff_sing(2) = ioff_cc_typ(itp) 2094 ilen_sing(2) = namp_cc_typ(itp) 2095 else if (nca.eq.1.and.ncb.eq.1.and. 2096 & naa.eq.1.and.nab.eq.1 ) then 2097 ioff_doub(1) = ioff_cc_typ(itp) 2098 ilen_doub(1) = namp_cc_typ(itp) 2099 else if (nca.eq.2.and.ncb.eq.0.and. 2100 & naa.eq.2.and.nab.eq.0 ) then 2101 ioff_doub(2) = ioff_cc_typ(itp) 2102 ilen_doub(2) = namp_cc_typ(itp) 2103 else if (nca.eq.0.and.ncb.eq.2.and. 2104 & naa.eq.0.and.nab.eq.2 ) then 2105 ioff_doub(3) = ioff_cc_typ(itp) 2106 ilen_doub(3) = namp_cc_typ(itp) 2107 end if 2108 end if 2109 end do 2110 2111 if (mscomb_cc.ne.0) then 2112 ! don't worry about missing info 2113 ioff_sing(2) = 1 2114 ilen_sing(2) = 0 2115 ioff_doub(3) = 1 2116 ilen_doub(3) = 0 2117 end if 2118 2119 if (ntest.ge.5) then 2120 write(6,*) 'offsets and lengthes extracted:' 2121 write(6,*) '(mscomb_cc = ',mscomb_cc,')' 2122 write(6,*) ioff_sing(1:nsing), ioff_doub(1:ndoub) 2123 write(6,*) ilen_sing(1:nsing), ilen_doub(1:ndoub) 2124 end if 2125 2126 if (ilen_sing(1)*ilen_sing(nsing).eq.0) then 2127 ! try to guess singles size from the number of 2128 ! possible holes and particles 2129 nph(1:nsmst,1:2) = 0 2130 do igs = 1, ngas 2131 if (igs.eq.1) then 2132 nelmin = iocc(1,1) 2133 nelmax = iocc(1,2) 2134 else 2135 nelmin = iocc(igs,1)-iocc(igs-1,2) 2136 nelmax = iocc(igs,2)-iocc(igs-1,1) 2137 end if 2138 ! may at least one electron be removed in this space? 2139 ihp = 0 2140 if (nelmin.lt.2*nobpt(igs).and.ihpv(igs).eq.1) ihp=1 2141 ! may at least one electron be added in this space 2142 if (nelmax.gt.0.and.ihpv(igs).eq.2) ihp=2 2143 if (ihp.gt.0) then 2144 do ism = 1, nsmst 2145 ! get the number of holes/particles per symmetry 2146 nph(ism,ihp) = nph(ism,ihp) + ngssh(ism,igs) 2147 end do 2148 end if 2149 end do 2150 lsing = 0 2151 do ism = 1, nsmst 2152 lsing = lsing + nph(ism,1)*nph(ism,2) 2153 end do 2154 ! there has to be done some more work for open-shell cases! 2155 ! for now: 2156 ilen_sing(1:nsing) = lsing 2157 2158 write(6,*) 'There seem to be no singles in your general '// 2159 & 'TWOBODY operator!' 2160 write(6,*) 'From the number of active holes and particles'// 2161 & ' I guess ',ilen_sing(1:nsing) 2162 2163 end if 2164 2165 if (ioff_doub(1)*ioff_doub(2)*ioff_doub(3).eq.0) then 2166 write(6,*) 'No offsets for doubles found!!!' 2167 stop 'difficulties in gtbce_init' 2168 end if 2169 2170 ! decide what to do 2171 if (imode.eq.-1) then 2172 namp_d = ilen_doub(1)+ilen_doub(2)+ilen_doub(3) 2173 namp_sd = namp_d + ilen_sing(1) + ilen_sing(2) 2174 imode_ = 0 2175 if (namp_read.eq.namp_d ) imode_ = 3 2176 if (namp_read.eq.namp_sd) imode_ = 2 2177 if (namp_read.eq.n_cc_amp)imode_ = 1 2178 2179 if (ntest.ge.5) then 2180 write (6,*) 'namp_read ',namp_read 2181 write (6,*) 'namp_d ',namp_d 2182 write (6,*) 'namp_sd ',namp_sd 2183 write (6,*) 'n_cc_amp ',n_cc_amp 2184 write (6,*) ' imode_ =',imode_ 2185 end if 2186 end if ! imode.eq.-1 2187 2188 end if ! imode_.eq.2/3/-1 2189 2190 if (imode_.eq.0) then 2191 ccamp(1:n_cc_amp) = 0d0 2192 else if (imode_.eq.1) then 2193 lblk = -1 2194 call vec_from_disc(ccamp,n_cc_amp,1,lblk,luamp) 2195 else if (imode_.eq.2.or.imode_.eq.3) then 2196 ioff1 = 0 2197 if (imode_.eq.2) then 2198 do ii = 1, nsing 2199 if (ilen_sing(ii).gt.0.and.ioff_sing(ii).gt.0) 2200 & ccamp(ioff_sing(ii) :ioff_sing(ii)+ilen_sing(ii)-1) = 2201 & ccscr(ioff1 +1:ioff1 +ilen_sing(ii)) 2202 ioff1 = ioff1 + ilen_sing(ii) 2203 end do 2204 end if 2205 do ii = 1, ndoub 2206 if (ilen_doub(ii).gt.0.and.ioff_doub(ii).gt.0) 2207 & ccamp(ioff_doub(ii) :ioff_doub(ii)+ilen_doub(ii)-1) = 2208 & ccscr(ioff1 +1:ioff1 +ilen_doub(ii)) 2209 ioff1 = ioff1 + ilen_doub(ii) 2210 end do 2211 2212 else 2213 write(6,*) 'unknown imode in init_gtbce(', imode,') !' 2214 stop 'init_gtbce' 2215 end if 2216 2217 if (ntest.ge.100) then 2218 write(6,*) 'Initialized G: ' 2219 call wrt_cc_vec2(ccamp,6,'GEN_CC') 2220 end if 2221 2222 return 2223 end 2224********************************************************************** 2225********************************************************************** 2226* DECK: gtbce_E 2227********************************************************************** 2228 subroutine gtbce_E(igtbmod_l, 2229 & elen,variance,ovl, 2230 & e_core, 2231 & ccvec1,iopsym,ccvecscr, 2232 & civec1,civec2,c2vec, 2233 & n_cc_amp,mxb_ci, 2234 & luc,luec,luhc,lusc1,lusc2) 2235********************************************************************** 2236* 2237* purpose: calculate the Energy of the GTBCE. 2238* 2239* E = <0|exp(G^+) H exp(G)|0> / <0|exp(G^+)exp(G^+)|0> 2240* 2241* input: |0> on luc 2242* G on ccvec1 2243* 2244* output: exp(G)|0> on luec 2245* H exp(G)|0> on luhc 2246* 2247* E on elen 2248* S = <0|exp(G^+)exp(G^+)|0> on ovl 2249* v = <H^2>/S - E^2 on variance 2250* 2251* igtbmod_l.eq.(0/2) proceed as usual 2252* igtbmod_l.eq.1 use exp(G^2) 2253* 2254* ak, early 2004 2255* 2256********************************************************************** 2257* diverse inludes with commons and paramters 2258c include 'implicit.inc' 2259c include 'mxpdim.inc' 2260 include 'wrkspc.inc' 2261c include 'crun.inc' 2262 include 'cstate.inc' 2263 include 'cgas.inc' 2264 include 'ctcc.inc' 2265 include 'gasstr.inc' 2266 include 'strinp.inc' 2267 include 'orbinp.inc' 2268 include 'cprnt.inc' 2269 include 'corbex.inc' 2270 include 'csm.inc' 2271 include 'cands.inc' 2272 include 'oper.inc' 2273 include 'gtbce.inc' 2274* debugging: 2275 integer, parameter :: ntest = 5 2276 2277* input arrays 2278 real*8 ccvec1(n_cc_amp) 2279 2280* local 2281 logical test_h1 2282 2283* scratch arrays 2284 character*8 cctype 2285 real*8 civec1(mxb_ci),civec2(mxb_ci),c2vec(*), 2286 & ccvecscr(n_cc_amp) 2287* external functions 2288 real*8 inprod, inprdd 2289 2290 call atim(cpu0,wall0) 2291 2292 ! settings for expt_ref2 2293 thresh=expg_thrsh 2294 mx_term=-mxterm_expg 2295 cctype='GEN_CC' 2296 2297 if (ntest.ge.5) then 2298 write (6,*) '=================' 2299 write (6,*) ' This is gtbce_E ' 2300 write (6,*) '=================' 2301 write (6,*) 2302 write (6,*) 'on entry: ' 2303 write (6,*) 'e_core : ', e_core 2304 write (6,*) 'n_cc_amp,mxb_ci : ', n_cc_amp,mxb_ci 2305 write (6,*) 'luc,luec,luhc,lusc1,lusc2: ', 2306 & luc,luec,luhc,lusc1,lusc2 2307 write (6,*) 'igtbmod_l: ',igtbmod_l 2308 end if 2309 if (ntest.ge.5) then 2310 write(6,*) ' gtbce_E > ' 2311 xnorm = sqrt(inprod(ccvec1,ccvec1,n_cc_amp)) 2312 write(6,*) ' n_cc_amp,norm of T: ',n_cc_amp,xnorm 2313 end if 2314 if (ntest.ge.100) then 2315 call wrt_cc_vec2(ccvec1,6,cctype) 2316 end if 2317 2318 lblk = -1 2319*--------------------------------------------------------------------* 2320* |0tilde> = exp(G)|0> 2321* 2322* |0> on luc, |0tilde> on luec, 2323* G is on ccvec1 2324*--------------------------------------------------------------------* 2325 if (igtbmod_l.ne.1) then 2326 call expt_ref2(luc,luec,luhc,lusc1,lusc2, 2327 & thresh,mx_term, ccvec1, ccvecscr, civec1, civec2, 2328 & n_cc_amp,cctype,iopsym) 2329 else 2330 call expt2_ref(luc,luec,luhc,lusc1,lusc2, 2331 & thresh,mx_term, 2332 & 1d0,ccvec1, ccvecscr, civec1, civec2, n_cc_amp, 2333 & iopsym) 2334 end if 2335*--------------------------------------------------------------------* 2336* |H0tilde> = H exp(G)|0> 2337* 2338* |H0tilde> on luhc 2339*--------------------------------------------------------------------* 2340 if (igtb_test_h1.eq.1) i12 = 1 2341 call mv7(civec1,civec2,luec,luhc) 2342*--------------------------------------------------------------------* 2343* S = <0tilde|0tilde> 2344*--------------------------------------------------------------------* 2345 xs = inprdd(civec1,civec2,luec,luec,1,lblk) 2346 if (xs.eq.0) then 2347 write(6,*) 'gtbce_E > Wavefunction with zero norm!!' 2348 write(6,*) ' Are we trying to be funny today?' 2349 stop 'fatal inconsistency' 2350 end if 2351*--------------------------------------------------------------------* 2352* E S = <0tilde|H|0tilde>, E = <0tilde|H|0tilde>/S 2353*--------------------------------------------------------------------* 2354 xes= inprdd(civec1,civec2,luec,luhc, 1,lblk) 2355 elen = xes/xs 2356 ovl = xs 2357*--------------------------------------------------------------------* 2358* variance of <H>: <0tilde|H^2|0tilde>/S - E^2 2359*--------------------------------------------------------------------* 2360 xh2 = inprdd(civec1,civec2,luhc,luhc,1,lblk) 2361 variance = xh2/xs - xes*xes/(xs*xs) 2362 if (ntest.ge.5) then 2363 write(6,*) ' gtbce_E > ' 2364 write(6,*) ' <0tilde|0tilde> = ',xs 2365 write(6,*) ' <0tilde|H|0tilde> = ',xes 2366 write(6,*) ' <0tilde|H^2|0tilde> = ',xh2 2367 write(6,*) ' el. energy = ',elen 2368 write(6,*) ' e_core = ',e_core 2369 write(6,*) ' energy = ',elen+e_core 2370 write(6,*) ' variance = ',variance 2371 end if 2372 if (ntest.ge.1000) then 2373 write(6,*) ' gtbce_E > ' 2374 write(6,*) ' |0tilde>:' 2375 call wrtvcd(civec1,luec,1,lblk) 2376 write(6,*) ' H|0tilde>:' 2377 call wrtvcd(civec1,luhc,1,lblk) 2378 end if 2379 2380 call atim(cpu,wall) 2381 call prtim(6,'time in gtbce_E',cpu-cpu0,wall-wall0) 2382 2383 return 2384 end 2385*--------------------------------------------------------------------* 2386********************************************************************** 2387* DECK: gtbce_Omg 2388********************************************************************** 2389 subroutine gtbce_Omg(omg,xnomg, 2390 & elen,ovl,iopsym, 2391 & civec1,civec2,c2vec, 2392 & n_cc_amp,mxb_ci, 2393 & luec,luhc,lusc1,lusc2) 2394********************************************************************** 2395* 2396* purpose: calculate the Nakasuji-type 2397* Vectorfunction Omega of the GTBCE (or Contracted Schroedinger 2398* Equations (CSE) residual, if you will, if the operator space 2399* was chosen accordingly (SING,0,0,0/DOUB,1,1,1,1,1)) 2400* 2401* Omg = 1/S <0|exp(G^+) gamma (H-E) exp(G)|0> 2402* 2403* input: exp(G)|0> on luec 2404* H exp(G)|0> on luhc 2405* 2406* output: Omg on omg 2407* |Omg| on xnomg 2408* 2409* ak, early 2004 2410* 2411********************************************************************** 2412* diverse inludes with commons and paramters 2413c include 'implicit.inc' 2414c include 'mxpdim.inc' 2415 include 'wrkspc.inc' 2416c include 'crun.inc' 2417 include 'cstate.inc' 2418 include 'cgas.inc' 2419 include 'ctcc.inc' 2420 include 'gasstr.inc' 2421 include 'strinp.inc' 2422 include 'orbinp.inc' 2423 include 'cprnt.inc' 2424 include 'corbex.inc' 2425 include 'csm.inc' 2426 include 'cands.inc' 2427* debugging: 2428 integer, parameter :: ntest = 0 2429 2430* input/output arrays 2431 real*8 omg(n_cc_amp) 2432* scratch arrays 2433 character*8 cctype 2434 real*8 civec1(mxb_ci),civec2(mxb_ci),c2vec(*) 2435* external functions 2436 real*8 inprod, inprdd 2437 2438 call atim(cpu0,wall0) 2439 2440 if (ntest.ge.5) then 2441 write (6,*) '=========================' 2442 write (6,*) ' This is gtbce_Omg' 2443 write (6,*) '=========================' 2444 write (6,*) 2445 write (6,*) 'on entry: ' 2446 write (6,*) 'el. energy,mxb_ci : ', elen, mxb_ci 2447 write (6,*) 'luec,luhc,lusc1,lusc2: ', 2448 & luec,luhc,lusc1,lusc2 2449 end if 2450 2451 lblk = -1 2452*--------------------------------------------------------------------* 2453* (H-E)|0tilde> 2454* result on lusc1 2455*--------------------------------------------------------------------* 2456 call vecsmdp(civec1,civec2,1d0,-elen,luhc,luec,lusc1,1,lblk) 2457*--------------------------------------------------------------------* 2458* Omg_u = <0(tilde)|gamma_u(H-E)|0(tilde)> 2459* result on omg 2460*--------------------------------------------------------------------* 2461 isigden=2 2462 omg(1:n_cc_amp) = 0d0 2463 call sigden_cc(civec1,civec2,luec,lusc1,omg,isigden) 2464 if (iopsym.eq.1.or.iopsym.eq.-1) then 2465 if (iopsym.eq.-1) call scalve(omg,-1d0,n_cc_amp) 2466 call conj_t 2467 call sigden_cc(civec1,civec2,luec,lusc1,omg,isigden) 2468 call conj_t 2469 if (iopsym.eq.-1) call scalve(omg,-1d0,n_cc_amp) 2470 end if 2471c call memchk 2472 call scalve(omg,1d0/ovl,n_cc_amp) 2473 2474 xnomg = sqrt(inprod(omg,omg,n_cc_amp)) 2475 2476 if (ntest.ge.5) then 2477c call memchk 2478 write(6,*) ' gtbce_Omg > ' 2479 write(6,*) ' n_cc_amp,norm of omega: ',n_cc_amp,xnomg 2480 end if 2481 if (ntest.ge.100) then 2482 cctype='GEN_CC' 2483 call wrt_cc_vec2(omg,6,cctype) 2484 end if 2485 2486 call atim(cpu,wall) 2487 call prtim(6,'time in gtbce_Omg',cpu-cpu0,wall-wall0) 2488 2489 return 2490 end 2491*--------------------------------------------------------------------* 2492********************************************************************** 2493* DECK: gtbce_gradE 2494********************************************************************** 2495 subroutine gtbce_gradE(!igtbmod, 2496 & isymmet_G,grad,xngrad,igradmode, 2497 & imode,npnts, 2498 & elen,ovl, 2499 & ccvec1,iopsym,ccvec2,ccvec3, 2500 & civec1,civec2,c2vec, 2501 & n_cc_typ,i_cc_typ,ictp, 2502 & namp_cc_typ,ioff_cc_typ, 2503 & n_cc_amp,mxb_ci,nprint, 2504 & luamp,luc,luec,luhc, 2505 & lusc1,lusc2,lusc3,lusc4,lusc5,lusc6) 2506********************************************************************** 2507* 2508* purpose: calculate the gradient of the GTBCE energy by numerical 2509* integration of the Wilcox identity 2510* 2511* Ref. van Voorhis, Head-Gordon, JCP 115(11) 5033 (2001) 2512* 2513* gradE = 2514* 2/S int_0^1 da <0|exp(G^+) (H-E) exp((1-a)G) gamma exp(aG)|0> 2515* 2516* input: |0> on luc 2517* exp(G)|0> on luec 2518* H exp(G)|0> on luhc 2519* E on elen 2520* S on ovl 2521* G on ccvec1 2522* 2523* imode: num. integration scheme 2524* npnts: number of integration points 2525* 2526* note on scratch vectors: ccvec3 is only needed if iopsym.eq.+/-1 2527* 2528* output: gradE on grad 2529* |gradE| on xngrad 2530* 2531* igtbmod.eq.1: use exp(G^2) 2532* 2533* ak, early 2004 2534* 2535********************************************************************** 2536* diverse inludes with commons and paramters 2537c include 'implicit.inc' 2538c include 'mxpdim.inc' 2539 include 'wrkspc.inc' 2540c include 'crun.inc' 2541 include 'cstate.inc' 2542 include 'cgas.inc' 2543 include 'ctcc.inc' 2544 include 'gasstr.inc' 2545 include 'strinp.inc' 2546 include 'orbinp.inc' 2547 include 'cprnt.inc' 2548 include 'corbex.inc' 2549 include 'csm.inc' 2550 include 'cands.inc' 2551 include 'gtbce.inc' 2552* debugging: 2553 integer, parameter :: ntest = 005 2554 logical, parameter :: tstgrad = .false. 2555 2556* input/output arrays 2557 integer, intent(in) :: 2558 & igradmode, ioff_cc_typ(n_cc_typ), namp_cc_typ(n_cc_typ) 2559 real*8, intent(inout) :: 2560 & grad(n_cc_amp) 2561* scratch arrays 2562 real*8 civec1(mxb_ci),civec2(mxb_ci),c2vec(*), 2563 & ccvec1(n_cc_amp), ccvec2(n_cc_amp), ccvec3(n_cc_amp) 2564* local arrays 2565 character*8 cctype 2566 real*8 alp(npnts+2), wght(npnts+2) 2567* external functions 2568 real*8 inprod, inprdd 2569 2570 call atim(cpu0,wall0) 2571 2572 nprintl = max(ntest,nprint) 2573 2574 lblk = -1 2575 if (ntest.ge.5) then 2576 write (6,*) '=====================' 2577 write (6,*) ' This is gtbce_gradE' 2578 write (6,*) '=====================' 2579 write (6,*) 2580 write (6,*) 'on entry: ' 2581 write (6,*) 'imode, npnts : ', imode, npnts 2582 write (6,*) 'igradmode : ', igradmode 2583 write (6,*) 'isymmet_G : ', isymmet_G 2584 write (6,*) 'ovl, elen: ',ovl,elen 2585 write (6,*) 'n_cc_amp,mxb_ci : ', n_cc_amp,mxb_ci 2586 write (6,*) 'luc,luec,luhc,lusc1,lusc2: ', 2587 & luc,luec,luhc,lusc1,lusc2 2588 end if 2589 2590 if (ntest.ge.1000) then 2591 write(6,*) 'on entry:' 2592 write(6,*) 'Reference on LUC' 2593 call wrtvcd(civec1,luc,1,lblk) 2594 write(6,*) 'e^G|0> on LUEC' 2595 call wrtvcd(civec1,luec,1,lblk) 2596 write(6,*) 'H e^G|0> on LUHC' 2597 call wrtvcd(civec1,luhc,1,lblk) 2598 end if 2599 2600c if (ntest.ge.5) then 2601c xnorm = sqrt(inprod(ccvec1,ccvec1,n_cc_amp)) 2602c write (6,*) 'norm of T: ',xnorm 2603c end if 2604c if (ntest.ge.100) then 2605c call wrt_cc_vec2(ccvec1,6,cctype) 2606c end if 2607 2608 ! for I/O 2609 lblk = -1 2610 ! for expt_ref 2611 thresh=expg_thrsh 2612 mx_term=-mxterm_expg 2613 cctype='GEN_CC' 2614*--------------------------------------------------------------------* 2615* set up points and weights 2616*--------------------------------------------------------------------* 2617 select case (imode) 2618 case (0) ! just testing 2619 do ipnt = 1, npnts 2620 alp(ipnt) = dble(ipnt-1)/dble(npnts-1) 2621 wght(ipnt) = 1d0 2622 end do 2623 case (1) ! Gauss-Legendre 2624 call gl_weights(0d0,1d0,npnts,alp,wght) 2625 case (2) ! Simpson 2626c if (mod(npnts,2).eq.0) npnts = npnts-1 2627 call s_weights(0d0,1d0,npnts,alp,wght) 2628 case default 2629 stop 'unknown imode in gtbce_gradE' 2630 end select 2631c call test_quad(0d0,1d0,npnts,alp,wght) 2632c stop 'enf stop after quad' 2633 2634 mxpnts=npnts 2635 ! if G == 0 ... 2636 xnrm2 = inprod(ccvec1,ccvec1,n_cc_amp) 2637 ! ... things are trivial and we evaluate the formula only once 2638 if (xnrm2.lt.10d-20) then 2639 mxpnts=1 2640 wght(1)=1d0 2641 alp(1)=0d0 2642 if (ntest.ge.5) then 2643 write(6,*) 'Detected zero amplitudes: ', 2644 & 'only case alpha = 0 will be processed' 2645 end if 2646 else if (tstgrad) then 2647 ! does not work in route 3! 2648 mxpnts = npnts+2 2649 wght(npnts+1)=0d0 2650 wght(npnts+2)=0d0 2651 alp(npnts+1)=0d0 2652 alp(npnts+2)=1d0 2653 end if 2654 call setvec(grad,0d0,n_cc_amp) 2655 2656*--------------------------------------------------------------------* 2657* (H-E)|0tilde> 2658* result on lusc1 2659*--------------------------------------------------------------------* 2660 if (igradmode.eq.1) then ! (H-E)|0tilde> 2661 call vecsmdp(civec1,civec2,1d0,-elen,luhc,luec,lusc1,1,lblk) 2662 else if (igradmode.eq.2) then ! H|0tilde> only 2663 call copvcd(luhc,lusc1,civec1,1,lblk) 2664 else if (igradmode.eq.3) then ! |0tilde> only 2665 call copvcd(luec,lusc1,civec1,1,lblk) 2666 end if 2667 2668**-------------------------------------------------------------------* 2669* loop over quadrature points 2670**-------------------------------------------------------------------* 2671 do ipnt = 1, mxpnts 2672 if (ntest.ge.5) then 2673 write(6,*) 'info for quadrature point: ', ipnt,'/',npnts 2674 write(6,*) 'point, weight: ', alp(ipnt), wght(ipnt) 2675 end if 2676 2677 if (ipnt.gt.1.and.(alp(ipnt).le.alp(ipnt-1))) then 2678 write(6,*) 'quadrature point should be in ascending order!' 2679 stop 'gtbce_gradE > quadrature ' 2680 end if 2681 2682 if (ipnt.eq.1) then 2683 dltalp = alp(1) 2684 else 2685 dltalp = alp(ipnt)-alp(ipnt-1) 2686 call copvcd(lusc2,lusc1,civec1,1,lblk) 2687 end if 2688*--------------------------------------------------------------------* 2689* |a_i> = exp(a_i G^+) [(H-E)exp(G)|0>] 2690* = exp((a_i-a_{i-1})G^+) [exp(a_{i-1}G^+) (H-E)exp(G)|0>] 2691* result on lusc2 2692*--------------------------------------------------------------------* 2693 if (ntest.ge.5) then 2694 write(6,*) 2695 & 'constructing |a_i> = exp(a_i G^+) [(H-E)exp(G)|0>]' 2696 end if 2697 2698 if (abs(dltalp).lt.1d-20) then 2699 call copvcd(lusc1,lusc2,civec1,1,lblk) 2700 else 2701 ! get the conjugate operator G^+ on ccvec2 2702 call conj_ccamp(ccvec1,1,ccvec2) 2703 if (igtbmod.ne.1) then 2704 ! and scale it 2705 call scalve(ccvec2,dltalp,n_cc_amp) 2706 call conj_t 2707 call expt_ref2(lusc1,lusc2,lusc4,lusc5,lusc6, 2708 & thresh,mx_term, ccvec2, ccvec3, civec1, civec2, 2709 & n_cc_amp,cctype, iopsym) 2710 call conj_t 2711 else 2712 call conj_t 2713 call expt2_ref(lusc1,lusc2,lusc4,lusc5,lusc6, 2714 & thresh,mx_term, 2715 & dltalp,ccvec2, ccvec3, civec1, civec2,n_cc_amp, 2716 & iopsym) 2717 call conj_t 2718 end if 2719 if (ntest.ge.5) then 2720 xnrm = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 2721 etest = inprdd(civec1,civec2,luc,lusc2,1,lblk) 2722 write(6,*) '|dlta G^+|, dlta = ',xnrm, dltalp 2723 write(6,*) '<ref|a_i> = ', etest, 2724 & 'for alp(i) = ', alp(ipnt) 2725 end if 2726 2727 end if 2728 2729*--------------------------------------------------------------------* 2730* |b_i> = exp(-a_i G)exp(G)|0> = 2731* = exp(-(a_i-a_{i-1})G) [exp(-a_{i-1}G)exp(G)|0>] 2732* result on lusc3 2733*--------------------------------------------------------------------* 2734 if (ipnt.eq.1) then 2735 call copvcd(luec,lusc1,civec1,1,lblk) 2736 else 2737 call copvcd(lusc3,lusc1,civec1,1,lblk) 2738 end if 2739 2740 if (ntest.ge.5) then 2741 write(6,*) 'constructing |b_i> = exp(-a_i G) exp(G)|0>]' 2742 end if 2743 2744 if (abs(dltalp).lt.1d-20) then 2745 call copvcd(lusc1,lusc3,civec1,1,lblk) 2746 else 2747 if (igtbmod.ne.1) then 2748 ! get a copy of G 2749 call copvec(ccvec1,ccvec2,n_cc_amp) 2750 ! and scale it 2751 call scalve(ccvec2,-dltalp,n_cc_amp) 2752 call expt_ref2(lusc1,lusc3,lusc4,lusc5,lusc6, 2753 & thresh,mx_term, ccvec2, ccvec3, civec1, civec2, 2754 & n_cc_amp,cctype, iopsym) 2755 else 2756 call expt2_ref(lusc1,lusc3,lusc4,lusc5,lusc6, 2757 & thresh,mx_term, 2758 & -dltalp,ccvec1, ccvec3, civec1, civec2,n_cc_amp, 2759 & iopsym) 2760 end if 2761 if (ntest.ge.5) then 2762 xnrm = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 2763 etest = inprdd(civec1,civec2,lusc3,lusc3,1,lblk) 2764 etest2= inprdd(civec1,civec2,lusc2,lusc3,1,lblk) 2765 write(6,*) '|dltaG|, dlta = ',xnrm, dltalp 2766 write(6,*) '<b_i|b_i> , S = ', etest, ovl, 2767 & 'for alp(i) = ', alp(ipnt) 2768 write(6,*) '<a_i|b_i> = ', etest2, 2769 & 'for alp(i) = ', alp(ipnt) 2770 end if 2771 end if 2772 2773*--------------------------------------------------------------------* 2774* dE_u += w_i <a_i|gamma_u|b_i> 2775* note: sigden implements ccvec2 = <lusc2|gamma_u|lusc3> 2776* 2777* for exp(G^2) we have 2778* 2779* dE_u += w_i ( <a_i|G gamma_u|b_i> + <a_i|gamma_u G|b_i> ) 2780* 2781*--------------------------------------------------------------------* 2782 2783 if (ntest.ge.1000) then 2784 write(6,*) 'Before calling sigden_cc:' 2785 write(6,*) '|a_i> on lusc2:' 2786 call wrtvcd(civec1,lusc2,1,lblk) 2787 write(6,*) '|b_i> on lusc3:' 2788 call wrtvcd(civec1,lusc3,1,lblk) 2789 end if 2790 2791 if (igtbmod.ne.1) then 2792 isigden=2 2793 ccvec2(1:n_cc_amp)=0d0 2794 call sigden_cc(civec1,civec2,lusc3,lusc2,ccvec2,isigden) 2795 2796 call vecsum(grad,grad,ccvec2,1d0,wght(ipnt),n_cc_amp) 2797 2798 if (ntest.ge.150) then 2799 xnorm = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 2800 write(6,*) 2801 & 'non-weighted contrib to gradient: norm = ', xnorm 2802 if (iopsym.ne.0) write(6,*) 2803 & ' (from non-conjugated exc. op.)' 2804 call wrt_cc_vec2(ccvec2,6,cctype) 2805 if (imode.eq.0) then 2806 ist = 1 2807 do 2808 ind = min(ist+19,n_cc_amp) 2809 if (ind-ist.gt.0) write(6,*) '@@ ',ist,ind,alp(ipnt), 2810 & grad(ist:ind) 2811 if (ind.ge.n_cc_amp) exit 2812 ist = ist + 20 2813 end do 2814 end if 2815 end if 2816 2817 if (iopsym.eq.1.or.iopsym.eq.-1) then 2818 ccvec2(1:n_cc_amp)=0d0 2819 call conj_t 2820 call sigden_cc(civec1,civec2,lusc3,lusc2,ccvec2,isigden) 2821 call conj_ccamp(ccvec2,1,ccvec3) 2822 call conj_t 2823 fac = wght(ipnt) 2824 if (iopsym.eq.-1) fac = -wght(ipnt) 2825 call vecsum(grad,grad,ccvec3,1d0,fac,n_cc_amp) 2826 2827 if (ntest.ge.150) then 2828 xnorm = sqrt(inprod(ccvec3,ccvec3,n_cc_amp)) 2829 write(6,*) 2830 & 'non-weighted contrib to gradient: norm = ', xnorm 2831 write(6,*)' (from conjugated exc. op.)' 2832 call wrt_cc_vec2(ccvec3,6,cctype) 2833 if (imode.eq.0) then 2834 ist = 1 2835 do 2836 ind = min(ist+19,n_cc_amp) 2837 if (ind-ist.gt.0) write(6,*) '@@ ',ist,ind,alp(ipnt), 2838 & grad(ist:ind) 2839 if (ind.ge.n_cc_amp) exit 2840 ist = ist + 20 2841 end do 2842 end if 2843 end if 2844 end if 2845 2846 else ! exp(G^2) part: 2847* G^+ |a> on lusc4 2848 isigden=1 2849 call conj_ccamp(ccvec1,1,ccvec2) 2850 call conj_t 2851 call sigden_cc(civec1,civec2,lusc2,lusc4,ccvec2,isigden) 2852 call conj_t 2853 2854* <a| G gamma |b> contribution: 2855* note: sigden implements ccvec2 = <lusc4|gamma_u|lusc3> 2856 isigden=2 2857 ccvec2(1:n_cc_amp)=0d0 2858 call sigden_cc(civec1,civec2,lusc3,lusc4,ccvec2,isigden) 2859 2860* increment gradient: 2861 call vecsum(grad,grad,ccvec2,1d0,wght(ipnt),n_cc_amp) 2862 2863* G |b> on lusc4 2864 isigden=1 2865 call sigden_cc(civec1,civec2,lusc3,lusc4,ccvec1,isigden) 2866 2867* <a| gamma G |b> contribution: 2868 isigden=2 2869 ccvec2(1:n_cc_amp)=0d0 2870 call sigden_cc(civec1,civec2,lusc4,lusc2,ccvec2,isigden) 2871 2872* increment gradient: 2873 call vecsum(grad,grad,ccvec2,1d0,wght(ipnt),n_cc_amp) 2874 2875 if (ntest.ge.150) then 2876 xnorm = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 2877 write(6,*) 2878 & 'non-weighted contrib to gradient: norm = ', xnorm 2879 if (iopsym.ne.0) write(6,*) 2880 & ' (from non-conjugated exc. op.)' 2881 call wrt_cc_vec2(ccvec2,6,cctype) 2882 end if 2883 2884 if (iopsym.eq.1.or.iopsym.eq.-1) 2885 & stop 'not prepared for iopsym.ne.0' 2886 2887 end if 2888 2889 end do 2890 2891 2892 if (isymmet_G.ne.0) then 2893 if (ntest.ge.1000) then 2894 write(6,*) 'The new gradient (bef. symmetrizing):' 2895 call wrt_cc_vec2(grad,6,'GEN_CC') 2896 end if 2897 call symmet_t(isymmet_G,1, 2898 & grad,ccvec2, 2899 & ictp,i_cc_typ,n_cc_typ, 2900 & namp_cc_typ,ioff_cc_typ,ngas) 2901 end if 2902 2903 if (igradmode.eq.1) then 2904 ! normalize gradient 2905 call scalve(grad,2d0/ovl,n_cc_amp) 2906 xngrad = sqrt(inprod(grad,grad,n_cc_amp)) 2907 end if 2908 2909 if (ntest.ge.5) then 2910 write(6,*) ' gtbce_gradE > ' 2911 write(6,*) ' n_cc_amp,norm of grad: ',n_cc_amp,xngrad 2912 end if 2913 if (ntest.ge.100) then 2914 call wrt_cc_vec2(grad,6,'GEN_CC') 2915 end if 2916 2917 if (nprintl.ge.1) then 2918 write(6,'(4(/x,a))') 2919 & ' Contributions to gradient norm per operator type:', 2920 & '-----------------------------------------------------------', 2921 & ' type n norm norm/n max min', 2922 & '-----------------------------------------------------------' 2923 do itp = 1, n_cc_typ 2924 ist = ioff_cc_typ(itp) 2925 len = namp_cc_typ(itp) 2926 xnorm = sqrt(inprod(grad(ist),grad(ist),len)) 2927 xmax = fndmnx(grad(ist),len,2) 2928 xmin = fndmnx(grad(ist),len,1) 2929 write(6,'(4x,i3,x,i7,4(x,e10.4))') 2930 & itp,len,xnorm,xnorm/dble(len),xmax,xmin 2931 end do 2932 write(6,'(x,a,/)') 2933 & '-----------------------------------------------------------' 2934 2935 end if 2936 2937 call atim(cpu,wall) 2938 call prtim(6,'time in gtbce_gradE',cpu-cpu0,wall-wall0) 2939 2940 return 2941 end 2942*--------------------------------------------------------------------* 2943* DECK: gtbce_tstgradE 2944*--------------------------------------------------------------------* 2945 subroutine gtbce_testgradE(igtbmod,isymmet_G,igtb_closed, 2946 & ccvec1,ccvec2,xngrad_num, 2947 & ecore, 2948 & ccvec3,iopsym,ccvec4, 2949 & civec1,civec2,c2vec, 2950 & n_cc_typ,i_cc_typ,namp_cc_typ,ioff_cc_typ, 2951 & n_cc_amp,mxb_ci, 2952 & n11amp,n33amp,iamp_packed,ictp, 2953 & luamp,lugrd, 2954 & luc,luec,luhc, 2955 & lusc1,lusc2) 2956*--------------------------------------------------------------------* 2957* 2958* test gradient by numerical differentiation 2959* the exact gradient should be passed 2960* 2961*--------------------------------------------------------------------* 2962* diverse inludes with commons and paramters 2963c include 'implicit.inc' 2964c include 'mxpdim.inc' 2965 include 'wrkspc.inc' 2966c include 'crun.inc' 2967 include 'cstate.inc' 2968 include 'cgas.inc' 2969 include 'ctcc.inc' 2970 include 'gasstr.inc' 2971 include 'strinp.inc' 2972 include 'orbinp.inc' 2973 include 'cprnt.inc' 2974 include 'corbex.inc' 2975 include 'csm.inc' 2976 include 'cands.inc' 2977* debugging: 2978 integer, parameter :: ntest = 1000000 2979 2980* input/output arrays 2981 real*8 :: 2982 & ccvec1(n_cc_amp), ccvec2(n_cc_amp) 2983* scratch arrays 2984 real*8 :: 2985 & civec1(mxb_ci),civec2(mxb_ci),c2vec(*) 2986 real*8 :: 2987 & ccvec3(n_cc_amp), ccvec4(n_cc_amp) 2988* external functions 2989 real*8 :: 2990 & inprod 2991 2992 write (6,'(/,3(x,a,/))') 2993 & '============================', 2994 & ' Welcome to gtbce_tstgradE!', 2995 & '============================' 2996 2997* increment is 0.001 2998 xinc = 0.00001d0 2999 3000 if (igtb_closed.eq.0) then 3001 namp = n_cc_amp 3002 else 3003 namp_packed = n11amp+n33amp 3004 namp = namp_packed 3005 end if 3006 3007 do iamp = 1, namp 3008 3009 if (igtb_closed.eq.0) then 3010 call vec_from_disc(ccvec3,namp,1,-1,luamp) 3011* increment + 3012 ccvec3(iamp) = ccvec3(iamp) + xinc 3013 else 3014 call vec_from_disc(ccvec1,namp,1,-1,luamp) 3015* increment + 3016 ccvec1(iamp) = ccvec1(iamp) + xinc 3017 iway = -1 3018 idual = 3 3019 call pack_g(iway,idual,isymmet_G,ccvec1,ccvec3, 3020 & n_cc_typ,i_cc_typ,ioff_cc_typ, 3021 & n11amp,n33amp,iamp_packed,n_cc_amp) 3022 3023 call chksym_t(isymmet_G,1, 3024 & ccvec3,ccvec1, 3025 & ictp,i_cc_typ,n_cc_typ, 3026 & namp_cc_typ,ioff_cc_typ,ngas) 3027 3028 end if 3029 3030 call gtbce_E(igtbmod,elenp,varp,ovl, 3031 & ecore, 3032 & ccvec3,iopsym,ccvec4, 3033 & civec1,civec2,c2vec, 3034 & n_cc_amp,mxb_ci, 3035 & luc,luec,luhc,lusc1,lusc2) 3036 3037* increment - 3038 if (igtb_closed.eq.0) then 3039 call vec_from_disc(ccvec3,namp,1,-1,luamp) 3040 ccvec3(iamp) = ccvec3(iamp) - xinc 3041 else 3042 call vec_from_disc(ccvec1,namp,1,-1,luamp) 3043 ccvec1(iamp) = ccvec1(iamp) - xinc 3044 iway = -1 3045 idual = 3 3046 call pack_g(iway,idual,isymmet_G,ccvec1,ccvec3, 3047 & n_cc_typ,i_cc_typ,ioff_cc_typ, 3048 & n11amp,n33amp,iamp_packed,n_cc_amp) 3049 call chksym_t(isymmet_G,1, 3050 & ccvec3,ccvec1, 3051 & ictp,i_cc_typ,n_cc_typ, 3052 & namp_cc_typ,ioff_cc_typ,ngas) 3053 end if 3054 call gtbce_E(igtbmod,elenm,varm,ovl, 3055 & ecore, 3056 & ccvec3,iopsym,ccvec4, 3057 & civec1,civec2,c2vec, 3058 & n_cc_amp,mxb_ci, 3059 & luc,luec,luhc,lusc1,lusc2) 3060 3061* compare 3062 gradnum = (elenp-elenm)/(2d0*xinc) 3063 ccvec2(iamp) = gradnum 3064 call vec_from_disc(ccvec1,namp,1,-1,lugrd) 3065 if (ntest.gt.150) then 3066 write(6,'(/,x,a,/x,a,i6,/x,a,3(/x,a,e20.13)/)') 3067 & '==================================', 3068 & ' RESULT FOR IAMP = ',iamp, 3069 & '==================================', 3070 & ' analytic ',ccvec1(iamp), 3071 & ' numeric ',gradnum, 3072 & ' diff ',ccvec1(iamp)-gradnum 3073 if (gradnum.ne.0d0) 3074 & write(6,*) 3075 & ' a/n ',ccvec1(iamp)/gradnum 3076 if (ccvec1(iamp).ne.0d0) 3077 & write(6,*) 3078 & ' n/a ',gradnum/ccvec1(iamp) 3079 end if 3080 3081 end do 3082 3083 write (6,*) 'comparison of analytical and numerical gradient:' 3084 call cmp2vc(ccvec1,ccvec2,namp,.1d-2*xinc*xinc) 3085 3086 xngrad_num = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 3087 3088 return 3089 3090 end 3091*--------------------------------------------------------------------* 3092* stop card: ccvec1, ccvec2, grad, grad_num 3093*--------------------------------------------------------------------* 3094* DECK: gtbce_tstgradE_L 3095*--------------------------------------------------------------------* 3096 subroutine gtbce_testgradE_L( 3097 & gradL,ampL, 3098 & ecore, 3099 & ccvec1,iopsym,ccvec2, 3100 & civec1,civec2,c2vec, 3101 & n_cc_amp,n_l_amp,mxb_ci, 3102 & luc,luec,luhc, 3103 & lusc1,lusc2) 3104*--------------------------------------------------------------------* 3105* 3106* test gradient by numerical differentiation 3107* the exact gradient should be passed 3108* 3109*--------------------------------------------------------------------* 3110* diverse inludes with commons and paramters 3111c include 'implicit.inc' 3112c include 'mxpdim.inc' 3113 include 'wrkspc.inc' 3114c include 'crun.inc' 3115 include 'cstate.inc' 3116 include 'cgas.inc' 3117 include 'ctcc.inc' 3118 include 'gasstr.inc' 3119 include 'strinp.inc' 3120 include 'orbinp.inc' 3121 include 'cprnt.inc' 3122 include 'corbex.inc' 3123 include 'csm.inc' 3124 include 'cands.inc' 3125 include 'glbbas.inc' 3126* debugging: 3127 integer, parameter :: ntest = 1000000 3128 3129* input/output arrays 3130 real*8 :: 3131 & gradL(*), ampL(*) 3132* scratch arrays 3133 real*8 :: 3134 & civec1(mxb_ci),civec2(mxb_ci),c2vec(*) 3135 real*8 :: 3136 & ccvec1(n_cc_amp), ccvec2(n_cc_amp) 3137* external functions 3138 real*8 :: 3139 & inprod 3140 3141 write (6,'(/,3(x,a,/))') 3142 & '=============================', 3143 & ' Welcome to gtbce_tstgradE_L', 3144 & '=============================' 3145 3146* increment is 0.001 3147 xinc = 0.0001d0 3148 3149 do iamp = 1, n_l_amp 3150 3151* increment + 3152 ampL(iamp) = ampL(iamp) + xinc 3153 3154 call l2g(ampL,ccvec1,nspobex_tp, 3155 & work(klsobex),work(klibsobex),0 ,ntoob) 3156 3157 igtbmod = 2 ! obviously 3158 call gtbce_E(igtbmod,elenp,varp,ovl, 3159 & ecore, 3160 & ccvec1,iopsym,ccvec2, 3161 & civec1,civec2,c2vec, 3162 & n_cc_amp,mxb_ci, 3163 & luc,luec,luhc,lusc1,lusc2) 3164 3165* increment - 3166 ampL(iamp) = ampL(iamp) - 2d0*xinc 3167 3168 call l2g(ampL,ccvec1,nspobex_tp, 3169 & work(klsobex),work(klibsobex),0 ,ntoob) 3170 3171 call gtbce_E(igtbmod,elenm,varm,ovl, 3172 & ecore, 3173 & ccvec1,iopsym,ccvec2, 3174 & civec1,civec2,c2vec, 3175 & n_cc_amp,mxb_ci, 3176 & luc,luec,luhc,lusc1,lusc2) 3177 3178* reset 3179 ampL(iamp) = ampL(iamp) + xinc 3180 3181* compare 3182 gradnum = (elenp-elenm)/(2d0*xinc) 3183 if (ntest.gt.150) then 3184 ii = iamp/ntoob + 1 3185 jj = mod(iamp-1,ntoob) + 1 3186 write(6,'(/,x,a,/x,a,i6,x,i3,x,i3,/x,a,3(/x,a,e20.13)/)') 3187 & '==================================', 3188 & ' RESULT FOR IAMP = ',iamp,ii,jj, 3189 & '==================================', 3190 & ' analytic ',gradL(iamp), 3191 & ' numeric ',gradnum, 3192 & ' diff ',gradL(iamp)-gradnum 3193 end if 3194 3195 end do 3196 3197c write (6,*) 'comparistion of analytical and numerical gradient:' 3198c call cmp2vc(grad,grad_num,n_cc_amp,.1d-2*xinc*xinc) 3199c 3200c xngrad_num = sqrt(inprod(grad_num,grad_num,n_cc_amp)) 3201 3202 return 3203 3204 end 3205*--------------------------------------------------------------------* 3206*--------------------------------------------------------------------* 3207 subroutine gtbce_testgradE_UOU(imode, 3208 & grad,omvec,urvec,uivec, 3209 & elen,ecore, 3210 & ccvec1,iopsym,ccvec2, 3211 & civec1,civec2,c2vec, 3212 & n_cc_amp,n_l_amp,mxb_ci, 3213 & luc,luec,luhc, 3214 & lusc1,lusc2) 3215*--------------------------------------------------------------------* 3216* 3217* test gradient by numerical differentiation 3218* the exact gradient should be passed 3219* 3220*--------------------------------------------------------------------* 3221* diverse inludes with commons and paramters 3222c include 'implicit.inc' 3223c include 'mxpdim.inc' 3224 include 'wrkspc.inc' 3225c include 'crun.inc' 3226 include 'cstate.inc' 3227 include 'cgas.inc' 3228 include 'ctcc.inc' 3229 include 'gasstr.inc' 3230 include 'strinp.inc' 3231 include 'orbinp.inc' 3232 include 'cprnt.inc' 3233 include 'corbex.inc' 3234 include 'csm.inc' 3235 include 'cands.inc' 3236 include 'glbbas.inc' 3237* debugging: 3238 integer, parameter :: ntest = 1000000 3239 3240* input/output arrays 3241 real*8 :: 3242 & grad(*), omvec(*), urvec(*), uivec(*) 3243* scratch arrays 3244 real*8 :: 3245 & civec1(mxb_ci),civec2(mxb_ci),c2vec(*) 3246 real*8 :: 3247 & ccvec1(n_cc_amp), ccvec2(n_cc_amp) 3248* external functions 3249 real*8 :: 3250 & inprod 3251 3252 write (6,'(/,3(x,a,/))') 3253 & '===============================', 3254 & ' Welcome to gtbce_tstgradE_UOU', 3255 & '===============================' 3256 write(6,*) ' imode = ', imode 3257 write(6,*) ' number of amplitudes = ', n_l_amp 3258 3259 call uou2g(omvec,urvec,uivec,ccvec1, 3260 & nspobex_tp, 3261 & work(klsobex),work(klibsobex),ntoob) 3262 igtbmod = 3 ! obviously 3263 call gtbce_E(igtbmod,elen0,varp,ovl, 3264 & ecore, 3265 & ccvec1,iopsym,ccvec2, 3266 & civec1,civec2,c2vec, 3267 & n_cc_amp,mxb_ci, 3268 & luc,luec,luhc,lusc1,lusc2) 3269 3270* increment is 0.001 3271 xinc = 0.0001d0 3272 3273 write(6,*) ' xinc = ',xinc 3274 write(6,*) ' elen0 = ',elen0 3275 3276 do iamp = 1, n_l_amp 3277 3278* increment + 3279 if (imode.eq.1) omvec(iamp) = omvec(iamp) + xinc 3280 if (imode.eq.2) urvec(iamp) = urvec(iamp) + xinc 3281 if (imode.eq.3) uivec(iamp) = uivec(iamp) + xinc 3282 3283 call uou2g(omvec,urvec,uivec,ccvec1, 3284 & nspobex_tp, 3285 & work(klsobex),work(klibsobex),ntoob) 3286 3287 igtbmod = 3 ! obviously 3288 call gtbce_E(igtbmod,elenp,varp,ovl, 3289 & ecore, 3290 & ccvec1,iopsym,ccvec2, 3291 & civec1,civec2,c2vec, 3292 & n_cc_amp,mxb_ci, 3293 & luc,luec,luhc,lusc1,lusc2) 3294 3295* increment - 3296 if (imode.eq.1) omvec(iamp) = omvec(iamp) - 2d0*xinc 3297 if (imode.eq.2) urvec(iamp) = urvec(iamp) - 2d0*xinc 3298 if (imode.eq.3) uivec(iamp) = uivec(iamp) - 2d0*xinc 3299 3300 call uou2g(omvec,urvec,uivec,ccvec1, 3301 & nspobex_tp, 3302 & work(klsobex),work(klibsobex),ntoob) 3303 3304 call gtbce_E(igtbmod,elenm,varm,ovl, 3305 & ecore, 3306 & ccvec1,iopsym,ccvec2, 3307 & civec1,civec2,c2vec, 3308 & n_cc_amp,mxb_ci, 3309 & luc,luec,luhc,lusc1,lusc2) 3310 3311* reset 3312 if (imode.eq.1) omvec(iamp) = omvec(iamp) + xinc 3313 if (imode.eq.2) urvec(iamp) = urvec(iamp) + xinc 3314 if (imode.eq.3) uivec(iamp) = uivec(iamp) + xinc 3315 3316* compare 3317 gradnum = (elenp-elenm)/(2d0*xinc) 3318 3319 hessnum = (elenp+elenm - 2d0*elen0)/(xinc*xinc) 3320 3321 if (ntest.gt.150) then 3322 ii = iamp/ntoob + 1 3323 jj = mod(iamp-1,ntoob) + 1 3324 write(6,'(/,x,a,/x,a,i6,x,i3,x,i3,/x,a,4(/x,a,e20.13)/)') 3325 & '==================================', 3326 & ' RESULT FOR IAMP = ',iamp,ii,jj, 3327 & '==================================', 3328 & ' analytic ',grad(iamp), 3329 & ' numeric ',gradnum, 3330 & ' diff ',grad(iamp)-gradnum, 3331 & ' num.hess ',hessnum 3332 end if 3333 3334 end do 3335 3336c write (6,*) 'comparistion of analytical and numerical gradient:' 3337c call cmp2vc(grad,grad_num,n_cc_amp,.1d-2*xinc*xinc) 3338c 3339c xngrad_num = sqrt(inprod(grad_num,grad_num,n_cc_amp)) 3340 3341 return 3342 3343 end 3344*--------------------------------------------------------------------* 3345* DECK: gtbce_num2drv 3346*--------------------------------------------------------------------* 3347 subroutine gtbce_num2drv(igtbmod,imode,iomggrd, 3348 & igtb_closed,isymmet_G, 3349 & inumint,npnts, 3350 & ecore, 3351 & iccvec,nSdim, 3352 & ccvec1,iopsym,ccvec2,ccvec3,ccvec4, 3353 & civec1,civec2,c2vec, 3354 & n_cc_typ,i_cc_typ,ictp, 3355 & namp_cc_typ,ioff_cc_typ, 3356 & n_cc_amp,mxb_ci, 3357 & n11amp,n33amp,iamp_packed, 3358 & luhss, 3359 & luamp,luleqv,luc,luec,luhc, 3360 & lusc1,lusc2,lusc3,lusc4,lusc5,lusc6,lusc7) 3361*--------------------------------------------------------------------* 3362* 3363* purpose: calculate the numerical second derivatives of E/S or 3364* the Jacobian dOmg/dG resp.ly 3365* 3366* imode = 1 get matrix-vector product 3367* 2 calculate complete H-ES matrix 3368* 3 calculate complete H matrix 3369* 4 calculate complete S matrix 3370* 3371* iomggrd = 0 calc. Omega 3372* 1 calc. Gradient 3373* 3374* ak, early 2004 3375* 3376*--------------------------------------------------------------------* 3377 include 'implicit.inc' 3378 3379* constants 3380 integer, parameter :: 3381 & ntest = 010 3382 3383* input 3384 3385* scratch 3386 real*8, intent(inout) :: 3387 & ccvec1(n_cc_amp),ccvec2(n_cc_amp), 3388 & ccvec3(n_cc_amp),ccvec4(n_cc_amp), 3389 & civec1(*), civec2(*), c2vec(*) 3390 integer, intent(inout) :: 3391 & iccvec(n_cc_amp) 3392 3393 real(8), external :: 3394 & inprod 3395 3396 lblk = -1 3397 xinc = 1d-5 3398 3399 if (ntest.gt.0) then 3400 write(6,*) '=======================' 3401 write(6,*) ' This is gtbce_num2drv' 3402 write(6,*) '=======================' 3403 write(6,*) ' imode = ',imode 3404 write(6,*) ' xinc = ',xinc 3405 write(6,*) ' luhss,luamp,luleqv: ',luhss,luamp,luleqv 3406 write(6,*) ' igtbmod,isymmet_G,igtb_closed,iopsym: ', 3407 & igtbmod,isymmet_G,igtb_closed,iopsym 3408 if (igtb_closed.ne.0) then 3409 write(6,*) 'n11amp, n33amp: ',n11amp,n33amp 3410 end if 3411 end if 3412 3413c if (imode.gt.1) igradmode=imode-1 3414 igradmode = 1 3415 3416 namp = n_cc_amp 3417 if (igtb_closed.eq.1) namp = n11amp+n33amp 3418 nloops = namp 3419 if (imode.eq.1) nloops = 1 3420 3421 ! rewind output file 3422 call rewino(luhss) 3423 3424* loop over elements in vector 3425 do iloop = 1, nloops 3426 3427 if (imode.ne.1.and.igtb_closed.ne.1.and.isymmet_G.ne.0) then 3428 if (iccvec(iloop).lt.0) cycle 3429 end if 3430 3431 if (ntest.ge.5) then 3432 write(6,*) 'iloop = ',iloop,'/',nloops 3433 end if 3434 3435 ! reload amplitudes 3436 if (igtb_closed.eq.0) then 3437 call vec_from_disc(ccvec1,namp,1,-1,luamp) 3438 else 3439 call vec_from_disc(ccvec2,namp,1,-1,luamp) 3440 end if 3441 3442* inc + xinc 3443 if (ntest.ge.10) then 3444 write(6,*) '------------------' 3445 write(6,*) 'positive increment' 3446 write(6,*) '------------------' 3447 end if 3448 call memchk2('zzz---') 3449 if (imode.eq.1.and.igtb_closed.eq.0) then 3450 call vec_from_disc(ccvec2,namp,1,-1,luleqv) 3451 if (ntest.ge.100.and.imode.eq.1) then 3452 xnorm = sqrt(inprod(ccvec2,ccvec2,namp)) 3453 write(6,*) ' norm of input vector = ',xnorm 3454 end if 3455 ccvec1(1:namp) = 3456 & ccvec1(1:namp)+xinc*ccvec2(1:namp) 3457 else if (imode.eq.1.and.igtb_closed.ne.0) then 3458 call vec_from_disc(ccvec1,namp,1,-1,luleqv) 3459 if (ntest.ge.100.and.imode.eq.1) then 3460 xnorm = sqrt(inprod(ccvec1,ccvec1,namp)) 3461 write(6,*) ' norm of input vector = ',xnorm 3462 end if 3463 ccvec2(1:namp) = 3464 & ccvec2(1:namp)+xinc*ccvec1(1:namp) 3465 else if (isymmet_G.eq.0) then 3466 ccvec1(iloop) = ccvec1(iloop) + xinc 3467 else if (isymmet_G.ne.0.and.igtb_closed.ne.0) then 3468 call memchk2('yyy---') 3469 ccvec2(iloop) = ccvec2(iloop) + xinc 3470 call memchk2('xxx---') 3471 else 3472 iadj = abs(iccvec(iloop)) 3473 fac = dble(isymmet_G) 3474 ccvec1(iloop) = ccvec1(iloop) + sqrt(2d0)*xinc 3475 ccvec1(iadj) = ccvec1(iadj) + fac*sqrt(2d0)*xinc 3476 end if 3477 3478 call memchk2('aaa---') 3479 3480 if (igtb_closed.ne.0) then 3481 iway = -1 3482 call pack_g(iway,idum,isymmet_G,ccvec2,ccvec1, 3483 & n_cc_typ,i_cc_typ,ioff_cc_typ, 3484 & n11amp,n33amp,iamp_packed,n_cc_amp) 3485 end if 3486 call memchk2('bbb---') 3487 3488 call gtbce_E(igtbmod,elen,variance,ovl, 3489 & ecore, 3490 & ccvec1,iopsym,ccvec4, 3491 & civec1,civec2,c2vec, 3492 & n_cc_amp,mxb_ci, 3493 & luc,luec,luhc,lusc1,lusc2) 3494 if (iomggrd.eq.0) then 3495 call gtbce_Omg(ccvec3,xnomg, 3496 & elen,ovl,iopsym, 3497 & civec1,civec2,c2vec, 3498 & n_cc_amp,mxb_ci, 3499 & luec,luhc,lusc1,lusc2) 3500 else 3501 ipr=0 3502 call gtbce_gradE(isymmet_G,ccvec3,xngrad,igradmode, 3503 & inumint,npnts, 3504 & elen,ovl, 3505 & ccvec1,iopsym,ccvec2,ccvec4, 3506 & civec1,civec2,c2vec, 3507 & n_cc_typ,i_cc_typ,ictp, 3508 & namp_cc_typ,ioff_cc_typ, 3509 & n_cc_amp,mxb_ci,ipr, 3510 & luamp,luc,luec,luhc, 3511 & lusc1,lusc2,lusc3,lusc4,lusc5,lusc6) 3512 end if 3513 3514* save 3515 if (ntest.ge.1000) then 3516 write (6,*) 'gradient for positive increment:' 3517 call wrt_cc_vec2(ccvec3,6,'GEN_CC') 3518 end if 3519 call vec_to_disc(ccvec3,n_cc_amp,1,lblk,lusc7) 3520 3521* inc - xinc 3522 if (ntest.ge.10) then 3523 write(6,*) '------------------' 3524 write(6,*) 'negative increment' 3525 write(6,*) '------------------' 3526 end if 3527 if (imode.eq.1.and.igtb_closed.eq.0) then 3528 call vec_from_disc(ccvec2,namp,1,-1,luleqv) 3529 ccvec1(1:namp) = 3530 & ccvec1(1:namp)-2d0*xinc*ccvec2(1:namp) 3531 else if (imode.eq.1.and.igtb_closed.eq.1) then 3532 call vec_from_disc(ccvec2,namp,1,-1,luamp) 3533 call vec_from_disc(ccvec1,namp,1,-1,luleqv) 3534 ccvec2(1:namp) = 3535 & ccvec2(1:namp)-2d0*xinc*ccvec1(1:namp) 3536 else if (isymmet_G.eq.0) then 3537 ccvec1(iloop) = ccvec1(iloop) - 2d0*xinc 3538 else if (isymmet_G.ne.0.and.igtb_closed.ne.0) then 3539 call vec_from_disc(ccvec2,namp,1,-1,luamp) 3540 ccvec2(iloop) = ccvec2(iloop) - xinc 3541 else 3542 iadj = abs(iccvec(iloop)) 3543 fac = dble(isymmet_G) 3544 ccvec1(iloop) = ccvec1(iloop) - 2d0*sqrt(2d0)*xinc 3545 ccvec1(iadj) = ccvec1(iadj) - fac*2d0*sqrt(2d0)*xinc 3546 end if 3547 3548 if (igtb_closed.ne.0) then 3549 iway = -1 3550 call pack_g(iway,idum,isymmet_G,ccvec2,ccvec1, 3551 & n_cc_typ,i_cc_typ,ioff_cc_typ, 3552 & n11amp,n33amp,iamp_packed,n_cc_amp) 3553 end if 3554 3555 call gtbce_E(igtbmod,elen,variance,ovl, 3556 & ecore, 3557 & ccvec1,iopsym,ccvec4, 3558 & civec1,civec2,c2vec, 3559 & n_cc_amp,mxb_ci, 3560 & luc,luec,luhc,lusc1,lusc2) 3561 if (iomggrd.eq.0) then 3562 call gtbce_Omg(ccvec3,xnomg, 3563 & elen,ovl,iopsym, 3564 & civec1,civec2,c2vec, 3565 & n_cc_amp,mxb_ci, 3566 & luec,luhc,lusc1,lusc2) 3567 else 3568 ipr=0 3569 call gtbce_gradE(isymmet_G,ccvec3,xngrad,igradmode, 3570 & inumint,npnts, 3571 & elen,ovl, 3572 & ccvec1,iopsym,ccvec2,ccvec4, 3573 & civec1,civec2,c2vec, 3574 & n_cc_typ,i_cc_typ,ictp, 3575 & namp_cc_typ,ioff_cc_typ, 3576 & n_cc_amp,mxb_ci,ipr, 3577 & luamp,luc,luec,luhc, 3578 & lusc1,lusc2,lusc3,lusc4,lusc5,lusc6) 3579 end if 3580 3581 if (ntest.ge.1000) then 3582 write (6,*) 'gradient for negative increment:' 3583 call wrt_cc_vec2(ccvec3,6,'GEN_CC') 3584 end if 3585 3586* get difference 3587 call vec_from_disc(ccvec2,n_cc_amp,1,lblk,lusc7) 3588 fac = 1d0/(2d0*xinc) 3589 call vecsum(ccvec3,ccvec3,ccvec2,-fac,fac,n_cc_amp) 3590 3591 if (ntest.ge.500) then 3592 write(6,*) 'result for iloop = ', iloop 3593 call wrt_cc_vec2(ccvec3,6,'GEN_CC') 3594 end if 3595 3596 if (isymmet_G.ne.0.and.igtb_closed.eq.0.and.imode.ne.1) then 3597 ! compress result vector 3598 idx = 0 3599 do ii = 1, n_cc_amp 3600 if (iccvec(ii).le.0) cycle 3601 idx = idx + 1 3602 ccvec2(idx) = 2d0*ccvec3(ii) 3603 end do 3604 if (idx.ne.nSdim) stop 'verdacht' 3605 call vec_to_disc(ccvec2,nSdim,0,lblk,luhss) 3606 else if (igtb_closed.ne.0) then 3607 iway = 2 3608 call pack_g(iway,idum,isymmet_G,ccvec1,ccvec3, 3609 & n_cc_typ,i_cc_typ,ioff_cc_typ, 3610 & n11amp,n33amp,iamp_packed,n_cc_amp) 3611 if (imode.eq.1.and.ntest.ge.100) then 3612 xnorm = sqrt(inprod(ccvec1,ccvec1,namp)) 3613 write(6,*) ' norm of MV-product: ',xnorm 3614 end if 3615 call vec_to_disc(ccvec1,namp,0,lblk,luhss) 3616 else 3617* save result 3618 if (imode.eq.1.and.ntest.ge.100) then 3619 xnorm = sqrt(inprod(ccvec3,ccvec3,n_cc_amp)) 3620 write(6,*) ' norm of MV-product: ',xnorm 3621 end if 3622c if (imode.eq.1) call scalve(ccvec3,-1d0,n_cc_amp) 3623 call vec_to_disc(ccvec3,n_cc_amp,0,lblk,luhss) 3624 end if 3625 3626 end do 3627 3628 if (ntest.gt.0) then 3629 write(6,*) '======================' 3630 write(6,*) ' END OF gtbce_num2drv' 3631 write(6,*) '======================' 3632 end if 3633 3634 return 3635 3636 end 3637*--------------------------------------------------------------------* 3638*--------------------------------------------------------------------* 3639* DECK: gtbce_foo 3640*--------------------------------------------------------------------* 3641 subroutine gtbce_foo_old(inumint,npnts, 3642 & ovl, 3643 & ccvec1,iopsym,comm_ops, 3644 & ccvec2,ccvec3, 3645 & civec1,civec2,c2vec, 3646 & n_cc_amp,mxb_ci, 3647 & lufoo, 3648 & luamp,luc,luec,luhc, 3649 & lusc1,lusc2,lusc3,lusc4, 3650 & lusc5,lusc6,lusc7,lusc8) 3651*--------------------------------------------------------------------* 3652* 3653* purpose: Calculate the overlap of the first order wavefunction 3654* change 3655* 3656* S_ij = N <0|(d/dg_i exp(G^+))(d/dg_j exp(G))|0> 3657* 3658* ak, early 2004 3659* 3660*--------------------------------------------------------------------* 3661* diverse inludes with commons and paramters 3662c include 'implicit.inc' 3663c include 'mxpdim.inc' 3664 include 'wrkspc.inc' 3665 include 'gtbce.inc' 3666* debugging: 3667 integer, parameter :: ntest = 000 3668 logical, parameter :: tstgrad = .false. 3669 3670* input/output arrays 3671 logical comm_ops 3672 integer, intent(in) :: 3673 & inumint, npnts 3674* scratch arrays 3675 real*8 civec1(mxb_ci),civec2(mxb_ci),c2vec(*), 3676 & ccvec1(n_cc_amp), ccvec2(n_cc_amp), ccvec3(n_cc_amp) 3677* local arrays 3678 character*8 cctype 3679 real*8 alp(npnts+2), wght(npnts+2) 3680* external functions 3681 real*8 inprod, inprdd 3682 3683 call atim(cpu0,wall0) 3684 3685 lblk = -1 3686 if (ntest.ge.5) then 3687 write (6,*) '=====================' 3688 write (6,*) ' This is gtbce_foo (old)' 3689 write (6,*) '=====================' 3690 write (6,*) 3691 write (6,*) 'on entry: ' 3692 write (6,*) 'inumint, npnts : ', inumint, npnts 3693 write (6,*) 'ovl, elen: ',ovl 3694 write (6,*) 'n_cc_amp,mxb_ci : ', n_cc_amp,mxb_ci 3695 write (6,*) 'luc,luec,luhc,lusc1,lusc2: ', 3696 & luc,luec,luhc,lusc1,lusc2 3697 end if 3698 if (ntest.ge.1000) then 3699 write(6,*) 'on entry:' 3700 write(6,*) '|0> on LUC' 3701 call wrtvcd(civec1,luc,1,lblk) 3702 write(6,*) 'e^G|0> on LUEC' 3703 call wrtvcd(civec1,luec,1,lblk) 3704 end if 3705 3706 ! for I/O 3707 lblk = -1 3708 ! for expt_ref 3709 thresh=expg_thrsh 3710 mx_term=-mxterm_expg 3711 cctype='GEN_CC' 3712*--------------------------------------------------------------------* 3713* set up points and weights 3714*--------------------------------------------------------------------* 3715 select case (inumint) 3716 case (0) ! just testing 3717 do ipnt = 1, npnts 3718 alp(ipnt) = dble(ipnt-1)/dble(npnts-1) 3719 wght(ipnt) = 1d0 3720 end do 3721 case (1) ! Gauss-Legendre 3722 call gl_weights(0d0,1d0,npnts,alp,wght) 3723 case (2) ! Simpson 3724c if (mod(npnts,2).eq.0) npnts = npnts-1 3725 call s_weights(0d0,1d0,npnts,alp,wght) 3726 case default 3727 stop 'unknown inumint in gtbce_foo' 3728 end select 3729 3730 mxpnts=npnts 3731 ! if G == 0 ... 3732 xnrm2 = inprod(ccvec1,ccvec1,n_cc_amp) 3733 ! ... things are trivial and we evaluate the formula only once 3734c comm_ops = .false. 3735 if (xnrm2.lt.10d-20.or.comm_ops) then 3736 mxpnts=1 3737 wght(1)=1d0 3738 alp(1)=0.0d0 3739 if (ntest.ge.5) then 3740 write(6,*) 'Detected zero amplitudes: ', 3741 & 'only case alpha = 0 will be processed' 3742 end if 3743 end if 3744 3745 ! rewind output file 3746 call rewino(lufoo) 3747 3748**-------------------------------------------------------------------* 3749* loop i over parameters 3750**-------------------------------------------------------------------* 3751 do iamp = 1, n_cc_amp 3752 if (ntest.ge.10) write(6,*) 'iamp = ',iamp,'/',n_cc_amp 3753 3754 ! reset |0tilde> = exp(G)|0> 3755 call copvcd(luec,lusc1,civec1,1,lblk) 3756 3757**-------------------------------------------------------------------* 3758* loop over quadrature points 3759**-------------------------------------------------------------------* 3760 do ipnt = 1, mxpnts 3761 if (ntest.ge.5) then 3762 write(6,*) 'info for quadrature point: ', ipnt,'/',npnts 3763 write(6,*) 'point, weight: ', alp(ipnt), wght(ipnt) 3764 end if 3765 3766 if (ipnt.gt.1.and.(alp(ipnt).le.alp(ipnt-1))) then 3767 write(6,*) 'quadrature points should be in ascending order!' 3768 stop 'gtbce_foo > quadrature ' 3769 end if 3770 3771 if (ipnt.eq.1) then 3772 dltalp = -alp(1) 3773 else 3774 dltalp = -alp(ipnt)+alp(ipnt-1) 3775 end if 3776*--------------------------------------------------------------------* 3777* |a_i>(1) = exp(-a_i G) [exp(G)|0>] 3778* = exp(-(a_i-a_{i-1})G) exp(-a_{i-1} G) [exp(G)|0>] 3779* result on lusc2 3780*--------------------------------------------------------------------* 3781 if (ntest.ge.5) then 3782 write(6,*) 3783 & 'constructing |a_i> = exp(-a_i G^+) exp(G)|0>]' 3784 end if 3785 3786 if (abs(dltalp).lt.1d-20) then 3787 call copvcd(lusc1,lusc2,civec1,1,lblk) 3788 else 3789 ! get G on ccvec2 3790 call copvec(ccvec1,ccvec2,n_cc_amp) 3791 ! and scale it 3792 call scalve(ccvec2,dltalp,n_cc_amp) 3793 call expt_ref2(lusc1,lusc2,lusc4,lusc5,lusc6, 3794 & thresh,mx_term, ccvec2, ccvec3, civec1, civec2, 3795 & n_cc_amp,cctype, iopsym) 3796 if (ntest.ge.5) then 3797 xnrm = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 3798 etest = inprdd(civec1,civec2,luc,lusc2,1,lblk) 3799 write(6,*) '|dlta G^+|, dlta = ',xnrm, dltalp 3800 write(6,*) '<ref|a_i> = ', etest, 3801 & 'for alp(i) = ', alp(ipnt) 3802 end if 3803 ! save for next round 3804 call copvcd(lusc2,lusc1,civec1,1,lblk) 3805 end if 3806 3807*--------------------------------------------------------------------* 3808* |a_i(ii)>(2) = tau_ii exp(-a_i G)[exp(G)|0>] 3809* result on lusc3 3810*--------------------------------------------------------------------* 3811 ccvec2(1:n_cc_amp) = 0d0 3812 ccvec2(iamp) = 1d0 3813 isigden=1 3814 call sigden_cc(civec1,civec2,lusc2,lusc3,ccvec2,isigden) 3815 if (iopsym.ne.0) then 3816 fac = dble(iopsym) 3817 call conj_ccamp(ccvec2,1,ccvec3) 3818 call conj_t 3819 call sigden_cc(civec1,civec2,lusc2,lusc4,ccvec3,isigden) 3820 call conj_t 3821 call vecsmdp(civec1,civec2,1d0,fac,lusc3,lusc4,lusc5,1,lblk) 3822 call copvcd(lusc5,lusc3,civec1,1,lblk) 3823 end if 3824 3825*--------------------------------------------------------------------* 3826* |a_i(ii)>(3) = exp(a_i G) tau_ii exp(-a_i G)[exp(G)|0>] 3827* result on lusc2 again 3828*--------------------------------------------------------------------* 3829 if (abs(alp(ipnt)).lt.1d-20) then 3830 call copvcd(lusc3,lusc2,civec1,1,lblk) 3831 else 3832 ! get G on ccvec2 3833 call copvec(ccvec1,ccvec2,n_cc_amp) 3834 ! and scale it 3835 call scalve(ccvec2,alp(ipnt),n_cc_amp) 3836 call expt_ref2(lusc3,lusc2,lusc4,lusc5,lusc6, 3837 & thresh,mx_term, ccvec2, ccvec3, civec1, civec2, 3838 & n_cc_amp,cctype, iopsym) 3839 if (ntest.ge.5) then 3840 xnrm = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 3841 etest = inprdd(civec1,civec2,luc,lusc2,1,lblk) 3842 write(6,*) '|alp(i) G^+|, alp(i) = ',xnrm, alp(ipnt) 3843 write(6,*) '<ref|a_i> = ', etest, 3844 & 'for alp(i) = ', alp(ipnt) 3845 end if 3846 end if 3847 3848 if (ntest.ge.2000) then 3849 write (6,*) 'contribution to 1st derivative of ', 3850 & 'wavefunction, element ',iamp,alp(ipnt) 3851 call wrtvcd(civec1,lusc2,1,lblk) 3852 end if 3853 3854 ! update result on lusc8 3855 if (ipnt.gt.1) then 3856 call vecsmdp(civec1,civec2,1d0,wght(ipnt),lusc8,lusc2, 3857 & lusc4,1,lblk) 3858 call copvcd(lusc4,lusc8,civec1,1,lblk) 3859 else 3860 call sclvcd(lusc2,lusc8,wght(ipnt),civec1,1,lblk) 3861 end if 3862 3863 end do ! loop over quadrature 3864 3865c TEST compare with numerical wavefunction derivative: 3866 itest = 1 3867 if (itest.eq.1) then 3868 xinc = 1d-4 3869 call copvec(ccvec1,ccvec2,n_cc_amp) 3870 ccvec2(iamp) = ccvec2(iamp)+xinc 3871 call expt_ref2(luc,lusc2,lusc4,lusc5,lusc6, 3872 & thresh,mx_term, ccvec2, ccvec3, civec1, civec2, 3873 & n_cc_amp,cctype, iopsym) 3874 call copvec(ccvec1,ccvec2,n_cc_amp) 3875 ccvec2(iamp) = ccvec2(iamp)-xinc 3876 call expt_ref2(luc,lusc3,lusc4,lusc5,lusc6, 3877 & thresh,mx_term, ccvec2, ccvec3, civec1, civec2, 3878 & n_cc_amp,cctype, iopsym) 3879 fac=1d0/(2d0*xinc) 3880 call vecsmdp(civec1,civec2,fac,-fac,lusc2,lusc3, 3881 & lusc4,1,lblk) 3882 print *,'===============================================' 3883 print *,' RESULT for iamp = ',iamp 3884 print *,' analytic 1st der. of WF: norm = ', 3885 & sqrt(inprdd(civec1,civec2,lusc8,lusc8,1,lblk)) 3886 print *,' numeric 1st der. of WF: norm = ', 3887 & sqrt(inprdd(civec1,civec2,lusc4,lusc4,1,lblk)) 3888 print *,' calling compare routine:' 3889 call cmp2vcd(civec1,civec2,lusc4,lusc8,1d-10,1,lblk) 3890 print *,'===============================================' 3891 end if 3892c TEST 3893 if (ntest.ge.1000) then 3894 write (6,*) '1st derivative of wavefunction, element ',iamp 3895 call wrtvcd(civec1,lusc8,1,lblk) 3896 end if 3897 3898 3899 ! rewind file with old |a(ii)> 3900 call rewino(lusc7) 3901 3902 ccvec2(1:iamp) = 0d0 3903 do jamp = 1, iamp-1 3904 call rewino(lusc8) 3905 sij = inprdd(civec1,civec2,lusc7,lusc8,0,lblk) 3906 if (ntest.ge.1000) write(6,*) iamp,jamp,': sij =',sij 3907 ccvec2(jamp) = sij 3908 end do 3909 sii = inprdd(civec1,civec2,lusc8,lusc8,1,lblk) 3910 if (ntest.ge.1000) write(6,*) iamp,iamp,': sii =',sii 3911 ccvec2(iamp) = sii 3912 call rewino(lusc8) 3913 ! append as last record 3914 call copvcd(lusc8,lusc7,civec1,0,lblk) 3915 call vec_to_disc(ccvec2,iamp,0,lblk,lufoo) 3916 3917 end do ! loop over iamp 3918 3919 call atim(cpu,wall) 3920 call prtim(6,'time in gtbce_foo',cpu-cpu0,wall-wall0) 3921 3922 return 3923 end 3924*--------------------------------------------------------------------* 3925*--------------------------------------------------------------------* 3926* DECK: gtbce_foo 3927*--------------------------------------------------------------------* 3928 subroutine gtbce_foo(igtb_closed_al,isymmet_G,irest, 3929c !!!!!!!!!!!!!!!!!!!!!!!!!^^^^^^^^^^^^^^!!!!!!!!!!!!!!!!!!!!! 3930 & inumint,npnts, 3931 & ovl, 3932 & iccvec,nsdim, 3933 & ccvec1,iopsym,comm_ops, 3934 & ccvec2,ccvec3, 3935 & civec1,civec2,c2vec, 3936 & n_cc_typ,i_cc_typ,ictp, 3937 & namp_cc_typ,ioff_cc_typ, 3938 & n_cc_amp,mxb_ci, 3939 & n11amp,n33amp,iamp_packed, 3940 & lufoo, 3941 & luamp,luc,luec,luhc, 3942 & lusc1,lusc2,lusc3,lusc4, 3943 & lusc5,lusc6,lusc7,lusc8, 3944 & lusc9,lusc10) 3945*--------------------------------------------------------------------* 3946* 3947* purpose: Calculate the overlap of the first order wavefunction 3948* change 3949* 3950* S_ij = N <0|(d/dg_i exp(G^+))(d/dg_j exp(G))|0> 3951* 3952* ak, early 2004 3953* 3954*--------------------------------------------------------------------* 3955* diverse inludes with commons and paramters 3956c include 'implicit.inc' 3957c include 'mxpdim.inc' 3958 include 'wrkspc.inc' 3959 include 'gtbce.inc' 3960* debugging: 3961 integer, parameter :: ntest = 50 3962 logical, parameter :: tstrgad = .false. 3963 3964* input/output arrays 3965 logical comm_ops 3966 integer iccvec(n_cc_amp) 3967 integer, intent(in) :: 3968 & inumint, npnts 3969* scratch arrays 3970 character*8 cctype 3971 real*8 civec1(mxb_ci),civec2(mxb_ci),c2vec(*), 3972 & ccvec1(n_cc_amp), ccvec2(n_cc_amp), ccvec3(n_cc_amp) 3973* local arrays 3974 real*8 alp(npnts+2), wght(npnts+2) 3975* external functions 3976 real*8 inprod, inprdd 3977 3978 call atim(cpu0,wall0) 3979 3980 iamp_rst = 0 3981 if (irest.gt.0) then 3982 iamp_rst = irest 3983 else 3984 if (isymmet_G.ne.0) 3985 & iccvec(1:n_cc_amp) = 0 3986 end if 3987 3988 lblk = -1 3989 if (ntest.ge.5) then 3990 write (6,*) '=====================' 3991 write (6,*) ' This is gtbce_foo ' 3992 write (6,*) '=====================' 3993 write (6,*) 3994 write (6,*) 'on entry: ' 3995 write (6,*) 'igtb_closed, isymmet_G: ', 3996 & igtb_closed, isymmet_G 3997 write (6,*) 'inumint, npnts : ', inumint, npnts 3998 write (6,*) 'iopsym: ',iopsym 3999 write (6,*) 'n_cc_amp,mxb_ci : ', n_cc_amp,mxb_ci 4000 write (6,*) 'luc,luec,luhc,lusc1,lusc2: ', 4001 & luc,luec,luhc,lusc1,lusc2 4002 write (6,*) 'lusc3,lusc4,lusc5,lusc6,lusc7,lusc8,lusc9: ', 4003 & lusc3,lusc4,lusc5,lusc6,lusc7,lusc8,lusc9 4004 end if 4005 if (ntest.ge.1000) then 4006 write(6,*) 'on entry:' 4007 write(6,*) 'e^G|0> on LUEC' 4008 call wrtvcd(civec1,luec,1,lblk) 4009 end if 4010 4011 ! for I/O 4012 lblk = -1 4013 ! for expt_ref 4014 thresh=expg_thrsh 4015 mx_term=-mxterm_expg 4016 cctype='GEN_CC' 4017*--------------------------------------------------------------------* 4018* set up points and weights 4019*--------------------------------------------------------------------* 4020 select case (inumint) 4021 case (0) ! just testing 4022 do ipnt = 1, npnts 4023 alp(ipnt) = dble(ipnt-1)/dble(npnts-1) 4024 wght(ipnt) = 1d0 4025 end do 4026 case (1) ! Gauss-Legendre 4027 call gl_weights(0d0,1d0,npnts,alp,wght) 4028 case (2) ! Simpson 4029c if (mod(npnts,2).eq.0) npnts = npnts-1 4030 call s_weights(0d0,1d0,npnts,alp,wght) 4031 case default 4032 stop 'unknown inumint in gtbce_foo' 4033 end select 4034 4035 call vec_from_disc(ccvec1,n_cc_amp,1,-1,luamp) 4036 mxpnts=npnts 4037 ! if G == 0 ... 4038 xnrm2 = inprod(ccvec1,ccvec1,n_cc_amp) 4039 ! ... we have a set of commuting operators 4040 ! things are trivial and we evaluate the formula only once 4041 if (xnrm2.lt.10d-20.or.comm_ops) then 4042 mxpnts=1 4043 wght(1)=1d0 4044 alp(1)=0d0 4045 if (ntest.ge.5.and..not.comm_ops) then 4046 write(6,*) 'Detected zero amplitudes: ', 4047 & 'only case alpha = 0 will be processed' 4048 end if 4049 end if 4050 4051 ! rewind output file 4052 call rewino(lufoo) 4053 4054 if (iamp_rst.gt.0) then 4055 4056 write(6,*) 'position unit ',lufoo,' after record ',iamp_rst 4057 call flush(6) 4058 call skpvcd(lufoo,iamp_rst,ccvec2,1,lblk) 4059 4060 end if 4061 4062 nsdim = 0 4063 mxperbatch = 50 4064 nbatch = n_cc_amp/mxperbatch 4065 if (mod(n_cc_amp,mxperbatch).gt.0) nbatch = nbatch+1 4066**-------------------------------------------------------------------* 4067* loop i over parameters in batches 4068**-------------------------------------------------------------------* 4069 do ibatch = 1, nbatch 4070 namp = mxperbatch 4071 if (ibatch.eq.nbatch) namp = n_cc_amp - mxperbatch*(nbatch-1) 4072 ista = (ibatch-1)*mxperbatch+1 4073 iend = (ibatch-1)*mxperbatch+namp 4074 4075 if (iamp_rst.ne.0) then 4076 if (iend.lt.iamp_rst+1) then 4077 cycle 4078 else if (ista.le.iamp_rst+1) then 4079 ista = iamp_rst+1 4080 iamp_rst = 0 4081 write(6,*) 'restarting calculation from amplitude ',ista 4082 else 4083 write(6,*) 'error: ',ista,iend,iamp_rst 4084 stop 'impossible things happen sometimes ....' 4085 end if 4086 end if 4087 4088 if (isymmet_G.ne.0) then 4089 iskip = 1 4090 do iamp = ista,iend 4091 if (iccvec(iamp).eq.0) then 4092 iskip = 0 4093 exit 4094 end if 4095 end do 4096 if (iskip.eq.1) cycle 4097 end if 4098c do iamp = 1, n_cc_amp 4099 if (ntest.ge.10) write(6,*) 'batch, start, end ', 4100 & ibatch,ista,iend 4101 4102 ! reset |0tilde> = exp(G)|0> 4103 call copvcd(luec,lusc1,civec1,1,lblk) 4104 4105**-------------------------------------------------------------------* 4106* loop over quadrature points 4107**-------------------------------------------------------------------* 4108 do ipnt = 1, mxpnts 4109 if (ntest.ge.50) then 4110 write(6,*) 'info for quadrature point: ', ipnt,'/',npnts 4111 write(6,*) 'point, weight: ', alp(ipnt), wght(ipnt) 4112 end if 4113 4114 if (ipnt.gt.1.and.(alp(ipnt).le.alp(ipnt-1))) then 4115 write(6,*) 'quadrature point should be in ascending order!' 4116 stop 'gtbce_foo > quadrature ' 4117 end if 4118 4119 if (ipnt.eq.1) then 4120 dltalp = -alp(1) 4121 else 4122 dltalp = -alp(ipnt)+alp(ipnt-1) 4123 end if 4124*--------------------------------------------------------------------* 4125* |a_i>(1) = exp(-a_i G) [exp(G)|0>] 4126* = exp(-(a_i-a_{i-1})G) exp(-a_{i-1} G) [exp(G)|0>] 4127* result on lusc2 4128*--------------------------------------------------------------------* 4129 if (ntest.ge.50) then 4130 write(6,*) 4131 & 'constructing |a_i> = exp(-a_i G^+) exp(G)|0>]' 4132 end if 4133 4134 if (abs(dltalp).lt.1d-20) then 4135 call copvcd(lusc1,lusc2,civec1,1,lblk) 4136 else 4137 ! get G on ccvec2 4138 call copvec(ccvec1,ccvec2,n_cc_amp) 4139 ! and scale it 4140 call scalve(ccvec2,dltalp,n_cc_amp) 4141 call expt_ref2(lusc1,lusc2,lusc4,lusc5,lusc6, 4142 & thresh,mx_term, ccvec2, ccvec3, civec1, civec2, 4143 & n_cc_amp,cctype, iopsym) 4144 if (ntest.ge.100) then 4145 xnrm = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 4146 etest = inprdd(civec1,civec2,luc,lusc2,1,lblk) 4147 write(6,*) '|dlta G^+|, dlta = ',xnrm, dltalp 4148 write(6,*) '<ref|a_i> = ', etest, 4149 & 'for alp(i) = ', alp(ipnt) 4150 end if 4151 ! save for next round 4152 call copvcd(lusc2,lusc1,civec1,1,lblk) 4153 end if 4154 4155*--------------------------------------------------------------------* 4156* |a_i(ii)>(2) = tau_ii exp(-a_i G)[exp(G)|0>] for each paramter in batch 4157* result on lusc3 4158*--------------------------------------------------------------------* 4159 call rewino(lusc8) 4160 call rewino(lusc9) 4161 4162 ! alternate units to collect contributions 4163 ! the final result is on lunew in the end 4164 if (ipnt.eq.1) then 4165 lunew = lusc8 4166 luold = lusc9 4167 else 4168 if (lunew.eq.lusc8) then 4169 lunew = lusc9 4170 luold = lusc8 4171 else 4172 lunew = lusc8 4173 luold = lusc9 4174 end if 4175 end if 4176 4177 if (ntest.ge.50) then 4178 write(6,*) 4179 & 'constructing |a_i> = exp((1-a_i) G^+)tau_i '// 4180 & 'exp(-a_i G^+) exp(G)|0>]' 4181 end if 4182 do iamp = ista, iend 4183 if (ntest.ge.50) then 4184 write (6,*) 'batch: ',ibatch,' iamp = ',iamp 4185 4186 if (isymmet_G.ne.0) then 4187 if (ntest.ge.50) 4188 & write(6,*) ' iccvec(iamp): ', 4189 & iamp,iccvec(iamp) 4190 if (ntest.ge.50.and.iccvec(iamp).lt.0) 4191 & write(6,*) ' this amplitude is skipped' 4192 if (iccvec(iamp).lt.0) cycle 4193 end if 4194 end if 4195 ccvec2(1:n_cc_amp) = 0d0 4196 ccvec2(iamp) = 1d0 4197 if (isymmet_G.ne.0) then 4198 ! (anti-)symmetrize 4199 call symmet_t(isymmet_G,1, 4200 & ccvec2,ccvec3, 4201 & ictp,i_cc_typ,n_cc_typ, 4202 & namp_cc_typ,ioff_cc_typ,ngas) 4203 ! if not already marked, do that now: 4204 if (iccvec(iamp).eq.0) then 4205 ! remains non-vanishing amplitude afterwards? 4206 if (abs(inprod(ccvec2,ccvec2,n_cc_amp)).lt.1d-12) then 4207 if (ntest.ge.100) 4208 & write(6,*) ' aha, amplitude was diagonal! skipped' 4209 iccvec(iamp) = -iamp 4210 cycle 4211 end if 4212 if (ntest.ge.50) 4213 & write(6,*) ' this amplitude is taken' 4214 4215 if (abs(abs(ccvec2(iamp)-1d0)).lt.1d-12) then 4216 iccvec(iamp) = iamp 4217 if (ntest.ge.50) then 4218 write(6,*) ' iamp, counterpart : ',iamp,iamp 4219 end if 4220 else 4221 ! mark counterpart as inactive 4222 do ii = iamp+1, n_cc_amp 4223 if (abs(abs(ccvec2(ii))-0.5d0).lt.1d-12) then 4224 if (ntest.ge.50) then 4225 write(6,*) ' iamp, counterpart : ',iamp,ii 4226 end if 4227 iccvec(ii) = -iamp 4228 iccvec(iamp) = ii 4229 exit 4230 end if 4231 end do 4232 end if 4233 nsdim = nsdim + 1 4234 end if 4235 end if 4236 4237 isigden=1 4238 if (iopsym.eq.0) then 4239 call sigden_cc(civec1,civec2,lusc2,lusc3,ccvec2,isigden) 4240 else 4241 call sigden_cc(civec1,civec2,lusc2,lusc4,ccvec2,isigden) 4242 fac = dble(iopsym) 4243 call conj_ccamp(ccvec2,1,ccvec3) 4244 call conj_t 4245 call sigden_cc(civec1,civec2,lusc2,lusc5,ccvec3,isigden) 4246 call conj_t 4247 call vecsmdp(civec1,civec2,1d0,fac, 4248 & lusc4,lusc5,lusc3,1,lblk) 4249 end if 4250 4251*--------------------------------------------------------------------* 4252* |a_i(ii)>(3) = exp(a_i G) tau_ii exp(-a_i G)[exp(G)|0>] 4253* result on lusc4 4254*--------------------------------------------------------------------* 4255 if (abs(alp(ipnt)).lt.1d-20) then 4256 call copvcd(lusc3,lusc4,civec1,1,lblk) 4257 else 4258 ! get G on ccvec2 4259 call copvec(ccvec1,ccvec2,n_cc_amp) 4260 ! and scale it 4261 call scalve(ccvec2,alp(ipnt),n_cc_amp) 4262 call expt_ref2(lusc3,lusc4,lusc5,lusc6,lusc10, 4263 & thresh,mx_term, ccvec2, ccvec3, civec1, civec2, 4264 & n_cc_amp,cctype, iopsym) 4265 if (ntest.ge.100) then 4266 xnrm = sqrt(inprod(ccvec2,ccvec2,n_cc_amp)) 4267 etest = inprdd(civec1,civec2,luc,lusc4,1,lblk) 4268 write(6,*) '|alp(i) G^+|, alp(i) = ',xnrm, alp(ipnt) 4269 write(6,*) '<ref|a_i> = ', etest, 4270 & 'for alp(i) = ', alp(ipnt) 4271 end if 4272 end if 4273 4274 if (ntest.ge.2000) then 4275 write (6,*) 'contribution to 1st derivative of ', 4276 & 'wavefunction, element ',iamp,alp(ipnt) 4277 call wrtvcd(civec1,lusc4,1,lblk) 4278 end if 4279 4280 ! add lusc4 to luold giving lunew 4281 if (ipnt.eq.1) then 4282 call rewino(lusc4) 4283 call sclvcd(lusc4,lunew,wght(ipnt),civec1,0,lblk) 4284 else 4285 call rewino(lusc4) 4286 call vecsmdp(civec1,civec2,1d0,wght(ipnt), 4287 & luold,lusc4,lunew,0,lblk) 4288 end if 4289 end do ! loop over iamp 4290 4291 end do ! loop over quadrature 4292 4293 call rewino(lunew) 4294 do iamp = ista, iend 4295 ! rewind file with old |a(ii)> 4296 if (isymmet_G.ne.0) then 4297 if (ntest.ge.100) 4298 & write(6,*) ' iamp, iccvec(iamp): ',iamp,iccvec(iamp) 4299 if (iccvec(iamp).le.0) cycle 4300 if (ntest.ge.100) 4301 & write(6,*) ' taken! ' 4302 end if 4303 call rewino(lusc7) 4304 4305c call skpvcd(lunew,iamp-ista,civec1,1,lblk) 4306 call rewino(lusc3) 4307 4308 call copvcd(lunew,lusc3,civec1,0,lblk) 4309 4310 if (ntest.ge.1000) then 4311 write (6,*) '1st derivative of wavefunction, element ',iamp 4312 call wrtvcd(civec1,lusc3,1,lblk) 4313 end if 4314 4315 ccvec2(1:iamp) = 0d0 4316 icnt = 0 4317 ! get the lunew/lusc7 contrib to Sij 4318 do jamp = 1, iamp-1 4319 if (isymmet_G.ne.0) then 4320 if (ntest.ge.100) 4321 & write(6,*) ' jamp, iccvec(jamp): ',jamp,iccvec(jamp) 4322 if (iccvec(jamp).le.0) cycle 4323 if (ntest.ge.100) 4324 & write(6,*) ' taken! ' 4325 end if 4326 icnt = icnt + 1 4327 call rewino(lusc3) 4328 sij = inprdd(civec1,civec2,lusc3,lusc7,0,lblk) 4329 if (ntest.ge.100) write(6,*) iamp,jamp,': sij =',sij 4330 ccvec2(icnt) = sij 4331c ccvec2(jamp) = sij 4332 end do 4333 ! get the lunew/lunew contrib to Sij 4334 sii = inprdd(civec1,civec2,lusc3,lusc3,1,lblk) 4335 if (ntest.ge.100) write(6,*) iamp,iamp,': sii =',sii 4336 icnt = icnt+1 4337 ccvec2(icnt) = sii 4338c ccvec2(iamp) = sii 4339 ! append vector iamp a last record on lusc7 4340 call rewino(lusc3) 4341 call copvcd(lusc3,lusc7,civec1,0,lblk) 4342 4343 call vec_to_disc(ccvec2,icnt,0,lblk,lufoo) 4344c call vec_to_disc(ccvec2,iamp,0,lblk,lufoo) 4345 4346 end do ! loop over iamp within batch 4347 4348 end do ! loop over batches of iamp 4349 4350 if (isymmet_G.eq.0) nsdim = n_cc_amp 4351 if (ntest.ge.50) then 4352 write(6,*) 'dimension: ',nsdim 4353 end if 4354 4355 call atim(cpu,wall) 4356 call prtim(6,'time in gtbce_foo',cpu-cpu0,wall-wall0) 4357 4358 return 4359 end 4360*--------------------------------------------------------------------* 4361 subroutine mk_iccvec(isymmet_G,lufoo,irest, 4362 & iccvec,nSdim,ccvec1,ccvec2, 4363 & n_cc_typ,i_cc_typ,ictp, 4364 & namp_cc_typ,ioff_cc_typ,ngas, 4365 & n_cc_amp) 4366*--------------------------------------------------------------------* 4367* set up iccvec array and nsdim for restarts 4368*--------------------------------------------------------------------* 4369 implicit none 4370 4371 integer, parameter :: 4372 & ntest = 100 4373 4374 integer, intent(in) :: 4375 & lufoo, 4376 & isymmet_G,n_cc_amp,ngas,n_cc_typ(*),i_cc_typ(*),ictp(*), 4377 & namp_cc_typ(*),ioff_cc_typ(*) 4378 4379 integer, intent(out) :: 4380 & iccvec(n_cc_amp), nSdim 4381 4382 integer, intent(inout) :: 4383 & irest 4384 4385 real(8), intent(inout) :: 4386 & ccvec1(n_cc_amp), ccvec2(n_cc_amp) 4387 4388 logical :: 4389 & testrec 4390 4391 integer :: 4392 & iamp, ii, ierr 4393 4394 real(8), external :: 4395 & inprod 4396 4397 nsdim = 0 4398 testrec = irest.ne.0 4399 if (irest.ne.0) call rewino(lufoo) 4400 iccvec(1:n_cc_amp) = 0 4401 do iamp = 1, n_cc_amp 4402 if (ntest.ge.100) 4403 & write(6,*) ' iccvec(iamp): ', 4404 & iamp,iccvec(iamp) 4405 if (iccvec(iamp).eq.0) then 4406 ccvec1(1:n_cc_amp) = 0d0 4407 ccvec1(iamp) = 1d0 4408 ! (anti-)symmetrize 4409 call symmet_t(isymmet_G,1, 4410 & ccvec1,ccvec2, 4411 & ictp,i_cc_typ,n_cc_typ, 4412 & namp_cc_typ,ioff_cc_typ,ngas) 4413 ! remains non-vanishing amplitude afterwards? 4414 if (abs(inprod(ccvec1,ccvec1,n_cc_amp)).lt.1d-12) then 4415 if (ntest.ge.100) 4416 & write(6,*) ' aha, amplitude was diagonal! skipped' 4417 iccvec(iamp) = -iamp 4418 cycle 4419 end if 4420 ! if requested, test whether this record is present on lufoo 4421 if (testrec) then 4422 call vec_from_disc_e(ccvec2,nsdim+1,0,-1,lufoo,ierr) 4423 if (ierr.eq.2) write(6,*) 'I/O-error detected :-(' 4424 if (ierr.eq.1) write(6,*) 'EOF detected :-|' 4425 if (ierr.eq.0) write(6,*) 'record is fine :-)' 4426 if (ierr.ne.0) then 4427 irest = nsdim 4428 testrec = .false. 4429 else 4430 irest = nsdim+1 4431 end if 4432 end if 4433 4434 if (abs(abs(ccvec1(iamp)-1d0)).lt.1d-12) then 4435 nsdim = nsdim + 1 4436 iccvec(iamp) = iamp 4437 if (ntest.ge.100) then 4438 write(6,*) ' iamp, counterpart : ',iamp,iamp 4439 end if 4440 else 4441 ! mark counterpart as inactive 4442 nsdim = nsdim + 1 4443 do ii = iamp+1, n_cc_amp 4444 if (abs(abs(ccvec1(ii))-0.5d0).lt.1d-12) then 4445 if (ntest.ge.100) then 4446 write(6,*) ' iamp, counterpart : ',iamp,ii 4447 end if 4448 iccvec(ii) = -iamp 4449 iccvec(iamp) = ii 4450 exit 4451 end if 4452 end do 4453 end if 4454 end if 4455 4456 end do 4457 4458 if (ntest.ge.100) write(6,*) 'dimension of S: ',nSdim 4459 4460 return 4461 4462 end 4463*--------------------------------------------------------------------* 4464* DECK: gtbce_anahss 4465*--------------------------------------------------------------------* 4466 subroutine gtbce_anahss(hessi,luhss,ludia,istmode, 4467 & n_cc_amp,n_cc_typ,i_cc_typ, 4468 & namp_cc_typ,ioff_cc_typ,iopsym) 4469*--------------------------------------------------------------------* 4470* 4471* analyze a 2nd derivative matrix: 4472* print blocks and get eigenvalues 4473* 4474* istmode: 1 -- full matrix on file (one column per block) 4475* 2 -- upper triangle on file (one column up to diagonal 4476* per block) 4477*--------------------------------------------------------------------* 4478c include 'implicit.inc' 4479c include 'mxpdim.inc' 4480 include 'wrkspc.inc' 4481* constants 4482 integer, parameter :: 4483 & ntest = 100 4484 4485* external functions 4486 real*8 inprod, inprdd 4487 4488* input 4489 integer, intent(in) :: 4490 & i_cc_typ(n_cc_typ), namp_cc_typ(n_cc_typ), 4491 & ioff_cc_typ(n_cc_typ) 4492 real*8, intent(inout) :: 4493 & hessi(n_cc_amp,n_cc_amp) 4494 4495 lblk = -1 4496 4497* read file luhss 4498 call rewino(luhss) 4499 hessi(1:n_cc_amp,1:n_cc_amp) = 0d0 4500 do iirec = 1, n_cc_amp 4501 if (ntest.ge.10) write (6,*) 'read rec. ',iirec 4502 nread = n_cc_amp 4503 if (istmode.eq.2) nread = iirec 4504 call vec_from_disc(hessi(1,iirec),nread,0,lblk,luhss) 4505 end do 4506 if (ntest.ge.100) then 4507 write(6,*) 'The Hessian as read in:' 4508 call wrtmat2(hessi,n_cc_amp,n_cc_amp,n_cc_amp,n_cc_amp) 4509 end if 4510 4511 ! some waste of time, but for the moment much easier: 4512 ! get full matrix 4513 if (istmode.eq.2) then 4514 do ii = 1, n_cc_amp 4515 do jj = ii+1, n_cc_amp 4516 hessi(jj,ii)=hessi(ii,jj) 4517 end do 4518 end do 4519 else if (istmode.eq.3) then 4520 do ii = 1, n_cc_amp 4521 do jj = ii+1, n_cc_amp 4522 xel = 0.5d0*(hessi(jj,ii)+hessi(ii,jj)) 4523 hessi(jj,ii)= xel 4524 hessi(ii,jj)= xel 4525 end do 4526 end do 4527 end if 4528 if (ntest.ge.100) then 4529 write(6,*) 'The Hessian as full matrix:' 4530 call wrtmat2(hessi,n_cc_amp,n_cc_amp,n_cc_amp,n_cc_amp) 4531 end if 4532 4533* print-out of raw blocks 4534c if (ntest.ge.5) then 4535c do ii_tp = 1, n_cc_typ 4536c iioff = ioff_cc_typ(ii_tp) 4537c iilen = namp_cc_typ(ii_tp) 4538c do jj_tp = 1, n_cc_typ 4539c jjoff = ioff_cc_typ(jj_tp) 4540c jjlen = namp_cc_typ(jj_tp) 4541c write (6,*) 'block: ',ii_tp, jj_tp 4542c call wrtmat(hessi(iioff,jjoff),iilen,jjlen,n_cc_amp,n_cc_amp) 4543c end do 4544c end do 4545c end if 4546 4547* diagonalize the matrix 4548 ltria = n_cc_amp*(n_cc_amp+1)/2 4549 leig = n_cc_amp 4550 lscr = 80*n_cc_amp 4551 idum = 0 4552 call memman(idum,idum,'MARK',idum,'TSTHSS') 4553 call memman(ktria,ltria,'ADDL',2,'HSSTRIA') 4554 call memman(keig,leig,'ADDL',2,'HSS EIG') 4555 call memman(kscr,lscr,'ADDL',2,'HSS SCR') 4556 4557 call copdia(hessi,work(keig),n_cc_amp,0) 4558 write(6,*) 'the diagonal:' 4559 call wrtmat_ep(work(keig),n_cc_amp,1,n_cc_amp,1) 4560 4561 irt = 1 4562 if (irt.eq.0) then 4563 iway = -1 ! symmetrize on the way 4564 call tripak(hessi,work(ktria),iway,n_cc_amp,n_cc_amp) 4565 call jacobi(work(ktria),hessi,n_cc_amp,n_cc_amp) 4566 call copdia(work(ktria),work(keig),n_cc_amp,1) 4567 stop 'test purpose route only' 4568 else if(irt.eq.1) then 4569 call diag_symmat_eispack(hessi,work(keig),work(ktria), 4570 & n_cc_amp,iret) 4571 if (ntest.ge.100) then 4572 write(6,*) 'Eigenvector array:' 4573 call wrtmat2(hessi,n_cc_amp,n_cc_amp,n_cc_amp,n_cc_amp) 4574 end if 4575 else 4576 stop 'irt = ???' 4577 end if 4578c hessi(1:n_cc_amp,1:n_cc_amp) = 0d0 4579c do ii = 1, n_cc_amp 4580c hessi(ii,ii) = 1d0 4581c end do 4582c work(keig:keig-1+leig) = 0d0 4583c eps = 1d-14 4584c call rdiag(work(ktria),hessi,work(keig),n_cc_amp,eps,work(kscr)) 4585 4586 write(6,*) 'the eigenvalues:' 4587 call wrtmat_ep(work(keig),n_cc_amp,1,n_cc_amp,1) 4588 4589c thrs = 1d-8 4590c do ii = 1, n_cc_amp 4591c if (work(keig-1+ii).gt.thrs) then 4592c write(6,*) 'the eigenvector ',ii,work(keig-1+ii) 4593c do ii_tp = 1, n_cc_typ 4594c iioff = ioff_cc_typ(ii_tp) 4595c iilen = namp_cc_typ(ii_tp) 4596c xnrm = sqrt(inprod(hessi(iioff,ii),hessi(iioff,ii),iilen)) 4597c write (6,*) ' contributions from typ', ii_tp, xnrm 4598c if (xnrm.gt.0.1*dble(iilen)) 4599c & call wrtmat(hessi(iioff,ii),1,iilen,1,n_cc_amp) 4600c end do 4601c end if 4602c end do 4603 4604 imk_hinv = 0 4605 if (imk_hinv.eq.1) then 4606 ! find lowest eigenvalue and shift according to xdiag_min 4607 ! get column of hinv as 4608 ! hinv(i,j) = U(i,k) eig(k) U(j,k) 4609 end if 4610 4611 idum = 0 4612 call memman(idum,idum,'FLUSM',idum,'TSTHSS') 4613 4614 return 4615 end 4616*--------------------------------------------------------------------* 4617*--------------------------------------------------------------------* 4618 subroutine gtbce_getrdvec(isymmet_G, 4619 & xsmat,lusmat,lurdvec,nrdvec, 4620 & nsmat,n_cc_amp,iccvec, 4621 & ccvec1,ccvec2) 4622*--------------------------------------------------------------------* 4623* 4624* get redundant directions from smat 4625* upper triangle on file (one column up to diagonal per block) 4626*--------------------------------------------------------------------* 4627c include 'implicit.inc' 4628c include 'mxpdim.inc' 4629 include 'wrkspc.inc' 4630* constants 4631 integer, parameter :: 4632 & ntest = 100 4633 4634* external functions 4635 real*8 inprod, inprdd 4636 4637* input 4638 integer, intent(in) :: 4639 & iccvec(n_cc_amp) 4640 real*8, intent(inout) :: 4641 & xsmat(nsmat,nsmat), ccvec1(n_cc_amp), ccvec2(n_cc_amp) 4642 4643 lblk = -1 4644 4645* read file luhss 4646 call rewino(lusmat) 4647 xsmat(1:nsmat,1:nsmat) = 0d0 4648 do iirec = 1, nsmat 4649 if (ntest.ge.10) write (6,*) 'read rec. ',iirec 4650 nread = iirec 4651c if (istmode.eq.2) nread = iirec 4652 call vec_from_disc(xsmat(1,iirec),nread,0,lblk,lusmat) 4653 end do 4654 if (ntest.ge.100) then 4655 write(6,*) 'The S-matrix as read in:' 4656 call wrtmat2(xsmat,nsmat,nsmat,nsmat,nsmat) 4657 end if 4658 4659 ! some waste of time, but for the moment much easier: 4660 ! get full matrix 4661 do ii = 1, nsmat 4662 do jj = ii+1, nsmat 4663 xsmat(jj,ii)=xsmat(ii,jj) 4664 end do 4665 end do 4666 if (ntest.ge.100) then 4667 write(6,*) 'The S-matrix as full matrix:' 4668 call wrtmat2(xsmat,nsmat,nsmat,nsmat,nsmat) 4669 end if 4670 4671* diagonalize the matrix 4672 ltria = nsmat*(nsmat+1)/2 4673 leig = nsmat 4674 lscr = 80*nsmat 4675 idum = 0 4676 call memman(idum,idum,'MARK',idum,'TSTHSS') 4677 call memman(ktria,ltria,'ADDL',2,'HSSTRIA') 4678 call memman(keig,leig,'ADDL',2,'HSS EIG') 4679 call memman(kscr,lscr,'ADDL',2,'HSS SCR') 4680 4681 call copdia(xsmat,work(keig),nsmat,0) 4682 write(6,*) 'the diagonal:' 4683 call wrtmat_ep(work(keig),nsmat,1,nsmat,1) 4684 4685 irt = 1 4686 if (irt.eq.0) then 4687 iway = -1 ! symmetrize on the way 4688 call tripak(xsmat,work(ktria),iway,nsmat,nsmat) 4689 call jacobi(work(ktria),xsmat,nsmat,nsmat) 4690 call copdia(work(ktria),work(keig),nsmat,1) 4691 stop 'test purpose route only' 4692 else if(irt.eq.1) then 4693 call diag_symmat_eispack(xsmat,work(keig),work(ktria), 4694 & nsmat,iret) 4695 if (ntest.ge.100) then 4696 write(6,*) 'Eigenvector array:' 4697 call wrtmat2(xsmat,nsmat,nsmat,nsmat,nsmat) 4698 end if 4699 else 4700 stop 'irt = ???' 4701 end if 4702 4703 write(6,*) 'the eigenvalues:' 4704 call wrtmat_ep(work(keig),nsmat,1,nsmat,1) 4705 4706 thrsh = 1d-12 4707c thrsh = 1d-7 4708 nrdvec=0 4709 fac = dble(isymmet_G) 4710 call rewino(lurdvec) 4711 do ii = 1, nsmat 4712 if (work(keig-1+ii).lt.thrsh) then 4713 nrdvec = nrdvec+1 4714 ! expand this eigenvector to full aray 4715 ccvec1(1:n_cc_amp) = 0d0 4716 ismat = 0 4717 do iamp = 1, n_cc_amp 4718 if (iccvec(iamp).gt.0) then 4719 ismat = ismat+1 4720 if (ismat.gt.nsmat) 4721 & stop 'inconsistency!' 4722 ccvec1(iamp)=xsmat(ismat,ii) 4723 if (isymmet_G.ne.0) then 4724 idx = iccvec(iamp) 4725 ccvec1(idx)=fac*xsmat(ismat,ii) 4726 end if 4727 end if 4728 end do 4729 ! renormalize and 4730 ! save as next record on lurdvec 4731 xnrm = sqrt(inprod(ccvec1,ccvec1,n_cc_amp)) 4732 ccvec1(1:n_cc_amp) = 1d0/xnrm*ccvec1(1:n_cc_amp) 4733 call vec_to_disc(ccvec1,n_cc_amp,0,-1,lurdvec) 4734 end if 4735 end do 4736 4737 write(6,*) '>> # redundant vectors: ',nrdvec 4738 4739 idum = 0 4740 call memman(idum,idum,'FLUSM',idum,'TSTHSS') 4741 4742 return 4743 end 4744*--------------------------------------------------------------------* 4745 subroutine gtbce_prjout_rdvec(nrdvec,lurdvec,luvec, 4746 & n_cc_amp,ccvec1,ccvec2) 4747 4748 implicit none 4749 4750 integer, parameter :: 4751 & ntest = 100 4752 4753 integer, intent(in) :: 4754 & nrdvec, lurdvec, luvec, n_cc_amp 4755 real(8), intent(inout) :: 4756 & ccvec1(n_cc_amp), ccvec2(n_cc_amp) 4757 4758 integer :: 4759 & irdvec 4760 real(8) :: 4761 & ovl, xnrm 4762 real(8), external :: 4763 & inprod 4764 4765 call vec_from_disc(ccvec1,n_cc_amp,1,-1,luvec) 4766 4767 xnrm = sqrt(inprod(ccvec1,ccvec1,n_cc_amp)) 4768 4769 write(6,*) ' norm of unprojected gradient: ',xnrm 4770 4771 call rewino(lurdvec) 4772 do irdvec = 1, nrdvec 4773 call vec_from_disc(ccvec2,n_cc_amp,0,-1,lurdvec) 4774 ovl = inprod(ccvec1,ccvec2,n_cc_amp) 4775 write(6,*) ' overlap with vec ',irdvec,' :',ovl 4776 ccvec1(1:n_cc_amp) = ccvec1(1:n_cc_amp) - ovl*ccvec2(1:n_cc_amp) 4777 end do 4778 4779 xnrm = sqrt(inprod(ccvec1,ccvec1,n_cc_amp)) 4780 4781 write(6,*) ' norm of projected gradient: ',xnrm 4782 4783 call vec_to_disc(ccvec1,n_cc_amp,1,-1,luvec) 4784 4785 return 4786 end 4787*--------------------------------------------------------------------* 4788 subroutine gtbce_EalongG(tvec,npnts,from_g,to_g, 4789 & ecore, 4790 & ccvec1,iopsym,ccvec3,ccvec4, 4791 & civec1,civec2,c2vec, 4792 & n_cc_amp,mxb_ci, 4793 & luc,luec,luhc,lusc1,lusc2) 4794*--------------------------------------------------------------------* 4795* 4796* purpose: calculate energy along a selected direction tvec and 4797* generate plot data 4798* 4799* ak, early 2004 4800* 4801*--------------------------------------------------------------------* 4802 include "implicit.inc" 4803 4804* input 4805 real*8, intent(in) :: 4806 & ccvec1(n_cc_amp), tvec(n_cc_amp) 4807 real*8, intent(inout) :: 4808 & ccvec3(n_cc_amp), ccvec4(n_cc_amp) 4809* external 4810 real*8 :: 4811 & inprod 4812 4813 4814 xdelt = to_g - from_g 4815 4816 xinc = xdelt/dble(npnts-1) 4817 xnorm = sqrt(inprod(tvec, tvec,n_cc_amp)) 4818 xovl = inprod(ccvec1,tvec,n_cc_amp) 4819 4820 write (6,'("@p",a,e10.4)') ' comp. of G along t: ',xovl/xnorm 4821 4822 write (6,'("@p",a)') ' n c energy variance dnorm' 4823 4824 do ipnt = 0, npnts-1 4825 4826 fac = (from_g+xdelt*dble(ipnt)/dble(npnts-1))/xnorm 4827 ccvec3(1:n_cc_amp) = ccvec1(1:n_cc_amp)+fac*tvec(1:n_cc_amp) 4828 4829c igtbmod = 1 4830 call gtbce_E(igtbmod,elen,var,ovl, 4831 & ecore, 4832 & ccvec3,iopsym,ccvec4, 4833 & civec1,civec2,c2vec, 4834 & n_cc_amp,mxb_ci, 4835 & luc,luec,luhc,lusc1,lusc2) 4836 4837 write(6,'("@p",i4,e14.6,f21.12,2(2x,e10.4))') 4838 & ipnt,fac,elen,var,1d0-sqrt(ovl) 4839 4840 end do 4841 4842 return 4843 4844 end 4845 4846*--------------------------------------------------------------------* 4847 subroutine prjout_red(gop,xrs,ntss_tp,itss_tp,ibtss_tp) 4848*--------------------------------------------------------------------* 4849* 4850* project out redundant directions from input vector 4851* 4852 include 'implicit.inc' 4853 include 'mxpdim.inc' 4854 include 'cgas.inc' 4855 include 'multd2h.inc' 4856 include 'orbinp.inc' 4857 include 'csm.inc' 4858 include 'ctcc.inc' 4859 include 'cc_exc.inc' 4860 4861 integer, parameter :: 4862 & ntest = 1000 4863 4864* input 4865 real(8), intent(inout) :: 4866 & gop(*), xrs(*) 4867 4868c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 4869 integer, intent(in) :: 4870 & ntss_tp, 4871 & itss_tp(ngas,4,ntss_tp), 4872 & ibtss_tp(ntss_tp) 4873 4874* local 4875 integer :: 4876 & igrp_ca(mxpngas), igrp_cb(mxpngas), 4877 & igrp_aa(mxpngas), igrp_ab(mxpngas), 4878 & iocc_ca(mx_st_tsoso_blk_mx), 4879 & iocc_cb(mx_st_tsoso_blk_mx), 4880 & iocc_aa(mx_st_tsoso_blk_mx), 4881 & iocc_ab(mx_st_tsoso_blk_mx), 4882 & idx_c(4), idx_s(4), 4883 & irs(ntoob*ntoob) 4884 4885 if (ntest.ge.1000) then 4886 write(6,*) ' input amplitudes: ' 4887 call wrt_cc_vec2(gop,6,'GEN_CC') 4888 write(6,*) 'ibtss_tp:' 4889 call iwrtma(ibtss_tp,1,ntss_tp,1,ntss_tp) 4890 end if 4891 4892 ! init 4893 xrs(1:ntoob*ntoob) = 0d0 4894 irs(1:ntoob*ntoob) = 0 4895 do ipass = 1, 2 4896 ! 4897 ! run over all operator elements and ... 4898 ! 4899 ! pass 1: 4900 ! X^{(rs)} = sum_p G_pprs (p,p of equal spin) 4901 ! 4902 ! pass 2: 4903 ! subtract X^{(rs)} from each entry G_pprs 4904 4905 ! loop over types 4906 idx = 0 4907 do itss = 1, ntss_tp 4908 ! identify two-particle excitations: 4909 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 4910 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 4911 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 4912 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 4913 nc = nel_ca + nel_cb 4914 na = nel_aa + nel_ab 4915 if (na.ne.2) cycle 4916 ! transform occupations to groups 4917 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 4918 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 4919 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 4920 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 4921 4922 if (mscomb_cc.ne.0) then 4923 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 4924 & itss_tp(1,3,itss),itss_tp(1,4,itss), 4925 & ngas,idiag) 4926 else 4927 idiag = 0 4928 end if 4929 4930 4931 ! loop over symmetry blocks 4932 ism = 1 ! totally symmetric operators 4933 do ism_c = 1, nsmst 4934 ism_a = multd2h(ism,ism_c) 4935 do ism_ca = 1, nsmst 4936 ism_cb = multd2h(ism_c,ism_ca) 4937 do ism_aa = 1, nsmst 4938 ism_ab = multd2h(ism_a,ism_aa) 4939 ! get alpha and beta symmetry index 4940 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 4941 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 4942 4943 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 4944 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 4945 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 4946 irestr = 0 4947 else 4948 irestr = 1 4949 end if 4950 4951 ! get the strings 4952 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 4953 & lca,iocc_ca,norb,0,idum,idum) 4954 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 4955 & lcb,iocc_cb,norb,0,idum,idum) 4956 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 4957 & laa,iocc_aa,norb,0,idum,idum) 4958 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 4959 & lab,iocc_ab,norb,0,idum,idum) 4960 4961 ! length of strings in this symmetry block 4962 if (lca*lcb*laa*lab.eq.0) cycle 4963 4964 do iab = 1, lab 4965 if (irestr.eq.1) then 4966 iaa_min = iab 4967 else 4968 iaa_min = 1 4969 end if 4970 do iaa = iaa_min, laa 4971 do icb = 1, lcb 4972 if (irestr.eq.1.and.iaa.eq.iab) then 4973 ica_min = icb 4974 else 4975 ica_min = 1 4976 end if 4977 do ica = ica_min, lca 4978 idx = idx + 1 4979 ! translate into canonical index quadrupel 4980 ii = 0 4981 do iel = 1, nel_ca 4982 ii = ii + 1 4983 idx_c(ii) = iocc_ca((ica-1)*nel_ca+iel) 4984 idx_s(ii) = 1 4985 end do 4986 do iel = 1, nel_cb 4987 ii = ii + 1 4988 idx_c(ii) = iocc_cb((icb-1)*nel_cb+iel) 4989 idx_s(ii) = 2 4990 end do 4991 do iel = 1, nel_aa 4992 ii = ii + 1 4993 idx_c(ii) = iocc_aa((iaa-1)*nel_aa+iel) 4994 idx_s(ii) = 1 4995 idx_s(ii) = 1 4996 end do 4997 do iel = 1, nel_ab 4998 ii = ii + 1 4999 idx_c(ii) = iocc_ab((iab-1)*nel_ab+iel) 5000 idx_s(ii) = 2 5001 end do 5002 5003 ! have one particle and one hole operator the same index? 5004c TEST tabula rasa test 5005c if ((idx_s(1).eq.idx_s(2).and. 5006 if ((!idx_s(1).eq.idx_s(2).and. 5007 & (idx_c(1).eq.idx_c(3).or. 5008 & idx_c(1).eq.idx_c(4).or. 5009 & idx_c(2).eq.idx_c(3).or. 5010 & idx_c(2).eq.idx_c(4))) .or. 5011 & (idx_s(1).ne.idx_s(2).and. 5012 & (idx_c(1).eq.idx_c(3).or. 5013 & idx_c(2).eq.idx_c(4)) ) ) then 5014 if (idx_c(1).eq.idx_c(3)) 5015 & idx_rs = (idx_c(2)-1)*ntoob 5016 & + idx_c(4) 5017 if (idx_c(1).eq.idx_c(4)) 5018 & idx_rs = (idx_c(2)-1)*ntoob 5019 & + idx_c(3) 5020 if (idx_c(2).eq.idx_c(3)) 5021 & idx_rs = (idx_c(1)-1)*ntoob 5022 & + idx_c(4) 5023 if (idx_c(2).eq.idx_c(4)) 5024 & idx_rs = (idx_c(1)-1)*ntoob 5025 & + idx_c(3) 5026 if (ipass.eq.1) then 5027 xrs(idx_rs) = xrs(idx_rs) + gop(idx) 5028 irs(idx_rs) = irs(idx_rs) + 1 5029 end if 5030c if (ipass.eq.2) 5031c & gop(idx) = gop(idx) 5032c & - 1d0/dble(irs(idx_rs))*xrs(idx_rs) 5033c TEST --- tabula rasa for all amplitudes with repeated indices 5034 if (ipass.eq.2) 5035 & gop(idx) = 0d0 5036 5037 5038 end if 5039 5040 end do ! ica 5041 end do ! icb 5042 end do ! iaa 5043 end do ! iab 5044 5045 end do ! ism_aa 5046 end do ! ism_ca 5047 end do ! ism_c 5048 5049 end do ! itss 5050 5051 if (ipass.eq.1.and.ntest.ge.150) then 5052 write(6,*) 'The xrs array:' 5053 call wrtmat(xrs,ntoob,ntoob,ntoob,ntoob) 5054 write(6,*) 'The irs array:' 5055 call iwrtma(irs,ntoob,ntoob,ntoob,ntoob) 5056 end if 5057 5058 end do ! ipass 5059 5060 if (ntest.ge.1000) then 5061 write(6,*) ' output amplitudes: ' 5062 call wrt_cc_vec2(gop,6,'GEN_CC') 5063 end if 5064 5065 return 5066 end 5067 5068*--------------------------------------------------------------------* 5069 subroutine ggrad2lgrad(ggrad,lgrad,lop, 5070 & ntss_tp,itss_tp,nloff,ldiml) 5071*--------------------------------------------------------------------* 5072* 5073* 5074* 5075*--------------------------------------------------------------------* 5076 5077 include 'implicit.inc' 5078 include 'mxpdim.inc' 5079 include 'cgas.inc' 5080 include 'multd2h.inc' 5081 include 'orbinp.inc' 5082 include 'csm.inc' 5083 include 'ctcc.inc' 5084 include 'cc_exc.inc' 5085 5086 integer, parameter :: 5087 & ntest = 100 5088 5089* input 5090 real(8), intent(in) :: 5091 & ggrad(*), lop(*) 5092c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 5093 integer, intent(in) :: 5094 & ntss_tp, 5095 & itss_tp(ngas,4,ntss_tp) 5096 5097 real(8), intent(out) :: 5098 & lgrad(*) 5099 5100* local 5101 integer :: 5102 & igrp_ca(mxpngas), igrp_cb(mxpngas), 5103 & igrp_aa(mxpngas), igrp_ab(mxpngas), 5104 & iocc_ca(mx_st_tsoso_blk_mx), 5105 & iocc_cb(mx_st_tsoso_blk_mx), 5106 & iocc_aa(mx_st_tsoso_blk_mx), 5107 & iocc_ab(mx_st_tsoso_blk_mx), 5108 & idx_c(4), idx_s(4) 5109 5110 ! init 5111 lgrad(1:ldiml**2) = 0d0 5112 if (nloff.gt.0) lgrad(nloff:nloff+ldiml**2-1) = 0d0 5113 5114 ! loop over types 5115 idx = 0 5116 do itss = 1, ntss_tp 5117 ! identify two-particle excitations: 5118 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 5119 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 5120 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 5121 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 5122 nc = nel_ca + nel_cb 5123 na = nel_aa + nel_ab 5124 if (na.ne.2) cycle 5125 5126 ! transform occupations to groups 5127 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 5128 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 5129 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 5130 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 5131 5132 if (mscomb_cc.ne.0) then 5133 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 5134 & itss_tp(1,3,itss),itss_tp(1,4,itss), 5135 & ngas,idiag) 5136 else 5137 idiag = 0 5138 end if 5139 5140 ! loop over symmetry blocks 5141 ism = 1 ! totally symmetric operators, n'est-ce pas? 5142 do ism_c = 1, nsmst 5143 ism_a = multd2h(ism,ism_c) 5144 do ism_ca = 1, nsmst 5145 ism_cb = multd2h(ism_c,ism_ca) 5146 do ism_aa = 1, nsmst 5147 ism_ab = multd2h(ism_a,ism_aa) 5148 ! get alpha and beta symmetry index 5149 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 5150 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 5151 5152 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 5153 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 5154 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 5155 irestr = 0 5156 else 5157 irestr = 1 5158 end if 5159 5160 ! get the strings 5161 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 5162 & lca,iocc_ca,norb,0,idum,idum) 5163 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 5164 & lcb,iocc_cb,norb,0,idum,idum) 5165 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 5166 & laa,iocc_aa,norb,0,idum,idum) 5167 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 5168 & lab,iocc_ab,norb,0,idum,idum) 5169 5170 ! length of strings in this symmetry block 5171 if (lca*lcb*laa*lab.eq.0) cycle 5172 5173 do iab = 1, lab 5174 if (irestr.eq.1) then 5175 iaa_min = iab 5176 else 5177 iaa_min = 1 5178 end if 5179 do iaa = iaa_min, laa 5180 do icb = 1, lcb 5181 if (irestr.eq.1.and.iaa.eq.iab) then 5182 ica_min = icb 5183 else 5184 ica_min = 1 5185 end if 5186 do ica = ica_min, lca 5187 idx = idx + 1 5188 ! translate into canonical index quadrupel 5189 ii = 0 5190 do iel = 1, nel_ca 5191 ii = ii + 1 5192 idx_c(ii) = iocc_ca((ica-1)*nel_ca+iel) 5193 idx_s(ii) = 1 5194 end do 5195 do iel = 1, nel_cb 5196 ii = ii + 1 5197 idx_c(ii) = iocc_cb((icb-1)*nel_cb+iel) 5198 idx_s(ii) = 2 5199 end do 5200 do iel = 1, nel_aa 5201 ii = ii + 1 5202 idx_c(ii) = iocc_aa((iaa-1)*nel_aa+iel) 5203 idx_s(ii) = 1 5204 idx_s(ii) = 1 5205 end do 5206 do iel = 1, nel_ab 5207 ii = ii + 1 5208 idx_c(ii) = iocc_ab((iab-1)*nel_ab+iel) 5209 idx_s(ii) = 2 5210 end do 5211 5212 idxpq = idx_s(1)*nloff + 5213 & (idx_c(3)-1)*ldiml + idx_c(1) 5214 if (idx_s(1).ne.idx_s(3)) stop 'ups (1)' 5215 idxrs = idx_s(2)*nloff + 5216 & (idx_c(4)-1)*ldiml + idx_c(2) 5217 if (idx_s(2).ne.idx_s(4)) stop 'ups (2)' 5218 5219c print *,'pq = ',idx_c(3), idx_c(1), idx_s(1) 5220c print *,'rs = ',idx_c(4), idx_c(2), idx_s(2) 5221 5222c print '(x,a,3i4,a,3i4)', 5223c & ' contr. ',idx_c(3),idx_c(1),idx_s(1), 5224c & ' to ',idx_c(4),idx_c(2),idx_s(2) 5225 lgrad(idxpq) = lgrad(idxpq)+ggrad(idx)*lop(idxrs) 5226c print '(x,a,3i4,a,3i4)', 5227c & ' contr. ',idx_c(4),idx_c(2),idx_s(2), 5228c & ' to ',idx_c(3),idx_c(1),idx_s(1) 5229c print *,' grad(',idxpq,idxrs,')=',ggrad(idx) 5230 lgrad(idxrs) = lgrad(idxrs)+ggrad(idx)*lop(idxpq) 5231 5232 end do ! ica 5233 end do ! icb 5234 end do ! iaa 5235 end do ! iab 5236 5237 end do ! ism_aa 5238 end do ! ism_ca 5239 end do ! ism_c 5240 5241 end do ! itss 5242 5243 if (ntest.ge.100) then 5244 write(6,*) 'L gradient:' 5245 do ii = 1, ntoob 5246 do jj = 1, ntoob 5247 idx = (ii-1)*ntoob+jj 5248 write(6,*) ii,jj,lgrad(idx) 5249 end do 5250 end do 5251 end if 5252 5253 return 5254 5255 end 5256 5257*--------------------------------------------------------------------* 5258 subroutine ggrad2omgrad(ggrad,omgrad,omop,urop,uiop, 5259 & ntss_tp,itss_tp,ndim) 5260*--------------------------------------------------------------------* 5261* 5262* get Omega gradient acc. to chain rule 5263* 5264*--------------------------------------------------------------------* 5265 5266 include 'implicit.inc' 5267 include 'mxpdim.inc' 5268 include 'cgas.inc' 5269 include 'multd2h.inc' 5270 include 'orbinp.inc' 5271 include 'csm.inc' 5272 include 'ctcc.inc' 5273 include 'cc_exc.inc' 5274 5275 integer, parameter :: 5276 & ntest = 00 5277 5278* input 5279 real(8), intent(in) :: 5280 & ggrad(*), omop(ndim,ndim,2,2), 5281 & urop(ndim,ndim,2,2), uiop(ndim,ndim,2,2) 5282c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 5283 integer, intent(in) :: 5284 & ntss_tp, 5285 & itss_tp(ngas,4,ntss_tp) 5286 5287 real(8), intent(out) :: 5288 & omgrad(ndim,ndim,2,2) 5289 5290* local 5291 integer :: 5292 & igrp_ca(mxpngas), igrp_cb(mxpngas), 5293 & igrp_aa(mxpngas), igrp_ab(mxpngas), 5294 & iocc_ca(mx_st_tsoso_blk_mx), 5295 & iocc_cb(mx_st_tsoso_blk_mx), 5296 & iocc_aa(mx_st_tsoso_blk_mx), 5297 & iocc_ab(mx_st_tsoso_blk_mx), 5298 & idx_c(4), idx_s(4) 5299 5300 call atim(cpu0,wall0) 5301 5302 ! init 5303 omgrad(1:ndim,1:ndim,1:2,1:2) = 0d0 5304 5305 ! loop over types 5306 idx = 0 5307 do itss = 1, ntss_tp 5308 ! identify two-particle excitations: 5309 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 5310 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 5311 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 5312 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 5313 nc = nel_ca + nel_cb 5314 na = nel_aa + nel_ab 5315 if (na.ne.2) cycle 5316 5317 ! transform occupations to groups 5318 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 5319 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 5320 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 5321 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 5322 5323 if (mscomb_cc.ne.0) then 5324 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 5325 & itss_tp(1,3,itss),itss_tp(1,4,itss), 5326 & ngas,idiag) 5327 else 5328 idiag = 0 5329 end if 5330 5331 ! loop over symmetry blocks 5332 ism = 1 ! totally symmetric operators, n'est-ce pas? 5333 do ism_c = 1, nsmst 5334 ism_a = multd2h(ism,ism_c) 5335 do ism_ca = 1, nsmst 5336 ism_cb = multd2h(ism_c,ism_ca) 5337 do ism_aa = 1, nsmst 5338 ism_ab = multd2h(ism_a,ism_aa) 5339 ! get alpha and beta symmetry index 5340 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 5341 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 5342 5343 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 5344 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 5345 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 5346 irestr = 0 5347 else 5348 irestr = 1 5349 end if 5350 5351 ! get the strings 5352 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 5353 & lca,iocc_ca,norb,0,idum,idum) 5354 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 5355 & lcb,iocc_cb,norb,0,idum,idum) 5356 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 5357 & laa,iocc_aa,norb,0,idum,idum) 5358 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 5359 & lab,iocc_ab,norb,0,idum,idum) 5360 5361 ! length of strings in this symmetry block 5362 if (lca*lcb*laa*lab.eq.0) cycle 5363 5364 do iab = 1, lab 5365 if (irestr.eq.1) then 5366 iaa_min = iab 5367 else 5368 iaa_min = 1 5369 end if 5370 do iaa = iaa_min, laa 5371 do icb = 1, lcb 5372 if (irestr.eq.1.and.iaa.eq.iab) then 5373 ica_min = icb 5374 else 5375 ica_min = 1 5376 end if 5377 do ica = ica_min, lca 5378 idx = idx + 1 5379 ! translate into canonical index quadrupel 5380 ii = 0 5381 do iel = 1, nel_ca 5382 ii = ii + 1 5383 idx_c(ii) = iocc_ca((ica-1)*nel_ca+iel) 5384 idx_s(ii) = 1 5385 end do 5386 do iel = 1, nel_cb 5387 ii = ii + 1 5388 idx_c(ii) = iocc_cb((icb-1)*nel_cb+iel) 5389 idx_s(ii) = 2 5390 end do 5391 do iel = 1, nel_aa 5392 ii = ii + 1 5393 idx_c(ii) = iocc_aa((iaa-1)*nel_aa+iel) 5394 idx_s(ii) = 1 5395 idx_s(ii) = 1 5396 end do 5397 do iel = 1, nel_ab 5398 ii = ii + 1 5399 idx_c(ii) = iocc_ab((iab-1)*nel_ab+iel) 5400 idx_s(ii) = 2 5401 end do 5402 5403 ip = idx_c(1) 5404 ir = idx_c(2) 5405 iq = idx_c(3) 5406 is = idx_c(4) 5407 5408 imp = idx_s(1) 5409 imr = idx_s(2) 5410 imq = idx_s(3) 5411 ims = idx_s(4) 5412 5413 do imt = 1, 2 5414 do imu = 1, 2 5415 do it = 1, ndim 5416 urur_t = urop(ip,it,imp,imt)* 5417 & urop(iq,it,imq,imt) 5418 uiui_t = uiop(ip,it,imp,imt)* 5419 & uiop(iq,it,imq,imt) 5420 uiur_t = uiop(ip,it,imp,imt)* 5421 & urop(iq,it,imq,imt) 5422 urui_t = urop(ip,it,imp,imt)* 5423 & uiop(iq,it,imq,imt) 5424 5425 5426 do iu = 1, ndim 5427 5428 urur_u = urop(ir,iu,imr,imu)* 5429 & urop(is,iu,ims,imu) 5430 uiui_u = uiop(ir,iu,imr,imu)* 5431 & uiop(is,iu,ims,imu) 5432 uiur_u = uiop(ir,iu,imr,imu)* 5433 & urop(is,iu,ims,imu) 5434 urui_u = urop(ir,iu,imr,imu)* 5435 & uiop(is,iu,ims,imu) 5436 5437 omgrad(it,iu,imt,imu) = 5438 & omgrad(it,iu,imt,imu) + 5439 & ggrad(idx) 5440 & *((urur_t+uiui_t)*(uiur_u-urui_u) 5441 & +(uiur_t-urui_t)*(urur_u+uiui_u)) 5442* new: update also the inversed pair 5443 if (imu.ne.imt) then 5444 omgrad(iu,it,imu,imt) = 5445 & omgrad(iu,it,imu,imt) + 5446 & ggrad(idx) 5447 & *((urur_t+uiui_t)*(uiur_u-urui_u) 5448 & +(uiur_t-urui_t)*(urur_u+uiui_u)) 5449 end if 5450 5451 end do 5452 end do 5453 end do 5454 end do 5455 5456 end do ! ica 5457 end do ! icb 5458 end do ! iaa 5459 end do ! iab 5460 5461 end do ! ism_aa 5462 end do ! ism_ca 5463 end do ! ism_c 5464 5465 end do ! itss 5466 5467 if (ntest.ge.100) then 5468 write(6,*) 'Omega gradient:' 5469 do imp = 1, 2 5470 do imq = 1, 2 5471 write(6,*) 'spin block: ',imp,imq 5472 call wrtmat2(omgrad(1,1,imp,imq),ndim,ndim,ndim,ndim) 5473 end do 5474 end do 5475 end if 5476 5477 call atim(cpu,wall) 5478 call prtim(6,'time in ggrad2omgrad',cpu-cpu0,wall-wall0) 5479 5480 return 5481 5482 end 5483 5484*--------------------------------------------------------------------* 5485 subroutine ggrad2ugrad(ggrad,urgrad,omop,urop,uiop, 5486 & ntss_tp,itss_tp,ndim,irmod) 5487*--------------------------------------------------------------------* 5488* 5489* get U gradient acc. to chain rule 5490* 5491*--------------------------------------------------------------------* 5492 5493 include 'implicit.inc' 5494 include 'mxpdim.inc' 5495 include 'cgas.inc' 5496 include 'multd2h.inc' 5497 include 'orbinp.inc' 5498 include 'csm.inc' 5499 include 'ctcc.inc' 5500 include 'cc_exc.inc' 5501 5502 integer, parameter :: 5503 & ntest = 00 5504 5505* input 5506 real(8), intent(in) :: 5507 & ggrad(*), omop(ndim,ndim,2,2), 5508 & urop(ndim,ndim,2,2), uiop(ndim,ndim,2,2) 5509c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 5510 integer, intent(in) :: 5511 & ntss_tp, 5512 & itss_tp(ngas,4,ntss_tp) 5513 real(8), intent(out) :: 5514 & urgrad(ndim,ndim,2,2) 5515* local 5516 integer :: 5517 & igrp_ca(mxpngas), igrp_cb(mxpngas), 5518 & igrp_aa(mxpngas), igrp_ab(mxpngas), 5519 & iocc_ca(mx_st_tsoso_blk_mx), 5520 & iocc_cb(mx_st_tsoso_blk_mx), 5521 & iocc_aa(mx_st_tsoso_blk_mx), 5522 & iocc_ab(mx_st_tsoso_blk_mx), 5523 & idx_c(4), idx_s(4) 5524 5525 call atim(cpu0,wall0) 5526 5527 ! init 5528 urgrad(1:ndim,1:ndim,1:2,1:2) = 0d0 5529 5530 ! loop over types 5531 idx = 0 5532 do itss = 1, ntss_tp 5533 ! identify two-particle excitations: 5534 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 5535 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 5536 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 5537 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 5538 nc = nel_ca + nel_cb 5539 na = nel_aa + nel_ab 5540 if (na.ne.2) cycle 5541 5542 ! transform occupations to groups 5543 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 5544 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 5545 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 5546 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 5547 5548 if (mscomb_cc.ne.0) then 5549 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 5550 & itss_tp(1,3,itss),itss_tp(1,4,itss), 5551 & ngas,idiag) 5552 else 5553 idiag = 0 5554 end if 5555 5556 ! loop over symmetry blocks 5557 ism = 1 ! totally symmetric operators, n'est-ce pas? 5558 do ism_c = 1, nsmst 5559 ism_a = multd2h(ism,ism_c) 5560 do ism_ca = 1, nsmst 5561 ism_cb = multd2h(ism_c,ism_ca) 5562 do ism_aa = 1, nsmst 5563 ism_ab = multd2h(ism_a,ism_aa) 5564 ! get alpha and beta symmetry index 5565 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 5566 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 5567 5568 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 5569 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 5570 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 5571 irestr = 0 5572 else 5573 irestr = 1 5574 end if 5575 5576 ! get the strings 5577 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 5578 & lca,iocc_ca,norb,0,idum,idum) 5579 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 5580 & lcb,iocc_cb,norb,0,idum,idum) 5581 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 5582 & laa,iocc_aa,norb,0,idum,idum) 5583 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 5584 & lab,iocc_ab,norb,0,idum,idum) 5585 5586 ! length of strings in this symmetry block 5587 if (lca*lcb*laa*lab.eq.0) cycle 5588 5589 do iab = 1, lab 5590 if (irestr.eq.1) then 5591 iaa_min = iab 5592 else 5593 iaa_min = 1 5594 end if 5595 do iaa = iaa_min, laa 5596 do icb = 1, lcb 5597 if (irestr.eq.1.and.iaa.eq.iab) then 5598 ica_min = icb 5599 else 5600 ica_min = 1 5601 end if 5602 do ica = ica_min, lca 5603 idx = idx + 1 5604 ! translate into canonical index quadrupel 5605 ii = 0 5606 do iel = 1, nel_ca 5607 ii = ii + 1 5608 idx_c(ii) = iocc_ca((ica-1)*nel_ca+iel) 5609 idx_s(ii) = 1 5610 end do 5611 do iel = 1, nel_cb 5612 ii = ii + 1 5613 idx_c(ii) = iocc_cb((icb-1)*nel_cb+iel) 5614 idx_s(ii) = 2 5615 end do 5616 do iel = 1, nel_aa 5617 ii = ii + 1 5618 idx_c(ii) = iocc_aa((iaa-1)*nel_aa+iel) 5619 idx_s(ii) = 1 5620 idx_s(ii) = 1 5621 end do 5622 do iel = 1, nel_ab 5623 ii = ii + 1 5624 idx_c(ii) = iocc_ab((iab-1)*nel_ab+iel) 5625 idx_s(ii) = 2 5626 end do 5627 5628 idxpq = idx_s(1)*nloff + 5629 & (idx_c(3)-1)*ldiml + idx_c(1) 5630 if (idx_s(1).ne.idx_s(3)) stop 'ups (1)' 5631 idxrs = idx_s(2)*nloff + 5632 & (idx_c(4)-1)*ldiml + idx_c(2) 5633 if (idx_s(2).ne.idx_s(4)) stop 'ups (2)' 5634 5635 ip = idx_c(1) 5636 ir = idx_c(2) 5637 iq = idx_c(3) 5638 is = idx_c(4) 5639 5640 imp = idx_s(1) 5641 imr = idx_s(2) 5642 imq = idx_s(3) 5643 ims = idx_s(4) 5644 5645 if (irmod.eq.1) fac = 1d0 5646c if (irmod.eq.2) fac = -1d0 5647 if (irmod.eq.2) fac = 1d0 5648 5649 5650 do imu = 1,2 5651 do imw = 1, 2 5652 do iu = 1, ndim 5653 urur_rs = urop(ir,iu,imr,imu)* 5654 & urop(is,iu,ims,imu) 5655 uiui_rs = uiop(ir,iu,imr,imu)* 5656 & uiop(is,iu,ims,imu) 5657 uiur_rs = uiop(ir,iu,imr,imu)* 5658 & urop(is,iu,ims,imu) 5659 urui_rs = urop(ir,iu,imr,imu)* 5660 & uiop(is,iu,ims,imu) 5661 5662 urur_pq = urop(ip,iu,imp,imu)* 5663 & urop(iq,iu,imq,imu) 5664 uiui_pq = uiop(ip,iu,imp,imu)* 5665 & uiop(iq,iu,imq,imu) 5666 uiur_pq = uiop(ip,iu,imp,imu)* 5667 & urop(iq,iu,imq,imu) 5668 urui_pq = urop(ip,iu,imp,imu)* 5669 & uiop(iq,iu,imq,imu) 5670 5671 5672 do iw = 1,ndim 5673* term 1 5674 ur = urop(iq,iw,imq,imw) 5675 urgrad(ip,iw,imp,imw) = 5676 & urgrad(ip,iw,imp,imw) + 5677 & ur * (uiur_rs-urui_rs) * 5678 & omop(iw,iu,imw,imu) * ggrad(idx) 5679 5680 ur = urop(ip,iw,imp,imw) 5681 urgrad(iq,iw,imq,imw) = 5682 & urgrad(iq,iw,imq,imw) + 5683 & ur * (uiur_rs-urui_rs) * 5684 & omop(iw,iu,imw,imu) * ggrad(idx) 5685 5686* term 2 5687 5688 ur = urop(is,iw,ims,imw) 5689 urgrad(ir,iw,imr,imw) = 5690 & urgrad(ir,iw,imr,imw) + 5691 & ur * (uiur_pq-urui_pq) * 5692 & omop(iu,iw,imu,imw)* ggrad(idx) 5693 5694 ur = urop(ir,iw,imr,imw) 5695 urgrad(is,iw,ims,imw) = 5696 & urgrad(is,iw,ims,imw) + 5697 & ur * (uiur_pq-urui_pq) * 5698 & omop(iu,iw,imu,imw)* ggrad(idx) 5699 5700* term 3 5701 ui = uiop(ir,iw,imr,imw) 5702 urgrad(is,iw,ims,imw) = 5703 & urgrad(is,iw,ims,imw) + 5704 & (urur_pq+uiui_pq) * ui * 5705 & omop(iu,iw,imu,imw)* ggrad(idx) 5706 5707 ui = - uiop(is,iw,ims,imw) 5708 urgrad(ir,iw,imr,imw) = 5709 & urgrad(ir,iw,imr,imw) + 5710 & (urur_pq+uiui_pq) * ui * 5711 & omop(iu,iw,imu,imw)* ggrad(idx) 5712 5713* term 4 5714 ui = uiop(ip,iw,imp,imw) 5715 urgrad(iq,iw,imq,imw) = 5716 & urgrad(iq,iw,imq,imw) + fac* 5717 & (urur_rs+uiui_rs) * ui * 5718 & omop(iw,iu,imw,imu)* ggrad(idx) 5719 5720 ui = - uiop(iq,iw,imq,imw) 5721 urgrad(ip,iw,imp,imw) = 5722 & urgrad(ip,iw,imp,imw) + fac* 5723 & (urur_rs+uiui_rs) * ui * 5724 & omop(iw,iu,imw,imu)* ggrad(idx) 5725 5726 end do 5727 end do 5728 end do 5729 end do 5730 5731 end do ! ica 5732 end do ! icb 5733 end do ! iaa 5734 end do ! iab 5735 5736 end do ! ism_aa 5737 end do ! ism_ca 5738 end do ! ism_c 5739 5740 end do ! itss 5741 5742c scale with 2d0 5743 fac = 2d0 5744 if (irmod.eq.2) fac = -2d0 5745 call scalve(urgrad,fac,4*ndim**2) 5746 5747 5748 if (ntest.ge.100) then 5749 write(6,*) 'U gradient:' 5750 do imp = 1, 2 5751 do imq = 1, 2 5752 write(6,*) 'spin block: ',imp,imq 5753 call wrtmat2(urgrad(1,1,imp,imq),ndim,ndim,ndim,ndim) 5754 end do 5755 end do 5756 end if 5757 5758 call atim(cpu,wall) 5759 call prtim(6,'time in ggrad2ugrad',cpu-cpu0,wall-wall0) 5760 5761 return 5762 5763 end 5764 5765*--------------------------------------------------------------------* 5766 subroutine ggrad2ugrad_old(ggrad,urgrad,omop,urop,uiop, 5767 & ntss_tp,itss_tp,ndim,irmod) 5768*--------------------------------------------------------------------* 5769* 5770* get U gradient acc. to chain rule 5771* 5772*--------------------------------------------------------------------* 5773 5774 include 'implicit.inc' 5775 include 'mxpdim.inc' 5776 include 'cgas.inc' 5777 include 'multd2h.inc' 5778 include 'orbinp.inc' 5779 include 'csm.inc' 5780 include 'ctcc.inc' 5781 include 'cc_exc.inc' 5782 5783 integer, parameter :: 5784 & ntest = 100 5785 5786* input 5787 real(8), intent(in) :: 5788 & ggrad(*), omop(ndim,ndim,2,2), 5789 & urop(ndim,ndim,2,2), uiop(ndim,ndim,2,2) 5790c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 5791 integer, intent(in) :: 5792 & ntss_tp, 5793 & itss_tp(ngas,4,ntss_tp) 5794 real(8), intent(out) :: 5795 & urgrad(ndim,ndim,2,2) 5796* local 5797 integer :: 5798 & igrp_ca(mxpngas), igrp_cb(mxpngas), 5799 & igrp_aa(mxpngas), igrp_ab(mxpngas), 5800 & iocc_ca(mx_st_tsoso_blk_mx), 5801 & iocc_cb(mx_st_tsoso_blk_mx), 5802 & iocc_aa(mx_st_tsoso_blk_mx), 5803 & iocc_ab(mx_st_tsoso_blk_mx), 5804 & idx_c(4), idx_s(4) 5805 5806 call atim(cpu0,wall0) 5807 5808 ! init 5809 urgrad(1:ndim,1:ndim,1:2,1:2) = 0d0 5810 5811 ! loop over types 5812 idx = 0 5813 do itss = 1, ntss_tp 5814 ! identify two-particle excitations: 5815 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 5816 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 5817 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 5818 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 5819 nc = nel_ca + nel_cb 5820 na = nel_aa + nel_ab 5821 if (na.ne.2) cycle 5822 5823 ! transform occupations to groups 5824 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 5825 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 5826 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 5827 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 5828 5829 if (mscomb_cc.ne.0) then 5830 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 5831 & itss_tp(1,3,itss),itss_tp(1,4,itss), 5832 & ngas,idiag) 5833 else 5834 idiag = 0 5835 end if 5836 5837 ! loop over symmetry blocks 5838 ism = 1 ! totally symmetric operators, n'est-ce pas? 5839 do ism_c = 1, nsmst 5840 ism_a = multd2h(ism,ism_c) 5841 do ism_ca = 1, nsmst 5842 ism_cb = multd2h(ism_c,ism_ca) 5843 do ism_aa = 1, nsmst 5844 ism_ab = multd2h(ism_a,ism_aa) 5845 ! get alpha and beta symmetry index 5846 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 5847 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 5848 5849 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 5850 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 5851 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 5852 irestr = 0 5853 else 5854 irestr = 1 5855 end if 5856 5857 ! get the strings 5858 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 5859 & lca,iocc_ca,norb,0,idum,idum) 5860 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 5861 & lcb,iocc_cb,norb,0,idum,idum) 5862 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 5863 & laa,iocc_aa,norb,0,idum,idum) 5864 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 5865 & lab,iocc_ab,norb,0,idum,idum) 5866 5867 ! length of strings in this symmetry block 5868 if (lca*lcb*laa*lab.eq.0) cycle 5869 5870 do iab = 1, lab 5871 if (irestr.eq.1) then 5872 iaa_min = iab 5873 else 5874 iaa_min = 1 5875 end if 5876 do iaa = iaa_min, laa 5877 do icb = 1, lcb 5878 if (irestr.eq.1.and.iaa.eq.iab) then 5879 ica_min = icb 5880 else 5881 ica_min = 1 5882 end if 5883 do ica = ica_min, lca 5884 idx = idx + 1 5885 ! translate into canonical index quadrupel 5886 ii = 0 5887 do iel = 1, nel_ca 5888 ii = ii + 1 5889 idx_c(ii) = iocc_ca((ica-1)*nel_ca+iel) 5890 idx_s(ii) = 1 5891 end do 5892 do iel = 1, nel_cb 5893 ii = ii + 1 5894 idx_c(ii) = iocc_cb((icb-1)*nel_cb+iel) 5895 idx_s(ii) = 2 5896 end do 5897 do iel = 1, nel_aa 5898 ii = ii + 1 5899 idx_c(ii) = iocc_aa((iaa-1)*nel_aa+iel) 5900 idx_s(ii) = 1 5901 idx_s(ii) = 1 5902 end do 5903 do iel = 1, nel_ab 5904 ii = ii + 1 5905 idx_c(ii) = iocc_ab((iab-1)*nel_ab+iel) 5906 idx_s(ii) = 2 5907 end do 5908 5909 idxpq = idx_s(1)*nloff + 5910 & (idx_c(3)-1)*ldiml + idx_c(1) 5911 if (idx_s(1).ne.idx_s(3)) stop 'ups (1)' 5912 idxrs = idx_s(2)*nloff + 5913 & (idx_c(4)-1)*ldiml + idx_c(2) 5914 if (idx_s(2).ne.idx_s(4)) stop 'ups (2)' 5915 5916 ip = idx_c(1) 5917 ir = idx_c(2) 5918 iq = idx_c(3) 5919 is = idx_c(4) 5920 5921 imp = idx_s(1) 5922 imr = idx_s(2) 5923 imq = idx_s(3) 5924 ims = idx_s(4) 5925 5926 if (irmod.eq.1) fac = 1d0 5927c if (irmod.eq.2) fac = -1d0 5928 if (irmod.eq.2) fac = 1d0 5929 5930 5931 do imu = 1,2 5932 do imv = 1, 2 5933 do imw = 1, 2 5934 do iu = 1, ndim 5935 urur_rs = urop(ir,iu,imr,imu)* 5936 & urop(is,iu,ims,imu) 5937 uiui_rs = uiop(ir,iu,imr,imu)* 5938 & uiop(is,iu,ims,imu) 5939 uiur_rs = uiop(ir,iu,imr,imu)* 5940 & urop(is,iu,ims,imu) 5941 urui_rs = urop(ir,iu,imr,imu)* 5942 & uiop(is,iu,ims,imu) 5943 5944 urur_pq = urop(ip,iu,imp,imu)* 5945 & urop(iq,iu,imq,imu) 5946 uiui_pq = uiop(ip,iu,imp,imu)* 5947 & uiop(iq,iu,imq,imu) 5948 uiur_pq = uiop(ip,iu,imp,imu)* 5949 & urop(iq,iu,imq,imu) 5950 urui_pq = urop(ip,iu,imp,imu)* 5951 & uiop(iq,iu,imq,imu) 5952 5953 5954 do iv = 1, ndim 5955 do iw = 1,ndim 5956* term 1 5957 ur = 0d0 5958 if (iv.eq.ip.and.imv.eq.imp) then 5959 ur = urop(iq,iw,imq,imw) 5960 end if 5961 if (iv.eq.iq.and.imv.eq.imq) then 5962 ur = ur + urop(ip,iw,imp,imw) 5963 end if 5964 urgrad(iv,iw,imv,imw) = 5965 & urgrad(iv,iw,imv,imw) + 5966 & ur * (uiur_rs-urui_rs) * 5967 & omop(iw,iu,imw,imu) * ggrad(idx) 5968* term 2 5969 ur = 0d0 5970 if (iv.eq.ir.and.imv.eq.imr) then 5971 ur = urop(is,iw,ims,imw) 5972 end if 5973 if (iv.eq.is.and.imv.eq.ims) then 5974 ur = ur + urop(ir,iw,imr,imw) 5975 end if 5976 urgrad(iv,iw,imv,imw) = 5977 & urgrad(iv,iw,imv,imw) + 5978 & ur * (uiur_pq-urui_pq) * 5979 & omop(iu,iw,imu,imw)* ggrad(idx) 5980* term 3 5981 ui = 0d0 5982 if (iv.eq.is.and.imv.eq.ims) then 5983 ui = uiop(ir,iw,imr,imw) 5984 end if 5985 if (iv.eq.ir.and.imv.eq.imr) then 5986 ui = ui - uiop(is,iw,ims,imw) 5987 end if 5988 urgrad(iv,iw,imv,imw) = 5989 & urgrad(iv,iw,imv,imw) + fac* 5990 & (urur_pq+uiui_pq) * ui * 5991 & omop(iu,iw,imu,imw)* ggrad(idx) 5992* term 4 5993 ui = 0d0 5994 if (iv.eq.iq.and.imv.eq.imq) then 5995 ui = uiop(ip,iw,imp,imw) 5996 end if 5997 if (iv.eq.ip.and.imv.eq.imp) then 5998 ui = ui - uiop(iq,iw,imq,imw) 5999 end if 6000 urgrad(iv,iw,imv,imw) = 6001 & urgrad(iv,iw,imv,imw) + fac* 6002 & (urur_rs+uiui_rs) * ui * 6003 & omop(iw,iu,imw,imu)* ggrad(idx) 6004 6005 end do 6006 end do 6007 end do 6008 end do 6009 end do 6010 end do 6011 6012 end do ! ica 6013 end do ! icb 6014 end do ! iaa 6015 end do ! iab 6016 6017 end do ! ism_aa 6018 end do ! ism_ca 6019 end do ! ism_c 6020 6021 end do ! itss 6022 6023c scale with 2d0 6024 fac = 2d0 6025 if (irmod.eq.2) fac = -2d0 6026 call scalve(urgrad,fac,4*ndim**2) 6027 6028 6029 if (ntest.ge.100) then 6030 write(6,*) 'U gradient:' 6031 do imp = 1, 2 6032 do imq = 1, 2 6033 write(6,*) 'spin block: ',imp,imq 6034 call wrtmat2(urgrad(1,1,imp,imq),ndim,ndim,ndim,ndim) 6035 end do 6036 end do 6037 end if 6038 6039 call atim(cpu,wall) 6040 call prtim(6,'time in ggrad2ugrad',cpu-cpu0,wall-wall0) 6041 6042 return 6043 6044 end 6045 6046*--------------------------------------------------------------------* 6047 subroutine uou2g(omop,urop,uiop,gop, 6048 & ntss_tp,itss_tp,ibtss_tp,ndim) 6049*--------------------------------------------------------------------* 6050* 6051* Set up elements of two-particle operator G according to 6052* 6053* G(pq,rs)a_pqrs = (....) a_pqrs 6054* 6055*--------------------------------------------------------------------* 6056 6057 include 'implicit.inc' 6058 include 'mxpdim.inc' 6059 include 'cgas.inc' 6060 include 'multd2h.inc' 6061 include 'orbinp.inc' 6062 include 'csm.inc' 6063 include 'ctcc.inc' 6064 include 'cc_exc.inc' 6065 6066 integer, parameter :: 6067 & ntest = 000 6068 6069* input 6070 real(8), intent(inout) :: 6071 & omop(ndim,ndim,2,2), 6072 & urop(ndim,ndim,2,2), 6073 & uiop(ndim,ndim,2,2) 6074c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 6075 integer, intent(in) :: 6076 & ntss_tp, 6077 & itss_tp(ngas,4,ntss_tp), 6078 & ibtss_tp(ntss_tp) 6079 6080 real(8), intent(out) :: 6081 & gop(*) 6082 6083* local 6084 integer :: 6085 & igrp_ca(mxpngas), igrp_cb(mxpngas), 6086 & igrp_aa(mxpngas), igrp_ab(mxpngas), 6087 & iocc_ca(mx_st_tsoso_blk_mx), 6088 & iocc_cb(mx_st_tsoso_blk_mx), 6089 & iocc_aa(mx_st_tsoso_blk_mx), 6090 & iocc_ab(mx_st_tsoso_blk_mx), 6091 & idx_c(4), idx_s(4) 6092 6093 if (ntest.eq.1000) then 6094 write(6,*) '======' 6095 write(6,*) 'Omega:' 6096 write(6,*) '======' 6097 do imp = 1, 2 6098 do imq = 1, 2 6099 write(6,*) 'spin block: ',imp,imq 6100 call wrtmat2(omop(1,1,imp,imq),ndim,ndim,ndim,ndim) 6101 end do 6102 end do 6103 write(6,*) '======' 6104 write(6,*) 'U(Re):' 6105 write(6,*) '======' 6106 do imp = 1, 2 6107 do imq = 1, 2 6108 write(6,*) 'spin block: ',imp,imq 6109 call wrtmat2(urop(1,1,imp,imq),ndim,ndim,ndim,ndim) 6110 end do 6111 end do 6112 write(6,*) '======' 6113 write(6,*) 'U(Im):' 6114 write(6,*) '======' 6115 do imp = 1, 2 6116 do imq = 1, 2 6117 write(6,*) 'spin block: ',imp,imq 6118 call wrtmat2(uiop(1,1,imp,imq),ndim,ndim,ndim,ndim) 6119 end do 6120 end do 6121 6122 end if 6123 6124 ! loop over types 6125 idx = 0 6126 do itss = 1, ntss_tp 6127 if (ibtss_tp(itss).ne.idx+1) then 6128 write(6,*) 'problem with offset for op. ',itss 6129 write(6,*) ' ',ibtss_tp(itss),' != ',idx+1 6130 end if 6131 ! identify two-particle excitations: 6132 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 6133 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 6134 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 6135 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 6136 nc = nel_ca + nel_cb 6137 na = nel_aa + nel_ab 6138 if (na.ne.2) cycle 6139 6140 ! transform occupations to groups 6141 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 6142 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 6143 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 6144 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 6145 6146 if (mscomb_cc.ne.0) then 6147 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 6148 & itss_tp(1,3,itss),itss_tp(1,4,itss), 6149 & ngas,idiag) 6150 else 6151 idiag = 0 6152 end if 6153 6154 ! loop over symmetry blocks 6155 ism = 1 ! totally symmetric operators, n'est-ce pas? 6156 do ism_c = 1, nsmst 6157 ism_a = multd2h(ism,ism_c) 6158 do ism_ca = 1, nsmst 6159 ism_cb = multd2h(ism_c,ism_ca) 6160 do ism_aa = 1, nsmst 6161 ism_ab = multd2h(ism_a,ism_aa) 6162 ! get alpha and beta symmetry index 6163 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 6164 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 6165 6166 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 6167 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 6168 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 6169 irestr = 0 6170 else 6171 irestr = 1 6172 end if 6173 6174 ! get the strings 6175 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 6176 & lca,iocc_ca,norb,0,idum,idum) 6177 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 6178 & lcb,iocc_cb,norb,0,idum,idum) 6179 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 6180 & laa,iocc_aa,norb,0,idum,idum) 6181 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 6182 & lab,iocc_ab,norb,0,idum,idum) 6183 6184 ! length of strings in this symmetry block 6185 if (lca*lcb*laa*lab.eq.0) cycle 6186 6187 do iab = 1, lab 6188 if (irestr.eq.1) then 6189 iaa_min = iab 6190 else 6191 iaa_min = 1 6192 end if 6193 do iaa = iaa_min, laa 6194 do icb = 1, lcb 6195 if (irestr.eq.1.and.iaa.eq.iab) then 6196 ica_min = icb 6197 else 6198 ica_min = 1 6199 end if 6200 do ica = ica_min, lca 6201 idx = idx + 1 6202 ! translate into canonical index quadrupel 6203 ii = 0 6204 do iel = 1, nel_ca 6205 ii = ii + 1 6206 idx_c(ii) = iocc_ca((ica-1)*nel_ca+iel) 6207 idx_s(ii) = 1 6208 end do 6209 do iel = 1, nel_cb 6210 ii = ii + 1 6211 idx_c(ii) = iocc_cb((icb-1)*nel_cb+iel) 6212 idx_s(ii) = 2 6213 end do 6214 do iel = 1, nel_aa 6215 ii = ii + 1 6216 idx_c(ii) = iocc_aa((iaa-1)*nel_aa+iel) 6217 idx_s(ii) = 1 6218 idx_s(ii) = 1 6219 end do 6220 do iel = 1, nel_ab 6221 ii = ii + 1 6222 idx_c(ii) = iocc_ab((iab-1)*nel_ab+iel) 6223 idx_s(ii) = 2 6224 end do 6225 6226 ip = idx_c(1) 6227 ir = idx_c(2) 6228 iq = idx_c(3) 6229 is = idx_c(4) 6230 6231 imp = idx_s(1) 6232 imr = idx_s(2) 6233 imq = idx_s(3) 6234 ims = idx_s(4) 6235 6236 gop(idx) = 0d0 6237 6238 do imt = 1, 2 6239 do imu = 1, 2 6240 do it = 1, ndim 6241 urur_t = urop(ip,it,imp,imt)* 6242 & urop(iq,it,imq,imt) 6243 uiui_t = uiop(ip,it,imp,imt)* 6244 & uiop(iq,it,imq,imt) 6245 uiur_t = uiop(ip,it,imp,imt)* 6246 & urop(iq,it,imq,imt) 6247 urui_t = urop(ip,it,imp,imt)* 6248 & uiop(iq,it,imq,imt) 6249 6250 do iu = 1, ndim 6251 6252 urur_u = urop(ir,iu,imr,imu)* 6253 & urop(is,iu,ims,imu) 6254 uiui_u = uiop(ir,iu,imr,imu)* 6255 & uiop(is,iu,ims,imu) 6256 uiur_u = uiop(ir,iu,imr,imu)* 6257 & urop(is,iu,ims,imu) 6258 urui_u = urop(ir,iu,imr,imu)* 6259 & uiop(is,iu,ims,imu) 6260 6261 gop(idx) = gop(idx) + 6262 & ((urur_t+uiui_t)*(uiur_u-urui_u) 6263 & +(uiur_t-urui_t)*(urur_u+uiui_u)) 6264 & *omop(it,iu,imt,imu) 6265 6266 if (imt.ne.imu) then 6267 gop(idx) = gop(idx) + 6268 & ((urur_t+uiui_t)*(uiur_u-urui_u) 6269 & +(uiur_t-urui_t)*(urur_u+uiui_u)) 6270 & *omop(iu,it,imu,imt) 6271 end if 6272 6273 6274 end do 6275 end do 6276 end do 6277 end do 6278 6279 end do ! ica 6280 end do ! icb 6281 end do ! iaa 6282 end do ! iab 6283 6284 end do ! ism_aa 6285 end do ! ism_ca 6286 end do ! ism_c 6287 6288 end do ! itss 6289 if (ntest.ge.1000) then 6290 write(6,*) 'the two-particle operator:' 6291 call wrt_cc_vec2(gop,6,'GEN_CC') 6292 end if 6293 6294 6295 return 6296 6297 end 6298 6299 6300*------------------------------------------------------------------------* 6301* another clone of EXPT_REF: 6302*------------------------------------------------------------------------* 6303 SUBROUTINE EXPT2_REF(LUC,LUHC,LUSC1,LUSC2,LUSC3, 6304 & THRES_C,MX_TERM, 6305 & ALPHA,TAMP,TSCR,VEC1,VEC2,N_CC_AMP, 6306 & IOPTYP) 6307* 6308* Obtain Exp (alpha T^2) !ref> by Taylor expansion of exponential 6309* 6310* Orig. Version: Jeppe Olsen, March 1998 6311* 6312* Extended to include general CC, summer of 99 6313* 6314* IOPTYP defines symmetry of operator: 6315* 6316* +1 Hermitian 6317* -1 unitary 6318* 0 general 6319* 6320* TSCR is only needed in the first two cases. 6321* 6322c IMPLICIT REAL*8(A-H,O-Z) 6323c INCLUDE 'mxpdim.inc' 6324 INCLUDE 'wrkspc.inc' 6325 6326 REAL*8 INPRDD, INPROD 6327* 6328 INCLUDE 'glbbas.inc' 6329 INCLUDE 'cprnt.inc' 6330* 6331 DIMENSION VEC1(*),VEC2(*),TAMP(*),TSCR(*) 6332 COMMON/CINT_CC/INT_CC 6333* 6334 LBLK = -1 6335* 6336 NTEST = 5 6337 NTEST = MAX(NTEST,IPRCC) 6338* 6339 IF (IOPTYP.EQ.1) THEN 6340 SFAC = 1d0 6341 ELSE IF(IOPTYP.EQ.-1) THEN 6342 SFAC = -1d0 6343 ELSE IF (IOPTYP.NE.0) THEN 6344 WRITE(6,*) 'Indigestible input in EXPT_REF2!!!' 6345 STOP 'IOPTYP in EXPT_REF2' 6346 END IF 6347* 6348 IF(NTEST.GE.5) THEN 6349 WRITE(6,*) 6350 WRITE(6,*) '====================' 6351 WRITE(6,*) 'EXPT2_REF in action ' 6352 WRITE(6,*) '====================' 6353 WRITE(6,*) ' ioptyp = ',ioptyp 6354 WRITE(6,*) ' alpha = ',alpha 6355 WRITE(6,*) ' mx_term = ',mx_term 6356 WRITE(6,*) ' thresh = ',THRES_C 6357 WRITE(6,*) 6358 END IF 6359 IF(NTEST.GE.100) THEN 6360 WRITE(6,*) ' LUC,LUHC,LUSC1,LUSC2',LUC,LUHC,LUSC1,LUSC2 6361 WRITE(6,*) ' Initial vector on LUC ' 6362 IF (NTEST.GE.1000) THEN 6363 CALL WRTVCD(VEC1,LUC,1,LBLK) 6364 ELSE 6365 CALL WRTVSD(VEC1,LUC,1,LBLK) 6366 END IF 6367 END IF 6368* Tell integral fetcher to fetch cc amplitudes, not integrals 6369 INT_CC = 1 6370*. Loop over orders of expansion 6371 N = 0 6372* 6373 IF(NTEST.GE.500) THEN 6374 WRITE(6,*) 'TAMP:' 6375 CALL WRT_CC_VEC2(TAMP,6,'GEN_CC') 6376 END IF 6377 6378 IF (IOPTYP.NE.0) THEN 6379 CALL CONJ_CCAMP(TAMP,1,TSCR) 6380 CALL SCALVE(TSCR,SFAC,N_CC_AMP) 6381 IF(NTEST.GE.500) THEN 6382 WRITE(6,*) 'TAMP+:' 6383 CALL WRT_CC_VEC2(TSCR,6,'GEN_CC') 6384 END IF 6385 END IF 6386* 6387 CALL COPVCD(LUC,LUSC1,VEC1,1,LBLK) 6388 CALL COPVCD(LUC,LUHC,VEC1,1,LBLK) 6389* 6390 DO 6391 N = N+1 6392 IF(NTEST.GE.5) THEN 6393 WRITE(6,*) ' Info for N = ', N 6394 END IF 6395*. (T^2)^N times vector on LUSC1 6396C? WRITE(6,*) ' Input vector to MV7 ' 6397C? CALL WRTVCD(VEC1,LUSC1,1,LBLK) 6398*. T * 1/(N-1)! (T^2)^(N-1) 6399 CALL SIG_GCC(VEC1,VEC2,LUSC1,LUSC2,TAMP) 6400*. T^2 * 1/(N-1)! (T^2)^(N-1) 6401 CALL SIG_GCC(VEC1,VEC2,LUSC2,LUSC3,TAMP) 6402 IF(NTEST.GE.500.AND.IOPTYP.NE.0) THEN 6403 WRITE(6,*) ' 1/(N-1)! (T^2)**(N-1) |0> ' 6404 WRITE(6,*) ' ==================================' 6405 CALL WRTVCD(VEC1,LUSC3,1,LBLK) 6406 END IF 6407 6408 FAC = ALPHA/DBLE(N) 6409 6410 IF(IOPTYP.NE.0) THEN 6411* Part for unitary/hermitean operators: 6412 STOP 'NOT PREPARED FOR IOPTYPE.NE.0' 6413 CALL SCLVCD(LUSC2,LUSC3,FAC,VEC1,1,LBLK) 6414 CALL CONJ_T 6415 CALL SIG_GCC(VEC1,VEC2,LUSC1,LUSC2,TSCR) 6416 CALL CONJ_T 6417 IF(NTEST.GE.500) THEN 6418 WRITE(6,*) ' 1/(N-1)! T^+ (T +/- T^+)**(N-1) |0> ' 6419 WRITE(6,*) ' ==================================' 6420 IF (NTEST.GE.5000) THEN 6421 CALL WRTVCD(VEC1,LUSC2,1,LBLK) 6422 ELSE 6423 CALL WRTVSD(VEC1,LUSC2,1,LBLK) 6424 END IF 6425 END IF 6426c in1 in2 res 6427 CALL VECSMD(VEC1,VEC2,FAC,1d0,LUSC2,LUSC3,LUSC1,1,LBLK) 6428 ELSE 6429* Part for unsymmetric operators: 6430 CALL SCLVCD(LUSC3,LUSC1,FAC,VEC1,1,LBLK) 6431 END IF 6432 IF(NTEST.GE.500) THEN 6433 WRITE(6,*) ' 1/N! (T**2)**(N) |0> ' 6434 WRITE(6,*) ' ================' 6435 IF (NTEST.GE.5000) THEN 6436 CALL WRTVCD(VEC1,LUSC1,1,LBLK) 6437 ELSE 6438 CALL WRTVSD(VEC1,LUSC1,1,LBLK) 6439 END IF 6440 END IF 6441*. Norm of this correction term 6442c XNORM2 = INPRDD(VEC1,VEC2,LUSC1,LUSC1,1,LBLK) 6443c XNORM = SQRT(XNORM2) 6444c I prefer the maximum-norm: 6445 XMXNRM = FDMNXD(LUSC1,2,VEC1,1,LBLK) 6446 IF(NTEST.GE.5) THEN 6447 WRITE(6,*) ' Max.-norm of correction ', XMXNRM 6448 END IF 6449*. Update output file with 1/N! T^N !ref> 6450 ONE = 1.0D0 6451 CALL VECSMD(VEC1,VEC2,ONE,ONE,LUSC1,LUHC,LUSC2,1,LBLK) 6452 CALL COPVCD(LUSC2,LUHC,VEC1,1,LBLK) 6453*. give up? 6454 IF (XMXNRM.GT.1d+100) THEN 6455 WRITE(6,*) 'Wavefunction blows up! Take a step back :-)' 6456 WRITE(6,*) ' Norm of last 1/N! T^N !ref>: ',XMXNRM,' for N=',N 6457 XNORM=SQRT(INPROD(TAMP,TAMP,N_CC_AMP)) 6458 WRITE(6,*) ' Norm of T was: ', XNORM 6459 STOP 'WOOMM!' 6460 END IF 6461*. Finito ? 6462 IF (XMXNRM.LE.THRES_C .OR. N.GE.MX_TERM) EXIT 6463 6464 END DO 6465*. NOTE: Result on LUHC 6466* 6467* Not converged ? 6468 IF (XMXNRM.GT.THRES_C) THEN 6469 WRITE(6,'(x,a,i5,a)') 6470 $ 'Fatal: No convergence in EXPT_REF (max. iter.:', 6471 $ MX_TERM, ' )' 6472 STOP 'No convergence in EXPT_REF!' 6473 END IF 6474C CALL COPVCD(LUSC3,LUHC,VEC1,1,LBLK) 6475 IF(NTEST.GE.5) THEN 6476 WRITE(6,*) ' Convergence obtained in ', N, ' iterations' 6477 WRITE(6,*) ' Max.-norm of last correction ', XMXNRM 6478 END IF 6479* 6480 IF(NTEST.GE.100) THEN 6481 WRITE(6,*) 6482 WRITE(6,*) ' ===============' 6483 WRITE(6,*) ' Exp (T^2) |ref> ' 6484 WRITE(6,*) ' ===============' 6485 WRITE(6,*) 6486 IF (NTEST.GE.1000) THEN 6487 CALL WRTVCD(VEC1,LUHC,1,LBLK) 6488 ELSE 6489 CALL WRTVSD(VEC1,LUHC,1,LBLK) 6490 END IF 6491 END IF 6492* 6493 RETURN 6494 END 6495*------------------------------------------------------------------------* 6496*--------------------------------------------------------------------* 6497 subroutine can2str(iway,gcan,gstr,ntss_tp,itss_tp,ibtss_tp) 6498*--------------------------------------------------------------------* 6499* 6500* Set up elements of operator G in spinstring ordering using 6501* operator G' in canonical, symmetry-blocked ordering 6502* 6503* iway == 1 : canonical -> string 6504* iway == 2 : canonical <- string 6505* 6506*--------------------------------------------------------------------* 6507 6508 include 'implicit.inc' 6509 include 'mxpdim.inc' 6510 include 'cgas.inc' 6511 include 'multd2h.inc' 6512 include 'lucinp.inc' 6513 include 'orbinp.inc' 6514 include 'csm.inc' 6515 include 'ctcc.inc' 6516 include 'cc_exc.inc' 6517 6518 integer, parameter :: 6519 & ntest = 1000 6520 6521* input 6522c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 6523 integer, intent(in) :: 6524 & ntss_tp, 6525 & itss_tp(ngas,4,ntss_tp), 6526 & ibtss_tp(ntss_tp) 6527 6528 real(8), intent(inout) :: 6529 & gcan(*), gstr(*) 6530 6531* local 6532 integer :: 6533 & igrp_ca(mxpngas), igrp_cb(mxpngas), 6534 & igrp_aa(mxpngas), igrp_ab(mxpngas), 6535 & iocc_ca(mx_st_tsoso_blk_mx), 6536 & iocc_cb(mx_st_tsoso_blk_mx), 6537 & iocc_aa(mx_st_tsoso_blk_mx), 6538 & iocc_ab(mx_st_tsoso_blk_mx), 6539 & idx_c(4), idx_s(4), isym_c(4), isymoff(nsmst) 6540 6541 if (iway.ne.1.and.iway.ne.2) then 6542 write(6,*) 'can2str: illegal value for iway: ',iway 6543 stop 'can2str' 6544 end if 6545 6546 if (ntest.ge.500) then 6547 write(6,*) ' iway = ',iway 6548 write(6,*) 'Input operator' 6549 if (iway.eq.1) then 6550 call aprblm2(gcan,ntoobs,ntoobs,nsmst,0) 6551 else if (iway.eq.2) then 6552 call wrt_cc_vec2(gstr,6,'GEN_CC') 6553 end if 6554 end if 6555 6556 ! get symmetry offsets (for 1-particle operators) 6557 idx = 0 6558 do ism = 1, nsmst 6559 isymoff(ism) = idx 6560 idx = idx + ntoobs(ism)*ntoobs(ism) 6561 end do 6562 nlen = idx 6563 6564 ! now we loop over the elements in string-ordered form 6565 6566 ! loop over types 6567 idx = 0 6568 do itss = 1, ntss_tp 6569c if (ibtss_tp(itss).ne.idx+1) then 6570c write(6,*) 'problem with offset for op. ',itss 6571c write(6,*) ' ',ibtss_tp(itss),' != ',idx+1 6572c end if 6573 ! identify two-particle excitations: 6574 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 6575 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 6576 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 6577 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 6578 nc = nel_ca + nel_cb 6579 na = nel_aa + nel_ab 6580 6581 ! transform occupations to groups 6582 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 6583 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 6584 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 6585 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 6586 6587 if (mscomb_cc.ne.0) then 6588 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 6589 & itss_tp(1,3,itss),itss_tp(1,4,itss), 6590 & ngas,idiag) 6591 else 6592 idiag = 0 6593 end if 6594 6595 ! loop over symmetry blocks 6596 ism = 1 ! totally symmetric operators, n'est-ce pas? 6597 do ism_c = 1, nsmst 6598 ism_a = multd2h(ism,ism_c) 6599 do ism_ca = 1, nsmst 6600 ism_cb = multd2h(ism_c,ism_ca) 6601 do ism_aa = 1, nsmst 6602 ism_ab = multd2h(ism_a,ism_aa) 6603 ! get alpha and beta symmetry index 6604 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 6605 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 6606 6607 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 6608 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 6609 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 6610 irestr = 0 6611 else 6612 irestr = 1 6613 end if 6614 6615 ! get the strings 6616 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 6617 & lca,iocc_ca,norb,0,idum,idum) 6618 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 6619 & lcb,iocc_cb,norb,0,idum,idum) 6620 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 6621 & laa,iocc_aa,norb,0,idum,idum) 6622 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 6623 & lab,iocc_ab,norb,0,idum,idum) 6624 6625 ! length of strings in this symmetry block 6626 if (lca*lcb*laa*lab.eq.0) cycle 6627 6628 do iab = 1, lab 6629 if (irestr.eq.1) then 6630 iaa_min = iab 6631 else 6632 iaa_min = 1 6633 end if 6634 do iaa = iaa_min, laa 6635 do icb = 1, lcb 6636 if (irestr.eq.1.and.iaa.eq.iab) then 6637 ica_min = icb 6638 else 6639 ica_min = 1 6640 end if 6641 do ica = ica_min, lca 6642 idx = idx + 1 6643 ! translate into canonical index n-tupel 6644 ! ireots: translates type-ordering to symmetry-ordering 6645 ! ibso: orbital-offset for symmetry 6646 ii = 0 6647 do iel = 1, nel_ca 6648 ii = ii + 1 6649 idx_c(ii) = ireots(iocc_ca((ica-1)*nel_ca+iel)) 6650 & -ibso(ism_ca) + 1 6651 idx_s(ii) = 1 6652 isym_c(ii) = ism_ca 6653 end do 6654 do iel = 1, nel_cb 6655 ii = ii + 1 6656 idx_c(ii) = ireots(iocc_cb((icb-1)*nel_cb+iel)) 6657 & -ibso(ism_cb) + 1 6658 idx_s(ii) = 2 6659 isym_c(ii) = ism_cb 6660 end do 6661 do iel = 1, nel_aa 6662 ii = ii + 1 6663 idx_c(ii) = ireots(iocc_aa((iaa-1)*nel_aa+iel)) 6664 & -ibso(ism_aa) + 1 6665 idx_s(ii) = 1 6666 isym_c(ii) = ism_aa 6667 end do 6668 do iel = 1, nel_ab 6669 ii = ii + 1 6670 idx_c(ii) = ireots(iocc_ab((iab-1)*nel_ab+iel)) 6671 & -ibso(ism_ab) + 1 6672 idx_s(ii) = 2 6673 isym_c(ii) = ism_ab 6674 end do 6675 6676 ! lots of if's in the inner loop ... 6677 if (na.eq.1) then 6678 ! 1-particle operators 6679 idxpq = (idx_s(1)-1)*nlen + 6680 & isymoff(isym_c(1)) + 6681 & (idx_c(2)-1)*ntoobs(isym_c(1)) + idx_c(1) 6682 if (idx_s(1).ne.idx_s(2)) stop 'flip (1)' 6683 6684 if (iway.eq.1) then 6685 gstr(idx) = gcan(idxpq) 6686 else if (iway.eq.2) then 6687 gcan(idxpq) = gstr(idx) 6688 end if 6689 6690 else if (na.eq.2) then 6691 ! 2-particle operators 6692 stop 'too lazy' 6693 6694 end if 6695 6696 end do ! ica 6697 end do ! icb 6698 end do ! iaa 6699 end do ! iab 6700 6701 end do ! ism_aa 6702 end do ! ism_ca 6703 end do ! ism_c 6704 6705 end do ! itss 6706 if (ntest.ge.500) then 6707 write(6,*) ' iway = ',iway 6708 write(6,*) 'Output operator' 6709 if (iway.eq.1) then 6710 call wrt_cc_vec2(gstr,6,'GEN_CC') 6711 else if (iway.eq.2) then 6712 call aprblm2(gcan,ntoobs,ntoobs,nsmst,0) 6713 end if 6714 end if 6715 6716 return 6717 6718 end 6719*--------------------------------------------------------------------* 6720 subroutine l2g(lop,gop,ntss_tp,itss_tp,ibtss_tp,nloff,ldiml) 6721*--------------------------------------------------------------------* 6722* 6723* Set up elements of two-particle operator G according to 6724* 6725* G(pq,rs)a_pqrs = L(pq)L(rs)a_pqrs 6726* 6727* G is blocked over operator types, each of these symmetry-blocked 6728* and in string ordering. 6729* 6730* L is quadratic array p,q running over indices in type ordering 6731* and includes also frozen or deleted orbitals, which are 6732* ignored when setting up G. 6733* 6734* Probably not the most elegant routine on earth, but at least 6735* it works.... 6736* 6737*--------------------------------------------------------------------* 6738 6739 include 'implicit.inc' 6740 include 'mxpdim.inc' 6741 include 'cgas.inc' 6742 include 'multd2h.inc' 6743 include 'orbinp.inc' 6744 include 'csm.inc' 6745 include 'ctcc.inc' 6746 include 'cc_exc.inc' 6747 6748 integer, parameter :: 6749 & ntest = 1000 6750 6751* input 6752 real(8), intent(in) :: 6753 & lop(*) 6754c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 6755 integer, intent(in) :: 6756 & ntss_tp, 6757 & itss_tp(ngas,4,ntss_tp), 6758 & ibtss_tp(ntss_tp) 6759 6760 real(8), intent(out) :: 6761 & gop(*) 6762 6763* local 6764 integer :: 6765 & igrp_ca(mxpngas), igrp_cb(mxpngas), 6766 & igrp_aa(mxpngas), igrp_ab(mxpngas), 6767 & iocc_ca(mx_st_tsoso_blk_mx), 6768 & iocc_cb(mx_st_tsoso_blk_mx), 6769 & iocc_aa(mx_st_tsoso_blk_mx), 6770 & iocc_ab(mx_st_tsoso_blk_mx), 6771 & idx_c(4), idx_s(4) 6772 6773 ! loop over types 6774 idx = 0 6775 do itss = 1, ntss_tp 6776 if (ibtss_tp(itss).ne.idx+1) then 6777 write(6,*) 'problem with offset for op. ',itss 6778 write(6,*) ' ',ibtss_tp(itss),' != ',idx+1 6779 end if 6780 ! identify two-particle excitations: 6781 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 6782 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 6783 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 6784 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 6785 nc = nel_ca + nel_cb 6786 na = nel_aa + nel_ab 6787 if (na.ne.2) cycle 6788 6789 ! transform occupations to groups 6790 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 6791 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 6792 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 6793 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 6794 6795 if (mscomb_cc.ne.0) then 6796 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 6797 & itss_tp(1,3,itss),itss_tp(1,4,itss), 6798 & ngas,idiag) 6799 else 6800 idiag = 0 6801 end if 6802 6803 ! loop over symmetry blocks 6804 ism = 1 ! totally symmetric operators, n'est-ce pas? 6805 do ism_c = 1, nsmst 6806 ism_a = multd2h(ism,ism_c) 6807 do ism_ca = 1, nsmst 6808 ism_cb = multd2h(ism_c,ism_ca) 6809 do ism_aa = 1, nsmst 6810 ism_ab = multd2h(ism_a,ism_aa) 6811 ! get alpha and beta symmetry index 6812 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 6813 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 6814 6815 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 6816 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 6817 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 6818 irestr = 0 6819 else 6820 irestr = 1 6821 end if 6822 6823 ! get the strings 6824 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 6825 & lca,iocc_ca,norb,0,idum,idum) 6826 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 6827 & lcb,iocc_cb,norb,0,idum,idum) 6828 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 6829 & laa,iocc_aa,norb,0,idum,idum) 6830 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 6831 & lab,iocc_ab,norb,0,idum,idum) 6832 6833 ! length of strings in this symmetry block 6834 if (lca*lcb*laa*lab.eq.0) cycle 6835 6836 do iab = 1, lab 6837 if (irestr.eq.1) then 6838 iaa_min = iab 6839 else 6840 iaa_min = 1 6841 end if 6842 do iaa = iaa_min, laa 6843 do icb = 1, lcb 6844 if (irestr.eq.1.and.iaa.eq.iab) then 6845 ica_min = icb 6846 else 6847 ica_min = 1 6848 end if 6849 do ica = ica_min, lca 6850 idx = idx + 1 6851 ! translate into canonical index quadrupel 6852 ii = 0 6853 do iel = 1, nel_ca 6854 ii = ii + 1 6855 idx_c(ii) = iocc_ca((ica-1)*nel_ca+iel) 6856 idx_s(ii) = 1 6857 end do 6858 do iel = 1, nel_cb 6859 ii = ii + 1 6860 idx_c(ii) = iocc_cb((icb-1)*nel_cb+iel) 6861 idx_s(ii) = 2 6862 end do 6863 do iel = 1, nel_aa 6864 ii = ii + 1 6865 idx_c(ii) = iocc_aa((iaa-1)*nel_aa+iel) 6866 idx_s(ii) = 1 6867 idx_s(ii) = 1 6868 end do 6869 do iel = 1, nel_ab 6870 ii = ii + 1 6871 idx_c(ii) = iocc_ab((iab-1)*nel_ab+iel) 6872 idx_s(ii) = 2 6873 end do 6874 6875c print *,idx,'-> (',idx_c(1:4),')' 6876c print *,' -> (',idx_s(1:4),')' 6877 6878 idxpq = idx_s(1)*nloff + 6879 & (idx_c(3)-1)*ldiml + idx_c(1) 6880 if (idx_s(1).ne.idx_s(3)) stop 'ups (1)' 6881 idxrs = idx_s(2)*nloff + 6882 & (idx_c(4)-1)*ldiml + idx_c(2) 6883 if (idx_s(2).ne.idx_s(4)) stop 'ups (2)' 6884 6885 gop(idx) = lop(idxpq)*lop(idxrs) 6886c print *,' gop(',idxpq,idxrs,')=',gop(idx) 6887c print *,' ',lop(idxpq),lop(idxrs) 6888 6889 end do ! ica 6890 end do ! icb 6891 end do ! iaa 6892 end do ! iab 6893 6894 end do ! ism_aa 6895 end do ! ism_ca 6896 end do ! ism_c 6897 6898 end do ! itss 6899 if (ntest.ge.1000) then 6900 write(6,*) 'the two-particle operator:' 6901 call wrt_cc_vec2(gop,6,'GEN_CC') 6902 end if 6903 6904 6905 return 6906 6907 end 6908 6909*--------------------------------------------------------------------* 6910 subroutine pack_g(iway,idum,isymG,gop_pack,gop, 6911 & ntss_tp,itss_tp,ibtss_tp, 6912 & n11amp,n33amp,ioff_amp_pack,n_cc_amp) 6913*--------------------------------------------------------------------* 6914* 6915* pack G from form defined by ntss_tp to usual lower triangle 6916* used for 2-el. integrals (for closed shell cases) 6917* 6918* iway: 2 pack and symmetrize 6919* 1 pack (no symmetrizations) 6920* -1 unpack 6921* 6922* be careful with changes: 6923* 1 and -1 should pack and unpack giving the same vector again 6924* AND: a packed gradient should be exactly the gradient wrt. the 6925* packed amplitudes (!!), else the optimization routines will go 6926* gaga .... 6927* 6928*--------------------------------------------------------------------* 6929 6930c include 'implicit.inc' 6931c include 'mxpdim.inc' 6932 include 'wrkspc.inc' 6933 include 'cgas.inc' 6934 include 'multd2h.inc' 6935 include 'orbinp.inc' 6936 include 'lucinp.inc' 6937 include 'csm.inc' 6938 include 'ctcc.inc' 6939 include 'glbbas.inc' 6940 include 'cc_exc.inc' 6941 6942 integer, parameter :: 6943 & ntest = 000 6944 real(8), parameter :: 6945c & f1 = 1d0, 6946c & f2 = 1.73205080756887729352d0 ! sqrt(3) 6947 & f1 = .70710678118654752440d0, ! sqrt(0.5) 6948 & f2 = 1.22474487139158904909d0 ! sqrt(1.5) 6949 6950* input 6951 real(8), intent(inout) :: 6952 & gop(*) 6953c input needed: itss_tp <-- work(klsobex), ntss_tp <-- nspobex_tp 6954 integer, intent(in) :: 6955 & ntss_tp, 6956 & itss_tp(ngas,4,ntss_tp), 6957 & ibtss_tp(ntss_tp), 6958 & ioff_amp_pack(*) 6959 6960 real(8), intent(inout) :: 6961 & gop_pack(*) 6962 6963* local 6964 integer :: 6965 & igrp_ca(mxpngas), igrp_cb(mxpngas), 6966 & igrp_aa(mxpngas), igrp_ab(mxpngas), 6967 & iocc_ca(mx_st_tsoso_blk_mx), 6968 & iocc_cb(mx_st_tsoso_blk_mx), 6969 & iocc_aa(mx_st_tsoso_blk_mx), 6970 & iocc_ab(mx_st_tsoso_blk_mx), 6971 & idx_c(4), idx_s(4) 6972 6973 if (ntest.ge.10) then 6974 write(6,*) '================' 6975 write(6,*) ' this is pack_g' 6976 write(6,*) '================' 6977 print *,'iway = ', iway 6978 print *,'isymG = ', isymG 6979 print *,'ntss_tp:', ntss_tp 6980 print *,'ibtss_tp: ',ibtss_tp 6981 print *,'n11amp,n33amp,n_cc_amp: ',n11amp,n33amp,n_cc_amp 6982 6983 if (ntest.ge.1000) then 6984 if (iway.gt.0) then 6985 print *,'input vector:' 6986 call wrt_cc_vec2(gop,6,'GEN_CC') 6987 else 6988 print *,'input packed vector (11 part):' 6989 call wrtmat(gop_pack,n11amp,1,n11amp,1) 6990 print *,'input packed vector (33 part):' 6991 call wrtmat(gop_pack(n11amp+1),n33amp,1,n11amp,1) 6992 end if 6993 end if 6994 end if 6995 6996 iap_off = nsmob**3+1 6997 ittoff = n11amp+1 6998 6999 if (iway.ne.1.and.iway.ne.2.and.iway.ne.3.and.iway.ne.-1) then 7000 write(6,*) 'strange iway = ', iway 7001 stop 'pack_G' 7002 end if 7003 if (isymG.ne.1.and.isymG.ne.-1) then 7004 write(6,*) 'pack_G called for non-symmetric G ',isymG 7005 stop 'pack_G' 7006 end if 7007 7008 if (iway.ge.1) gop_pack(1:n11amp+n33amp) = 0d0 7009 if (iway.le.-1) gop(1:n_cc_amp) = 0d0 7010 7011 ! loop over types 7012 do itss = 1, ntss_tp 7013 idx = ibtss_tp(itss) - 1 7014c if (ibtss_tp(itss).ne.idx+1) then 7015c write(6,*) 'problem with offset for op. ',itss 7016c write(6,*) ' ',ibtss_tp(itss),' != ',idx+1 7017c end if 7018 ! identify two-particle excitations: 7019 7020 nel_ca = ielsum(itss_tp(1,1,itss),ngas) 7021 nel_cb = ielsum(itss_tp(1,2,itss),ngas) 7022 nel_aa = ielsum(itss_tp(1,3,itss),ngas) 7023 nel_ab = ielsum(itss_tp(1,4,itss),ngas) 7024 nc = nel_ca + nel_cb 7025 na = nel_aa + nel_ab 7026 if (na.ne.2) stop 'accept only G2, not G1+G2 !' 7027 7028 ! skip all aa or bb operators on packing 7029 ! (only bb case for gradient packing) 7030 if ((iway.eq.1.or.iway.eq.2).and. 7031 & (nel_ca.eq.2.or.nel_cb.eq.2)) cycle 7032 7033 ! transform occupations to groups 7034 call occ_to_grp(itss_tp(1,1,itss),igrp_ca,1) 7035 call occ_to_grp(itss_tp(1,2,itss),igrp_cb,1) 7036 call occ_to_grp(itss_tp(1,3,itss),igrp_aa,1) 7037 call occ_to_grp(itss_tp(1,4,itss),igrp_ab,1) 7038 7039 if (mscomb_cc.ne.0) then 7040 call diag_exc_cc(itss_tp(1,1,itss),itss_tp(1,2,itss), 7041 & itss_tp(1,3,itss),itss_tp(1,4,itss), 7042 & ngas,idiag) 7043 else 7044 idiag = 0 7045 end if 7046 7047 ! loop over symmetry blocks 7048 ism = 1 ! totally symmetric operators, n'est-ce pas? 7049 do ism_c = 1, nsmst 7050 ism_a = multd2h(ism,ism_c) 7051 do ism_ca = 1, nsmst 7052 ism_cb = multd2h(ism_c,ism_ca) 7053 do ism_aa = 1, nsmst 7054 ism_ab = multd2h(ism_a,ism_aa) 7055 ! get alpha and beta symmetry index 7056 ism_alp = (ism_aa-1)*nsmst+ism_ca ! = (sym Ca,sym Aa) 7057 ism_bet = (ism_ab-1)*nsmst+ism_cb ! = (sym Cb,sym Ab) 7058 7059 ! restrict to (sym Ca,sym Aa) >= (sym Cb,sym Ab) 7060 if (idiag.eq.1.and.ism_bet.gt.ism_alp) cycle 7061 if (idiag.eq.0.or.ism_alp.gt.ism_bet) then 7062 irestr = 0 7063 else 7064 irestr = 1 7065 end if 7066 7067 ! get the strings 7068 call getstr2_totsm_spgp(igrp_ca,ngas,ism_ca,nel_ca, 7069 & lca,iocc_ca,norb,0,idum,idum) 7070 call getstr2_totsm_spgp(igrp_cb,ngas,ism_cb,nel_cb, 7071 & lcb,iocc_cb,norb,0,idum,idum) 7072 call getstr2_totsm_spgp(igrp_aa,ngas,ism_aa,nel_aa, 7073 & laa,iocc_aa,norb,0,idum,idum) 7074 call getstr2_totsm_spgp(igrp_ab,ngas,ism_ab,nel_ab, 7075 & lab,iocc_ab,norb,0,idum,idum) 7076 7077 ! length of strings in this symmetry block 7078 if (lca*lcb*laa*lab.eq.0) cycle 7079 7080 do iab = 1, lab 7081 if (irestr.eq.1) then 7082 iaa_min = iab 7083 else 7084 iaa_min = 1 7085 end if 7086 do iaa = iaa_min, laa 7087 do icb = 1, lcb 7088 if (irestr.eq.1.and.iaa.eq.iab) then 7089 ica_min = icb 7090 else 7091 ica_min = 1 7092 end if 7093 do ica = ica_min, lca 7094 idx = idx + 1 7095 ! translate into canonical index quadrupel 7096 ii = 0 7097 do iel = 1, nel_ca 7098 ii = ii + 1 7099 idx_c(ii) = iocc_ca((ica-1)*nel_ca+iel) 7100 idx_s(ii) = 1 7101 end do 7102 do iel = 1, nel_cb 7103 ii = ii + 1 7104 idx_c(ii) = iocc_cb((icb-1)*nel_cb+iel) 7105 idx_s(ii) = 2 7106 end do 7107 do iel = 1, nel_aa 7108 ii = ii + 1 7109 idx_c(ii) = iocc_aa((iaa-1)*nel_aa+iel) 7110 idx_s(ii) = 1 7111 end do 7112 do iel = 1, nel_ab 7113 ii = ii + 1 7114 idx_c(ii) = iocc_ab((iab-1)*nel_ab+iel) 7115 idx_s(ii) = 2 7116 end do 7117 7118 idxp = idx_c(1) 7119 idxr = idx_c(2) 7120 idxq = idx_c(3) 7121 idxs = idx_c(4) 7122 7123 idxpr = (min(idxp,idxr)-1)*ntoob+max(idxp,idxr) 7124 idxqs = (min(idxq,idxs)-1)*ntoob+max(idxq,idxs) 7125 7126 if (iway.eq.1) then 7127 ! packing 7128 ! take only triangle 7129 if (idxp.gt.idxr .or. idxq.gt.idxs) cycle 7130 7131 iadr = i2addr2(ireots(idxp),ireots(idxr), 7132 & ireots(idxq),ireots(idxs), 7133 & ioff_amp_pack,1,1,isymG) 7134 if (iadr.lt.0) cycle 7135 if (iadr.eq.0) stop 'iadr error' 7136 7137 gop_pack(iadr) = gop(idx) 7138 7139 if (ntest.ge.1000) 7140 & print '(a,2i4,a,4i4,i5,2(x,e12.6))', 7141 & '1S',itss,idx-ibtss_tp(itss)+1,'->', 7142 & idxp,idxr,idxq,idxs,iadr, 7143 & gop(idx) 7144 & 7145 7146 if (idxp.eq.idxr .or. idxq.eq.idxs) cycle 7147 7148 iadr = i2addr2(ireots(idxp),ireots(idxr), 7149 & ireots(idxq),ireots(idxs), 7150 & ioff_amp_pack(iap_off),-1,-1,isymG) 7151 if (iadr.lt.0) cycle 7152 if (iadr.eq.0) stop 'iadr error' 7153 7154 gop_pack(ittoff+iadr) = gop(idx) 7155 7156 if (ntest.ge.1000) 7157 & print '(a,2i4,a,4i4,i5,2(x,e12.6))', 7158 & '1T',itss,idx-ibtss_tp(itss)+1,'->', 7159 & idxp,idxr,idxq,idxs,iadr, 7160 & gop(idx) 7161 7162*----------------------------------------------------------------------* 7163* 2: packing and (anti-)symmetrizing 7164*----------------------------------------------------------------------* 7165 else if (iway.eq.2) then 7166*----------------------------------------------------------------------* 7167* 2A: contributions to G(+): 7168*----------------------------------------------------------------------* 7169 7170 fac = f1 7171 if (idxpr.ge.idxqs) fac = dble(isymG)*fac 7172 7173c & sqrt(dble(isymfac(idxp,idxr,idxq,idxs))) 7174c if (idxp.eq.idxr) fac = fac/2d0 7175c if (idxq.eq.idxs) fac = fac/2d0 7176c if (idxp.eq.idxr.and.idxq.eq.idxs) fac = fac/2d0 7177C if (idxp.eq.idxr.or.idxq.eq.idxs) fac = fac/2d0 7178 7179 write(6,*) ' Jeppe commented this out to get code running ' 7180C if ( idxp.eq.idxr.xor.idxq.eq.idxs) 7181C & fac = fac*sqrt(2d0) 7182 7183 if (idxp.le.idxr.and.idxq.le.idxs) then 7184 iadr = i2addr2(ireots(idxp),ireots(idxr), 7185 & ireots(idxq),ireots(idxs), 7186 & ioff_amp_pack,1,1,isymG) 7187 if (iadr.lt.0) cycle 7188 if (iadr.eq.0) stop 'iadr error' 7189 7190c sfac = 1d0 7191c if (idxp.eq.idxr.or.idxq.eq.idxs) sfac = 2d0 7192 gop_pack(iadr) = gop_pack(iadr) 7193 & + fac*gop(idx) 7194 7195 if (ntest.ge.1000) 7196 & print '(a,2i4,i5,a,4i4,i5,3(x,e12.6))', 7197 & '2S1',itss,idx-ibtss_tp(itss)+1,idx,'->', 7198 & idxp,idxr,idxq,idxs,iadr, 7199 & gop(idx),gop_pack(iadr),fac 7200 7201 else if (idxp.lt.idxr.and.idxq.ne.idxs) then 7202 iadr = i2addr2(ireots(idxp),ireots(idxr), 7203 & ireots(idxs),ireots(idxq), 7204 & ioff_amp_pack,1,1,isymG) 7205 if (iadr.lt.0) cycle 7206 if (iadr.eq.0) stop 'iadr error' 7207 7208 gop_pack(iadr) = gop_pack(iadr) 7209 & + fac*gop(idx) 7210 if (ntest.ge.1000) 7211 & print '(a,2i4,i5,a,4i4,i5,3(x,e12.6))', 7212 & '2S2',itss,idx-ibtss_tp(itss)+1,idx,'->', 7213 & idxp,idxr,idxs,idxq,iadr, 7214 & gop(idx),gop_pack(iadr),fac 7215 7216 end if 7217 7218*----------------------------------------------------------------------* 7219* 2B: contributions to G(-): 7220*----------------------------------------------------------------------* 7221 fac = f2 7222 if (idxpr.ge.idxqs) fac = dble(isymG)*fac 7223 7224 if (idxp.lt.idxr.and.idxq.lt.idxs) then 7225 iadr = i2addr2(ireots(idxp),ireots(idxr), 7226 & ireots(idxq),ireots(idxs), 7227 & ioff_amp_pack(iap_off),-1,-1,isymG) 7228 if (iadr.lt.0) cycle 7229 if (iadr.eq.0) stop 'iadr error' 7230 7231 gop_pack(ittoff+iadr) = gop_pack(ittoff+iadr) 7232 & + fac*gop(idx) 7233 7234 if (ntest.ge.1000) 7235 & print '(a,2i4,i5,a,4i4,i5,3(x,e12.6))', 7236 & '2T1',itss,idx-ibtss_tp(itss)+1,idx,'->', 7237 & idxp,idxr,idxs,idxq,iadr, 7238 & gop(idx),gop_pack(ittoff+iadr),fac 7239 7240 else if (idxp.lt.idxr.and.idxq.ne.idxs) then 7241 iadr = i2addr2(ireots(idxp),ireots(idxr), 7242 & ireots(idxs),ireots(idxq), 7243 & ioff_amp_pack(iap_off),-1,-1,isymG) 7244 7245 if (iadr.lt.0) cycle 7246 if (iadr.eq.0) stop 'iadr error' 7247 7248 gop_pack(ittoff+iadr) = gop_pack(ittoff+iadr) 7249 & - fac*gop(idx) 7250 if (ntest.ge.1000) 7251 & print '(a,2i4,i5,a,4i4,i5,3(x,e12.6))', 7252 & '2T2',itss,idx-ibtss_tp(itss)+1,idx,'->', 7253 & idxp,idxr,idxs,idxq,iadr, 7254 & gop(idx),gop_pack(ittoff+iadr),-fac 7255 7256 end if 7257 7258*----------------------------------------------------------------------* 7259* -1: unpacking 7260*----------------------------------------------------------------------* 7261 else 7262*----------------------------------------------------------------------* 7263* -1A: unpack contrib.s from G(-) to either G(aa),G(bb) or G(ab) 7264*----------------------------------------------------------------------* 7265c fac = 7266c & 1d0/sqrt(dble(isymfac(idxp,idxr,idxq,idxs))) 7267 if (idx_s(1).eq.idx_s(2)) then 7268 fac = 0.5d0/f2 7269 else 7270 fac = 0.5d0/f2 7271 if (idxp.ne.idxr.and.idxq.ne.idxs) 7272 & fac = fac/2d0 7273 end if 7274 7275 if ( idxpr.gt.idxqs) 7276 & fac = dble(isymG)*fac 7277 7278c if (idx_s(1).ne.idx_s(2)) 7279c & fac = 0.5d0*fac 7280 7281 sfac = 1d0 7282 if (idxp.gt.idxr) sfac = sfac*(-1d0) 7283 if (idxq.gt.idxs) sfac = sfac*(-1d0) 7284 iadr = i2addr2(ireots(idxp),ireots(idxr), 7285 & ireots(idxq),ireots(idxs), 7286 & ioff_amp_pack(iap_off),-1,-1,isymG) 7287 7288 if (iadr.ge.0) then 7289 if (iadr.eq.0) stop 'iadr error' 7290 if (iadr.gt.n33amp) then 7291 print *,'1: ',idxp,idxq,idxr,idxs 7292 print *,'2: ',ioff_amp_pack(1:3) 7293 stop 'error error' 7294 end if 7295 7296 gop(idx) = sfac*fac*gop_pack(ittoff+iadr) 7297 7298 if (ntest.ge.1000) 7299 & print '(a,2i4,i5,a,4i4,i5,3(x,e12.6))', 7300 & '3:-',itss,idx-ibtss_tp(itss)+1,idx,'<-', 7301 & idxp,idxr,idxq,idxs,iadr, 7302 & gop(idx),gop_pack(ittoff+iadr),sfac*fac 7303 & 7304 end if 7305 7306 if (idx_s(1).eq.idx_s(2)) cycle 7307*----------------------------------------------------------------------* 7308* -1B: unpack contrib.s from G(+) to G(ab) 7309*----------------------------------------------------------------------* 7310 7311c fac = 1.0d0 7312 fac = 0.5d0/f1 7313 7314 write(6,*) ' Jeppe commented this out to get code running ' 7315C if ( idxp.eq.idxr.xor.idxq.eq.idxs) 7316C & fac = fac/sqrt(2d0) 7317 7318 if ( idxpr.gt.idxqs) 7319 & fac = dble(isymG)*fac 7320 if (idxp.ne.idxr.and.idxq.ne.idxs) 7321 & fac = fac/2d0 7322 7323c if (idxp.eq.idxr) fac = fac*2d0 7324c if (idxq.eq.idxs) fac = fac*2d0 7325 7326 iadr = i2addr2( 7327 & ireots(idxp),ireots(idxr), 7328 & ireots(idxs),ireots(idxq), 7329 & ioff_amp_pack,1,1,isymG) 7330 7331 if (iadr.lt.0) cycle 7332 if (iadr.eq.0) stop 'iadr error' 7333 gop(idx) = gop(idx)+fac*gop_pack(iadr) 7334 7335 if (ntest.ge.1000) 7336 & print '(a,2i4,i5,a,4i4,i5,3(x,e12.6))', 7337 & '3:+',itss,idx-ibtss_tp(itss)+1,idx,'<-', 7338 & idxp,idxr,idxs,idxq,iadr, 7339 & gop(idx),gop_pack(iadr),fac 7340 & 7341 end if 7342 7343 end do ! ica 7344 end do ! icb 7345 end do ! iaa 7346 end do ! iab 7347 7348 end do ! ism_aa 7349 end do ! ism_ca 7350 end do ! ism_c 7351 7352 end do ! itss 7353 7354 if (ntest.eq.1000) then 7355 if (iway.gt.0) then 7356 print *,'packed vector (11)' 7357 call wrtmat(gop_pack,n11amp,1,n11amp,1) 7358 print *,'packed vector (33)' 7359 call wrtmat(gop_pack(n11amp+1),n33amp,1,n33amp,1) 7360 else 7361 print *,'unpacked vector' 7362 call wrt_cc_vec2(gop,6,'GEN_CC') 7363 end if 7364 end if 7365 7366 return 7367 7368 end 7369 7370 integer function isymfac(ip,ir,iq,is) 7371* return the number of non-identical permutations of the index-quadruple 7372* unter (anti-)hermitian and particle symmetry 7373* 7374* identity (ip,ir,iq,is) 7375* hermitian conj. (iq,is,ip,ir) 7376* particle perm. (ir,ip,is,iq) 7377* h. c. + p. p. (is,iq,ir,ip) 7378* 7379 implicit none 7380 7381 integer, parameter :: 7382 & ntest = 00 7383 7384 integer, intent(in) :: 7385 & ip,ir,iq,is 7386 7387 integer :: 7388 & ifac 7389 7390 ifac = 1 7391 ! symmetric under herm. conj.? 7392 if (.not.(ip.eq.iq.and.ir.eq.is)) ifac = ifac*2 7393 ! symmetric under particle perm.? 7394 if (.not.(ip.eq.ir.and.iq.eq.is)) ifac = ifac*2 7395 ! symmetric under combination of both? 7396 if (ifac.eq.4 .and. 7397 & (ip.eq.is.and.iq.eq.ir)) ifac = ifac/2 7398 7399 if (ntest.ge.100) 7400 & write(6,'(x,a,4i10,a,i2)') 7401 & 'isymfac: ',ip,ir,iq,is,' --> ',ifac 7402 7403 isymfac = ifac 7404 return 7405 7406 end 7407 7408 subroutine set_frobs(nfrob,nfrobs) 7409 7410 include 'implicit.inc' 7411 include 'mxpdim.inc' 7412 include 'lucinp.inc' 7413 include 'csm.inc' 7414 include 'csmprd.inc' 7415 include 'cgas.inc' 7416 7417 dimension nfrobs(nsmob) 7418 7419 isym = 1 7420 7421 nfrobs(1:nsmob) = 0 7422 do igas = 1, ngas-1 7423 ! excitations allowed in this GAS space? 7424 nrem = igsocc(igas,2)-igsocc(igas,1) 7425 if (nrem.gt.0) exit 7426 nfrobs(1:nsmob) = nfrobs(1:nsmob)+ngssh(1:nsmob,igas) 7427 print *,'1> ',igspc,nrem 7428 print *,' ',nfrobs(1:nsmob) 7429 end do 7430 7431 nfrob = sum(nfrobs,nsmob) 7432 7433 print *,'final suggestion:' 7434 print *,' ',nfrobs(1:nsmob) 7435 print *,' >',nfrob 7436 7437 return 7438 end 7439 7440 subroutine num_ssaa2op(nndiag,ndiag) 7441 7442* find the number of symmetry and spin (i.e. singlet) adapted 7443* antisymmetric two-body operators 7444 include 'implicit.inc' 7445 include 'mxpdim.inc' 7446 include 'lucinp.inc' 7447 include 'csm.inc' 7448 include 'csmprd.inc' 7449 include 'cgas.inc' 7450 7451 logical lpdiag,lhdiag,lhpdiag 7452 dimension iact(ngas) 7453 7454 isym = 1 7455 7456 do igspc = 1, ngas 7457 ! 2-body excitations allowed in this GAS space? 7458 nrem = igsocc(igspc,2)-igsocc(igspc,1) 7459 nadd = 0 7460 if (igspc.gt.1) 7461 & nadd = igsocc(igspc,2)-igsocc(igspc-1,1) 7462 if (nrem.ne.0.or.nadd.ne.0) then 7463 iact(igspc) = 1 7464 else 7465 iact(igspc) = 0 7466 end if 7467 print *,'1> ',igspc,nrem,nadd 7468 end do 7469 7470 print *,'-> ',iact(1:ngas) 7471 7472 isum = 0 7473 isumd = 0 7474 do ip1spc = 1, ngas 7475 if (iact(ip1spc).eq.0) cycle 7476 do ip2spc = 1, ip1spc 7477 if (iact(ip2spc).eq.0) cycle 7478 lpdiag = ip1spc.eq.ip2spc 7479 ipidx = (ip1spc-1)*ngas + ip2spc 7480 do ih1spc = 1, ngas 7481 if (iact(ih1spc).eq.0) cycle 7482 do ih2spc = 1, ih1spc 7483 if (iact(ih2spc).eq.0) cycle 7484 lhdiag = ih1spc.eq.ih2spc 7485 ihidx = (ih1spc-1)*ngas + ih2spc 7486 lhpdiag = ihidx.eq.ipidx 7487 if (ihidx.gt.ipidx) cycle 7488 7489 ii12 = 0 7490 ii34 = 0 7491 ii1234 = 0 7492 if (lpdiag) ii12 = 1 7493 if (lhdiag) ii34 = 1 7494 if (lhpdiag) ii1234 = 1 7495 7496 print *,'>> ',lpdiag,lhdiag,lhpdiag 7497 7498 print *,' p1: ',ngssh(1:nirrep,ip1spc) 7499 print *,' p2: ',ngssh(1:nirrep,ip2spc) 7500 print *,' h1: ',ngssh(1:nirrep,ih1spc) 7501 print *,' h2: ',ngssh(1:nirrep,ih2spc) 7502 7503 inum = ndxfsm(nsmob,nsmsx,mxpobs, 7504 & ngssh(1,ip1spc),ngssh(1,ip2spc), 7505 & ngssh(1,ih1spc),ngssh(1,ih2spc), 7506 & isym,adsxa,sxdxsx,ii12,ii34,ii1234,0) 7507 7508 idiag = 0 7509 if (lhpdiag) then 7510 do ii = 1, nirrep 7511 do jj = 1, nirrep 7512 idiag = idiag + ngssh(ii,ip1spc)*ngssh(jj,ih1spc) 7513 end do 7514 end do 7515 end if 7516 7517 print '(a,4i3,2i8)','> ',ip1spc,ip2spc,ih1spc,ih2spc,inum, 7518 & idiag 7519 7520 isum = isum + inum 7521 isumd = isumd + idiag 7522 7523 end do 7524 end do 7525 end do 7526 end do 7527 7528 ndiag = isumd 7529 nndiag = isum-isumd 7530 7531 return 7532 7533 end 7534*----------------------------------------------------------------------* 7535 subroutine gtbce_h0(imode,igtb_closed,isymmet_G, 7536 & iccvec,nSdim, 7537 & ccvec1,ccvec2,ccvec3, 7538 & civec1,civec2,c2vec, 7539 & n_cc_amp,mxb_ci, 7540 & n_cc_typ,i_cc_typ,ioff_cc_typ, 7541 & n11amp,n33amp,iamp_packed, 7542 & luh0,ludia, 7543 & luamp,luec,luhc, 7544 & lusc1,lusc2) 7545*----------------------------------------------------------------------* 7546* 7547* imode == 0: <ref|exp(-G)tau(mu)tau(nu)exp(G)|ref> 7548* imode == 1: 2<ref|exp(-G)tau(mu)H tau(nu)exp(G)|ref> 7549* -2<ref|exp(-G)H tau(mu)tau(nu)exp(G)|ref> 7550* imode == 2: dto. and save diagonal on ludia 7551* 7552*----------------------------------------------------------------------* 7553 implicit none 7554 7555 integer, parameter :: 7556 & ntest = 100 7557 7558 integer, intent(in) :: 7559 & isymmet_G, igtb_closed, n11amp, n33amp, 7560 & n_cc_amp, nsdim, mxb_ci, 7561 & luamp, luec, luhc, luh0, ludia, 7562 & lusc1, lusc2, iamp_packed(*), iccvec(n_cc_amp), 7563 & n_cc_typ(*), i_cc_typ(*), ioff_cc_typ(*) 7564 7565 real(8), intent(inout) :: 7566 & ccvec1(n_cc_amp), ccvec2(n_cc_amp), ccvec3(n_cc_amp), 7567 & civec1(mxb_ci), civec2(mxb_ci), c2vec(*) 7568 7569 integer :: 7570 & iamp, iadj, lblk, isigden, idx, ii, imode, icnt, 7571 & namp, nsave, iway, idum 7572 real(8) :: 7573 & fac, xmin, xsh, 7574 & wall0, wall, cpu0, cpu 7575 7576 real(8), external :: 7577 & inprod 7578 7579 call atim(cpu0,wall0) 7580 7581 if (ntest.gt.0) then 7582 write(6,*) '=====================' 7583 write(6,*) ' here comes gtbce_h0' 7584 write(6,*) '=====================' 7585 write(6,*) ' isymmet_G, igtb_closed : ',isymmet_G, igtb_closed 7586 write(6,*) ' nSdim, n_cc_amp: ',nSdim,n_cc_amp 7587 write(6,*) ' luh0, luamp, luec, luhc: ',luh0, luamp, luec, luhc 7588 end if 7589 7590 call rewino(luh0) 7591 7592 icnt = 0 7593 lblk = -1 7594 fac = dble(isymmet_G) 7595 namp = n_cc_amp 7596 if (igtb_closed.eq.1) then 7597 namp = n11amp+n33amp 7598 end if 7599 do iamp = 1, namp 7600 7601 if (ntest.ge.10) write(6,*) ' iamp = ',iamp,'/',namp 7602 7603 if (igtb_closed.eq.1.and.isymmet_G.ne.0) then 7604 if (iccvec(iamp).lt.0) cycle 7605 end if 7606 icnt = icnt+1 7607 7608 if (isymmet_G.ne.0.and.igtb_closed.eq.1) then 7609 ccvec1(1:namp) = 0d0 7610 ccvec1(iamp) = 1d0 7611 iway = -1 7612 call pack_g(iway,idum,isymmet_G,ccvec1,ccvec2, 7613 & n_cc_typ,i_cc_typ,ioff_cc_typ, 7614 & n11amp,n33amp,iamp_packed,n_cc_amp) 7615 7616 else if (isymmet_G.eq.0) then 7617 ccvec2(1:namp) = 0d0 7618 ccvec2(iamp) = 1d0 7619 else 7620 ccvec2(1:namp) = 0d0 7621 iadj = abs(iccvec(iamp)) 7622 ccvec2(iamp) = sqrt(2d0) 7623 ccvec2(iadj) = fac*sqrt(2d0) 7624 end if 7625 7626*----------------------------------------------------------------------* 7627* calculate tau_(iamp)exp(G)|ref> 7628*----------------------------------------------------------------------* 7629 isigden=1 7630 call sigden_cc(civec1,civec2,luec,lusc1,ccvec2,isigden) 7631 7632 7633 if (imode.ge.1) then 7634*----------------------------------------------------------------------* 7635* calculate H tau_(iamp)exp(G)|ref> 7636*----------------------------------------------------------------------* 7637 call mv7(civec1,civec2,lusc1,lusc2) 7638 7639*----------------------------------------------------------------------* 7640* 1: <ref|exp(G)tau_(iamp) tau(nu) H exp(G)|ref> 7641*----------------------------------------------------------------------* 7642 ccvec1(1:n_cc_amp) = 0d0 7643 isigden = 2 7644 call sigden_cc(civec1,civec2,luhc,lusc1,ccvec1,isigden) 7645 7646*----------------------------------------------------------------------* 7647* 2: <ref|exp(G)tau_(iamp) H tau(nu) exp(G)|ref> 7648*----------------------------------------------------------------------* 7649 ccvec2(1:n_cc_amp) = 0d0 7650 isigden = 2 7651 call sigden_cc(civec1,civec2,luec,lusc2,ccvec2,isigden) 7652 call vecsum(ccvec1,ccvec1,ccvec2,-2d0,2d0,n_cc_amp) 7653 else 7654*----------------------------------------------------------------------* 7655* 2: <ref|exp(G)tau_(iamp) tau(nu) exp(G)|ref> 7656*----------------------------------------------------------------------* 7657 ccvec1(1:n_cc_amp) = 0d0 7658 isigden = 2 7659 call sigden_cc(civec1,civec2,luec,lusc1,ccvec1,isigden) 7660 end if 7661 7662 if (isymmet_G.ne.0.and.igtb_closed.eq.0) then 7663 ! collect diagonal 7664 iadj = abs(iccvec(iamp)) 7665 ccvec3(iamp) = ccvec1(iamp)+fac*ccvec1(iadj) 7666 ccvec3(iadj) = ccvec3(iamp) ! we want them positive 7667 ! compress result vector 7668 idx = 0 7669 do ii = 1, n_cc_amp 7670 if (iccvec(ii).le.0) cycle 7671 idx = idx + 1 7672 iadj = abs(iccvec(ii)) 7673 ccvec2(idx) = ccvec1(ii)+fac*ccvec1(iadj) 7674 end do 7675 nsave = nSdim 7676 if (imode.eq.0) nsave = icnt 7677 call vec_to_disc(ccvec2,nsave,0,lblk,luh0) 7678 else if (igtb_closed.eq.1) then 7679 ! pack again 7680 iway = 2 7681 call pack_g(iway,idum,isymmet_G,ccvec2,ccvec1, 7682 & n_cc_typ,i_cc_typ,ioff_cc_typ, 7683 & n11amp,n33amp,iamp_packed,n_cc_amp) 7684 ccvec3(iamp) = ccvec2(iamp) 7685 nsave = nSdim 7686 if (imode.eq.0) nsave = icnt 7687 call vec_to_disc(ccvec2,nsave,0,lblk,luh0) 7688 else 7689 ccvec3(iamp) = ccvec1(iamp) 7690 nsave = nSdim 7691 if (imode.eq.0) nsave = icnt 7692 call vec_to_disc(ccvec1,nsave,0,lblk,luh0) 7693 end if 7694 7695 end do ! iamp 7696 7697 if (imode.eq.2) then 7698 ! look at diagonal 7699 xmin = 1000d0 7700 do ii = 1, namp 7701 xmin = min(ccvec3(ii),xmin) 7702 end do 7703 write(6,*) 'diagonal: lowest element = ',xmin 7704 xsh = max(0d0,0.01d0-xmin) 7705 write(6,*) 'shift diagonal by ',xsh 7706 do ii = 1, namp 7707 ccvec3(ii) = ccvec3(ii)+xsh 7708 end do 7709 if (isymmet_G.ne.0) then 7710 do ii = 1, namp 7711 if (iccvec(ii).eq.-ii) ccvec3(ii)=1d12 7712 end do 7713 end if 7714 call vec_to_disc(ccvec3,namp,1,-1,ludia) 7715 end if 7716 7717 call atim(cpu,wall) 7718 call prtim(6,'time in gtbce_h0',cpu-cpu0,wall-wall0) 7719 7720 return 7721 7722 end 7723********************************************************************** 7724 subroutine ana_gucc(vec,n11amp,n33amp,iamp_packed, 7725 & ireost,nsmob,ntoob) 7726 7727 implicit none 7728 7729 integer, parameter :: 7730 & ntest = 100, nlist = 20 7731 7732 integer, intent(in) :: 7733 & n11amp, n33amp, iamp_packed(*), ireost(*), nsmob, ntoob 7734 real(8), intent(in) :: 7735 & vec(*) 7736 7737 real(8) :: 7738 & xlist(nlist), x11n, x33n 7739 7740 integer :: 7741 & ii, ilist(nlist), ijkllist(4,nlist) 7742 7743 real(8), external :: 7744 & inprod 7745 7746 x11n = sqrt(inprod(vec,vec,n11amp)) 7747 7748 call list_asl(2,vec,n11amp,xlist,ilist,nlist) 7749 7750 call ijkl2iadr(ijkllist,ilist,nlist, 7751 & ntoob,ireost,iamp_packed,1,1,-1) 7752 7753 write(6,*) 'singlet-singlet coupled part: ' 7754 write(6,'(x,a,i10,a,g20.8)')' amplitudes: ',n11amp,' norm: ',x11n 7755 write(6,*) 'largest amplitudes:' 7756 do ii = 1, nlist 7757 write(6,'(x,i8,x,4i5,g20.8)') 7758 & ilist(ii),ijkllist(1:4,ii),xlist(ii) 7759 end do 7760 7761 x33n = sqrt(inprod(vec(n11amp+1),vec(n11amp+1),n33amp)) 7762 7763 call list_asl(2,vec(n11amp+1),n33amp,xlist,ilist,nlist) 7764 7765 call ijkl2iadr(ijkllist,ilist,nlist, 7766 & ntoob,ireost,iamp_packed(nsmob**3+1),-1,-1,-1) 7767 7768 write(6,*) 'triplet-triplet coupled part: ' 7769 write(6,'(x,a,i10,a,g20.8)')' amplitudes: ',n33amp,' norm: ',x33n 7770 write(6,*) 'largest amplitudes:' 7771 do ii = 1, nlist 7772 write(6,'(x,i8,x,4i5,g20.8)') 7773 & ilist(ii),ijkllist(1:4,ii),xlist(ii) 7774 end do 7775 7776 return 7777 7778 end 7779********************************************************************** 7780 FUNCTION NCSF_FOR_CISPACE(ISPC,ISYM) 7781* 7782* Find number of CSF's, CONF's (and SD's) for given CISPACE 7783* and symmetry 7784* 7785* The CI space is defined by the integer ISPC 7786* 7787* The spin-multiplicity, 2*Ms and combination flags 7788* are obtained from MULTS, MS2 and PSSIGN in CSTATE. 7789* 7790* The symmetry is defined by ISYM 7791* 7792* 7793* A bit of modifications from CSFDIM_GAS for Andreas 7794* 7795* Jeppe Olsen, Aug 2004 7796* 7797* 7798* ( Spin signaled by PSSIGN in CIINFO) 7799* 7800c INCLUDE 'implicit.inc' 7801c INCLUDE 'mxpdim.inc' 7802 INCLUDE 'wrkspc.inc' 7803 INCLUDE 'orbinp.inc' 7804 INCLUDE 'cstate.inc' 7805 INCLUDE 'glbbas.inc' 7806 INCLUDE 'cgas.inc' 7807 INCLUDE 'spinfo.inc' 7808 INCLUDE 'cprnt.inc' 7809 INCLUDE 'gasstr.inc' 7810* Scratch for one occupation class 7811 INTEGER IOCCLS(MXPNGAS) 7812* 7813 IDUM = 0 7814 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'NCSF_F') 7815* 7816 NTEST = 1 7817 NTEST = MAX(IPRCIX,NTEST) 7818 IF(NTEST.GE.10) WRITE(6,*) ' PSSIGN : ', PSSIGN 7819 IF(NTEST.GE.10) WRITE(6,*) ' MULTS, MS2 = ', MULTS,MS2 7820*. Obtain the occupation classes for this CISPACE 7821*. Number of occupation classes 7822*. Number 7823 IATP = 1 7824 IBTP = 2 7825 NEL = NELFTP(IATP)+NELFTP(IBTP) 7826 CALL OCCLSE(1,NOCCLS,IOCCLS,NEL,ISPC,0,0,NOBPT) 7827*. And the occupation classes 7828 CALL MEMMAN(KLOCCLS,NOCCLS*NGAS,'ADDL ',1,'OCCLS ') 7829 CALL OCCLSE(2,NOCCLS,WORK(KLOCCLS),NEL,ISPC,0,0,NOBPT) 7830*. Number of occupation classes for T-operators 7831* 7832*.. Define parameters in SPINFO 7833* 7834*. Allowed number of open orbitals 7835 MINOP = ABS(MS2) 7836 CALL MAX_OPEN_ORB(MAXOP,WORK(KLOCCLS),NGAS,NOCCLS,NOBPT) 7837 IF( NTEST .GE. 2 ) 7838 &WRITE(6,*) ' MINOP MAXOP ',MINOP,MAXOP 7839C 7840C.. Number of prototype sd's and csf's per configuration prototype 7841C 7842 ITP = 0 7843 DO IOPEN = 0, MAXOP 7844 ITP = IOPEN + 1 7845*. Unpaired electrons : 7846 IAEL = (IOPEN + MS2 ) / 2 7847 IBEL = (IOPEN - MS2 ) / 2 7848 IF(IAEL+IBEL .EQ. IOPEN .AND. IAEL-IBEL .EQ. MS2 .AND. 7849 & IAEL .GE. 0 .AND. IBEL .GE. 0) THEN 7850 NPDTCNF(ITP) = IBION(IOPEN,IAEL) 7851 IF(PSSIGN.EQ. 0.0D0 .OR. IOPEN .EQ. 0 ) THEN 7852 NPCMCNF(ITP) = NPDTCNF(ITP) 7853 ELSE 7854 NPCMCNF(ITP) = NPDTCNF(ITP)/2 7855 END IF 7856 IF(IOPEN .GE. MULTS-1) THEN 7857 NPCSCNF(ITP) = IWEYLF(IOPEN,MULTS) 7858 ELSE 7859 NPCSCNF(ITP) = 0 7860 END IF 7861 ELSE 7862 NPDTCNF(ITP) = 0 7863 NPCMCNF(ITP) = 0 7864 NPCSCNF(ITP) = 0 7865 END IF 7866 END DO 7867* 7868 IF(NTEST.GE.1) THEN 7869 IF(PSSIGN .EQ. 0 ) THEN 7870 WRITE(6,*) ' (Combinations = Determinants ) ' 7871 ELSE 7872 WRITE(6,*) ' (Spin combinations in use ) ' 7873 END IF 7874 WRITE(6,'(/A)') ' Information about prototype configurations ' 7875 WRITE(6,'( A)') ' ========================================== ' 7876 WRITE(6,'(/A)') 7877 &' Open orbitals Combinations CSFs ' 7878 DO IOPEN = MINOP,MAXOP,2 7879 WRITE(6,'(5X,I3,10X,I6,7X,I6)') 7880 & IOPEN,NPCMCNF(IOPEN+1),NPCSCNF(IOPEN+1) 7881 END DO 7882* 7883 END IF 7884C 7885C.. Number of Configurations per occupation type 7886C 7887 DO JOCCLS = 1, NOCCLS 7888 IF(JOCCLS.EQ.1) THEN 7889 INITIALIZE_CONF_COUNTERS = 1 7890 ELSE 7891 INITIALIZE_CONF_COUNTERS = 0 7892 END IF 7893* 7894 IDOREO = 0 7895 CALL ICOPVE2(WORK(KLOCCLS),(JOCCLS-1)*NGAS+1,NGAS,IOCCLS) 7896 IB_ORB = NINOB + 1 7897 CALL GEN_CONF_FOR_OCCLS(IOCCLS, 7898 & IDUM,INITIALIZE_CONF_COUNTERS, 7899 & NGAS,ISYM,MINOP,MAXOP,NSMST,1,NOCOB, 7900 & NOBPT,NCONF_PER_OPEN(1,ISYM),NCONF_OCCLS, 7901 & IB_CONF_REO,IB_CNOCC_OPEN, 7902 & IDUM,IDOREO,IDUMMY,IDUMMY,NCONF_ALL_SYM,IB_ORB) 7903* 7904 END DO 7905*. Number of CSF's in expansion 7906 CALL NCNF_TO_NCOMP(MAXOP,NCONF_PER_OPEN(1,ISYM),NPCSCNF, 7907 & NCSF) 7908*. Number of SD's in expansion 7909 CALL NCNF_TO_NCOMP(MAXOP,NCONF_PER_OPEN(1,ISYM),NPDTCNF, 7910 & NSD) 7911*. Number of combinations in expansion 7912 CALL NCNF_TO_NCOMP(MAXOP,NCONF_PER_OPEN(1,ISYM),NPCMCNF, 7913 & NCM) 7914* 7915 NCSF_PER_SYM(ISYM) = NCSF 7916 NSD_PER_SYM(ISYM) = NSD 7917 NCM_PER_SYM(ISYM) = NCM 7918 NCONF_PER_SYM(ISYM) = IELSUM(NCONF_PER_OPEN(1,ISYM),MAXOP+1) 7919 IF(NTEST.GE.5) THEN 7920 WRITE(6,*) ' Number of CSFs ', NCSF 7921 WRITE(6,*) ' Number of SDs ', NSD 7922 WRITE(6,*) ' Number of Confs ', NCONF_PER_SYM(ISYM) 7923 WRITE(6,*) ' Number of CMs ', NCM 7924 END IF 7925* 7926 NCSF_FOR_CISPACE = NCSF 7927* 7928 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'NCSF_F') 7929* 7930 RETURN 7931 END 7932c $Id$ 7933