Merge pull request #731 from edoapra/release-7-2-0

Release 7.2.0 updates

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,

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

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))

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

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

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