From 77fb82e876c8dc9a6dffafa56af5e6828565dfb7 Mon Sep 17 00:00:00 2001
From: edoapra <edoardo.apra@gmail.com>
Date: Tue, 31 Jan 2023 17:46:42 -0800
Subject: [PATCH] disable mirroring with mp2:tuhfreplicated=f

---
 src/mp2_grad/mp2_grad_doit.F |  2 +-
 src/mp2_grad/mp2_make_tuhf.F | 54 ++++++++++++++++++++++--------------
 2 files changed, 34 insertions(+), 22 deletions(-)

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..f27a4d8274 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,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