diff --git a/src/mp2_grad/mp2_grad_doit.F b/src/mp2_grad/mp2_grad_doit.F index 429592b83d..7e8d8242ca 100644 --- a/src/mp2_grad/mp2_grad_doit.F +++ b/src/mp2_grad/mp2_grad_doit.F @@ -333,7 +333,7 @@ c end if call pstat_on(ps_maket) - call mp2_make_tuhf(nbf,noa_lo,noa_hi,nva_lo,nva_hi, + call mp2_make_tuhf(rtdb,nbf,noa_lo,noa_hi,nva_lo,nva_hi, $ sym_lo_oa,sym_hi_oa,sym_lo_va,sym_hi_va,num_oa,num_va, $ nob_lo,nob_hi,nvb_lo,nvb_hi,sym_lo_ob,sym_hi_ob, $ sym_lo_vb,sym_hi_vb,num_ob,num_vb,oseg_lo,oseg_hi, diff --git a/src/mp2_grad/mp2_make_tuhf.F b/src/mp2_grad/mp2_make_tuhf.F index eac9057921..6c6413e4b7 100644 --- a/src/mp2_grad/mp2_make_tuhf.F +++ b/src/mp2_grad/mp2_make_tuhf.F @@ -1,4 +1,4 @@ - subroutine mp2_make_tuhf(nbf,noa_lo,noa_hi,nva_lo,nva_hi, + subroutine mp2_make_tuhf(rtdb,nbf,noa_lo,noa_hi,nva_lo,nva_hi, $ sym_lo_oa,sym_hi_oa,sym_lo_va,sym_hi_va,num_oa,num_va, $ nob_lo,nob_hi,nvb_lo,nvb_hi, sym_lo_ob,sym_hi_ob, $ sym_lo_vb,sym_hi_vb,num_ob,num_vb, @@ -16,6 +16,7 @@ #include "rtdb.fh" #include "eaf.fh" #include "util.fh" + integer rtdb character*8 task integer nbf,i integer noa_lo,noa_hi,nva_lo,nva_hi @@ -51,8 +52,10 @@ c logical otdebug logical do_mirra,do_mirrb,do_mirr integer g_ta_mirr,g_tb_mirr,g_ta_org,g_tb_org - logical util_mirrmat + logical util_mirrmat,tuhfreplicated external util_mirrmat + integer util_mirrmem,mem_mirr + external util_mirrmem c integer l_ia_uv, k_ia_uv, l_tmp, k_tmp, l_ia_jb, k_ia_jb double precision ddot @@ -86,24 +89,48 @@ c *ga:1:0 if(.not.ga_create(mt_dbl,nob*nvb,nva,'T_b',(nob*nvb),0,g_t_b)) $ call errquit('could not alloc ga for T_b',1, GA_ERR) - do_mirra=util_mirrmat(1,g_t_a,g_ta_mirr, - D .false., .true.) - do_mirrb=util_mirrmat(1,g_t_b,g_tb_mirr, - D .false., .true.) - if(do_mirra.and.do_mirrb) then - if(ga_nodeid().eq.0) - w write(6,*) 'mp2_make_tuhf mirroring' - do_mirr=.true. - g_ta_org=g_t_a - g_tb_org=g_t_b - g_t_a=g_ta_mirr - g_t_b=g_tb_mirr + if (.not.rtdb_get(rtdb, 'mp2:tuhfreplicated', mt_log, 1, + T tuhfreplicated)) tuhfreplicated=.false. + do_mirr=.false. + do_mirra=.false. + do_mirrb=.false. + if(tuhfreplicated) then + mem_mirr= + M util_mirrmem(1,g_t_a)+ + M util_mirrmem(1,g_t_b) + if(ga_nodeid().eq.0) then + write(6,14) ' needed by mirroring: ', mem_mirr + write(6,14) ' ga_memory_avail() : ', ga_memory_avail() + endif + 14 format(a,i10,' bytes') + if(ga_memory_avail().gt. mem_mirr) then + do_mirra=util_mirrmat(1,g_t_a,g_ta_mirr, + D .false., .true.) + do_mirrb=util_mirrmat(1,g_t_b,g_tb_mirr, + D .false., .true.) else - if(do_mirra) then - if(.not.ga_destroy(g_ta_mirr))call errquit( - $ 'could not destroy mirrt_a handle',1, GA_ERR) - endif + if(ga_nodeid().eq.0) + W write(6,*) ' insuff. memory for mirroring ' endif + endif + if(do_mirra.and.do_mirrb) then + if(ga_nodeid().eq.0) + w write(6,*) 'mp2_make_tuhf mirroring' + do_mirr=.true. + g_ta_org=g_t_a + g_tb_org=g_t_b + g_t_a=g_ta_mirr + g_t_b=g_tb_mirr + else + if(do_mirra) then + if(.not.ga_destroy(g_ta_mirr))call errquit( + $ 'could not destroy mirrt_a handle',1, GA_ERR) + write(6,10) ga_nodeid(),'destroyed g_ta_mirr',g_ta_mirr + 10 format(i5,a,i5) + endif + g_ta_org=0 + g_tb_org=0 + endif tunitptra=1 tunitptrb=1 do i=oseg_lo,oseg_hi @@ -295,15 +322,19 @@ c c if(do_mirr) then if(.not.ga_destroy(g_t_b))call errquit( - $ 'could not destroy t_b handle',1, GA_ERR) + $ 'could not destroy mirr t_b handle',1, GA_ERR) if(.not.ga_destroy(g_t_a))call errquit( - $ 'could not destroy t_a handle',1, GA_ERR) + $ 'could not destroy mirr t_a handle',1, GA_ERR) g_t_a=g_ta_org g_t_b=g_tb_org endif - if(.not.ga_destroy(g_t_b))call errquit( - $ 'could not destroy t_b handle',1, GA_ERR) + if(.not.ga_destroy(g_t_b))then + if(ga_nodeid().eq.0) call ga_summarize(1) + call ga_sync() + call errquit( + $ 'could not destroy t_b handle',1, GA_ERR) + endif if(.not.ga_destroy(g_t_a))call errquit( $ 'could not destroy t_a handle',1, GA_ERR) c diff --git a/src/nwdft/lr_tddft/tddft_iguess.F b/src/nwdft/lr_tddft/tddft_iguess.F index a820dbc6a0..2b0d85e745 100644 --- a/src/nwdft/lr_tddft/tddft_iguess.F +++ b/src/nwdft/lr_tddft/tddft_iguess.F @@ -371,7 +371,7 @@ c else if (lewin) then if (nroots.gt.newin) nroots = newin else if (nroots.gt.nov(1)+nov(2)) then - if (nodezero.and.util_print('initial guess',print_default)) + if (nodezero.and.util_print('initial guess',print_low)) 1 write(LuOut,9040) nroots,nov(1)+nov(2) nroots=nov(1)+nov(2) if (.not.rtdb_put(rtdb,'tddft:nroots',mt_int,1,nroots)) diff --git a/src/nwdft/lr_tddft/tddft_prod_v.F b/src/nwdft/lr_tddft/tddft_prod_v.F index 124c3c3c17..bb6588f6bd 100644 --- a/src/nwdft/lr_tddft/tddft_prod_v.F +++ b/src/nwdft/lr_tddft/tddft_prod_v.F @@ -58,7 +58,6 @@ c character*4 targetsym ! Symmetry of target excited state double precision cwall ! Wall timings double precision ccpu ! CPU timings - double precision dcpu ! CPU timings integer algorithm ! =1 multiple fock build; =2: conventional integer mult ! Ground state spin multiplicity integer l_irs(2),k_irs(2)! Irreps @@ -116,6 +115,8 @@ c double precision, allocatable, dimension(:,:) :: eye integer iwhich c nodezero=(ga_nodeid().eq.0) + ccpu=0d0 + cwall=0d0 cjb c call ga_print(g_movecs(1)) c diff --git a/src/qmd/qmd_driver.F b/src/qmd/qmd_driver.F index ba457b3c5d..f7ee698773 100644 --- a/src/qmd/qmd_driver.F +++ b/src/qmd/qmd_driver.F @@ -381,6 +381,17 @@ c $ nroots,ipol,nmo,nocc, $ dbl_mb(k_en),g_vecs) esys=dbl_mb(k_en+state-1) +c check nroots vs nstates (tddft might have changed nroots) +c get number of TDDFT roots calculated + if (.not.rtdb_get(rtdb,'tddft:nroots',mt_int,1,nroots)) + & call errquit(pname//'failed to get nroots ',0,RTDB_ERR) + if (nroots.lt.(nstates-1)) then +c call errquit(pname//'nroots<(nstates-1) ',0,RTDB_ERR) + if(ga_nodeid().eq.0) write(luout,124) nstates,nroots + 124 format(9x,'Number of states decreased from ',i8,' to ',i8) + nstates=nroots + endif + c calculate couplings call qmd_coup(rtdb,geom,geom_p,ipol,nstates,dt_nucl,nmo, $ nocc,g_vecs,g_vecs_p,dbl_mb(k_coup), diff --git a/src/util/util_mirror.F b/src/util/util_mirror.F index ab08217e61..5577c5eefc 100644 --- a/src/util/util_mirror.F +++ b/src/util/util_mirror.F @@ -136,3 +136,41 @@ c call util_mirrstop(g_densdis) return end + integer function util_mirrmem(nmat,g_a) + implicit none +#include "global.fh" +#include "mafdecls.fh" + integer g_a(*) + integer nmat +c + integer ppn + integer nbytes,i,imat + integer maxdim + parameter(maxdim=10) + integer type, dims(maxdim),ndim + util_mirrmem=0 + call util_getppn(ppn) + do imat=1,nmat + call nga_inquire(g_a(imat), type, ndim, dims) + if(ndim.gt.maxdim) call errquit( + Q ' mirrmem: increase maxdim to ',ndim,0) +#if 1 + if(ga_nodeid().eq.0) then + write(0,123) ga_nodeid(), ' ndim ',ndim,' dims ', + D (dims(i),i=1,ndim) + endif + 123 format(I2,A,I2,A,3I4) +#endif + nbytes=1 + do i=1,ndim + nbytes=nbytes*dims(i) + enddo + nbytes=ma_sizeof(mt_dbl,1,mt_byte)*nbytes + util_mirrmem=util_mirrmem+nbytes + enddo + if(ga_nnodes().ne.1) then +c divide by ppn & round it by 30% + util_mirrmem=(util_mirrmem*130)/(ppn*100) + endif + return + end