comp-chem/NWChem
1
0
Fork 0
mirror of https://github.com/nwchemgit/nwchem.git synced 2026-07-28 06:05:44 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

disable mirroring with mp2:tuhfreplicated=f

Browse source
This commit is contained in:
edoapra 2023-01-31 17:46:42 -08:00
parent 7894149750
commit 77fb82e876
No known key found for this signature in database
GPG key ID: 48E12DA1EDE9E1B0
2 changed files with 34 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/mp2_grad/mp2_grad_doit.F
View file

@ -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,

54
src/mp2_grad/mp2_make_tuhf.F
View file

@ -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,7 +52,7 @@ 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
c
integer l_ia_uv, k_ia_uv, l_tmp, k_tmp, l_ia_jb, k_ia_jb
@ -86,24 +87,35 @@ 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,
if (.not.rtdb_get(rtdb, 'mp2:tuhfreplicated', mt_log, 1,
T tuhfreplicated)) tuhfreplicated=.true.
if(tuhfreplicated) then
do_mirra=util_mirrmat(1,g_t_a,g_ta_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
else
if(do_mirra) then
if(.not.ga_destroy(g_ta_mirr))call errquit(
$ 'could not destroy mirrt_a handle',1, GA_ERR)
endif
endif
do_mirrb=util_mirrmat(1,g_t_b,g_tb_mirr,
D .false., .true.)
else
do_mirra=.false.
do_mirrb=.false.
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,9 +307,9 @@ 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