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

Merge pull request #1173 from edoapra/releasetags-7-3-0

Browse source 
trying to improve parallelization on quadrupole routine
This commit is contained in:
NWChem: Open Source High-Performance Computational Chemistry 2025-10-17 10:00:55 -07:00 • committed by GitHub
commit 554aef3e30
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
6 changed files with 123 additions and 118 deletions
Download patch file Download diff file Expand all files Collapse all files

195
src/ddscf/int_dip_ga.F
View file

@ -15,127 +15,95 @@
integer g_x, g_y, g_z
integer nshell_i, nshell_j
integer ishell, jshell, iproc, nproc, mscratch, max1e
integer ijshell, ilo, ihi, jlo, jhi
integer ilo, ihi, jlo, jhi
integer l_buf, l_scr
integer k_buf, k_scr
logical do_mirr
logical util_mirrmat
external util_mirrmat
integer g_x_mirr,g_y_mirr,g_z_mirr
integer g_x_org,g_y_org,g_z_org
integer g(3)
integer i0,i1,j0,j1
integer iptr0,iptr1,jptr0,jptr1
!
double precision center(3)
!
call dfill(3, 0.0d0, center, 1)
!
g(1)=g_x
g(2)=g_y
g(3)=g_z
call ga_sync()
call ga_zero(g_x)
call ga_zero(g_y)
call ga_zero(g_z)
g_x_mirr=0
g_y_mirr=0
g_z_mirr=0
do_mirr=util_mirrmat(1,g_x,g_x_mirr,
D .false., .true.)
do_mirr=do_mirr.and.util_mirrmat(1,g_y,g_y_mirr,
D .false., .true.)
do_mirr=do_mirr.and.util_mirrmat(1,g_z,g_z_mirr,
D .false., .true.)
if(do_mirr) then
g_x_org=g_x
g_x=g_x_mirr
g_y_org=g_y
g_y=g_y_mirr
g_z_org=g_z
g_z=g_z_mirr
else
if(g_x_mirr.ne.0) then
if(.not.ga_destroy(g_x_mirr))call errquit(
$ 'could not destroy mirrx handle',1, GA_ERR)
endif
if(g_y_mirr.ne.0) then
if(.not.ga_destroy(g_y_mirr))call errquit(
$ 'could not destroy mirry handle',1, GA_ERR)
endif
endif
if(oscfps) call pstat_on(ps_int_dip)
!
! grab basis set info type stuff
!
if(.not.bas_numcont(ibas,nshell_i))call errquit
$ ('int_dip_ga: bas_numcont failed for ibas',ibas, BASIS_ERR)
if(.not.bas_numcont(jbas,nshell_j))call errquit
$ ('int_dip_ga: bas_numcont failed for jbas',jbas, BASIS_ERR)
call ga_distribution(g_x,ga_nodeid(),i0,i1,j0,j1)
cdbg write(6,'(i5,a,5i5)')
cdbg I ga_nodeid(),'DDISTRIB',g_x,i0,i1,j0,j1
if (i0.gt.0 .and. i0.le.i1) then
if(.not.bas_numcont(ibas,nshell_i))call errquit
$ ('int_dip_ga: bas_numcont failed for ibas',ibas,BASIS_ERR)
if(.not.bas_numcont(jbas,nshell_j))call errquit
$ ('int_dip_ga: bas_numcont failed for jbas',jbas,BASIS_ERR)
!
! allocate temp. arrays
!
call int_mem_dipole(max1e,mscratch,ibas,jbas,1)
call int_mem_dipole(max1e,mscratch,ibas,jbas,1)
!
if(.not.MA_push_get(MT_DBL,max1e,'int_dip_ga:buf',l_buf,k_buf))
$ call errquit('int_dip_ga: ma failure',max1e, MA_ERR)
if(.not.MA_push_get(MT_DBL,mscratch,'int_dip_ga:scr',
$ l_scr,k_scr))
$ call errquit('int_dip_ga: ma failure',mscratch, MA_ERR)
if(.not.MA_push_get(MT_DBL,max1e,'int_dip_ga:buf',l_buf,k_buf))
$ call errquit('int_dip_ga: ma failure',max1e, MA_ERR)
if(.not.MA_push_get(MT_DBL,mscratch,'int_dip_ga:scr',
$ l_scr,k_scr))
$ call errquit('int_dip_ga: ma failure',mscratch, MA_ERR)
!
! loop over shells
!
iproc = ga_nodeid()
nproc = ga_nnodes()
ijshell = 0
call ga_sync()
do jshell = 1,nshell_j
do ishell = 1,nshell_i
if(mod(ijshell,nproc).eq.iproc)then
iproc = ga_nodeid()
do jshell = 1,nshell_j
do ishell = 1,nshell_i
if(.not.bas_cn2bfr(ibas,ishell,ilo,ihi))
$ call errquit('int_dip_ga:bas_cn2bfr ?', ibas,
& BASIS_ERR)
& BASIS_ERR)
if(.not.bas_cn2bfr(jbas,jshell,jlo,jhi))
$ call errquit('int_dip_ga:bas_cn2bfr ?', jbas,
& BASIS_ERR)
!
& BASIS_ERR)
iptr0=max(i0,ilo)
iptr1=min(i1,ihi)
jptr0=max(j0,jlo)
jptr1=min(j1,jhi)
if(iptr1.ge.iptr0.and.jptr1.ge.jptr0) then
! get the integrals we want
!
! call int_mpole(ibas, ishell, jbas, jshell,
call int_mpole(jbas, jshell, ibas, ishell,
$ 1,
$ center,
$ mscratch, dbl_mb(k_scr), max1e, dbl_mb(k_buf))
!
call int_mpole(jbas, jshell, ibas, ishell,
$ 1,
$ center,
$ mscratch, dbl_mb(k_scr), max1e,
D dbl_mb(k_buf))
!
! bung integrals into global array
!
call int_dip_put_in_g(g_x, g_y, g_z, ilo,ihi,jlo,jhi,
$ dbl_mb(k_buf+(ihi-ilo+1)*(jhi-jlo+1)))
endif
ijshell=ijshell+1
call int_mpole_put_in_g(g, 3,
L ilo,ihi,jlo,jhi,
P iptr0,iptr1,jptr0,jptr1,
$ dbl_mb(k_buf+(ihi-ilo+1)*(jhi-jlo+1)))
endif
enddo
enddo
enddo
!
if(.not.MA_pop_stack(l_scr))
if(.not.MA_pop_stack(l_scr))
$ call errquit('int_dip_ga:pop failed',0, MA_ERR)
if(.not.MA_pop_stack(l_buf))
$ call errquit('int_dip_ga:pop failed',0, MA_ERR)
if(.not.MA_pop_stack(l_buf))
$ call errquit('int_dip_ga:pop failed',0, MA_ERR)
!
endif
call ga_sync()
if (do_mirr) then
g_x=g_x_org
call util_mirrmerge(g_x_mirr,g_x)
if(.not.ga_destroy(g_x_mirr))call errquit(
$ 'could not destroy g_x_mirr handle',1, GA_ERR)
g_y=g_y_org
call util_mirrmerge(g_y_mirr,g_y)
if(.not.ga_destroy(g_y_mirr))call errquit(
$ 'could not destroy g_y_mirr handle',1, GA_ERR)
g_z=g_z_org
call util_mirrmerge(g_z_mirr,g_z)
if(.not.ga_destroy(g_z_mirr))call errquit(
$ 'could not destroy g_x_mirr handle',1, GA_ERR)
endif
call ga_sync()
!
c if (.true.) then
if (util_print('multipole', print_debug)) then
call ga_print(g_x)
call ga_print(g_y)
@ -162,6 +130,25 @@ c do i = ilo,ihi
end do
c end do
end
subroutine int_mpole_put_in_g(g,
M mult_size,
L ilo,ihi,jlo,jhi,
1 iptr0, iptr1, jptr0, jptr1,
B buf)
implicit none
#include "global.fh"
integer mult_size,mult
integer g(mult_size)
integer ilo,ihi,jlo,jhi
integer iptr0, iptr1, jptr0, jptr1
double precision buf(ilo:ihi,mult_size,jlo:jhi)
integer i, j
do j = jptr0, jptr1
do mult=1,mult_size
call ga_put(g(mult),iptr0,iptr1,j,j,buf(iptr0,mult,j),1)
end do
end do
end
subroutine int_qdr_ga(ibas, jbas, g_xx, g_xy, g_xz,
1 g_yy, g_yz, g_zz)
@ -184,6 +171,10 @@ c end do
integer ijshell, ilo, ihi, jlo, jhi
integer l_buf, l_scr
integer k_buf, k_scr
integer g(6)
integer i0,i1,j0,j1
integer iptr0,iptr1,jptr0,jptr1
!
double precision center(3)
!
@ -191,17 +182,27 @@ c end do
!
call ga_sync()
g(1)=g_xx
g(2)=g_xy
g(3)=g_xz
g(4)=g_yy
g(5)=g_yz
g(6)=g_zz
call ga_zero(g_xx)
call ga_zero(g_xy)
call ga_zero(g_xz)
call ga_zero(g_yy)
call ga_zero(g_yz)
call ga_zero(g_zz)
call ga_distribution(g_xx,ga_nodeid(),i0,i1,j0,j1)
c if(ga_nodeid().eq.0) write(6,'(a,4i5)')
cdbg write(6,'(i5,a,5i5)')
cdbg I ga_nodeid(),'QDISTRIB',g_xx,i0,i1,j0,j1
if(oscfps) call pstat_on(ps_int_dip)
!
! grab basis set info type stuff
!
if (i0.gt.0 .and. i0.le.i1) then
if(.not.bas_numcont(ibas,nshell_i))call errquit
$ ('int_qdr_ga: bas_numcont failed for ibas',ibas, BASIS_ERR)
if(.not.bas_numcont(jbas,nshell_j))call errquit
@ -220,29 +221,34 @@ c end do
! loop over shells
!
iproc = ga_nodeid()
nproc = ga_nnodes()
ijshell = 0
do jshell = 1,nshell_j
do ishell = 1,nshell_i
if(mod(ijshell,nproc).eq.iproc)then
! if(mod(ijshell,nproc).eq.iproc)then
if(.not.bas_cn2bfr(ibas,ishell,ilo,ihi))
$ call errquit('int_qdr_ga:bas_cn2bfr ?', ibas,
& BASIS_ERR)
if(.not.bas_cn2bfr(jbas,jshell,jlo,jhi))
$ call errquit('int_qdr_ga:bas_cn2bfr ?', jbas,
& BASIS_ERR)
iptr0=max(i0,ilo)
iptr1=min(i1,ihi)
jptr0=max(j0,jlo)
jptr1=min(j1,jhi)
if(iptr1.ge.iptr0.and.jptr1.ge.jptr0) then
!
! get the integrals we want
!
call int_mpole(ibas, ishell, jbas, jshell,
call int_mpole(jbas, ishell, ibas, jshell,
$ 2,
$ center,
$ mscratch, dbl_mb(k_scr), max1e, dbl_mb(k_buf))
!
! bung integrals into global array
!
call int_qdr_put_in_g(g_xx, g_xy, g_xz,
$ g_yy, g_yz, g_zz, ilo,ihi,jlo,jhi,
call int_mpole_put_in_g(g,6,
$ ilo,ihi,jlo,jhi,
P iptr0,iptr1,jptr0,jptr1,
$ dbl_mb(k_buf+(ihi-ilo+1)*(jhi-jlo+1)*4))
endif
ijshell=ijshell+1
@ -252,11 +258,13 @@ c end do
if(.not.MA_pop_stack(l_scr))
$ call errquit('int_qdr_ga:pop failed',0, MA_ERR)
if(.not.MA_pop_stack(l_buf))
$ call errquit('int_qdr_ga:pop failed',0, MA_ERR)
$ call errquit('int_qdr_ga:pop failed',0, MA_ERR)
endif
!
call ga_sync()
!
if (util_print('multipole', print_debug)) then
c if (.true.) then
call ga_print(g_xx)
call ga_print(g_xy)
call ga_print(g_xz)
@ -279,6 +287,7 @@ c end do
double precision buf(jlo:jhi,6,ilo:ihi)
integer i, j
do i = ilo,ihi
#if 0
do j = jlo, jhi
call ga_put(g_xx,i,i,j,j,buf(j,1,i),1)
call ga_put(g_xy,i,i,j,j,buf(j,2,i),1)
@ -287,6 +296,14 @@ c end do
call ga_put(g_yz,i,i,j,j,buf(j,5,i),1)
call ga_put(g_zz,i,i,j,j,buf(j,6,i),1)
end do
#else
call ga_put(g_xx,jlo,jhi,i,i,buf(jlo,1,i),1)
call ga_put(g_xy,jlo,jhi,i,i,buf(jlo,2,i),1)
call ga_put(g_xz,jlo,jhi,i,i,buf(jlo,3,i),1)
call ga_put(g_yy,jlo,jhi,i,i,buf(jlo,4,i),1)
call ga_put(g_yz,jlo,jhi,i,i,buf(jlo,5,i),1)
call ga_put(g_zz,jlo,jhi,i,i,buf(jlo,6,i),1)
#endif
end do
end

21
src/nwdft/rt_tddft/headers/rt_tddft.fh
View file

@ -61,9 +61,7 @@ C
C Vector for field, dipoles, etc.
C
type :: rt_vector_t
#ifdef XLFLINUX
sequence
#endif
double precision :: x, y, z
end type rt_vector_t
@ -72,9 +70,7 @@ C
C "half" of a 3x3 tensor (for quadrupole quantities)
C
type :: rt_quad_t
#ifdef XLFLINUX
sequence
#endif
double precision :: xx, xy, xz, yy, yz, zz
end type rt_quad_t
@ -83,9 +79,7 @@ C
C Handles for vector GA's
C
type :: rt_vector_handle_t
#ifdef XLFLINUX
sequence
#endif
integer :: x, y, z
end type rt_vector_handle_t
@ -94,9 +88,7 @@ C
C Handles for quadrupole GA's
C
type :: rt_quad_handle_t
#ifdef XLFLINUX
sequence
#endif
integer :: xx, xy, xz, yy, yz, zz
end type rt_quad_handle_t
@ -105,9 +97,7 @@ C
C Geometry fragments.
C
type :: rt_geom_t
#ifdef XLFLINUX
sequence
#endif
character*16 :: name
integer :: ncent
integer :: g_mask !dbl, nbf_ao x nbf_ao, allocd in rt_tddft_init_geoms
@ -124,9 +114,7 @@ C
C Time-dependent system energies.
C
type :: rt_energies_t
#ifdef XLFLINUX
sequence
#endif
double precision :: core
double precision :: coul
double precision :: xc(2)
@ -139,9 +127,7 @@ C
C Contains parameters for an external field (excitation)
C
type :: rt_field_t
#ifdef XLFLINUX
sequence
#endif
character(16) :: name !hardcoded to match geom name max
character(256) :: filename
character(20) :: type
@ -164,9 +150,7 @@ C
C Rule for applying field
C
type :: rt_excite_t
#ifdef XLFLINUX
sequence
#endif
integer :: field_indx
integer :: geom_indx
integer :: ao_indx
@ -190,9 +174,7 @@ C using "super" matrices.
C
C
type :: rt_params_t
#ifdef XLFLINUX
sequence
#endif
integer :: rtdb
character(len=24):: tag
@ -281,9 +263,6 @@ C (charge density fitting for Coulomb part of Fock matrix)
integer :: n3c_int
integer :: l_3cwhat, k_3cwhat !int
integer :: n3c_dbl
integer :: iwhat_max
integer :: n_semi_bufs
integer :: fd
C (matrix sizes)

5
src/nwdft/rt_tddft/init/rt_tddft_init_coulcdfit.F
View file

@ -19,7 +19,7 @@ C
C == In/out ==
type(rt_params_t) params !cdfit params stored in here
type(rt_params_t), intent(inout) :: params !cdfit params stored in here
C == Parameters ==
@ -163,9 +163,6 @@ C
params%k_3cwhat = k_3cwhat
params%l_3cwhat = l_3cwhat
params%n3c_dbl = n3c_dbl
params%iwhat_max = iwhat_max
params%n_semi_bufs = n_semi_bufs
params%fd = fd
end subroutine rt_tddft_init_coulcdfit

4
src/nwdft/rt_tddft/init/rt_tddft_init_dip_quad_ints.F
View file

@ -16,7 +16,7 @@ C
C == Inputs ==
type(rt_params_t), intent(in) :: params
type(rt_params_t), intent(inout) :: params
C == Parameters ==
@ -122,7 +122,7 @@ C
C == Inputs ==
type(rt_params_t), intent(in) :: params
type(rt_params_t), intent(inout) :: params
C == Parameters ==

2
src/nwdft/rt_tddft/init/rt_tddft_init_rtdb.F
View file

@ -13,7 +13,7 @@ C
C == In/out ==
type(rt_params_t) params
type(rt_params_t), intent(inout) :: params
C == Parameters ==
character(*), parameter :: pname = "rt_tddft_init_rtdb: "

14
src/nwdft/rt_tddft/input/rt_tddft_input_field.F
View file

@ -389,6 +389,19 @@ C
C
C Load into rtdb
C
c set variables to avoid being unitialized (and later trash rtdb)
this_field%filename = "fname"
this_field%polarization = "pol"
this_field%spin = "sp"
this_field%max = 0d0
this_field%frequency = 0d0
this_field%width = 0d0
this_field%center = 0d0
this_field%start = 0d0
this_field%phase = 0d0
this_field%theta = 0d0
this_field%phi = 0d0
c
this_field%name = field_name
this_field%type = type
@ -442,7 +455,6 @@ C
else
call errquit (pname//"invalid type: "//trim(type), 0, 0)
endif
C XXX REFACTOR THIS
if (type .ne. "file") then