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

Merge pull request #702 from edoapra/sifs

Browse source 
updates
This commit is contained in:
Edoardo Aprà 2022-12-02 17:22:09 -08:00 • committed by GitHub
commit 68c4e2d3da
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
5 changed files with 140 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

16
src/NWints/sifs/build_sifs.sh
View file

@ -24,3 +24,19 @@ cat > ibummr.patch <<EOF
EOF
patch -p0 < ibummr.patch
rm -f ibummr.patch
rm -f siftdy.patch
cat > siftdy.patch <<EOF
--- siftdy.F.org 2022-12-02 14:50:03.807903254 -0800
+++ siftdy.F 2022-12-02 14:54:13.969471516 -0800
@@ -282,7 +282,7 @@
c
c # default code: just return a dummy string.
c
- chrtdy = site // 'Machine=? ??:??:?? ??-???-??'
+ chrtdy = site // 'Machine=unknown'
#endif
c
return
EOF
patch -p0 < siftdy.patch
rm -f siftdy.patch

20
src/mp2_grad/mp2_back_transform.F
View file

@ -55,7 +55,8 @@ c
integer l_c_t, k_c_t
integer l_act, k_act, l_actsh, k_actsh
integer twopdmunit
integer junk, ninseg, ierr, i, j, ish, ishlo, ishhi, shmax, tdim
integer junk(2), ninseg, ierr, i, j, ish, ishlo, ishhi, shmax,
t tdim
integer nsh, natoms, nactive, nblock
c
integer k_scr, l_scr, k_lab, l_lab, k_eri, l_eri, leneri, lenscr
@ -475,7 +476,7 @@ c
end do ! End of a
call ga_sync()
if (.not. rtdb_get(rtdb, 'mp2:copyback', mt_log, 1, mp2cpybck))
$ mp2cpybck=.false.
$ mp2cpybck=.true.
if(mp2cpybck) then
call mp2_copyback(g_buf,g_buf_trans)
@ -1158,27 +1159,12 @@ c check for boundaries of buff()
write(6,*) ga_nodeid(),' i_1.gt.ihi ',i_1,ihi
call errquit(' mp2copybck: i boundary passed ',0,0)
endif
#if 0
call ga_get(g_a_trans,i_0,i_1,
A jlo,jhi,buff(i_0,jlo),i_ld)
#else
call ga_get(g_a_trans,i_0,i_1,
A jlo,jhi,buff,i_ld)
call ga_put(g_a, i_0, i_1, jlo, jhi, buff, i_ld)
#endif
enddo
endif
c everybody needs to have the buffer filled
call ga_sync()
cold if(dowork) call ga_put(g_a, ilo, ihi, jlo, jhi, buff, ihi-ilo+1)
call ga_sync()
#if 0
call ga_sync()
tr=ga_ddot(g_a,g_a)
tr_tr=ga_ddot(g_a_trans,g_a_trans)
if(abs(tr-tr_tr).gt.1d-6)then
if(ga_nodeid().eq.0)write(6,*) 'tr ',tr,' tr_tr ',tr_tr
endif
#endif
return
end

20
src/mp2_grad/mp2_energy.F
View file

@ -717,6 +717,10 @@ c
endif
endif
call pstat_on(ps_laifock)
if (doprint) then
write(6,111) ' Start laifock', util_wallsec()
call util_flush(6)
end if
call mp2_lai_fock_uhf_prepar(
$ g_p_ab_a,g_p_ab_b,g_p_ij_a,g_p_ij_b,
$ noa,nob,nva,nvb,g_tmpa, g_tmpb,nmo)
@ -725,6 +729,10 @@ c
$ noa,nob,nva,nvb,g_lai_a,g_lai_b,rtdb,tol2e_fock)
call mp2_lai_fock_uhf_tidy(g_tmpa, g_tmpb)
call pstat_off(ps_laifock)
if (doprint) then
write(6,111) ' Done laifock', util_wallsec()
call util_flush(6)
end if
c
if (omatrix) then
call ga_print(g_lai_a)
@ -782,11 +790,20 @@ c
if(.not.ga_create(mt_dbl,nmo,nmo,'tot beta dens',nmo,0,
$ g_p_tot_b))call errquit(
$ 'mp2_energy: ga_create failed',0, GA_ERR)
c
c
if (doprint) then
write(6,111) ' Start make_tot_dens', util_wallsec()
call util_flush(6)
end if
call mp2_make_tot_dens(g_p_ij_a,g_p_ij_b,g_p_ab_a,g_p_ab_b,
$ g_rhs,g_p_tot_a,g_p_tot_b,noa,nva,nob,nvb,nbf,nmo,
$ int_mb(k_map_a), int_mb(k_map_b),
$ g_vecs_a,g_vecs_b,basis,scftype)
if (doprint) then
write(6,111) ' Done make_tot_dens', util_wallsec()
call util_flush(6)
end if
c
if (otrace) then
call mp2_print_trace_norm(g_p_tot_a,'g_p_tot_a',nmo)
@ -931,6 +948,7 @@ c
endif
c
call ga_sync
111 format(a,' at ', f10.1,'s')
c
end
subroutine mp2_print_trace_norm(g, text, n)

73
src/mp2_grad/mp2_make_tot_dens.F
View file

@ -26,6 +26,8 @@
character*256 p_a_ao
character*256 p_b_ao
integer base
integer l_buf,k_buf
integer ilo,ihi,jlo,jhi,dowork
c
call util_file_name('p_a_ao',.true.,.true.,p_a_ao)
call util_file_name('p_b_ao',.true.,.true.,p_b_ao)
@ -48,22 +50,48 @@ c$$$ call ga_put(g_p_tot_a,i,i,a+noa,a+noa,temp,1)
c$$$ end do
c$$$ end do
c
call ga_distribution(g_p_tot_a, ga_nodeid(),
T ilo, ihi, jlo, jhi)
c check if distrib by columns
if ((ilo.eq.0).and.(ihi.eq.-1)) then
dowork=0
else
if(ilo.ne.1.and.ihi.ne.nmo) call
R errquit(' mp2maketotdens bug ',0,0)
dowork=1
endif
ioff = 0
do i = 1+ga_nodeid(),noa,ga_nnodes() ! Loop thru SCF order
if(dowork.eq.1) then
do i = 1,noa
ii = map_a(i)
if(ii.ge.jlo.and.ii.le.jhi) then
do a = 1,nva
ii = map_a(i)
aa = map_a(a+noa)-noa
ia = ioff+a+(i-1)*nva
call ga_get(g_rhs,ia,ia,1,1,xx,1)
call ga_put(g_p_tot_a,aa+noa,aa+noa,ii,ii,xx,1)
call ga_put(g_p_tot_a,ii,ii,aa+noa,aa+noa,xx,1)
end do
endif
end do
c
call ga_copy_patch('n',g_p_ij_a,1,noa,1,noa,g_p_tot_a,
$ 1,noa,1,noa)
call ga_copy_patch('n',g_p_ab_a,1,nva,1,nva,g_p_tot_a,
$ noa+1,nmo,noa+1,nmo)
if (.not. ma_push_get(mt_dbl, nmo, 'mp2: maket',
$ l_buf, k_buf)) call errquit
$ ('mp2: insufficient memory : bug ', nmo, MA_ERR)
do i=jlo,jhi
if(i.le.nob) then
call ga_get(g_p_ij_a,1,noa,i,i,dbl_mb(k_buf),noa)
call ga_put(g_p_tot_a,1,noa,i,i,dbl_mb(k_buf),noa)
else
call ga_get(g_p_ab_a,1,nva,i-noa,i-noa,dbl_mb(k_buf),nva)
call ga_put(g_p_tot_a,noa+1,nmo,i,i,dbl_mb(k_buf),nva)
endif
enddo
if (.not. ma_pop_stack(l_buf)) call errquit
$ ('mp2: pop_stack failed ', nmo, MA_ERR)
endif
call ga_mask_sync(.true.,.false.)
call ga_sync()
c
if (scftype .eq. 'UHF') then
base = (nva*noa)
@ -71,15 +99,18 @@ c
base = 0 ! Alpha is the same as beta
end if
ioff = base
do i = 1+ga_nodeid(),nob,ga_nnodes() ! Loop thru SCF order
if (dowork.eq.1) then
do i = 1,nob
ii = map_b(i)
if(ii.ge.jlo.and.ii.le.jhi) then
do a = 1,nvb
ii = map_b(i)
aa = map_b(a+nob)-nob
ia = ioff+a+(i-1)*nvb
call ga_get(g_rhs,ia,ia,1,1,xx,1)
call ga_put(g_p_tot_b,aa+nob,aa+nob,ii,ii,xx,1)
call ga_put(g_p_tot_b,ii,ii,aa+nob,aa+nob,xx,1)
end do
endif
end do
c$$$ call ga_copy_patch('n',g_rhs,base+1,base+(nvb*nob),
c$$$ $ 1,1,g_p_tot_b,nob+1,nmo,1,nob)
@ -90,11 +121,25 @@ c$$$ call ga_get(g_rhs,indx,indx,1,1,temp,1)
c$$$ call ga_put(g_p_tot_b,i,i,a+nob,a+nob,temp,1)
c$$$ end do
c$$$ end do
c
call ga_copy_patch('n',g_p_ij_b,1,nob,1,nob,g_p_tot_b,
$ 1,nob,1,nob)
call ga_copy_patch('n',g_p_ab_b,1,nvb,1,nvb,g_p_tot_b,
$ nob+1,nmo,nob+1,nmo)
c
if (.not. ma_push_get(mt_dbl, nmo, 'mp2: maket',
$ l_buf, k_buf)) call errquit
$ ('mp2: insufficient memory : bug ', nmo, MA_ERR)
do i=jlo,jhi
if(i.le.nob) then
call ga_get(g_p_ij_b,1,nob,i,i,dbl_mb(k_buf),nob)
call ga_put(g_p_tot_b,1,nob,i,i,dbl_mb(k_buf),nob)
else
call ga_get(g_p_ab_b,1,nvb,i-nob,i-nob,dbl_mb(k_buf),nvb)
call ga_put(g_p_tot_b,nob+1,nmo,i,i,dbl_mb(k_buf),nvb)
endif
enddo
if (.not. ma_pop_stack(l_buf)) call errquit
$ ('mp2: pop_stack failed ', nmo, MA_ERR)
endif
call ga_sync()
c
*ga:1:0
if(.not.ga_create(mt_dbl,nmo,nbf,'scratch',0,0,g_scratch))

45
src/mp2_grad/mp2_make_tot_wdens.F
View file

@ -46,7 +46,7 @@ c
call ga_copy_patch('n',g_w_ai_a,1,noa_hi,1,nva,g_w_tot_a,
$ 1, noa_hi, noa_hi+1, nmo)
c
call ga_transpose(g_w_ai_a,g_w_ai_a_tr)
call mp2_transpwai(g_w_ai_a,g_w_ai_a_tr)
call ga_copy_patch('n',g_w_ai_a_tr,1,nva,1,noa_hi,g_w_tot_a,
$ noa_hi+1,nmo,1,noa_hi)
call ga_copy_patch('n',g_w_ij_a,1,noa_hi,1,noa_hi,g_w_tot_a,
@ -55,7 +55,7 @@ c
$ noa_hi+1,nmo,noa_hi+1,nmo)
call ga_copy_patch('n',g_w_ai_b,1,nob_hi,1,nvb,g_w_tot_b,
$ 1, nob_hi, nob_hi+1,nmo)
call ga_transpose(g_w_ai_b,g_w_ai_b_tr)
call mp2_transpwai(g_w_ai_b,g_w_ai_b_tr)
call ga_copy_patch('n',g_w_ai_b_tr,1,nvb,1,nob_hi,g_w_tot_b,
$ nob_hi+1,nmo,1,nob_hi)
call ga_copy_patch('n',g_w_ij_b,1,nob_hi,1,nob_hi,g_w_tot_b,
@ -148,3 +148,44 @@ c
c
end
subroutine mp2_transpwai(g,g_tr)
implicit none
#include "mafdecls.fh"
#include "global.fh"
#include "errquit.fh"
integer g,g_tr
c
integer ilo,ihi,jlo,jhi
integer i,j
integer k_buf,l_buf
integer n_row,n_col,gtype
integer dowork
c
call ga_inquire(g_tr, gtype, n_row, n_col)
call ga_distribution(g_tr, ga_nodeid(),
T ilo, ihi, jlo, jhi)
if ((ilo.eq.0).and.(ihi.eq.-1)) then
dowork=0
else
c check if distrib by columns
if(ilo.ne.1.and.ihi.ne.n_row) call
R errquit(' mp2transpwai bug ',0,0)
dowork=1
endif
if(dowork.eq.1) then
if (.not. ma_push_get(mt_dbl, n_row, 'mp2: wdens',
$ l_buf, k_buf)) call errquit
$ ('mp2: insufficient memory : bug ', n_row, MA_ERR)
do j=jlo,jhi
call ga_get(g,j,j,1,n_row,dbl_mb(k_buf),1)
if (.not.ma_verify_allocator_stuff()) stop ' ma ck 2b'
call ga_put(g_tr,1,n_row,j,j,dbl_mb(k_buf),n_row)
if (.not.ma_verify_allocator_stuff()) stop ' ma ck 2b'
enddo
if (.not. ma_pop_stack(l_buf)) call errquit
$ ('mp2transp pop_stack failed ', n_row, MA_ERR)
endif
call ga_sync()
return
end