diff --git a/src/cphf/cphf_poliz.F b/src/cphf/cphf_poliz.F index e2fdb30651f..7262ef17e65 100644 --- a/src/cphf/cphf_poliz.F +++ b/src/cphf/cphf_poliz.F @@ -45,7 +45,7 @@ logical function cphf_poliz(rtdb) c c Get MO vectors etc. c - hf_job = .not. bgj_have_xc() + hf_job = .not. bgj_have_xc(rtdb) if(.not.rtdb_cget(rtdb, 'title', 1, title)) title = ' ' if(.not.geom_create(geom, 'geometry')) $ call errquit('cphf_poliz: geom_create?', 0, GEOM_ERR) @@ -70,7 +70,7 @@ logical function cphf_poliz(rtdb) $ call errquit('cphf_poliz: no DFT MO vectors',0, RTDB_ERR) c write(*,*)'*** cphf_poliz: dft movecs: ',movecs c !!! Hack to set up scftype properly for later code - if (bgj_restricted()) then + if (bgj_restricted(rtdb)) then scftype = 'RHF' else scftype = 'UHF' @@ -142,7 +142,7 @@ logical function cphf_poliz(rtdb) nob=noa endif endif - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'*** cphf_poliz: noa nob',noa,nob nopen = 0 nva=nmo-noa @@ -152,7 +152,7 @@ logical function cphf_poliz(rtdb) else if (scftype .eq. 'RHF' .or. scftype.eq.'ROHF') then nvirt = nmo - nclosed - nopen vlen = nclosed*(nopen+nvirt) + nopen*nvirt - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'nvirt,nmo,nclosed,nopen',nvirt,nmo,nclosed,nopen else call errquit('cphf: unknown SCF type',0, @@ -237,7 +237,7 @@ logical function cphf_poliz(rtdb) c enddo c - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'*** cphf_poliz: done with x y z loop' if (.not. ga_destroy(g_vecs_a)) call errquit('cphf_poliz: ga',1, & GA_ERR) diff --git a/src/cphf/cphf_solve.F b/src/cphf/cphf_solve.F index 16084b7d132..622bde628d5 100644 --- a/src/cphf/cphf_solve.F +++ b/src/cphf/cphf_solve.F @@ -76,7 +76,7 @@ subroutine cphf_solve(rtdb) $ call errquit('cphf_solve: no DFT MO vectors',0, RTDB_ERR) c !!! Hack to set up scftype properly for later code !!! ? need this? #if 0 - if (bgj_restricted()) then + if (bgj_restricted(rtdb)) then scftype = 'RHF' else scftype = 'UHF' @@ -91,7 +91,7 @@ subroutine cphf_solve(rtdb) & UNKNOWN_ERR) nbases = 1 bases(1) = basis - if (bgj_have_j_fit()) then + if (bgj_have_j_fit(rtdb)) then nbases = 2 bases(2) = bgj_CD_bas_han() write(*,*) 'cphf_solve: bases',bases diff --git a/src/cphf/cphf_solve2.F b/src/cphf/cphf_solve2.F index 0f841f88e09..3db6bf2c6d7 100644 --- a/src/cphf/cphf_solve2.F +++ b/src/cphf/cphf_solve2.F @@ -96,7 +96,7 @@ subroutine cphf_solve2(rtdb) nbases = 1 bases(1) = basis #if 0 - if (bgj_have_j_fit()) then + if (bgj_have_j_fit(rtdb)) then nbases = 2 bases(2) = bgj_CD_bas_han() if (ga_nodeid().eq.0) then diff --git a/src/cphf/cphf_solve3.F b/src/cphf/cphf_solve3.F index 6f2f2299992..46caeb17496 100644 --- a/src/cphf/cphf_solve3.F +++ b/src/cphf/cphf_solve3.F @@ -149,7 +149,7 @@ subroutine cphf_solve3(rtdb, omega, lifetime, gamwidth) $ call errquit('cphf_solve3: no DFT MO vectors',0, RTDB_ERR) #if 0 c !!! Hack to set up scftype properly for later code !!! ? need this? - if (bgj_restricted()) then + if (bgj_restricted(rtdb)) then scftype = 'RHF' else scftype = 'UHF' @@ -164,7 +164,7 @@ subroutine cphf_solve3(rtdb, omega, lifetime, gamwidth) & UNKNOWN_ERR) nbases = 1 bases(1) = basis - if (bgj_have_j_fit()) then + if (bgj_have_j_fit(rtdb)) then nbases = 2 bases(2) = bgj_CD_bas_han() write(*,*) 'cphf_solve3: bases',bases diff --git a/src/cphf/cphf_solve4.F b/src/cphf/cphf_solve4.F index c9f1b27bf2e..b1a014946ec 100644 --- a/src/cphf/cphf_solve4.F +++ b/src/cphf/cphf_solve4.F @@ -77,7 +77,7 @@ subroutine cphf_solve4(rtdb) $ call errquit('cphf_solve: no DFT MO vectors',0, RTDB_ERR) #if 0 c !!! Hack to set up scftype properly for later code !!! ? need this? - if (bgj_restricted()) then + if (bgj_restricted(rtdb)) then scftype = 'RHF' else scftype = 'UHF' @@ -92,7 +92,7 @@ subroutine cphf_solve4(rtdb) & UNKNOWN_ERR) nbases = 1 bases(1) = basis - if (bgj_have_j_fit()) then + if (bgj_have_j_fit(rtdb)) then nbases = 2 bases(2) = bgj_CD_bas_han() write(*,*) 'cphf_solve4: bases',bases diff --git a/src/ddscf/fock_2e.F b/src/ddscf/fock_2e.F index 2cf86c58e12..41cec6e4044 100644 --- a/src/ddscf/fock_2e.F +++ b/src/ddscf/fock_2e.F @@ -1,4 +1,4 @@ - subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, + subroutine fock_2e( rtdb, geom1, ao_basis, mfock, jfac, kfac, $ tol2e1, oskel1, vg_dens, vg_fock, asym ) c$Id$ c @@ -19,6 +19,7 @@ subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, #include "util.fh" #include "stdio.fh" + integer rtdb integer geom1, ao_basis ! [input] parameter handles integer nfock,mfock ! [input] number of Fock matrices double precision tol2e1 ! [input] integral selection threshold @@ -41,7 +42,7 @@ subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, logical xc_active, jfit,oprint,odft,cphf_uhf oprint= util_print('fock_2e',print_debug) cphf_uhf = .false. - if (.not. rtdb_get(bgj_get_rtdb_handle(), + if (.not. rtdb_get(rtdb, & 'cphf_solve:cphf_uhf', mt_log, 1, cphf_uhf)) then cphf_uhf = .false. endif @@ -59,15 +60,15 @@ subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, c c See if XC is active for this call c - if (.not.rtdb_get(bgj_get_rtdb_handle(),'bgj:xc_active',MT_LOG,1, + if (.not.rtdb_get(rtdb,'bgj:xc_active',MT_LOG,1, & xc_active)) xc_active = .false. if (oprint) & write(luout,*)'*** fock_2e: xc_active ',xc_active c c Set K contribution to be correct even for pure DFT and hybrids c - if (xc_active .and. bgj_have_xc()) then - call dscal(nfock, bgj_kfac(), kfac, 1) + if (xc_active .and. bgj_have_xc(rtdb)) then + call dscal(nfock, bgj_kfac(rtdb), kfac, 1) if (oprint) & write(luout,*)'*** fock_2e: set kfac to ', & (kfac(ifock),ifock=1,nfock) @@ -75,7 +76,7 @@ subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, c c Determine whether J fitting is involved c - jfit = bgj_have_j_fit().and.(jfac(1).ne.0d0) + jfit = bgj_have_j_fit(rtdb).and.(jfac(1).ne.0d0) c !!! Edo commented this out before since it caused bugs - ask him about c !!! it when it is necessary to turn back on for J fit CPKS jfit = .false. @@ -90,8 +91,8 @@ subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, & write(luout,*)'*** fock_2e: jfit case - original jfac = ', & jfac(1) cold jfac(1)=0d0 -cold kfac(1)=-0.5d0*bgj_kfac() - call ao_fock_2e( geom1, ao_basis, 1, 0d0, -0.5d0*bgj_kfac(), +cold kfac(1)=-0.5d0*bgj_kfac(rtdb) + call ao_fock_2e(geom1, ao_basis, 1, 0d0, -0.5d0*bgj_kfac(rtdb), $ tol2e1, oskel1, vg_dens, vg_fock, asym ) call fock_j_fit(nfock, vg_dens, vg_fockc) @@ -137,7 +138,7 @@ subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, c !!! Exit if no XC part to do - this can be changed to just do XC c !!! part and print it out for comparison by removing xc_active c !!! from the test below - if (.not. (xc_active .and. bgj_have_xc())) then + if (.not. (xc_active .and. bgj_have_xc(rtdb))) then c write(*,*)'*** fock_2e: no xc, returning' return endif @@ -145,7 +146,7 @@ subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, if(ga_nodeid().eq.0) then write(0,*) ' WARNING: likely restart: nfock = ',nfock endif - if (.not.rtdb_put(bgj_get_rtdb_handle(),'bgj:xc_active', + if (.not.rtdb_put(rtdb,'bgj:xc_active', M MT_LOG,1,.false.)) C call errquit(' fock2e: bgjrtdbput failed',0,0) return @@ -183,7 +184,7 @@ subroutine fock_2e( geom1, ao_basis, mfock, jfac, kfac, Exc(1) = 0.0d0 Exc(2) = 0.0d0 nExc = 1 - call fock_xc(geom1, nbf,ao_basis, + call fock_xc(rtdb,geom1, nbf,ao_basis, & nfock, vg_dens, g_xc,Exc,nExc,.false.) ffac=1d0 if (xc_active) then diff --git a/src/ddscf/fock_2e_cam.F b/src/ddscf/fock_2e_cam.F index a2de9760ab9..88cddb56438 100644 --- a/src/ddscf/fock_2e_cam.F +++ b/src/ddscf/fock_2e_cam.F @@ -1,4 +1,4 @@ - subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, + subroutine fock_2e_cam( rtdb, geom1, ao_basis, mfock, jfac, kfac, $ tol2e1, oskel1, vg_dens, vg_fock, asym, doxc ) c$Id$ c @@ -42,13 +42,10 @@ subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, c external ga_create_atom_blocked logical xc_active, jfit,oprint,odft,cphf_uhf -c -c Get a handle to the rtdb - rtdb = bgj_get_rtdb_handle() c oprint= util_print('fock_2e',print_debug) cphf_uhf = .false. - if (.not. rtdb_get(bgj_get_rtdb_handle(), + if (.not. rtdb_get(rtdb, & 'cphf_solve:cphf_uhf', mt_log, 1, cphf_uhf)) then cphf_uhf = .false. endif @@ -66,15 +63,15 @@ subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, c c See if XC is active for this call c - if (.not.rtdb_get(bgj_get_rtdb_handle(),'bgj:xc_active',MT_LOG,1, + if (.not.rtdb_get(rtdb,'bgj:xc_active',MT_LOG,1, & xc_active)) xc_active = .false. if (oprint) & write(luout,*)'*** fock_2e: xc_active ',xc_active c c Set K contribution to be correct even for pure DFT and hybrids c - if (xc_active .and. bgj_have_xc()) then - call dscal(nfock, bgj_kfac(), kfac, 1) + if (xc_active .and. bgj_have_xc(rtdb)) then + call dscal(nfock, bgj_kfac(rtdb), kfac, 1) if (oprint) & write(luout,*)'*** fock_2e: set kfac to ', & (kfac(ifock),ifock=1,nfock) @@ -82,7 +79,7 @@ subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, c c Determine whether J fitting is involved c - jfit = bgj_have_j_fit().and.(jfac(1).ne.0d0) + jfit = bgj_have_j_fit(rtdb).and.(jfac(1).ne.0d0) c !!! Edo commented this out before since it caused bugs - ask him about c !!! it when it is necessary to turn back on for J fit CPKS jfit = .false. @@ -97,8 +94,8 @@ subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, & write(luout,*)'*** fock_2e: jfit case - original jfac = ', & jfac(1) cold jfac(1)=0d0 -cold kfac(1)=-0.5d0*bgj_kfac() - call ao_fock_2e( geom1, ao_basis, 1, 0d0, -0.5d0*bgj_kfac(), +cold kfac(1)=-0.5d0*bgj_kfac(rtdb) + call ao_fock_2e(geom1, ao_basis, 1, 0d0, -0.5d0*bgj_kfac(rtdb), $ tol2e1, oskel1, vg_dens, vg_fock, asym ) call fock_j_fit(nfock, vg_dens, vg_fockc) @@ -135,7 +132,7 @@ subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, $ tol2e1, oskel1, vg_dens, vg_fock,asym ) endif else - if (bgj_have_j_fit()) call fock_force_direct(rtdb) + if (bgj_have_j_fit(rtdb)) call fock_force_direct(rtdb) call ao_fock_2e( geom1, ao_basis, nfock, jfac, kfac, $ tol2e1, oskel1, vg_dens, vg_fock, asym ) @@ -146,7 +143,7 @@ subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, c !!! Exit if no XC part to do - this can be changed to just do XC c !!! part and print it out for comparison by removing xc_active c !!! from the test below - if (.not. (xc_active .and. bgj_have_xc())) then + if (.not. (xc_active .and. bgj_have_xc(rtdb))) then c write(*,*)'*** fock_2e: no xc, returning' return endif @@ -154,7 +151,7 @@ subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, if(ga_nodeid().eq.0) then write(0,*) ' WARNING: likely restart: nfock = ',nfock endif - if (.not.rtdb_put(bgj_get_rtdb_handle(),'bgj:xc_active', + if (.not.rtdb_put(rtdb,'bgj:xc_active', M MT_LOG,1,.false.)) C call errquit(' fock2e: bgjrtdbput failed',0,0) return @@ -193,7 +190,7 @@ subroutine fock_2e_cam( geom1, ao_basis, mfock, jfac, kfac, Exc(2) = 0.0d0 nExc = 1 if (doxc) then - call fock_xc(geom1, nbf,ao_basis, + call fock_xc(rtdb,geom1, nbf,ao_basis, & nfock, vg_dens, g_xc,Exc,nExc,.false.) ffac=1d0 if (xc_active) then diff --git a/src/ddscf/fock_j_fit.F b/src/ddscf/fock_j_fit.F index 84bb7a8e28b..9fa71e4fe73 100644 --- a/src/ddscf/fock_j_fit.F +++ b/src/ddscf/fock_j_fit.F @@ -62,20 +62,19 @@ subroutine fock_j_fit_gen(nmat, g_dens, g_j, Tvec, have_Tvec, double precision ddum logical IOLGC, old_incore, old_direct c - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'--------Entered fock_j_fit-------------' - rtdb = bgj_get_rtdb_handle() c write(*,*)'nmat rtdb geom',nmat,rtdb,geom c c Get fock_j_fit variables c if (.not. rtdb_get(rtdb, 'fock_j:derfit', mt_log, 1, & derfit)) then - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'*** fock_j_fit: derfit not set: setting to false' derfit = .false. !!! endif - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'fock_j_fit: derfit =',derfit c c Initialize J matrices @@ -143,7 +142,7 @@ subroutine fock_j_fit_gen(nmat, g_dens, g_j, Tvec, have_Tvec, direct = old_direct incore = old_incore c - if (bgj_print() .gt. 0) then + if (bgj_print(rtdb) .gt. 0) then do imat = 1, nmat write(*,*)'Fitted J matrix',imat call ga_print(g_j(imat)) diff --git a/src/ddscf/fock_xc.F b/src/ddscf/fock_xc.F index 2fcf0370d26..f5ba7e75e85 100644 --- a/src/ddscf/fock_xc.F +++ b/src/ddscf/fock_xc.F @@ -1,7 +1,7 @@ C> C> \brief Wrapper for AO-basis XC matrices without fitting C> - subroutine fock_xc(geom, nbf_ao, ao_bas_han, + subroutine fock_xc(rtdb, geom, nbf_ao, ao_bas_han, & nfock, g_dens, g_xc, Exc, nExc, l3d) c c $Id$ @@ -87,7 +87,6 @@ subroutine fock_xc(geom, nbf_ao, ao_bas_han, c ndens=1 if(xc_getipol().eq.2) ndens=2 - rtdb = bgj_get_rtdb_handle() alo(2) = 1 ahi(2) = nbf_ao alo(3) = 1 @@ -234,7 +233,7 @@ subroutine fock_xc(geom, nbf_ao, ao_bas_han, if(ndens.eq.2) int_mb(igxcd+1)=g_dens(3) endif if (calc_type .eq. 2) then - if (.not. bgj_get_scf_dens(g_dens_scf)) + if (.not. bgj_get_scf_dens(rtdb,g_dens_scf)) & call errquit('fock_xc: cant get scf density handles',0, & UNKNOWN_ERR) alo(1) = 1 diff --git a/src/ddscf/rhf_dens_mo.F b/src/ddscf/rhf_dens_mo.F index 4b3c67d4d93..1ad1c342ddf 100644 --- a/src/ddscf/rhf_dens_mo.F +++ b/src/ddscf/rhf_dens_mo.F @@ -85,7 +85,7 @@ subroutine rhf_dens_to_mo(rtdb, geom, basis, nelec, nbf, nmo, call int_1e_ga(basis, basis, g_hcore,'potential', oskel) c if (nelec.gt.1 .and. abs(dens_norm) .gt. 1d-2) - $ call rhf_fock_2e(geom, basis, g_dens, g_fock, tol2e, + $ call rhf_fock_2e(rtdb, geom, basis, g_dens, g_fock, tol2e, & .true., .true., oskel) c c Compute contributions to the energy and symmetrize diff --git a/src/ddscf/rhf_fock_2e.F b/src/ddscf/rhf_fock_2e.F index e831e0db413..f89c0f84d50 100644 --- a/src/ddscf/rhf_fock_2e.F +++ b/src/ddscf/rhf_fock_2e.F @@ -1,4 +1,4 @@ - subroutine rhf_fock_2e( geom, basis, g_dens, g_fock, tol2e, + subroutine rhf_fock_2e( rtdb, geom, basis, g_dens, g_fock, tol2e, $ ocoul, oexch, oskel ) * * $Id$ @@ -12,7 +12,7 @@ subroutine rhf_fock_2e( geom, basis, g_dens, g_fock, tol2e, c Now also called from moints_full to generate an effective c frozen-core hamiltonian c - integer geom, basis + integer rtdb, geom, basis integer g_dens, g_fock ! [input] handles double precision tol2e ! [input] integral selection threshold logical ocoul, oexch ! [input] compute coulomb/exchange @@ -38,7 +38,7 @@ subroutine rhf_fock_2e( geom, basis, g_dens, g_fock, tol2e, vg_dens(1) = g_dens vg_fock(1) = g_fock - call fock_2e( geom, basis, nfock, jfac, kfac, tol2e, oskel, + call fock_2e( rtdb, geom, basis, nfock, jfac, kfac, tol2e, oskel, $ vg_dens, vg_fock, .false.) return diff --git a/src/ddscf/rohf_fock.F b/src/ddscf/rohf_fock.F index ad612ce60c4..513c58c36e2 100644 --- a/src/ddscf/rohf_fock.F +++ b/src/ddscf/rohf_fock.F @@ -229,7 +229,7 @@ subroutine rohf_fock(rtdb, geom, basis, nclosed, nopen, nmo, if ( nopen .eq. 0 ) call riscf_dovecs(.true., g_vecs) c if (.not.cam_exch) then - call fock_2e(geom, basis, nfock, jfactor, kfactor, + call fock_2e(rtdb, geom, basis, nfock, jfactor, kfactor, $ tol2e, oskel, iv_dens, iv_fock, .false.) else c for attenuated calculations diff --git a/src/ddscf/rohf_h2e.F b/src/ddscf/rohf_h2e.F index 6819c76737d..55e03445c5b 100644 --- a/src/ddscf/rohf_h2e.F +++ b/src/ddscf/rohf_h2e.F @@ -1,4 +1,5 @@ - subroutine rohf_hessv_2e( basis, geom, nbf, nmo, nclosed, nopen, + subroutine rohf_hessv_2e( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ g_movec, oskel, g_x, acc, g_ax ) C $Id$ implicit none @@ -12,7 +13,7 @@ subroutine rohf_hessv_2e( basis, geom, nbf, nmo, nclosed, nopen, c c Return the ROHF orbital 2e-Hessian vector product, g_ax = A * g_x c - integer basis, geom ! basis & geom handle + integer rtdb, basis, geom ! basis & geom handle integer nbf, nclosed, nopen ! Basis size and occupation integer nmo ! No. of linearly dependent MOs integer g_movec ! MO coefficients @@ -182,7 +183,7 @@ subroutine rohf_hessv_2e( basis, geom, nbf, nmo, nclosed, nopen, call ga_zero(iv_fock(ifock)) enddo c - call fock_2e( geom, basis, nfock, jfac, kfac, + call fock_2e( rtdb, geom, basis, nfock, jfac, kfac, $ tol2e, oskel, iv_dens, iv_fock,.false.) c if (oskel) then diff --git a/src/ddscf/rohf_hessv2.F b/src/ddscf/rohf_hessv2.F index 8a60666dd40..83063d0b886 100644 --- a/src/ddscf/rohf_hessv2.F +++ b/src/ddscf/rohf_hessv2.F @@ -9,6 +9,7 @@ subroutine rohf_hessv2( acc, g_x, g_ax ) c c $Id$ c + integer rtdb integer g_x, g_ax double precision acc c @@ -16,6 +17,10 @@ subroutine rohf_hessv2( acc, g_x, g_ax ) integer icol,ilo(2),ihi(2) logical oprint, olprint double precision dnrm + integer rohf_get_rtdb + external rohf_get_rtdb +c + rtdb = rohf_get_rtdb() c c Check c @@ -52,7 +57,7 @@ subroutine rohf_hessv2( acc, g_x, g_ax ) c c Call internal routine c - call rohf_hessv_xx2( basis, geom, nbf, nmo, + call rohf_hessv_xx2( rtdb, basis, geom, nbf, nmo, $ nclosed, nopen, $ pflg, g_movecs, oskel, noskew, $ crohf_g_fcv, crohf_g_fpv, crohf_g_fcp, @@ -82,7 +87,8 @@ subroutine rohf_hessv2( acc, g_x, g_ax ) endif c end - subroutine rohf_hessv_xx2( basis, geom, nbf, nmo, nclosed, nopen, + subroutine rohf_hessv_xx2( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ pflg, $ g_movecs, oskel, noskew, g_fcv, g_fpv, g_fcp, $ acc, lshift, g_x, g_ax ) @@ -94,7 +100,7 @@ subroutine rohf_hessv_xx2( basis, geom, nbf, nmo, nclosed, nopen, #include "rtdb.fh" #include "bgj.fh" c - integer basis, geom + integer rtdb, basis, geom integer nbf, nmo, nclosed, nopen integer pflg integer g_movecs(*) @@ -116,15 +122,16 @@ subroutine rohf_hessv_xx2( basis, geom, nbf, nmo, nclosed, nopen, endif 200 continue if (pflg .gt. 1) then - call rohf_hessv_2e2( basis, geom, nbf, nmo, nclosed, nopen, + call rohf_hessv_2e2( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ g_movecs, oskel, noskew, g_x, acc, ! was min(1d-6,acc) $ g_ax ) endif c c end - subroutine rohf_hessv_2e2( basis, geom, nbf, nmo, nclosed, nopen, - $ g_movec, oskel, noskew, g_x, acc, g_ax ) + subroutine rohf_hessv_2e2( rtdb, basis, geom, nbf, nmo, nclosed, + $ nopen, g_movec, oskel, noskew, g_x, acc, g_ax ) C $Id$ implicit none #include "errquit.fh" @@ -142,6 +149,7 @@ subroutine rohf_hessv_2e2( basis, geom, nbf, nmo, nclosed, nopen, ccccccccccccccc This code does NOT work for open shell!!!!!ccccccccccccccccc c c + integer rtdb integer basis, geom ! basis & geom handle integer nbf, nclosed, nopen ! Basis size and occupation integer nmo ! No. of linearly dependent MOs @@ -182,7 +190,7 @@ subroutine rohf_hessv_2e2( basis, geom, nbf, nmo, nclosed, nopen, parameter (one=1.0d0, mone=-1.0d0, zero=0.0d0, four=4.0d0) parameter (half=0.5d0, mhalf=-0.5d0, two=2.0d0, mtwo=-2.0d0) oprint= util_print('rohf_hessv2',print_debug) - xc_xfac1=bgj_kfac() + xc_xfac1=bgj_kfac(rtdb) c c This get's cleaned up a lot when the Fock build accepts c a single multiple dimension GA for its input. @@ -399,11 +407,11 @@ subroutine rohf_hessv_2e2( basis, geom, nbf, nmo, nclosed, nopen, c noskew is true, except for nmr perturbations (skew symmetric) c if (.not.cam_exch) then - call shell_fock_build(geom, basis, 0, nfock, + call shell_fock_build(rtdb, geom, basis, 0, nfock, $ dbl_mb(k_jfac), dbl_mb(k_kfac), $ tol2e, g_dens, g_fock, noskew) else ! for attenuated calculations - call shell_fock_build_cam(geom, basis, 0, nfock, + call shell_fock_build_cam(rtdb, geom, basis, 0, nfock, $ dbl_mb(k_jfac), dbl_mb(k_kfac), $ tol2e, g_dens, g_fock, noskew) end if @@ -421,12 +429,12 @@ subroutine rohf_hessv_2e2( basis, geom, nbf, nmo, nclosed, nopen, endif c c DIM/QM JEM - if (.not.rtdb_get(bgj_get_rtdb_handle(), 'dimqm:lrsp', mt_log, + if (.not.rtdb_get(rtdb, 'dimqm:lrsp', mt_log, $ 1, ldimqm)) ldimqm = .false. c Calculate DIM dipoles and DIM potential if (ldimqm) then c jbecca START: added false variable to subroutine call - call dimqm_rohf_calcDIM(bgj_get_rtdb_handle(), geom, basis, + call dimqm_rohf_calcDIM(rtdb, geom, basis, $ nbf, nfock, g_dens, g_dim, .false.) c jbecca END end if diff --git a/src/ddscf/rohf_hessv3.F b/src/ddscf/rohf_hessv3.F index 6fa7a3943f7..b50b0d9a05d 100644 --- a/src/ddscf/rohf_hessv3.F +++ b/src/ddscf/rohf_hessv3.F @@ -6,7 +6,7 @@ c we might have damping in the response. That causes all quantities to c have an imaginary part, too - subroutine rohf_hessv3(acc, g_x, g_ax, g_x_im, g_Ax_im, + subroutine rohf_hessv3(rtdb, acc, g_x, g_ax, g_x_im, g_Ax_im, & omega, limag, lifetime, gamwidth, ncomp) implicit none #include "errquit.fh" @@ -18,6 +18,7 @@ subroutine rohf_hessv3(acc, g_x, g_ax, g_x_im, g_Ax_im, c c $Id$ c + integer rtdb c ... jochen: these two arrays now have two components: integer g_x(2) ! [input] A-matrix elements for density matrix integer g_ax(2) ! [output] Perturbed Fock operator @@ -64,7 +65,7 @@ subroutine rohf_hessv3(acc, g_x, g_ax, g_x_im, g_Ax_im, c Call internal routine c if (debug) write (6,*) 'calling rohf_hessv_xx3' - call rohf_hessv_xx3( basis, geom, nbf, nmo, + call rohf_hessv_xx3( rtdb, basis, geom, nbf, nmo, $ nclosed, nopen, $ pflg, g_movecs, oskel, noskew, $ crohf_g_fcv, crohf_g_fpv, crohf_g_fcp, @@ -96,8 +97,8 @@ subroutine rohf_hessv3(acc, g_x, g_ax, g_x_im, g_Ax_im, cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine rohf_hessv_xx3( basis, geom, nbf, nmo, nclosed, nopen, - $ pflg, + subroutine rohf_hessv_xx3( rtdb, basis, geom, + $ nbf, nmo, nclosed, nopen, pflg, $ g_movecs, oskel, noskew, g_fcv, g_fpv, g_fcp, $ acc, lshift, g_x, g_ax, g_x_im, g_Ax_im, omega, limag, & lifetime, gamwidth, ncomp) @@ -109,6 +110,7 @@ subroutine rohf_hessv_xx3( basis, geom, nbf, nmo, nclosed, nopen, #include "rtdb.fh" #include "bgj.fh" c + integer rtdb integer basis, geom integer nbf, nmo, nclosed, nopen integer pflg @@ -228,23 +230,27 @@ subroutine rohf_hessv_xx3( basis, geom, nbf, nmo, nclosed, nopen, c if (ncomp.gt.1) then ! call 2e code for dynamic case if (debug) write (6,*) 'calling rohf_hessv_2e3' - call rohf_hessv_2e3( basis, geom, nbf, nmo, nclosed, nopen, + call rohf_hessv_2e3( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ g_movecs, oskel, noskew, g_x, acc, ! was min(1d-6,acc) $ g_ax, limag) if (debug) write (6,*) 'back from rohf_hessv_2e3' if (lifetime) then if (debug) write (6,*) 'calling rohf_hessv_2e3 for Im part' - call rohf_hessv_2e3( basis, geom, nbf, nmo, nclosed, nopen, + call rohf_hessv_2e3( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ g_movecs, oskel, noskew, g_x_im, acc, ! was min(1d-6,acc) $ g_ax_im, limag) if (debug) write (6,*) 'back from rohf_hessv_2e3 Im part' endif ! lifetime else ! call static 2e code - call rohf_hessv_2e2( basis, geom, nbf, nmo, nclosed, nopen, + call rohf_hessv_2e2( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ g_movecs, oskel, noskew, g_x(1), acc, ! was min(1d-6,acc) $ g_ax(1)) if (lifetime) then - call rohf_hessv_2e2( basis, geom, nbf, nmo, nclosed, nopen, + call rohf_hessv_2e2( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ g_movecs, oskel, noskew, g_x_im(1), acc, ! was min(1d-6,acc) $ g_ax_im(1)) endif ! lifetime @@ -254,7 +260,7 @@ subroutine rohf_hessv_xx3( basis, geom, nbf, nmo, nclosed, nopen, c DIM/QM JEM c This call is placed differently than in rohf_hessv2 because we c require knowledge of the real and imaginary simultaneously. - if (.not.rtdb_get(bgj_get_rtdb_handle(),'dimqm:lrsp',MT_LOG, 1, + if (.not.rtdb_get(rtdb,'dimqm:lrsp',MT_LOG, 1, $ ldimqm)) ldimqm = .false. if(ldimqm) then call dimqm_addop(g_x, g_x_im, g_ax, g_ax_im, ncomp, @@ -266,7 +272,8 @@ subroutine rohf_hessv_xx3( basis, geom, nbf, nmo, nclosed, nopen, ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine rohf_hessv_2e3( basis, geom, nbf, nmo, nclosed, nopen, + subroutine rohf_hessv_2e3( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ g_movec, oskel, noskew, g_x, acc, g_ax, limag) C $Id$ implicit none @@ -292,6 +299,7 @@ subroutine rohf_hessv_2e3( basis, geom, nbf, nmo, nclosed, nopen, ccccccccccccccc This code does NOT work for open shell!!!!!ccccccccccccccccc c c + integer rtdb integer basis, geom ! basis & geom handle integer nbf, nclosed, nopen ! Basis size and occupation integer nmo ! No. of linearly dependent MOs @@ -347,7 +355,7 @@ subroutine rohf_hessv_2e3( basis, geom, nbf, nmo, nclosed, nopen, if (debug) call ga_print(g_Ax(2)) c oprint= util_print('rohf_hessv2',print_debug) - xc_xfac1=bgj_kfac() ! amount of exact exchange in the functional + xc_xfac1=bgj_kfac(rtdb) ! amount of exact exchange in the functional if (debug) write (6,*) 'xc_xfac1: ', xc_xfac1 c c This get's cleaned up a lot when the Fock build accepts @@ -740,12 +748,12 @@ subroutine rohf_hessv_2e3( basis, geom, nbf, nmo, nclosed, nopen, c c case I: symmetric density matrix if (.not.cam_exch) then - call shell_fock_build(geom, basis, 0, nfock, + call shell_fock_build(rtdb, geom, basis, 0, nfock, $ dbl_mb(k_jfac(1)), dbl_mb(k_kfac(1)), $ tol2e, g_dens(1), g_fock(1), .true.) if (debug) write (6,*) 'rohf_h2e3 step 11' else ! for attenuated calculations - call shell_fock_build_cam(geom, basis, 0, nfock, + call shell_fock_build_cam(rtdb, geom, basis, 0, nfock, $ dbl_mb(k_jfac(1)), dbl_mb(k_kfac(1)), $ tol2e, g_dens(1), g_fock(1), .true.) end if @@ -757,12 +765,12 @@ subroutine rohf_hessv_2e3( basis, geom, nbf, nmo, nclosed, nopen, c if (abs(xc_xfac1).gt.tenm6) then if (.not.cam_exch) then - call shell_fock_build(geom, basis, 0, nfock, + call shell_fock_build(rtdb, geom, basis, 0, nfock, $ dbl_mb(k_jfac(2)), dbl_mb(k_kfac(2)), $ tol2e, g_dens(2), g_fock(2), .false.) if (debug) write (6,*) 'shell_fock_build called with P(A)' else ! for attenuated calculations - call shell_fock_build_cam(geom, basis, 0, nfock, + call shell_fock_build_cam(rtdb, geom, basis, 0, nfock, $ dbl_mb(k_jfac(2)), dbl_mb(k_kfac(2)), $ tol2e, g_dens(2), g_fock(2), .false.) end if diff --git a/src/ddscf/rohf_hessv3_ext.F b/src/ddscf/rohf_hessv3_ext.F index 00fe302a0d8..b92a857f66a 100644 --- a/src/ddscf/rohf_hessv3_ext.F +++ b/src/ddscf/rohf_hessv3_ext.F @@ -339,7 +339,7 @@ subroutine rohf_hessv_xx3_ext( c end - subroutine rohf_hessv3_cmplx( + subroutine rohf_hessv3_cmplx(rtdb, & acc, ! in : accuracy & g_z, ! in : z & g_Az1, ! in : Az1 @@ -365,6 +365,7 @@ subroutine rohf_hessv3_cmplx( #include "global.fh" c c $Id$ + integer rtdb integer ncomp integer g_z(ncomp), ! [input] A-matrix elements for density matrix & g_Az(ncomp) ! [output] Perturbed Fock operator @@ -414,7 +415,7 @@ subroutine rohf_hessv3_cmplx( c if (debug) write (6,*) 'calling rohf_hessv_xx3_cmplx' - call rohf_hessv_xx3_cmplx( + call rohf_hessv_xx3_cmplx(rtdb, & g_z, ! in : & g_Az1, & nsub, @@ -463,7 +464,7 @@ subroutine rohf_hessv3_cmplx( end - subroutine rohf_hessv_xx3_cmplx( + subroutine rohf_hessv_xx3_cmplx(rtdb, & g_z, ! in : & g_Az1, ! ou : product: A x z & nsub, ! in : nr. subspace @@ -500,6 +501,7 @@ subroutine rohf_hessv_xx3_cmplx( #include "mafdecls.fh" #include "rtdb.fh" #include "bgj.fh" + integer rtdb integer ipm,ncomp,iter_cphf integer ncompmx parameter(ncompmx=2) @@ -717,7 +719,7 @@ subroutine rohf_hessv_xx3_cmplx( endif ! pflg.gt.1 c c DIM/QM JEM - if (.not.rtdb_get(bgj_get_rtdb_handle(), 'dimqm:lrsp', MT_LOG, + if (.not.rtdb_get(rtdb, 'dimqm:lrsp', MT_LOG, $ 1, ldimqm)) ldimqm = .false. if(ldimqm) then c Transforming complex arrays to 2 real arrays to fit DIM structure diff --git a/src/ddscf/rohf_hxx.F b/src/ddscf/rohf_hxx.F index 84e0988482d..2083488ee9e 100644 --- a/src/ddscf/rohf_hxx.F +++ b/src/ddscf/rohf_hxx.F @@ -1,4 +1,5 @@ - subroutine rohf_hessv_xx( basis, geom, nbf, nmo, nclosed, nopen, + subroutine rohf_hessv_xx( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ pflg, $ g_movecs, oskel, g_fcv, g_fpv, g_fcp, $ acc, lshift, g_x, g_ax ) @@ -10,7 +11,7 @@ subroutine rohf_hessv_xx( basis, geom, nbf, nmo, nclosed, nopen, #include "rtdb.fh" #include "bgj.fh" c - integer basis, geom + integer rtdb, basis, geom integer nbf, nmo, nclosed, nopen integer pflg integer g_movecs @@ -32,7 +33,8 @@ subroutine rohf_hessv_xx( basis, geom, nbf, nmo, nclosed, nopen, endif 200 continue if (pflg .gt. 1) then - call rohf_hessv_2e( basis, geom, nbf, nmo, nclosed, nopen, + call rohf_hessv_2e( rtdb, basis, geom, + & nbf, nmo, nclosed, nopen, $ g_movecs, oskel, g_x, acc, ! was min(1d-6,acc) $ g_ax ) endif diff --git a/src/ddscf/rohf_scat.F b/src/ddscf/rohf_scat.F index 021adcc2917..edb07b030da 100644 --- a/src/ddscf/rohf_scat.F +++ b/src/ddscf/rohf_scat.F @@ -498,7 +498,7 @@ subroutine rohf_scat(rtdb, g_vecs, g_scatmo, g_borb, c kfactor(1)=0.0 c - call fock_2e(geom, all_bas_han, nfock, jfactor, kfactor, + call fock_2e(rtdb, geom, all_bas_han, nfock, jfactor, kfactor, $ tol2e, .false., iv_dens, iv_fock, .false.) call do_riscf (.true.) if ( nopen .eq. 0 ) call riscf_dovecs(.false., g_all) diff --git a/src/ddscf/rohf_wrap.F b/src/ddscf/rohf_wrap.F index df82955cf87..03f84eb5cc1 100644 --- a/src/ddscf/rohf_wrap.F +++ b/src/ddscf/rohf_wrap.F @@ -12,6 +12,22 @@ block data crohf_data $ crohf_g_fcp/-1/, $ noskew/.true./ end + + subroutine rohf_set_rtdb(rtdb) + implicit none + integer rtdb + integer rtdbcopy + common /rohfrtdbcommon/ rtdbcopy + rtdbcopy = rtdb + end + + integer function rohf_get_rtdb() + implicit none + integer rtdbcopy + common /rohfrtdbcommon/ rtdbcopy + rohf_get_rtdb = rtdbcopy + end + subroutine rohf_init( rtdb) implicit none #include "errquit.fh" @@ -27,6 +43,8 @@ subroutine rohf_init( rtdb) integer rtdb external crohf_data ! For T3D linker c + call rohf_set_rtdb(rtdb) +c if (crohf_init_flag.gt.0) $ call errquit('rohf internals already initialised?',0, & UNKNOWN_ERR) @@ -231,10 +249,16 @@ subroutine rohf_hessv( acc, g_x, g_ax ) c c $Id$ c + integer rtdb integer g_x, g_ax double precision acc c integer gtype,grow,gcol,growp,gcolp +c + integer rohf_get_rtdb + external rohf_get_rtdb +c + rtdb = rohf_get_rtdb() c c Check c @@ -255,7 +279,7 @@ subroutine rohf_hessv( acc, g_x, g_ax ) c c Call internal routine c - call rohf_hessv_xx( basis, geom, nbf, nmo, + call rohf_hessv_xx( rtdb, basis, geom, nbf, nmo, $ nclosed, nopen, $ pflg, g_movecs, oskel, $ crohf_g_fcv, crohf_g_fpv, crohf_g_fcp, diff --git a/src/ddscf/uhf.F b/src/ddscf/uhf.F index f4c133403b8..93dba6a56cb 100644 --- a/src/ddscf/uhf.F +++ b/src/ddscf/uhf.F @@ -707,7 +707,7 @@ subroutine uhf_energy(rtdb, g_vecs, eone, etwo, enrep, ecosmo, if ((grow.ne.cuhf_vlen).or.(gcol.ne.1)) $ call errquit('uhf_energy: invalid vector length',0, GA_ERR) cphf_uhf = .false. - if (.not. rtdb_get(bgj_get_rtdb_handle(), + if (.not. rtdb_get(rtdb, & 'cphf_solve:cphf_uhf', mt_log, 1, cphf_uhf)) then cphf_uhf = .false. endif @@ -812,7 +812,7 @@ subroutine uhf_energy(rtdb, g_vecs, eone, etwo, enrep, ecosmo, endif call do_riscf (.false.) if (.not.cam_exch) then - call fock_2e(geom, basis, nfock, jfac, kfac, tol2e, + call fock_2e(rtdb, geom, basis, nfock, jfac, kfac, tol2e, $ oskel, d, f, .false.) else ! for attenuated calculations c diff --git a/src/ddscf/uhf_hessv.F b/src/ddscf/uhf_hessv.F index 17289efbce4..166bd576149 100644 --- a/src/ddscf/uhf_hessv.F +++ b/src/ddscf/uhf_hessv.F @@ -1,4 +1,4 @@ - subroutine uhf_hessv(acc, g_x, g_ax) + subroutine uhf_hessv(rtdb, acc, g_x, g_ax) * * $Id$ * @@ -14,6 +14,7 @@ subroutine uhf_hessv(acc, g_x, g_ax) #include "util.fh" c + integer rtdb double precision acc ! [input] required accuracy of products integer g_x ! [input] handle to input vectors integer g_ax ! [input] handle to output products @@ -70,7 +71,7 @@ subroutine uhf_hessv(acc, g_x, g_ax) 200 continue c if (pflg .gt. 1)then - call uhf_hessv_2e(acc, g_x, g_ax, nvec) + call uhf_hessv_2e(rtdb, acc, g_x, g_ax, nvec) endif c if (oprint) then @@ -161,7 +162,7 @@ subroutine uhf_hessv_1e(acc, g_x, g_ax, nvec) enddo c end - subroutine uhf_hessv_2e(acc, g_x, g_ax, nvec) + subroutine uhf_hessv_2e(rtdb, acc, g_x, g_ax, nvec) implicit none #include "errquit.fh" #include "cuhf.fh" @@ -172,6 +173,7 @@ subroutine uhf_hessv_2e(acc, g_x, g_ax, nvec) #include "rtdb.fh" #include "bgj.fh" c + integer rtdb double precision acc ! [input] required accuracy of products integer g_x ! [input] handle to input vectors integer g_ax ! [input] handle to output products @@ -289,7 +291,7 @@ subroutine uhf_hessv_2e(acc, g_x, g_ax, nvec) c nfock = 4*nvec c - call fock_2e(geom, basis, nfock, jfac, kfac, + call fock_2e(rtdb, geom, basis, nfock, jfac, kfac, $ tol2e_local, oskel_local, g_dens, g_fock, .false.) c c Again, note that this is NOT what you want except for diff --git a/src/ddscf/uhf_hessv2.F b/src/ddscf/uhf_hessv2.F index d290435b5bb..22a0a9277d5 100644 --- a/src/ddscf/uhf_hessv2.F +++ b/src/ddscf/uhf_hessv2.F @@ -1,4 +1,4 @@ - subroutine uhf_hessv2(acc, g_x, g_ax) + subroutine uhf_hessv2(rtdb, acc, g_x, g_ax) * * $Id$ * @@ -14,6 +14,7 @@ subroutine uhf_hessv2(acc, g_x, g_ax) #include "global.fh" c + integer rtdb double precision acc ! [input] required accuracy of products integer g_x ! [input] handle to input vectors integer g_ax ! [input] handle to output products @@ -68,7 +69,7 @@ subroutine uhf_hessv2(acc, g_x, g_ax) 200 continue c if (pflg .gt. 1)then - call uhf_hessv_2e2(acc, g_x, g_ax, nvec) + call uhf_hessv_2e2(rtdb, acc, g_x, g_ax, nvec) endif c if (oprint) then @@ -87,7 +88,7 @@ subroutine uhf_hessv2(acc, g_x, g_ax) c end c - subroutine uhf_hessv_2e2(acc, g_x, g_ax, nvec) + subroutine uhf_hessv_2e2(rtdb, acc, g_x, g_ax, nvec) implicit none #include "errquit.fh" #include "cuhf.fh" @@ -99,6 +100,7 @@ subroutine uhf_hessv_2e2(acc, g_x, g_ax, nvec) #include "bgj.fh" #include "case.fh" c + integer rtdb double precision acc ! [input] required accuracy of products integer g_x ! [input] handle to input vectors integer g_ax ! [input] handle to output products @@ -146,7 +148,7 @@ subroutine uhf_hessv_2e2(acc, g_x, g_ax, nvec) c c write(6,*)"in uhf_hessv2, g_x" c call ga_print(g_x) - xc_xfac1=bgj_kfac() + xc_xfac1=bgj_kfac(rtdb) c c allocate MAs for jfacs and kfacs c @@ -250,7 +252,7 @@ subroutine uhf_hessv_2e2(acc, g_x, g_ax, nvec) c c DIM/QM JEM c Calculate DIM dipoles and DIM potential from TOTAL density - if (.not.rtdb_get(bgj_get_rtdb_handle(), 'dimqm:lrsp', mt_log, + if (.not.rtdb_get(rtdb, 'dimqm:lrsp', mt_log, $ 1, ldimqm)) ldimqm = .false. if (ldimqm) then dims(1) = nvec @@ -278,10 +280,10 @@ subroutine uhf_hessv_2e2(acc, g_x, g_ax, nvec) $ 0.25d0, g_dens, blo, bhi, $ g_dens, blo, bhi) c jbecca START: added .false. variable at end - call dimqm_rohf_calcDIM(bgj_get_rtdb_handle(), geom, basis, + call dimqm_rohf_calcDIM(rtdb, geom, basis, $ nbf, nvec, g_dens, g_dim, .false.) c jbecca END -c call dimqm_indDipoles(bgj_get_rtdb_handle(), nbf, geom, +c call dimqm_indDipoles(rtdb, nbf, geom, c $ basis, g_dens) c call ga_zero(g_dim) c call fock_dim(geom, nbf, basis, nvec, g_dim, 0, 1) @@ -331,11 +333,11 @@ subroutine uhf_hessv_2e2(acc, g_x, g_ax, nvec) c Actually do the Fock build c if (.not.cam_exch) then - call shell_fock_build(geom, basis, 0, nfock, + call shell_fock_build(rtdb, geom, basis, 0, nfock, $ dbl_mb(k_jfac), dbl_mb(k_kfac), $ tol2e, g_dens2, g_fock2, noskew_uhf) else - call shell_fock_build_cam(geom, basis, 0, nfock, + call shell_fock_build_cam(rtdb, geom, basis, 0, nfock, $ dbl_mb(k_jfac), dbl_mb(k_kfac), $ tol2e, g_dens2, g_fock2, noskew_uhf) end if ! cam_exch diff --git a/src/ddscf/uhf_hessv2_ext.F b/src/ddscf/uhf_hessv2_ext.F index 2c3c287cc89..4a1d9606b08 100644 --- a/src/ddscf/uhf_hessv2_ext.F +++ b/src/ddscf/uhf_hessv2_ext.F @@ -1,5 +1,6 @@ c ++++++++++++++++++ FA: uhf_hessv2_damp +++++++++++++++++++ START - subroutine uhf_hessv3(acc, ! in: accuracy of products + subroutine uhf_hessv3(rtdb, + & acc, ! in: accuracy of products & g_x, ! in: A-matrix elements for density matrix REAL & g_ax, ! in: Perturbed Fock operator REAL & g_x_im, ! in: A-matrix elements for density matrix IMAG @@ -26,6 +27,7 @@ subroutine uhf_hessv3(acc, ! in: accuracy of products #include "mafdecls.fh" #include "global.fh" + integer rtdb logical limag,lifetime double precision omega,gamwidth integer ipm,ncomp @@ -183,7 +185,8 @@ subroutine uhf_hessv3(acc, ! in: accuracy of products if (pflg .gt. 1)then if (ncomp.gt.1) then - call uhf_hessv_2e3(acc, + call uhf_hessv_2e3(rtdb, + & acc, & g_x, & g_x_im, & g_ax, @@ -766,7 +769,8 @@ subroutine get_dens_reorim_1( return end - subroutine uhf_hessv_2e3(acc, + subroutine uhf_hessv_2e3(rtdb, + & acc, & g_x_re, & g_x_im, & g_ax_re, @@ -797,6 +801,7 @@ subroutine uhf_hessv_2e3(acc, #include "case.fh" #include "msgids.fh" c + integer rtdb logical limag double precision acc ! [input] required accuracy of products integer g_x_re(2), ! [input] handle to input vectors @@ -1006,7 +1011,7 @@ subroutine uhf_hessv_2e3(acc, c as written here, this has no extension to the damped (lifetime) c case. This is okay because this routine is only called for c FD no damping as of now - if (.not.rtdb_get(bgj_get_rtdb_handle(), 'dimqm:lrsp', mt_log, + if (.not.rtdb_get(rtdb, 'dimqm:lrsp', mt_log, $ 1, ldimqm)) ldimqm = .false. if (ldimqm) then dims(1) = nvec @@ -2806,7 +2811,7 @@ subroutine uhf_hessv_2e2_opt_cmplx( c 000000000000000000000000000000000000000000000000000000000000 c ++++++++++++++++++ udft calc using g_Az1 +++++++++++++ END c 000000000000000000000000000000000000000000000000000000000000 - subroutine uhf_hessv3_cmplx1( + subroutine uhf_hessv3_cmplx1(rtdb, & acc, ! in: accuracy of products & g_z, ! in : z & g_Az, @@ -2831,6 +2836,7 @@ subroutine uhf_hessv3_cmplx1( #include "mafdecls.fh" #include "global.fh" + integer rtdb logical limag,lifetime double precision omega,gamwidth integer ipm,ncomp @@ -2989,7 +2995,7 @@ subroutine uhf_hessv3_cmplx1( if (pflg .gt. 1)then if (ncomp.gt.1) then - call uhf_hessv_2e3_cmplx1( + call uhf_hessv_2e3_cmplx1(rtdb, & acc, & g_z, & g_Az, ! in: (n1,maxsub) history of Az matrix (large matrix) @@ -3016,7 +3022,7 @@ subroutine uhf_hessv3_cmplx1( endif ! end-if-pflg end - subroutine uhf_hessv_2e3_cmplx1( + subroutine uhf_hessv_2e3_cmplx1(rtdb, & acc, & g_z, & g_Az, ! in: (n1,maxsub) history of Az matrix (large matrix) @@ -3045,6 +3051,7 @@ subroutine uhf_hessv_2e3_cmplx1( #include "case.fh" #include "msgids.fh" c + integer rtdb logical limag double precision acc ! [input] required accuracy of products integer g_z(2) @@ -3288,7 +3295,7 @@ subroutine uhf_hessv_2e3_cmplx1( c DIM/QM jbecca START: Allocate arrays and create real and imaginary c densities for total densities. - if (.not.rtdb_get(bgj_get_rtdb_handle(), 'dimqm:lrsp', mt_log, + if (.not.rtdb_get(rtdb, 'dimqm:lrsp', mt_log, $ 1, ldimqm)) ldimqm = .false. if (ldimqm) then dims(1) = nvec diff --git a/src/hessian/analytic/dft/xc_cpks_coeff.F b/src/hessian/analytic/dft/xc_cpks_coeff.F index 955b761221e..2e39c476ea5 100644 --- a/src/hessian/analytic/dft/xc_cpks_coeff.F +++ b/src/hessian/analytic/dft/xc_cpks_coeff.F @@ -339,7 +339,7 @@ subroutine xc_cpks_coeff(prho, pdelrho, pttau, endif c #if 0 - if (bgj_print() .gt. 1) then + if (bgj_print(rtdb) .gt. 1) then write(6,*) 'xc_cpks_coeff: prho out' call output(prho, 1, nq, 1, ipol*npert, nq, ipol*npert, 1) if (grad) then diff --git a/src/hessian/analytic/hess_cphf.F b/src/hessian/analytic/hess_cphf.F index 68354efa62c..f20b2a30223 100644 --- a/src/hessian/analytic/hess_cphf.F +++ b/src/hessian/analytic/hess_cphf.F @@ -1222,7 +1222,7 @@ subroutine hess_modfock(g_rhs_x, g_vecs, g_tmp, ndens, n3xyz, & dbl_mb(k_jfac), dbl_mb(k_kfac), ndensity, & nfock, nbf, ocphfprint) c - call shell_fock_build(geom,basis,0,ndensity,dbl_mb(k_jfac), + call shell_fock_build(rtdb, geom,basis,0,ndensity,dbl_mb(k_jfac), & dbl_mb(k_kfac),tol2e, & g_tmp,g_rhs_x,.true.) c diff --git a/src/hessian/analytic/hess_init.F b/src/hessian/analytic/hess_init.F index 6f702d399c3..456cc0fd8f6 100644 --- a/src/hessian/analytic/hess_init.F +++ b/src/hessian/analytic/hess_init.F @@ -244,7 +244,7 @@ subroutine hess_init(rtdb) if (.not. rtdb_get(rtdb, 'dft:noc', mt_int, 2, dftnoc)) * call errquit('hess_init: rtdb_get of dftnoc failed', 555, & RTDB_ERR) - if (bgj_restricted()) then + if (bgj_restricted(rtdb)) then nclosed = dftnoc(1) nalpha = nclosed nbeta = 0 diff --git a/src/hessian/analytic/shell_fock_build.F b/src/hessian/analytic/shell_fock_build.F index b4be7e038e2..23acae0c4d1 100644 --- a/src/hessian/analytic/shell_fock_build.F +++ b/src/hessian/analytic/shell_fock_build.F @@ -15,7 +15,7 @@ C> The latter occurs, for example, when the Fock matrix is the C> imaginary part of a matrix. C> - subroutine shell_fock_build(geom,basis, nder, ndens, + subroutine shell_fock_build(rtdb, geom,basis, nder, ndens, $ jfac, kfac, tol2e, g_dens, g_fock, osym) c c Took oactive out for the time being, but will probably need to @@ -34,6 +34,7 @@ subroutine shell_fock_build(geom,basis, nder, ndens, #include "prop.fh" #include "stdio.fh" c + integer rtdb integer basis !< [Input] The basis set handle integer nder !< [Input] The number of derivatives !< - nder = 0: Energy @@ -205,7 +206,7 @@ subroutine shell_fock_build(geom,basis, nder, ndens, call nga_reorder(g_fock, .true., int_mb(k_rbfmap), $ .true., int_mb(k_rbfmap)) c - call newfock( + call newfock(rtdb, $ basis, nder, ndens, nfock, $ g_dens, g_fock, $ dbl_mb(k_d_ij), dbl_mb(k_d_kl), dbl_mb(k_d_ik), @@ -243,7 +244,7 @@ subroutine shell_fock_build(geom,basis, nder, ndens, c in addition to checking xc_active() c if(use_theory.eq.'dft'.and.xc_gotxc().and.nder.eq.0)then - call xc_newfock(geom,basis,jfac,kfac,nbf, + call xc_newfock(rtdb, geom,basis,jfac,kfac,nbf, & nder, ndens, nfock, g_fock,g_dens) endif c @@ -256,7 +257,7 @@ subroutine shell_fock_build(geom,basis, nder, ndens, return end c - subroutine newfock( + subroutine newfock(rtdb, $ basis, nder, ndens, nfock, $ g_dens, g_fock, $ d_ij, d_kl, d_ik, d_jl, d_il, d_jk, @@ -278,6 +279,7 @@ subroutine newfock( #include "bas.fh" #include "rtdb.fh" c + integer rtdb integer basis ! [input] familiar handles integer nder ! [input] No. of derivatives (0 = energy) integer ndens ! [input] No. of density matrices (for UHF) @@ -398,7 +400,7 @@ subroutine newfock( c c turned off for nbf gt 3000 since becomes a memory hog c - rtdb_out=bgj_get_rtdb_handle() + rtdb_out=rtdb dorepon=.true. if (.not.rtdb_get(rtdb_out,'fock:mirrmat',mt_log,1,dorepon)) then dorepon=nbf.lt.3000 @@ -1235,7 +1237,7 @@ subroutine new_fock_doit_der(nint,labels,leri,eri,tol2e, end do c end - subroutine xc_newfock(geom,basis,jfac,kfac,nbf, + subroutine xc_newfock(rtdb,geom,basis,jfac,kfac,nbf, % nder, ndens, nfock,g_fock,g_dens) implicit none #include "errquit.fh" @@ -1244,6 +1246,7 @@ subroutine xc_newfock(geom,basis,jfac,kfac,nbf, #include "mafdecls.fh" #include "util.fh" #include "stdio.fh" + integer rtdb integer geom integer basis double precision jfac(*),kfac(*),tdum,Exc(2) @@ -1292,7 +1295,7 @@ subroutine xc_newfock(geom,basis,jfac,kfac,nbf, Exc(1) = 0.0d0 Exc(2) = 0.0d0 nExc = 1 - call fock_xc(geom, nbf,basis, + call fock_xc(rtdb,geom, nbf,basis, , ndens, g_dens, g_xc,Exc,nExc,.true.) call ga_add(1.0d0, g_xc, 1.0d0, g_fock, & g_fock) diff --git a/src/hessian/analytic/shell_fock_build_ext.F b/src/hessian/analytic/shell_fock_build_ext.F index bd86d2ea1de..fe128217caa 100644 --- a/src/hessian/analytic/shell_fock_build_ext.F +++ b/src/hessian/analytic/shell_fock_build_ext.F @@ -232,7 +232,8 @@ subroutine shell_fock_build_nosymm(geom,basis, nder, ndens, return end - subroutine shell_fock_build2(g_fock, ! out: Fock matrices + subroutine shell_fock_build2(rtdb, + & g_fock, ! out: Fock matrices & g_dens, ! in : density matrices & geom, ! in : geom handle & basis, ! in : basis handle @@ -274,6 +275,7 @@ subroutine shell_fock_build2(g_fock, ! out: Fock matrices c case is zero, i.e. there is no Coulomb term because there is c no density. However, there are still exchange contributions from c HF exchange. For pure DFT we just skip the call to save CPU time. + integer rtdb integer geom,basis, & nbf, & npol,imul,nmul,ncomp,nblock,nvec,nder, @@ -323,8 +325,8 @@ subroutine shell_fock_build2(g_fock, ! out: Fock matrices c initialize jfacs and kfacs (will go into the uhf_fock_setup) c If DFT get part of the exact exchange defined c xc_xfac = 1.0d0 -c if (use_theory.eq.'dft') xc_xfac = bgj_kfac() - xc_xfac = bgj_kfac() +c if (use_theory.eq.'dft') xc_xfac = bgj_kfac(rtdb) + xc_xfac = bgj_kfac(rtdb) dims(1) = nblock*npol*nvec dims(2) = nbf dims(3) = nbf diff --git a/src/hessian/analytic/twodd_cont.F b/src/hessian/analytic/twodd_cont.F index 9650e9b9a3d..ba9b3bd6674 100644 --- a/src/hessian/analytic/twodd_cont.F +++ b/src/hessian/analytic/twodd_cont.F @@ -254,7 +254,7 @@ subroutine twodd_cont(rtdb) nfock = ndens*n3xyz if (scftype .eq. 'UHF') call uhf_fock_setup(g_dens2,g_rhs, * jfac,kfac,ndens,nfock,nbf,otwoprint) - call shell_fock_build (geom,basis, 1, ndens, jfac, kfac, + call shell_fock_build(rtdb, geom,basis, 1, ndens, jfac, kfac, * tol2e, g_dens2, g_rhs,.true.) if (scftype .eq. 'UHF') call uhf_fock_finish(g_dens2,g_rhs, * jfac,kfac,ndens,nfock,nbf,otwoprint) diff --git a/src/mcscf/mcscf_debug.F b/src/mcscf/mcscf_debug.F index 75c221195cc..8aa19a4f083 100644 --- a/src/mcscf/mcscf_debug.F +++ b/src/mcscf/mcscf_debug.F @@ -835,7 +835,7 @@ subroutine mcscf_debugger( rtdb, basis, geom, nbf, nclosed, nact, c$$$ call ga_zero(g_prod) c$$$ pflg = 2 c$$$ lshift = 0.d0 -c$$$ call rohf_hessv_xx( basis, geom, nbf, nclosed, nact, pflg, +c$$$ call rohf_hessv_xx( rtdb, basis, geom, nbf, nclosed, nact, pflg, c$$$ $ g_movecs, oskel, g_fcv, g_fpv, g_fcp, c$$$ $ tol2e, lshift, g_x, g_prod ) c$$$ diff --git a/src/moints/moints_full.F b/src/moints/moints_full.F index cf6abaddcf3..67db3e4a380 100644 --- a/src/moints/moints_full.F +++ b/src/moints/moints_full.F @@ -438,7 +438,7 @@ logical function moints_full(rtdb) $ call ga_print(g_aodens) c call scf_get_fock_param(rtdb, tol2e) - call rhf_fock_2e(geom, basis, g_aodens, g_aofock, tol2e, + call rhf_fock_2e(rtdb, geom, basis, g_aodens, g_aofock, tol2e, $ .true., .true., osym ) call scf_tidy(rtdb) c diff --git a/src/nwchem.nw b/src/nwchem.nw index 77b2b04ee95..dce29745d75 100644 --- a/src/nwchem.nw +++ b/src/nwchem.nw @@ -25,4 +25,10 @@ scf; print low; end task scf optimize +task scf freq + +task dft optimize + +task dft freq + diff --git a/src/nwdft/dftgrad/dft_gradients.F b/src/nwdft/dftgrad/dft_gradients.F index 96bcdfbcc22..7b28731477d 100644 --- a/src/nwdft/dftgrad/dft_gradients.F +++ b/src/nwdft/dftgrad/dft_gradients.F @@ -608,7 +608,7 @@ subroutine dft_gradients(rtdb) & call errquit('dft_gradients: could not alloc j hessian', & 1, MA_ERR) call dfill(9*nat*nat, 0.0d0, dbl_mb(k_hess), 1) - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(LuOut,*)'*** In dft_gradients: calling j_hessian' call j_hessian(iga_dens, log_mb(k_act), nactive, & dbl_mb(k_hess)) @@ -647,7 +647,7 @@ subroutine dft_gradients(rtdb) c c Allocate and initialize temp GA's for RHS c - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'*** j cpks rhs test: nactive =',nactive if (nat.gt.100) & call errquit('dft_gradients: dimension error in test',0, @@ -666,7 +666,7 @@ subroutine dft_gradients(rtdb) endif enddo - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(LuOut,*)'*** In dft_gradients: calling j_cpks_rhs' call j_cpks_rhs(iga_dens, log_mb(k_act), nactive, g_rhs) diff --git a/src/nwdft/dftgrad/dftg_getxc.F b/src/nwdft/dftgrad/dftg_getxc.F index 6eb77e68040..3f638166d85 100644 --- a/src/nwdft/dftgrad/dftg_getxc.F +++ b/src/nwdft/dftgrad/dftg_getxc.F @@ -96,7 +96,7 @@ Subroutine dftg_getxc(rtdb, natom, iga_dens, force, oactive, & call errquit('dftg_getxc: could not allocate xc hessian', & 1, MA_ERR) call dfill(9*natom*natom, 0.0d0, dbl_mb(k_hess), 1) - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(LuOut,*)'*** In dftg_getxc: calling xc_hessian' call xc_hessian(geom,rtdb,nbf_ao,ao_bas_han, . iga_dens, oactive, nactive, dbl_mb(k_hess), @@ -117,7 +117,7 @@ Subroutine dftg_getxc(rtdb, natom, iga_dens, force, oactive, c c Allocate and initialize temp GA's for RHS c - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'*** xc cpks rhs test: nactive =',nactive if (ipol*3*natom.gt.100) & call errquit('dftg_getxc: dimension error in test',0, @@ -158,7 +158,7 @@ Subroutine dftg_getxc(rtdb, natom, iga_dens, force, oactive, endif enddo - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(LuOut,*)'*** In dftg_getxc: calling xc_cpks_rhs' call xc_cpks_rhs(geom,rtdb,nbf_ao,ao_bas_han, . iga_dens, oactive, nactive, g_rhs, diff --git a/src/nwdft/dftgrad/dftg_griddo.F b/src/nwdft/dftgrad/dftg_griddo.F index 5ebb019b1de..4161bb86b3e 100644 --- a/src/nwdft/dftgrad/dftg_griddo.F +++ b/src/nwdft/dftgrad/dftg_griddo.F @@ -129,7 +129,7 @@ Subroutine dftg_griddo(rtdb, Ec = 0.d0 Ex = 0.d0 oprint = util_print('quadrature', print_high) - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'*** dftg_gridv0a: logicals ', & do_force,do_hess,do_cpks_r c diff --git a/src/nwdft/dftgrad/dftg_gridv0a.F b/src/nwdft/dftgrad/dftg_gridv0a.F index 1a04b5aa0ce..ebb9403a9bd 100644 --- a/src/nwdft/dftgrad/dftg_gridv0a.F +++ b/src/nwdft/dftgrad/dftg_gridv0a.F @@ -161,7 +161,7 @@ Subroutine dftg_gridv0a(rtdb,iga_dens,ldew, me = ga_nodeid() Ec = 0.d0 Ex = 0.d0 - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'*** dftg_gridv0a: logicals ', & do_force,do_hess,do_cpks_r c diff --git a/src/nwdft/dftgrad/j_nucder_gen.F b/src/nwdft/dftgrad/j_nucder_gen.F index 059f08a1794..7ff2d188103 100644 --- a/src/nwdft/dftgrad/j_nucder_gen.F +++ b/src/nwdft/dftgrad/j_nucder_gen.F @@ -92,16 +92,15 @@ subroutine j_deriv_gen(g_dens, oactive, nactive, hess, g_rhs, integer l_ti_db, k_ti_db c !!! End BGJ temp test code c - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'--------Entered j_deriv_gen-------------' do_hess = calc_type .eq. 2 do_cpks_r = calc_type .eq. 3 if (.not. (do_hess .or. do_cpks_r)) & call errquit('j_deriv_gen: illegal calculation type',0, & INPUT_ERR) - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'logicals ', do_hess, do_cpks_r - rtdb = bgj_get_rtdb_handle() if (.not. geom_ncent(geom, natoms)) & call errquit('j_deriv_gen: geom_ncent failed',1, GEOM_ERR) #if 0 @@ -147,7 +146,7 @@ subroutine j_deriv_gen(g_dens, oactive, nactive, hess, g_rhs, c The s34 array is used for the fitting coefficients in the c fitted case (allocation is set up properly in j_nucder_alloc) c - if (bgj_print().gt.0) write(*,*) + if (bgj_print(rtdb).gt.0) write(*,*) & ': what about oactive for fitted J?' call dftg_cdfit_gen(geom,AO_bas_han, CD_bas_han, & nbf_cd, natoms, tol2e, @@ -247,7 +246,7 @@ subroutine j_deriv_gen(g_dens, oactive, nactive, hess, g_rhs, c All the code from here to the next !!! BGJ test !!! can be removed once c the code is stable c - if (bgj_print() .gt. 0) then + if (bgj_print(rtdb) .gt. 0) then if (do_hess) then c write(LuOut,*) 'j_deriv_gen: j hessian' diff --git a/src/nwdft/lr_tddft/tddft_contract.F b/src/nwdft/lr_tddft/tddft_contract.F index ae9d7173e3a..b86dcd89814 100644 --- a/src/nwdft/lr_tddft/tddft_contract.F +++ b/src/nwdft/lr_tddft/tddft_contract.F @@ -132,20 +132,20 @@ subroutine tddft_contract(rtdb,geom,ao_bas_han, jf(1)=1.0d0*scale_j kf(1)=-kfac*0.5d0*scale_k if (.not.cam_exch) then ! regular calculations - call shell_fock_build(geom,ao_bas_han,0,1, + call shell_fock_build(rtdb, geom,ao_bas_han,0,1, & jf,kf,tol2e,g_ntrl,g_nprd,.true.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,1, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,1, & jf,kf,tol2e,g_ntrl,g_nprd,.true.) end if ! cam_exch else if ((ipol.eq.1).and.(triplet)) then jf(1)=0.0d0*scale_j kf(1)=-kfac*0.5d0*scale_k if (.not.cam_exch) then ! regular calculations - call shell_fock_build(geom,ao_bas_han,0,1, + call shell_fock_build(rtdb, geom,ao_bas_han,0,1, 1 jf,kf,tol2e,g_ntrl,g_nprd,.true.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,1, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,1, 1 jf,kf,tol2e,g_ntrl,g_nprd,.true.) end if ! cam_exch else if (ipol.eq.2) then @@ -158,10 +158,10 @@ subroutine tddft_contract(rtdb,geom,ao_bas_han, call uhf_fock_setup(g_ntrl,g_nprd,jf,kf,ndu, 1 nfu,nbf_ao,.false.) if (.not.cam_exch) then ! regular calculations - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 jf,kf,tol2e,g_ntrl,g_nprd,.true.) else - call shell_fock_build_cam(geom,ao_bas_han,0,ndu, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,ndu, 1 jf,kf,tol2e,g_ntrl,g_nprd,.true.) end if ! cam_exch call uhf_fock_finish(g_ntrl,g_nprd,jf,kf,ndu, @@ -221,10 +221,10 @@ subroutine tddft_contract(rtdb,geom,ao_bas_han, jf(1)=0.0d0*scale_j kf(1)=-kfac*0.5d0*scale_k if (.not.cam_exch) then ! regular calculations - call shell_fock_build(geom,ao_bas_han,0,1, + call shell_fock_build(rtdb, geom,ao_bas_han,0,1, & jf,kf,tol2e,g_ntrl,g_nprd,.false.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,1, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,1, & jf,kf,tol2e,g_ntrl,g_nprd,.false.) end if ! cam_exch else @@ -237,10 +237,10 @@ subroutine tddft_contract(rtdb,geom,ao_bas_han, call uhf_fock_setup(g_ntrl,g_nprd,jf,kf,ndu, 1 nfu,nbf_ao,.false.) if (.not.cam_exch) then ! regular calculations - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 jf,kf,tol2e,g_ntrl,g_nprd,.false.) else - call shell_fock_build_cam(geom,ao_bas_han,0,ndu, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,ndu, 1 jf,kf,tol2e,g_ntrl,g_nprd,.false.) end if ! cam_exch call uhf_fock_finish(g_ntrl,g_nprd,jf,kf,ndu, @@ -458,12 +458,12 @@ subroutine tddft_nga_cont(rtdb,geom,ao_bas_han, enddo if(.not.cam_exch) then ! normal calculations c write(6,*)'HERE' - call shell_fock_build(geom,ao_bas_han,0,nvectors, + call shell_fock_build(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) else ! attenuated calculations c write(6,*)'NOT HERE' - call shell_fock_build_cam(geom,ao_bas_han,0,nvectors, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) end if ! cam_exch else if ((ipol.eq.1).and.(triplet)) then @@ -472,10 +472,10 @@ subroutine tddft_nga_cont(rtdb,geom,ao_bas_han, dbl_mb(k_kf+n-1)=-kfac*0.5d0*scale_k enddo if (.not.cam_exch) then ! normal calculations - call shell_fock_build(geom,ao_bas_han,0,nvectors, + call shell_fock_build(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,nvectors, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) end if ! cam_exch else if (ipol.eq.2) then @@ -488,10 +488,10 @@ subroutine tddft_nga_cont(rtdb,geom,ao_bas_han, call uhf_fock_setup(g_nsym,g_nprd_p,dbl_mb(k_jf),dbl_mb(k_kf), 1 ndu,nfu,nbf_ao,.false.) if (.not.cam_exch) then ! normal calculations - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) else - call shell_fock_build_cam(geom,ao_bas_han,0,ndu, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) end if ! cam_exch call uhf_fock_finish(g_nsym,g_nprd_p,dbl_mb(k_jf),dbl_mb(k_kf), @@ -544,11 +544,12 @@ subroutine tddft_nga_cont(rtdb,geom,ao_bas_han, enddo if (tda) then if (.not.cam_exch) then ! normal calculations - call shell_fock_build(geom,ao_bas_han,0,nvectors, + call shell_fock_build(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work,.false.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,nvectors, - 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work,.false.) + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0, + 1 nvectors,dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work, + 2 .false.) end if ! cam_exch alo(1)=1 ahi(1)=ipol*nvectors @@ -566,11 +567,11 @@ subroutine tddft_nga_cont(rtdb,geom,ao_bas_han, 1 g_nprd_p,blo,bhi,g_nprd_p,blo,bhi) else if (.not.cam_exch) then ! normal calculations - call shell_fock_build(geom,ao_bas_han,0,nvectors, - 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) + call shell_fock_build(rtdb, geom,ao_bas_han,0,nvectors, + 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,nvectors, - 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,nvectors, + 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) end if ! cam_exch endif ! tda else @@ -584,10 +585,10 @@ subroutine tddft_nga_cont(rtdb,geom,ao_bas_han, call uhf_fock_setup(g_nsym,g_work, 1 dbl_mb(k_jf),dbl_mb(k_kf),ndu,nfu,nbf_ao,.false.) if (.not.cam_exch) then - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work,.false.) else - call shell_fock_build_cam(geom,ao_bas_han,0,ndu, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work,.false.) end if ! cam_exch call uhf_fock_finish(g_nsym,g_work, @@ -611,10 +612,10 @@ subroutine tddft_nga_cont(rtdb,geom,ao_bas_han, call uhf_fock_setup(g_nsym,g_nprd_m, 1 dbl_mb(k_jf),dbl_mb(k_kf),ndu,nfu,nbf_ao,.false.) if (.not.cam_exch) then - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) else - call shell_fock_build_cam(geom,ao_bas_han,0,ndu, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) end if ! cam_exch call uhf_fock_finish(g_nsym,g_nprd_m, diff --git a/src/nwdft/lr_tddft/tddft_contract2.F b/src/nwdft/lr_tddft/tddft_contract2.F index 653ed698703..df79c8e2814 100644 --- a/src/nwdft/lr_tddft/tddft_contract2.F +++ b/src/nwdft/lr_tddft/tddft_contract2.F @@ -141,12 +141,12 @@ subroutine tddft_nga_cont2(rtdb,geom,ao_bas_han, enddo if(.not.cam_exch) then ! normal calculations c write(6,*)'HERE' - call shell_fock_build(geom,ao_bas_han,0,nvectors, + call shell_fock_build(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) else ! attenuated calculations c write(6,*)'NOT HERE' - call shell_fock_build_cam(geom,ao_bas_han,0,nvectors, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) end if ! cam_exch else if ((ipol.eq.1).and.(triplet)) then @@ -155,10 +155,10 @@ subroutine tddft_nga_cont2(rtdb,geom,ao_bas_han, dbl_mb(k_kf+n-1)=-kfac*0.5d0*scale_k enddo if (.not.cam_exch) then ! normal calculations - call shell_fock_build(geom,ao_bas_han,0,nvectors, + call shell_fock_build(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,nvectors, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) end if ! cam_exch else if (ipol.eq.2) then @@ -171,10 +171,10 @@ subroutine tddft_nga_cont2(rtdb,geom,ao_bas_han, call uhf_fock_setup(g_nsym,g_nprd_p,dbl_mb(k_jf),dbl_mb(k_kf), 1 ndu,nfu,nbf_ao,.false.) if (.not.cam_exch) then ! normal calculations - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) else - call shell_fock_build_cam(geom,ao_bas_han,0,ndu, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_p,.true.) end if ! cam_exch call uhf_fock_finish(g_nsym,g_nprd_p,dbl_mb(k_jf),dbl_mb(k_kf), @@ -227,10 +227,10 @@ subroutine tddft_nga_cont2(rtdb,geom,ao_bas_han, enddo if (tda) then if (.not.cam_exch) then ! normal calculations - call shell_fock_build(geom,ao_bas_han,0,nvectors, + call shell_fock_build(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work,.false.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,nvectors, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work,.false.) end if ! cam_exch alo(1)=1 @@ -249,10 +249,10 @@ subroutine tddft_nga_cont2(rtdb,geom,ao_bas_han, 1 g_nprd_p,blo,bhi,g_nprd_p,blo,bhi) else if (.not.cam_exch) then ! normal calculations - call shell_fock_build(geom,ao_bas_han,0,nvectors, + call shell_fock_build(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) else ! attenuated calculations - call shell_fock_build_cam(geom,ao_bas_han,0,nvectors, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,nvectors, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) end if ! cam_exch endif ! tda @@ -267,10 +267,10 @@ subroutine tddft_nga_cont2(rtdb,geom,ao_bas_han, call uhf_fock_setup(g_nsym,g_work, 1 dbl_mb(k_jf),dbl_mb(k_kf),ndu,nfu,nbf_ao,.false.) if (.not.cam_exch) then - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work,.false.) else - call shell_fock_build_cam(geom,ao_bas_han,0,ndu, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_work,.false.) end if ! cam_exch call uhf_fock_finish(g_nsym,g_work, @@ -294,10 +294,10 @@ subroutine tddft_nga_cont2(rtdb,geom,ao_bas_han, call uhf_fock_setup(g_nsym,g_nprd_m, 1 dbl_mb(k_jf),dbl_mb(k_kf),ndu,nfu,nbf_ao,.false.) if (.not.cam_exch) then - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) else - call shell_fock_build_cam(geom,ao_bas_han,0,ndu, + call shell_fock_build_cam(rtdb, geom,ao_bas_han,0,ndu, 1 dbl_mb(k_jf),dbl_mb(k_kf),tol2e,g_nsym,g_nprd_m,.false.) end if ! cam_exch call uhf_fock_finish(g_nsym,g_nprd_m, diff --git a/src/nwdft/scf_dft_cg/dft_cg_info.F b/src/nwdft/scf_dft_cg/dft_cg_info.F index f6e2aba94cf..3781f9c1470 100644 --- a/src/nwdft/scf_dft_cg/dft_cg_info.F +++ b/src/nwdft/scf_dft_cg/dft_cg_info.F @@ -31,8 +31,8 @@ subroutine dft_cg_init(rtdb) integer mult integer cd_basis c -c hf_job = .not. bgj_have_xc() -c if (bgj_print() .gt. 0) +c hf_job = .not. bgj_have_xc(rtdb) +c if (bgj_print(rtdb) .gt. 0) c & write(*,*)'*** scf_get_info: hf_job ',hf_job c c if (.not. rtdb_cget(rtdb, 'title', 1, title)) @@ -188,7 +188,7 @@ subroutine dft_cg_init(rtdb) c Determine no. of open and closed shells ... default is to run closed c shell unless told otherwise c -c if (bgj_print() .gt. 0) +c if (bgj_print(rtdb) .gt. 0) c & write(*,*)'*** !!! more stuff to check in scf_get_info.F !!!' c if(.not.rtdb_cget(rtdb,'task:theory',1,theory)) c + call errquit('task: no task input for theory?',0, INPUT_ERR) diff --git a/src/nwdft/scf_dft_cg/dft_roks_fock.F b/src/nwdft/scf_dft_cg/dft_roks_fock.F index 7e638e954ef..8a8f2c1b9d5 100644 --- a/src/nwdft/scf_dft_cg/dft_roks_fock.F +++ b/src/nwdft/scf_dft_cg/dft_roks_fock.F @@ -443,8 +443,8 @@ subroutine dft_roks_fock(rtdb, geom, basis, nclosed, nopen, nmo, Exc(1) = 0.0d0 Exc(2) = 0.0d0 if (xc_gotxc()) then - call fock_xc(geom, nbf, basis, nfockxc, iv_dens(4), iv_fock(4), - + Exc, nExc,.false.) + call fock_xc(rtdb,geom, nbf, basis, nfockxc, iv_dens(4), + + iv_fock(4),Exc, nExc,.false.) c AOR begin call xc_xdm_init(rtdb,ixdm_v,ixdm_ml) if (.not. rtdb_put(rtdb,'dft:xdmsave', mt_log, 1, .false.)) diff --git a/src/nwdft/scf_dft_cg/dft_roks_hessv_2e.F b/src/nwdft/scf_dft_cg/dft_roks_hessv_2e.F index ab7fbf8e130..1e1d95e83b5 100644 --- a/src/nwdft/scf_dft_cg/dft_roks_hessv_2e.F +++ b/src/nwdft/scf_dft_cg/dft_roks_hessv_2e.F @@ -277,7 +277,6 @@ subroutine dft_roks_hessv_2e( basis, geom, nbf, nmo, nclosed, c point. Keep the original setting to restore original state c at the end. c - rtdb = bgj_get_rtdb_handle() if (.not. rtdb_get(rtdb, 'fock_xc:calc_type', mt_int, 1, & calc_type)) then calc_type = 1 @@ -299,7 +298,7 @@ subroutine dft_roks_hessv_2e( basis, geom, nbf, nmo, nclosed, & rodft = .false. ! query the rtdb for the type of calculation if(xc_got2nd().and. (.not. rodft)) then - call fock_xc(geom, nbf, basis, jfock, g_dd, g_ff, + call fock_xc(rtdb,geom, nbf, basis, jfock, g_dd, g_ff, + Exc, nExc,.true.) end if c diff --git a/src/nwdft/scf_dft_cg/dft_uks_energy.F b/src/nwdft/scf_dft_cg/dft_uks_energy.F index ef57cc8c80b..d1cb2716769 100644 --- a/src/nwdft/scf_dft_cg/dft_uks_energy.F +++ b/src/nwdft/scf_dft_cg/dft_uks_energy.F @@ -68,7 +68,7 @@ subroutine dft_uks_energy( rtdb, g_vecs, eone, etwo, exc, enrep, $ call errquit('dft_uks_energy: invalid vector length',0, $ GA_ERR) cphf_uhf = .false. - if (.not. rtdb_get(bgj_get_rtdb_handle(), + if (.not. rtdb_get(rtdb, & 'cphf_solve:cphf_uhf', mt_log, 1, cphf_uhf)) then cphf_uhf = .false. endif @@ -259,7 +259,7 @@ subroutine dft_uks_energy( rtdb, g_vecs, eone, etwo, exc, enrep, if(util_print('dft timings', print_high)) & time1_xc=util_cpusec() ! start xc build time if (xc_gotxc()) then - call fock_xc(geom, nbf, basis, 4*2, d, f(5), Exc, nExc, + call fock_xc(rtdb,geom, nbf, basis, 4*2, d, f(5), Exc, nExc, & .false.) endif if(util_print('dft timings', print_high)) diff --git a/src/nwdft/scf_dft_cg/dft_uks_hessv_2e.F b/src/nwdft/scf_dft_cg/dft_uks_hessv_2e.F index 09a74281ff5..f17f2ec91a5 100644 --- a/src/nwdft/scf_dft_cg/dft_uks_hessv_2e.F +++ b/src/nwdft/scf_dft_cg/dft_uks_hessv_2e.F @@ -213,7 +213,6 @@ subroutine dft_uks_hessv_2e(acc, g_x, g_ax, nvec) if(util_print('dft timings', print_high)) & time1_xc=util_cpusec() ! start xc build time if (xc_gotxc()) then - rtdb = bgj_get_rtdb_handle() if (.not.rtdb_get(rtdb,'fock_xc:calc_type',MT_INT,1,calc_type)) + calc_type = 1 if (.not.rtdb_put(rtdb,'fock_xc:calc_type',MT_INT,1,2)) @@ -222,7 +221,8 @@ subroutine dft_uks_hessv_2e(acc, g_x, g_ax, nvec) c c include hessian contribution only if second derivatives are available if(xc_got2nd()) then - call fock_xc(geom,nbf,basis,nfock,g_dd,g_ff,Exc,nExc,.true.) + call fock_xc(rtdb,geom,nbf,basis,nfock,g_dd,g_ff,Exc,nExc, + + .true.) end if c if (.not.rtdb_put(rtdb,'fock_xc:calc_type',MT_INT,1,calc_type)) diff --git a/src/nwdft/so_dft/dft_gradients_so.F b/src/nwdft/so_dft/dft_gradients_so.F index b374b1b6a4d..fbaa8eab9c2 100644 --- a/src/nwdft/so_dft/dft_gradients_so.F +++ b/src/nwdft/so_dft/dft_gradients_so.F @@ -491,7 +491,7 @@ subroutine dft_gradients_so(rtdb) if (.not.status) & call errquit('dft_gradients_so: could not alloc j & hessian', 1, MA_ERR) - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(6,*)'*** In dft_gradients_so: calling j_hessian' call j_hessian(iga_dens, log_mb(k_act), nactive, & dbl_mb(k_hess)) @@ -530,7 +530,7 @@ subroutine dft_gradients_so(rtdb) c c Allocate temp GA's for RHS c - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(*,*)'*** j cpks rhs test: nactive =',nactive if (nat.gt.100) & call errquit('dft_gradients_so: @@ -546,7 +546,7 @@ subroutine dft_gradients_so(rtdb) endif enddo - if (bgj_print() .gt. 0) + if (bgj_print(rtdb) .gt. 0) & write(6,*)'*** In dft_gradients_so: calling j_cpks_rhs' call j_cpks_rhs(iga_dens, log_mb(k_act), nactive, g_rhs) diff --git a/src/nwdft/xc/setACmat.F b/src/nwdft/xc/setACmat.F index 22c6c93d45e..fb27619f7e5 100644 --- a/src/nwdft/xc/setACmat.F +++ b/src/nwdft/xc/setACmat.F @@ -194,7 +194,7 @@ Subroutine setACmat_d3(delrho, Amat, Amat2, Amat3, Cmat, Cmat2, endif c #if 0 - if (bgj_print() .gt. 1) then + if (bgj_print(rtdb) .gt. 1) then write(LuOut,*) ' setACmat: AMAT out' call output(amat, 1, nq, 1, ipol, nq, ipol, 1) if (grad) then @@ -229,7 +229,7 @@ Subroutine setACmat_d3(delrho, Amat, Amat2, Amat3, Cmat, Cmat2, enddo endif #if 0 - if (bgj_print() .gt. 1) then + if (bgj_print(rtdb) .gt. 1) then write(LuOut,*) ' setACmat_d2: AMAT2 out' call output(amat2, 1, nq, 1, NCOL_AMAT2, nq, NCOL_AMAT2, 1) if (grad) then diff --git a/src/nwdft/xc/xc_getv.F b/src/nwdft/xc/xc_getv.F index c074b0e56ef..1f65b613056 100644 --- a/src/nwdft/xc/xc_getv.F +++ b/src/nwdft/xc/xc_getv.F @@ -186,7 +186,7 @@ Subroutine xc_getv(rtdb, Exc, ecoul,nExc, iVxc_opt, g_xcinv, c calculate the exchange and coulomb parts call ga_zero(g_vxc(2)) g_dens(2)=g_dens(1) - call fock_2e(geom, AO_bas_han, 2, jfac, kfac, + call fock_2e(rtdb, geom, AO_bas_han, 2, jfac, kfac, & tol2e, oskel, g_dens, g_vxc, .false.) Exc(1) = Exc(1)+0.5d0*ga_ddot(g_dens(1),g_vxc(1)) ecoul = 0.5d0*ga_ddot(g_dens(1),g_vxc(2)) diff --git a/src/property/aor_get_giaoints.F b/src/property/aor_get_giaoints.F index c15b31c2e4e..5b846d62e22 100644 --- a/src/property/aor_get_giaoints.F +++ b/src/property/aor_get_giaoints.F @@ -129,7 +129,7 @@ subroutine aor_get_giaoints(rtdb,basis,geom, nspin, lifetime, c If DFT get part of the exact exchange defined xfac = 1.0d0 - if (use_theory.eq.'dft') xfac = bgj_kfac() + if (use_theory.eq.'dft') xfac = bgj_kfac(rtdb) do idir = 1,ndir jfac(idir) = 0.0d0 @@ -599,19 +599,19 @@ subroutine aor_get_giaoints(rtdb,basis,geom, nspin, lifetime, ifld = 3 if (.not.cam_exch) then - call shell_fock_build(geom, basis, 0, ifld, + call shell_fock_build(rtdb, geom, basis, 0, ifld, & jfac, kfac, tol2e, g_d1, g_fock, .false.) else - call shell_fock_build_cam(geom, basis, 0, ifld, + call shell_fock_build_cam(rtdb, geom, basis, 0, ifld, % jfac, kfac, tol2e, g_d1, g_fock, .false.) end if if (lifetime) then if (.not.cam_exch) then - call shell_fock_build(geom, basis, 0, ifld, + call shell_fock_build(rtdb, geom, basis, 0, ifld, & jfac, kfac, tol2e, g_d1_im, g_fock_im, .false.) else - call shell_fock_build_cam(geom, basis, 0, ifld, + call shell_fock_build_cam(rtdb, geom, basis, 0, ifld, % jfac, kfac, tol2e, g_d1_im, g_fock_im, .false.) end if end if ! lifetime diff --git a/src/property/aoresponse_driver.F b/src/property/aoresponse_driver.F index e7c5489e3e3..8acf5dd04dc 100644 --- a/src/property/aoresponse_driver.F +++ b/src/property/aoresponse_driver.F @@ -281,7 +281,7 @@ subroutine aoresponse_driver (rtdb, basis, geom) c If DFT get part of the exact exchange defined xfac = 1.0d0 - if (use_theory.eq.'dft') xfac = bgj_kfac() + if (use_theory.eq.'dft') xfac = bgj_kfac(rtdb) c c Integral initialization c diff --git a/src/property/aoresponse_driver_new.F b/src/property/aoresponse_driver_new.F index 284898b447f..bf28c6e21d4 100644 --- a/src/property/aoresponse_driver_new.F +++ b/src/property/aoresponse_driver_new.F @@ -334,7 +334,7 @@ subroutine aoresponse_driver_new(rtdb, basis, geom) c If DFT get part of the exact exchange defined xfac = 1.0d0 - if (use_theory.eq.'dft') xfac = bgj_kfac() + if (use_theory.eq.'dft') xfac = bgj_kfac(rtdb) c c read number of frequencies from run-time database diff --git a/src/property/aoresponse_giao_rhs.F b/src/property/aoresponse_giao_rhs.F index f42ba01b240..b8669e69410 100644 --- a/src/property/aoresponse_giao_rhs.F +++ b/src/property/aoresponse_giao_rhs.F @@ -93,7 +93,7 @@ subroutine aoresponse_giao_rhs (rtdb, basis, geom, c If DFT get part of the exact exchange defined xfac = 1.0d0 - if (use_theory.eq.'dft') xfac = bgj_kfac() + if (use_theory.eq.'dft') xfac = bgj_kfac(rtdb) if (debug) write (luout,*) 'use_theory, xfac =', use_theory, xfac @@ -275,7 +275,7 @@ subroutine aoresponse_giao_rhs (rtdb, basis, geom, c$$$ $ call errquit('aorgiao: rtdb_put of j_derfit failed',0, c$$$ & RTDB_ERR) c$$$ endif -c$$$ call shell_fock_build(geom, basis, 0, 3, +c$$$ call shell_fock_build(rtdb, geom, basis, 0, 3, c$$$ $ jfac, kfac,tol2e, g_d1, g_fock,.false.) c$$$ if(use_theory.eq.'dft') then c$$$ ifld = 0 @@ -298,7 +298,7 @@ subroutine aoresponse_giao_rhs (rtdb, basis, geom, $ call errquit('aor_giao: rtdb_put of j_derfit failed',0, & RTDB_ERR) endif - call shell_fock_build(geom, basis, 0, 3, + call shell_fock_build(rtdb, geom, basis, 0, 3, $ jfac, kfac,tol2e, g_d1, g_fock,.false.) if(use_theory.eq.'dft') then if (.not. rtdb_put(rtdb, 'fock_xc:calc_type', mt_int, 1, 0)) diff --git a/src/property/giao_b1_movecs.F b/src/property/giao_b1_movecs.F index 10732c8af22..d66a59c8cac 100644 --- a/src/property/giao_b1_movecs.F +++ b/src/property/giao_b1_movecs.F @@ -108,7 +108,7 @@ subroutine giao_b1_movecs(rtdb,basis,geom, ncomp, ! IN c c If DFT get part of the exact exchange defined xfac = 1.0d0 - if (use_theory.eq.'dft') xfac = bgj_kfac() + if (use_theory.eq.'dft') xfac = bgj_kfac(rtdb) nind_jk=12 do ifld = 1,nind_jk jfac(ifld) = 0.0d0 ! used in update_rhs_shfock() diff --git a/src/property/giao_b1_movecs_tools.F b/src/property/giao_b1_movecs_tools.F index a8a7bb9d0bd..f7d8a439dfa 100644 --- a/src/property/giao_b1_movecs_tools.F +++ b/src/property/giao_b1_movecs_tools.F @@ -219,7 +219,7 @@ subroutine update_rhs_shfock(g_rhs, ! in/out: RHS used for cphf2/3 c Note: Just the exchange: jfac = 0.d0 (see above) if (.not.cam_exch) then - call shell_fock_build(geom, basis,0,ndir*npol*2, + call shell_fock_build(rtdb, geom, basis,0,ndir*npol*2, $ jfac,kfac,tol2e, & g_d2, ! input & g_fock,! output @@ -227,7 +227,7 @@ subroutine update_rhs_shfock(g_rhs, ! in/out: RHS used for cphf2/3 else - call shell_fock_build_cam(geom, basis,0,ndir*npol*2, + call shell_fock_build_cam(rtdb, geom, basis,0,ndir*npol*2, $ jfac,kfac,tol2e, & g_d2, ! input & g_fock,! output diff --git a/src/property/giaofock.F b/src/property/giaofock.F index 532dab11b5c..1e20887095c 100644 --- a/src/property/giaofock.F +++ b/src/property/giaofock.F @@ -1,6 +1,7 @@ cedo#define NBACC 1 cedo#define NBGET 1 - subroutine new_giao_2e(geom, ! in: geometry handle + subroutine new_giao_2e(rtdb, + & geom, ! in: geometry handle & basis, ! in: basis handle & nbf, ! in: nr. of basis functions & tol2e, @@ -21,7 +22,7 @@ subroutine new_giao_2e(geom, ! in: geometry handle #include "case.fh" c integer npol,ntot - integer geom, basis, g_fock, nbf + integer rtdb,geom, basis, g_fock, nbf integer g_dens(3) ! g_dens(npol) integer g_fock1,disp integer i,g_dens1(4) ! for udft calc @@ -274,7 +275,7 @@ subroutine new_giao_2e(geom, ! in: geometry handle Exc(1) = 0.0d0 Exc(2) = 0.0d0 nExc = 1 - call fock_xc(geom,nbf,basis,nfock(npol), + call fock_xc(rtdb,geom,nbf,basis,nfock(npol), & g_dens1,g_xc, & Exc,nExc,.false.) ! out: g_xc c @@ -341,7 +342,7 @@ subroutine new_giao_2e(geom, ! in: geometry handle c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c To produce output: g_fock_Coul,g_fock_Exch =========== START - subroutine new_giao_2e_JK( + subroutine new_giao_2e_JK(rtdb, & geom, ! in : geometry handle & basis, ! in : basis handle & nbf, ! in : nr. of basis functions @@ -364,7 +365,7 @@ subroutine new_giao_2e_JK( #include "case.fh" integer npol,ntot - integer geom, basis, g_fock, nbf + integer rtdb,geom, basis, g_fock, nbf integer g_fock_Coul,g_fock_Exch integer g_dens(3) ! g_dens(npol) integer g_fock1,disp @@ -643,7 +644,7 @@ subroutine new_giao_2e_JK( Exc(1) = 0.0d0 Exc(2) = 0.0d0 nExc = 2 - call fock_xc(geom,nbf,basis,nfock(npol), + call fock_xc(rtdb,geom,nbf,basis,nfock(npol), & g_dens1,g_xc, & Exc,nExc,.false.) ! out: g_xc if (debug_giaofock.eq.1) then diff --git a/src/property/hnd_giaox.F b/src/property/hnd_giaox.F index d4c2f273bb4..3de5114ade1 100644 --- a/src/property/hnd_giaox.F +++ b/src/property/hnd_giaox.F @@ -72,7 +72,7 @@ subroutine hnd_giaox(rtdb,basis,geom) c If DFT get part of the exact exchange defined c xfac = 1.0d0 - if (use_theory.eq.'dft') xfac = bgj_kfac() + if (use_theory.eq.'dft') xfac = bgj_kfac(rtdb) c c Integral initialization c @@ -295,10 +295,10 @@ subroutine hnd_giaox(rtdb,basis,geom) c Note: Just the exchange: jfac = 0.d0 (see above) c if (.not.cam_exch) then - call shell_fock_build(geom, basis, 0, 3, + call shell_fock_build(rtdb, geom, basis, 0, 3, $ jfac, kfac, tol2e, g_d1, g_fock, .false.) else - call shell_fock_build_cam(geom, basis, 0, 3, + call shell_fock_build_cam(rtdb, geom, basis, 0, 3, $ jfac, kfac, tol2e, g_d1, g_fock, .false.) end if c diff --git a/src/property/hnd_giaox_zora.F b/src/property/hnd_giaox_zora.F index a9c13050489..fdf8f6de970 100644 --- a/src/property/hnd_giaox_zora.F +++ b/src/property/hnd_giaox_zora.F @@ -116,7 +116,7 @@ subroutine hnd_giaox_zora(rtdb,basis,geom) c If DFT get part of the exact exchange defined c xfac = 1.0d0 - if (use_theory.eq.'dft') xfac = bgj_kfac() + if (use_theory.eq.'dft') xfac = bgj_kfac(rtdb) nind_jk=12 do ifld = 1,nind_jk jfac(ifld) = 0.0d0 ! used in shell_fock_build() @@ -372,13 +372,13 @@ subroutine hnd_giaox_zora(rtdb,basis,geom) c Note: Just the exchange: jfac = 0.d0 (see above) c if (.not.cam_exch) then - call shell_fock_build(geom, basis,0,3*npol*2, + call shell_fock_build(rtdb, geom, basis,0,3*npol*2, $ jfac,kfac,tol2e, & g_d1, ! input & g_fock,! output & .false.) else - call shell_fock_build_cam(geom, basis,0,3*npol*2, + call shell_fock_build_cam(rtdb, geom, basis,0,3*npol*2, $ jfac,kfac,tol2e, & g_d1, ! input & g_fock,! output diff --git a/src/property/hnd_gshift_zora.F b/src/property/hnd_gshift_zora.F index 94351686138..0f4600dfd8f 100644 --- a/src/property/hnd_gshift_zora.F +++ b/src/property/hnd_gshift_zora.F @@ -102,7 +102,7 @@ subroutine hnd_gshift_zora(rtdb,basis,geom) c c If DFT get part of the exact exchange defined xfac = 1.0d0 - if (use_theory.eq.'dft') xfac = bgj_kfac() + if (use_theory.eq.'dft') xfac = bgj_kfac(rtdb) nind_jk=12 c ------- using different settings (j,k) 03-14-11--- START do ifld = 1,nind_jk @@ -384,13 +384,13 @@ subroutine hnd_gshift_zora(rtdb,basis,geom) c Note: Just the exchange: jfac = 0.d0 (see above) if (.not.cam_exch) then - call shell_fock_build(geom, basis,0,3*npol*2, + call shell_fock_build(rtdb, geom, basis,0,3*npol*2, $ jfac,kfac,tol2e, & g_d1, ! input & g_fock,! output & .false.) else - call shell_fock_build_cam(geom, basis,0,3*npol*2, + call shell_fock_build_cam(rtdb, geom, basis,0,3*npol*2, $ jfac,kfac,tol2e, & g_d1, ! input & g_fock,! output diff --git a/src/tce/tce_ao1e.F b/src/tce/tce_ao1e.F index 16a06c82a5e..04ebf3d77af 100644 --- a/src/tce/tce_ao1e.F +++ b/src/tce/tce_ao1e.F @@ -116,7 +116,7 @@ subroutine tce_ao1e_shellfockbuild(rtdb,g_ao1e) if (ipol.eq.1) then jf(1)=1.0d0 kf(1)=-0.5d0 - call shell_fock_build(geom,ao_bas_han,0,1, + call shell_fock_build(rtdb, geom,ao_bas_han,0,1, 1 jf,kf,tol2e,g_ndens,g_nfock,.true.) else if (ipol.eq.2) then jf(1)=1.0d0 @@ -127,7 +127,7 @@ subroutine tce_ao1e_shellfockbuild(rtdb,g_ao1e) nfu=2 call uhf_fock_setup(g_ndens,g_nfock,jf,kf,ndu, 1 nfu,nbf,.false.) - call shell_fock_build(geom,ao_bas_han,0,ndu, + call shell_fock_build(rtdb, geom,ao_bas_han,0,ndu, 1 jf,kf,tol2e,g_ndens,g_nfock,.true.) call uhf_fock_finish(g_ndens,g_nfock,jf,kf,ndu, 1 nfu,nbf,.false.) diff --git a/src/util/bgj.F b/src/util/bgj.F index ab82ea8b636..e1d0ee6d89b 100644 --- a/src/util/bgj.F +++ b/src/util/bgj.F @@ -10,11 +10,11 @@ c c Returns print level for BGJ debug writes c - function bgj_print() + function bgj_print(rtdb) c implicit none integer bgj_print -#include "bgj_common.fh" + integer rtdb #include "rtdb.fh" #include "mafdecls.fh" integer print_level @@ -22,7 +22,7 @@ function bgj_print() data print_level / -1 / c if (print_level .lt. 0) then - if (.not. rtdb_get(bgj_rtdb, 'bgj:print', mt_int, + if (.not. rtdb_get(rtdb, 'bgj:print', mt_int, & 1, print_level)) then print_level = 0 endif @@ -31,43 +31,25 @@ function bgj_print() c return end - -c -c Returns current rtdb handle -c - function bgj_get_rtdb_handle() -c - implicit none - integer bgj_get_rtdb_handle -#include "bgj_common.fh" -c -c write(*,*)'*** bgj_get_rtdb_handle called',bgj_rtdb - bgj_get_rtdb_handle = bgj_rtdb -c - return - end - c c Returns either 'hf', 'dft' or 'hyb' in name c - function bgj_get_scf_method(name) + function bgj_get_scf_method(rtdb,name) c implicit none -#include "errquit.fh" logical bgj_get_scf_method + integer rtdb character*3 name c +#include "errquit.fh" #include "rtdb.fh" #include "mafdecls.fh" -c!!! -#include "bgj_common.fh" -c!!! c integer itype c - if (.not. rtdb_get(bgj_rtdb, 'bgj:scf_type', mt_int, + if (.not. rtdb_get(rtdb, 'bgj:scf_type', mt_int, & 1, itype)) then - call errquit('bgj_get_scf_method: error reading rtdb',bgj_rtdb, + call errquit('bgj_get_scf_method: error reading rtdb',rtdb, & RTDB_ERR) endif if (itype.eq.1) then @@ -89,41 +71,41 @@ function bgj_get_scf_method(name) c c Returns whether there is an XC contribution in this calculation c - function bgj_have_xc() + function bgj_have_xc(rtdb) c implicit none #include "errquit.fh" logical bgj_have_xc + integer rtdb c external bgj_get_scf_method logical bgj_get_scf_method c character*3 name c - if (.not.bgj_get_scf_method(name)) then + if (.not.bgj_get_scf_method(rtdb,name)) then call errquit('bgj_have_xc: error getting method name',1, & UNKNOWN_ERR) endif bgj_have_xc = name .eq. 'dft' .or. name .eq. 'hyb' -c write(*,*)'*** bgj_have_xc called: ',name,' ',bgj_have_xc -c return end c c Returns coefficient of HF exchange for the current job c - function bgj_kfac() + function bgj_kfac(rtdb) c implicit none double precision bgj_kfac + integer rtdb c #include "../nwdft/include/cdft.fh" c external bgj_have_xc logical bgj_have_xc c - if (bgj_have_xc()) then + if (bgj_have_xc(rtdb)) then bgj_kfac = xfac(1) else bgj_kfac = 1.d0 @@ -135,17 +117,18 @@ function bgj_kfac() c c Returns whether J fitting is involved is this calculation c - function bgj_have_j_fit() + function bgj_have_j_fit(rtdb) c implicit none logical bgj_have_j_fit + integer rtdb c #include "../nwdft/include/cdft.fh" c external bgj_have_xc logical bgj_have_xc c - bgj_have_j_fit = bgj_have_xc() + bgj_have_j_fit = bgj_have_xc(rtdb) if (bgj_have_j_fit) then bgj_have_j_fit = CDFIT endif @@ -156,10 +139,11 @@ function bgj_have_j_fit() c c Returns CD basis handle, or -1 if there's not one c - function bgj_cd_bas_han() + function bgj_cd_bas_han(rtdb) c implicit none integer bgj_cd_bas_han + integer rtdb c #include "../nwdft/include/cdft.fh" c @@ -167,7 +151,7 @@ function bgj_cd_bas_han() logical bgj_have_xc c bgj_cd_bas_han = -1 - if (bgj_have_xc()) then + if (bgj_have_xc(rtdb)) then if (CDFIT) then bgj_cd_bas_han = CD_bas_han endif @@ -179,14 +163,12 @@ function bgj_cd_bas_han() c c Returns whether the calculation is restricted c - function bgj_restricted() + function bgj_restricted(rtdb) c implicit none #include "errquit.fh" logical bgj_restricted -c -c !!! BGJ -#include "bgj_common.fh" + integer rtdb #include "rtdb.fh" #include "../nwdft/include/cdft.fh" c @@ -195,8 +177,8 @@ function bgj_restricted() c character*10 scftype c - if (.not.bgj_have_xc()) then ! HF case - if (.not. rtdb_cget(bgj_rtdb, 'scf:scftype', 1, scftype)) + if (.not.bgj_have_xc(rtdb)) then ! HF case + if (.not. rtdb_cget(rtdb, 'scf:scftype', 1, scftype)) $ call errquit('bgj_restricted: problem getting scftype',0, & RTDB_ERR) bgj_restricted = scftype .ne. 'UHF' @@ -215,7 +197,7 @@ function bgj_restricted() c c Returns handles to AO-basis SCF density matrices c - function bgj_get_scf_dens(g_dens) + function bgj_get_scf_dens(rtdb,g_dens) c implicit none #include "errquit.fh" @@ -227,7 +209,6 @@ function bgj_get_scf_dens(g_dens) #include "global.fh" #include "rtdb.fh" #include "../nwdft/include/cdft.fh" -#include "bgj_common.fh" logical movecs_read_header, movecs_read external movecs_read_header, movecs_read integer ga_create_atom_blocked @@ -239,8 +220,6 @@ function bgj_get_scf_dens(g_dens) character*20 scftype_vecs double precision rhffact logical status -c - rtdb = bgj_rtdb c c get MO vectors from file c @@ -379,43 +358,3 @@ function bgj_get_scf_dens(g_dens) c return end -c -c Checks for unrestricted 2nd derivative calculation on equal -c number of alpha and beta electrons with functional having a -c restricted/unrestricted discontinuity in that case -c - subroutine bgj_check_xc_u2d() -c - implicit none -#include "errquit.fh" -#include "bgj_common.fh" -#include "rtdb.fh" -#include "mafdecls.fh" -#include "../nwdft/include/cdft.fh" - double precision c - logical dontcare -c - if (ipol .eq. 2) then - if(.not.rtdb_get(bgj_rtdb,'dft:dontcare',mt_log, 1,dontcare)) - . dontcare=.false. - if(dontcare) return - if (noc(1) .eq. noc(2)) then -c Add up coefficents for problematic functionals - c = abs(cfac(1)) + abs(cfac(7)) + abs(cfac(8)) - $ + abs(cfac(9)) + abs(cfac(10)) + abs(cfac(11)) - $ + abs(cfac(6)) + abs(cfac(3)) - if (c .gt. 1d-8) then - write(*,*)'*** For a closed-shell system the unrestricted version' - write(*,*)'*** of this XC functional yields different second' - write(*,*)'*** derivative results than the restricted form due to' - write(*,*)'*** a non-zero second derivative of the interpolation' - write(*,*)'*** function at rhoa = rhob. You may run this job as' - write(*,*)'*** a restricted calculation if you wish.' - call errquit('Problem with XC functional 2nd derivative',0, - & CALC_ERR) - endif - endif - endif -c - return - end diff --git a/src/util/bgj_common.fh b/src/util/bgj_common.fh deleted file mode 100644 index 12ff358fa0e..00000000000 --- a/src/util/bgj_common.fh +++ /dev/null @@ -1,9 +0,0 @@ -c -c $Id$ -c -c Common block used "behind the scenes" by BGJ -c - integer - & bgj_rtdb - common /bgj/ - & bgj_rtdb