PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-14 01:53:49 +01:00
Code Releases Activity

complex cleanup

Browse Source
This commit is contained in:
Kevin Gasperich 2020-03-04 18:20:03 -06:00
parent 5b214ac3c1
commit d6fb0f63fe
6 changed files with 409 additions and 425 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

472
src/cipsi/pt2_stoch_routines.irp.f
View File

@ -854,240 +854,240 @@ END_PROVIDER
subroutine ZMQ_pt2_complex(E, pt2,relative_error, error, variance, norm, N_in)
!todo: implement for complex
print*,irp_here
stop -1
use f77_zmq
use selection_types
implicit none
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
integer, intent(in) :: N_in
double precision, intent(in) :: relative_error, E(N_states)
double precision, intent(out) :: pt2(N_states),error(N_states)
double precision, intent(out) :: variance(N_states),norm(N_states)
integer :: i, N
double precision :: state_average_weight_save(N_states), w(N_states,4)
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
type(selection_buffer) :: b
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_complex psi_det_sorted
PROVIDE psi_det_hii selection_weight pseudo_sym
if (h0_type == 'SOP') then
PROVIDE psi_occ_pattern_hii det_to_occ_pattern
endif
if (N_det <= max(4,N_states)) then
pt2=0.d0
variance=0.d0
norm=0.d0
call zmq_selection_complex(N_in, pt2, variance, norm)
error(:) = 0.d0
else
N = max(N_in,1) * N_states
state_average_weight_save(:) = state_average_weight(:)
if (int(N,8)*2_8 > huge(1)) then
print *, irp_here, ': integer too large'
stop -1
endif
call create_selection_buffer(N, N*2, b)
ASSERT (associated(b%det))
ASSERT (associated(b%val))
do pt2_stoch_istate=1,N_states
state_average_weight(:) = 0.d0
state_average_weight(pt2_stoch_istate) = 1.d0
TOUCH state_average_weight pt2_stoch_istate selection_weight
PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
PROVIDE psi_selectors pt2_u pt2_J pt2_R
call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
integer, external :: zmq_put_psi
integer, external :: zmq_put_N_det_generators
integer, external :: zmq_put_N_det_selectors
integer, external :: zmq_put_dvector
integer, external :: zmq_put_ivector
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
stop 'Unable to put psi on ZMQ server'
endif
if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_generators on ZMQ server'
endif
if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_selectors on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
stop 'Unable to put energy on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
stop 'Unable to put state_average_weight on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
stop 'Unable to put selection_weight on ZMQ server'
endif
if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then
stop 'Unable to put pt2_stoch_istate on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',threshold_generators,1) == -1) then
stop 'Unable to put threshold_generators on ZMQ server'
endif
integer, external :: add_task_to_taskserver
character(300000) :: task
integer :: j,k,ipos,ifirst
ifirst=0
ipos=0
do i=1,N_det_generators
if (pt2_F(i) > 1) then
ipos += 1
endif
enddo
call write_int(6,sum(pt2_F),'Number of tasks')
call write_int(6,ipos,'Number of fragmented tasks')
ipos=1
do i= 1, N_det_generators
do j=1,pt2_F(pt2_J(i))
write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in
ipos += 30
if (ipos > 300000-30) then
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
ipos=1
if (ifirst == 0) then
ifirst=1
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
endif
endif
end do
enddo
if (ipos > 1) then
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
endif
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
double precision :: mem_collector, mem, rss
call resident_memory(rss)
mem_collector = 8.d0 * & ! bytes
( 1.d0*pt2_n_tasks_max & ! task_id, index
+ 0.635d0*N_det_generators & ! f,d
+ 3.d0*N_det_generators*N_states & ! eI, vI, nI
+ 3.d0*pt2_n_tasks_max*N_states & ! eI_task, vI_task, nI_task
+ 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3
+ 1.d0*(N_int*2.d0*N + N) & ! selection buffer
+ 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer
) / 1024.d0**3
integer :: nproc_target, ii
nproc_target = nthreads_pt2
ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
do
mem = mem_collector + & !
nproc_target * 8.d0 * & ! bytes
( 0.5d0*pt2_n_tasks_max & ! task_id
+ 64.d0*pt2_n_tasks_max & ! task
+ 3.d0*pt2_n_tasks_max*N_states & ! pt2, variance, norm
+ 1.d0*pt2_n_tasks_max & ! i_generator, subset
+ 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
+ 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
+ 2.0d0*(ii) & ! preinteresting, interesting,
! prefullinteresting, fullinteresting
+ 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
+ 1.0d0*(N_states*mo_num*mo_num) & ! mat
) / 1024.d0**3
if (nproc_target == 0) then
call check_mem(mem,irp_here)
nproc_target = 1
exit
endif
if (mem+rss < qp_max_mem) then
exit
endif
nproc_target = nproc_target - 1
enddo
call write_int(6,nproc_target,'Number of threads for PT2')
call write_double(6,mem,'Memory (Gb)')
call omp_set_nested(.false.)
print '(A)', '========== ================= =========== =============== =============== ================='
print '(A)', ' Samples Energy Stat. Err Variance Norm Seconds '
print '(A)', '========== ================= =========== =============== =============== ================='
PROVIDE global_selection_buffer
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
!$OMP PRIVATE(i)
i = omp_get_thread_num()
if (i==0) then
call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, w(1,1), w(1,2), w(1,3), w(1,4), b, N)
pt2(pt2_stoch_istate) = w(pt2_stoch_istate,1)
error(pt2_stoch_istate) = w(pt2_stoch_istate,2)
variance(pt2_stoch_istate) = w(pt2_stoch_istate,3)
norm(pt2_stoch_istate) = w(pt2_stoch_istate,4)
else
call pt2_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
print '(A)', '========== ================= =========== =============== =============== ================='
enddo
FREE pt2_stoch_istate
if (N_in > 0) then
b%cur = min(N_in,b%cur)
if (s2_eig) then
call make_selection_buffer_s2(b)
else
call remove_duplicates_in_selection_buffer(b)
endif
call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
endif
call delete_selection_buffer(b)
state_average_weight(:) = state_average_weight_save(:)
TOUCH state_average_weight
endif
do k=N_det+1,N_states
pt2(k) = 0.d0
enddo
call update_pt2_and_variance_weights(pt2, variance, norm, N_states)
end subroutine
!subroutine ZMQ_pt2_complex(E, pt2,relative_error, error, variance, norm, N_in)
! !todo: implement for complex
! print*,irp_here
! stop -1
! use f77_zmq
! use selection_types
!
! implicit none
!
! integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
! integer, intent(in) :: N_in
! double precision, intent(in) :: relative_error, E(N_states)
! double precision, intent(out) :: pt2(N_states),error(N_states)
! double precision, intent(out) :: variance(N_states),norm(N_states)
!
!
! integer :: i, N
!
! double precision :: state_average_weight_save(N_states), w(N_states,4)
! integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
! type(selection_buffer) :: b
!
! PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
! PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
! PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
! PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_complex psi_det_sorted
! PROVIDE psi_det_hii selection_weight pseudo_sym
!
! if (h0_type == 'SOP') then
! PROVIDE psi_occ_pattern_hii det_to_occ_pattern
! endif
!
! if (N_det <= max(4,N_states)) then
! pt2=0.d0
! variance=0.d0
! norm=0.d0
! call zmq_selection_complex(N_in, pt2, variance, norm)
! error(:) = 0.d0
! else
!
! N = max(N_in,1) * N_states
! state_average_weight_save(:) = state_average_weight(:)
! if (int(N,8)*2_8 > huge(1)) then
! print *, irp_here, ': integer too large'
! stop -1
! endif
! call create_selection_buffer(N, N*2, b)
! ASSERT (associated(b%det))
! ASSERT (associated(b%val))
!
! do pt2_stoch_istate=1,N_states
! state_average_weight(:) = 0.d0
! state_average_weight(pt2_stoch_istate) = 1.d0
! TOUCH state_average_weight pt2_stoch_istate selection_weight
!
! PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
! PROVIDE psi_selectors pt2_u pt2_J pt2_R
! call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
!
! integer, external :: zmq_put_psi
! integer, external :: zmq_put_N_det_generators
! integer, external :: zmq_put_N_det_selectors
! integer, external :: zmq_put_dvector
! integer, external :: zmq_put_ivector
! if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
! stop 'Unable to put psi on ZMQ server'
! endif
! if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
! stop 'Unable to put N_det_generators on ZMQ server'
! endif
! if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
! stop 'Unable to put N_det_selectors on ZMQ server'
! endif
! if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
! stop 'Unable to put energy on ZMQ server'
! endif
! if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
! stop 'Unable to put state_average_weight on ZMQ server'
! endif
! if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
! stop 'Unable to put selection_weight on ZMQ server'
! endif
! if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then
! stop 'Unable to put pt2_stoch_istate on ZMQ server'
! endif
! if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',threshold_generators,1) == -1) then
! stop 'Unable to put threshold_generators on ZMQ server'
! endif
!
!
! integer, external :: add_task_to_taskserver
! character(300000) :: task
!
! integer :: j,k,ipos,ifirst
! ifirst=0
!
! ipos=0
! do i=1,N_det_generators
! if (pt2_F(i) > 1) then
! ipos += 1
! endif
! enddo
! call write_int(6,sum(pt2_F),'Number of tasks')
! call write_int(6,ipos,'Number of fragmented tasks')
!
! ipos=1
! do i= 1, N_det_generators
! do j=1,pt2_F(pt2_J(i))
! write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in
! ipos += 30
! if (ipos > 300000-30) then
! if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
! stop 'Unable to add task to task server'
! endif
! ipos=1
! if (ifirst == 0) then
! ifirst=1
! if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
! print *, irp_here, ': Failed in zmq_set_running'
! endif
! endif
! endif
! end do
! enddo
! if (ipos > 1) then
! if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
! stop 'Unable to add task to task server'
! endif
! endif
!
! integer, external :: zmq_set_running
! if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
! print *, irp_here, ': Failed in zmq_set_running'
! endif
!
!
! double precision :: mem_collector, mem, rss
!
! call resident_memory(rss)
!
! mem_collector = 8.d0 * & ! bytes
! ( 1.d0*pt2_n_tasks_max & ! task_id, index
! + 0.635d0*N_det_generators & ! f,d
! + 3.d0*N_det_generators*N_states & ! eI, vI, nI
! + 3.d0*pt2_n_tasks_max*N_states & ! eI_task, vI_task, nI_task
! + 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3
! + 1.d0*(N_int*2.d0*N + N) & ! selection buffer
! + 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer
! ) / 1024.d0**3
!
! integer :: nproc_target, ii
! nproc_target = nthreads_pt2
! ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
!
! do
! mem = mem_collector + & !
! nproc_target * 8.d0 * & ! bytes
! ( 0.5d0*pt2_n_tasks_max & ! task_id
! + 64.d0*pt2_n_tasks_max & ! task
! + 3.d0*pt2_n_tasks_max*N_states & ! pt2, variance, norm
! + 1.d0*pt2_n_tasks_max & ! i_generator, subset
! + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
! + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
! + 2.0d0*(ii) & ! preinteresting, interesting,
! ! prefullinteresting, fullinteresting
! + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
! + 1.0d0*(N_states*mo_num*mo_num) & ! mat
! ) / 1024.d0**3
!
! if (nproc_target == 0) then
! call check_mem(mem,irp_here)
! nproc_target = 1
! exit
! endif
!
! if (mem+rss < qp_max_mem) then
! exit
! endif
!
! nproc_target = nproc_target - 1
!
! enddo
! call write_int(6,nproc_target,'Number of threads for PT2')
! call write_double(6,mem,'Memory (Gb)')
!
! call omp_set_nested(.false.)
!
!
! print '(A)', '========== ================= =========== =============== =============== ================='
! print '(A)', ' Samples Energy Stat. Err Variance Norm Seconds '
! print '(A)', '========== ================= =========== =============== =============== ================='
!
! PROVIDE global_selection_buffer
! !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
! !$OMP PRIVATE(i)
! i = omp_get_thread_num()
! if (i==0) then
!
! call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, w(1,1), w(1,2), w(1,3), w(1,4), b, N)
! pt2(pt2_stoch_istate) = w(pt2_stoch_istate,1)
! error(pt2_stoch_istate) = w(pt2_stoch_istate,2)
! variance(pt2_stoch_istate) = w(pt2_stoch_istate,3)
! norm(pt2_stoch_istate) = w(pt2_stoch_istate,4)
!
! else
! call pt2_slave_inproc(i)
! endif
! !$OMP END PARALLEL
! call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
!
! print '(A)', '========== ================= =========== =============== =============== ================='
!
! enddo
! FREE pt2_stoch_istate
!
! if (N_in > 0) then
! b%cur = min(N_in,b%cur)
! if (s2_eig) then
! call make_selection_buffer_s2(b)
! else
! call remove_duplicates_in_selection_buffer(b)
! endif
! call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
! endif
! call delete_selection_buffer(b)
!
! state_average_weight(:) = state_average_weight_save(:)
! TOUCH state_average_weight
! endif
! do k=N_det+1,N_states
! pt2(k) = 0.d0
! enddo
!
! call update_pt2_and_variance_weights(pt2, variance, norm, N_states)
!
!end subroutine

3
src/cipsi/selection.irp.f
View File

@ -2037,7 +2037,7 @@ end
!==============================================================================!
subroutine fill_buffer_double_complex(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf)
!todo: check indices for complex?
!todo: should be okay for complex
use bitmasks
use selection_types
implicit none
@ -2212,7 +2212,6 @@ subroutine fill_buffer_double_complex(i_generator, sp, h1, h2, bannedOrb, banned
end
subroutine splash_pq_complex(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting)
!todo: check indices for complex?
use bitmasks
implicit none
BEGIN_DOC

296
src/cipsi/zmq_selection.irp.f
View File

@ -17,7 +17,7 @@ subroutine ZMQ_selection(N_in, pt2, variance, norm)
N = max(N_in,1)
if (.True.) then
!todo: some providers have becom unlinked for real/complex (det/coef); do these need to be provided?
!todo: some providers have become unlinked for real/complex (det/coef); do these need to be provided?
PROVIDE pt2_e0_denominator nproc
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
@ -239,150 +239,150 @@ end subroutine
! !
!==============================================================================!
subroutine ZMQ_selection_complex(N_in, pt2, variance, norm)
!todo: implement
print*,irp_here
stop -1
use f77_zmq
use selection_types
implicit none
integer(ZMQ_PTR) :: zmq_to_qp_run_socket , zmq_socket_pull
integer, intent(in) :: N_in
type(selection_buffer) :: b
integer :: i, N
integer, external :: omp_get_thread_num
double precision, intent(out) :: pt2(N_states)
double precision, intent(out) :: variance(N_states)
double precision, intent(out) :: norm(N_states)
! PROVIDE psi_det psi_coef N_det qp_max_mem N_states pt2_F s2_eig N_det_generators
N = max(N_in,1)
if (.True.) then
PROVIDE pt2_e0_denominator nproc
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order selection_weight pseudo_sym
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection')
integer, external :: zmq_put_psi
integer, external :: zmq_put_N_det_generators
integer, external :: zmq_put_N_det_selectors
integer, external :: zmq_put_dvector
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
stop 'Unable to put psi on ZMQ server'
endif
if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_generators on ZMQ server'
endif
if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_selectors on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
stop 'Unable to put energy on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
stop 'Unable to put state_average_weight on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
stop 'Unable to put selection_weight on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',threshold_generators,1) == -1) then
stop 'Unable to put threshold_generators on ZMQ server'
endif
call create_selection_buffer(N, N*2, b)
endif
integer, external :: add_task_to_taskserver
character(len=100000) :: task
integer :: j,k,ipos
ipos=1
task = ' '
do i= 1, N_det_generators
do j=1,pt2_F(i)
write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, i, N
ipos += 30
if (ipos > 100000-30) then
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
ipos=1
endif
end do
enddo
if (ipos > 1) then
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
endif
ASSERT (associated(b%det))
ASSERT (associated(b%val))
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
integer :: nproc_target
if (N_det < 3*nproc) then
nproc_target = N_det/4
else
nproc_target = nproc
endif
double precision :: mem
mem = 8.d0 * N_det * (N_int * 2.d0 * 3.d0 + 3.d0 + 5.d0) / (1024.d0**3)
call write_double(6,mem,'Estimated memory/thread (Gb)')
if (qp_max_mem > 0) then
nproc_target = max(1,int(dble(qp_max_mem)/(0.1d0 + mem)))
nproc_target = min(nproc_target,nproc)
endif
f(:) = 1.d0
if (.not.do_pt2) then
double precision :: f(N_states), u_dot_u_complex
do k=1,min(N_det,N_states)
f(k) = 1.d0 / u_dot_u_complex(psi_selectors_coef_complex(1,k), N_det_selectors)
enddo
endif
!$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2, variance, norm) PRIVATE(i) NUM_THREADS(nproc_target+1)
i = omp_get_thread_num()
if (i==0) then
call selection_collector(zmq_socket_pull, b, N, pt2, variance, norm)
else
call selection_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'selection')
do i=N_det+1,N_states
pt2(i) = 0.d0
variance(i) = 0.d0
norm(i) = 0.d0
enddo
if (N_in > 0) then
if (s2_eig) then
call make_selection_buffer_s2(b)
endif
call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
call copy_H_apply_buffer_to_wf()
call save_wavefunction
endif
call delete_selection_buffer(b)
do k=1,N_states
pt2(k) = pt2(k) * f(k)
variance(k) = variance(k) * f(k)
norm(k) = norm(k) * f(k)
enddo
call update_pt2_and_variance_weights(pt2, variance, norm, N_states)
end subroutine
!subroutine ZMQ_selection_complex(N_in, pt2, variance, norm)
! !todo: implement
! print*,irp_here
! stop -1
! use f77_zmq
! use selection_types
!
! implicit none
!
! integer(ZMQ_PTR) :: zmq_to_qp_run_socket , zmq_socket_pull
! integer, intent(in) :: N_in
! type(selection_buffer) :: b
! integer :: i, N
! integer, external :: omp_get_thread_num
! double precision, intent(out) :: pt2(N_states)
! double precision, intent(out) :: variance(N_states)
! double precision, intent(out) :: norm(N_states)
!
!! PROVIDE psi_det psi_coef N_det qp_max_mem N_states pt2_F s2_eig N_det_generators
!
! N = max(N_in,1)
! if (.True.) then
! PROVIDE pt2_e0_denominator nproc
! PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
! PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
! PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
! PROVIDE psi_bilinear_matrix_transp_order selection_weight pseudo_sym
!
!
! call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection')
!
! integer, external :: zmq_put_psi
! integer, external :: zmq_put_N_det_generators
! integer, external :: zmq_put_N_det_selectors
! integer, external :: zmq_put_dvector
!
! if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
! stop 'Unable to put psi on ZMQ server'
! endif
! if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
! stop 'Unable to put N_det_generators on ZMQ server'
! endif
! if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
! stop 'Unable to put N_det_selectors on ZMQ server'
! endif
! if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
! stop 'Unable to put energy on ZMQ server'
! endif
! if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
! stop 'Unable to put state_average_weight on ZMQ server'
! endif
! if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
! stop 'Unable to put selection_weight on ZMQ server'
! endif
! if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',threshold_generators,1) == -1) then
! stop 'Unable to put threshold_generators on ZMQ server'
! endif
! call create_selection_buffer(N, N*2, b)
! endif
!
! integer, external :: add_task_to_taskserver
! character(len=100000) :: task
! integer :: j,k,ipos
! ipos=1
! task = ' '
!
! do i= 1, N_det_generators
! do j=1,pt2_F(i)
! write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, i, N
! ipos += 30
! if (ipos > 100000-30) then
! if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
! stop 'Unable to add task to task server'
! endif
! ipos=1
! endif
! end do
! enddo
! if (ipos > 1) then
! if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
! stop 'Unable to add task to task server'
! endif
! endif
!
!
! ASSERT (associated(b%det))
! ASSERT (associated(b%val))
!
! integer, external :: zmq_set_running
! if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
! print *, irp_here, ': Failed in zmq_set_running'
! endif
!
! integer :: nproc_target
! if (N_det < 3*nproc) then
! nproc_target = N_det/4
! else
! nproc_target = nproc
! endif
! double precision :: mem
! mem = 8.d0 * N_det * (N_int * 2.d0 * 3.d0 + 3.d0 + 5.d0) / (1024.d0**3)
! call write_double(6,mem,'Estimated memory/thread (Gb)')
! if (qp_max_mem > 0) then
! nproc_target = max(1,int(dble(qp_max_mem)/(0.1d0 + mem)))
! nproc_target = min(nproc_target,nproc)
! endif
!
! f(:) = 1.d0
! if (.not.do_pt2) then
! double precision :: f(N_states), u_dot_u_complex
! do k=1,min(N_det,N_states)
! f(k) = 1.d0 / u_dot_u_complex(psi_selectors_coef_complex(1,k), N_det_selectors)
! enddo
! endif
!
! !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2, variance, norm) PRIVATE(i) NUM_THREADS(nproc_target+1)
! i = omp_get_thread_num()
! if (i==0) then
! call selection_collector(zmq_socket_pull, b, N, pt2, variance, norm)
! else
! call selection_slave_inproc(i)
! endif
! !$OMP END PARALLEL
! call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'selection')
! do i=N_det+1,N_states
! pt2(i) = 0.d0
! variance(i) = 0.d0
! norm(i) = 0.d0
! enddo
! if (N_in > 0) then
! if (s2_eig) then
! call make_selection_buffer_s2(b)
! endif
! call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
! call copy_H_apply_buffer_to_wf()
! call save_wavefunction
! endif
! call delete_selection_buffer(b)
! do k=1,N_states
! pt2(k) = pt2(k) * f(k)
! variance(k) = variance(k) * f(k)
! norm(k) = norm(k) * f(k)
! enddo
!
! call update_pt2_and_variance_weights(pt2, variance, norm, N_states)
!
!end subroutine

40
src/davidson/davidson_parallel.irp.f
View File

@ -122,7 +122,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
allocate(u_tc(N_st,N_det))
!todo: resize for complex?
!todo: resize for complex? (should be okay)
! Warning : dimensions are modified for efficiency, It is OK since we get the
! full matrix
if (size(u_tc,kind=8) < 8388608_8) then
@ -718,9 +718,6 @@ end
!==============================================================================!
subroutine davidson_push_results_complex(zmq_socket_push, v_t, s_t, imin, imax, task_id)
!todo: implement for complex; check double sz
print*,irp_here,' not implemented for complex'
stop -1
use f77_zmq
implicit none
BEGIN_DOC
@ -745,12 +742,12 @@ subroutine davidson_push_results_complex(zmq_socket_push, v_t, s_t, imin, imax,
rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE)
if(rc /= 4) stop 'davidson_push_results failed to push imax'
!todo: double sz for complex?
rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz, ZMQ_SNDMORE)
!todo: double sz for complex? (done)
rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz*2, ZMQ_SNDMORE)
if(rc8 /= 8_8*sz) stop 'davidson_push_results failed to push vt'
!todo: double sz for complex?
rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz, 0)
!todo: double sz for complex? (done)
rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz*2, 0)
if(rc8 /= 8_8*sz) stop 'davidson_push_results failed to push st'
! Activate is zmq_socket_push is a REQ
@ -767,9 +764,6 @@ IRP_ENDIF
end subroutine
subroutine davidson_push_results_async_send_complex(zmq_socket_push, v_t, s_t, imin, imax, task_id,sending)
!todo: implement for complex; check double sz
print*,irp_here,' not implemented for complex'
stop -1
use f77_zmq
implicit none
BEGIN_DOC
@ -801,21 +795,18 @@ subroutine davidson_push_results_async_send_complex(zmq_socket_push, v_t, s_t, i
rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE)
if(rc /= 4) stop 'davidson_push_results failed to push imax'
!todo: double sz for complex?
rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz, ZMQ_SNDMORE)
!todo: double sz for complex? (done)
rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz*2, ZMQ_SNDMORE)
if(rc8 /= 8_8*sz) stop 'davidson_push_results failed to push vt'
!todo: double sz for complex?
rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz, 0)
!todo: double sz for complex? (done)
rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz*2, 0)
if(rc8 /= 8_8*sz) stop 'davidson_push_results failed to push st'
end subroutine
subroutine davidson_pull_results_complex(zmq_socket_pull, v_t, s_t, imin, imax, task_id)
!todo: implement for complex; check double sz
print*,irp_here,' not implemented for complex'
stop -1
use f77_zmq
implicit none
BEGIN_DOC
@ -841,12 +832,12 @@ subroutine davidson_pull_results_complex(zmq_socket_pull, v_t, s_t, imin, imax,
sz = (imax-imin+1)*N_states_diag
!todo: double sz for complex?
rc8 = f77_zmq_recv8( zmq_socket_pull, v_t(1,imin), 8_8*sz, 0)
!todo: double sz for complex? (done)
rc8 = f77_zmq_recv8( zmq_socket_pull, v_t(1,imin), 8_8*sz*2, 0)
if(rc8 /= 8*sz) stop 'davidson_pull_results failed to pull v_t'
!todo: double sz for complex?
rc8 = f77_zmq_recv8( zmq_socket_pull, s_t(1,imin), 8_8*sz, 0)
!todo: double sz for complex? (done)
rc8 = f77_zmq_recv8( zmq_socket_pull, s_t(1,imin), 8_8*sz*2, 0)
if(rc8 /= 8*sz) stop 'davidson_pull_results failed to pull s_t'
! Activate if zmq_socket_pull is a REP
@ -863,9 +854,6 @@ end subroutine
subroutine davidson_collector_complex(zmq_to_qp_run_socket, zmq_socket_pull, v0, s0, sze, N_st)
!todo: implement for complex; check conjg v_t s_t
print*,irp_here,' not implemented for complex'
stop -1
use f77_zmq
implicit none
BEGIN_DOC
@ -899,8 +887,6 @@ subroutine davidson_collector_complex(zmq_to_qp_run_socket, zmq_socket_pull, v0,
endif
do j=1,N_st
do i=imin,imax
!todo: conjg or no?
print*,irp_here,' not implemented for complex (conjg?)'
v0(i,j) = v0(i,j) + v_t(j,i)
s0(i,j) = s0(i,j) + s_t(j,i)
enddo

4
src/davidson/diagonalize_ci.irp.f
View File

@ -424,7 +424,7 @@ subroutine diagonalize_CI_complex
enddo
psi_energy(1:N_states) = CI_electronic_energy(1:N_states)
psi_s2(1:N_states) = CI_s2(1:N_states)
!todo: touch ci_{sc,electronic_energy}?
!todo: touch ci_{s2,electronic_energy}?
SOFT_TOUCH psi_coef_complex CI_electronic_energy_complex ci_energy CI_eigenvectors_complex CI_s2_complex psi_energy psi_s2
end
@ -443,6 +443,6 @@ subroutine diagonalize_CI
psi_energy(1:N_states) = CI_electronic_energy(1:N_states)
psi_s2(1:N_states) = CI_s2(1:N_states)
!todo: touch ci_{sc,electronic_energy}?
!todo: touch ci_{s2,electronic_energy}?
SOFT_TOUCH psi_coef CI_electronic_energy_real ci_energy CI_eigenvectors CI_s2_real psi_energy psi_s2
end

19
src/davidson/u0_h_u0.irp.f
View File

@ -1114,12 +1114,12 @@ compute_singles=.True.
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
call i_h_j_double_alpha_beta_complex(tmp_det,tmp_det2,$N_int,hij)
call get_s2(tmp_det,tmp_det2,$N_int,sij)
!DIR$ LOOP COUNT AVG(4)
do l=1,N_st
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
s_t(l,k_a) = s_t(l,k_a) + sij * utl(l,kk+1)
enddo
@ -1205,12 +1205,12 @@ compute_singles=.True.
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
call i_h_j_single_spin_complex( tmp_det, tmp_det2, $N_int, 1, hij)
!DIR$ LOOP COUNT AVG(4)
do l=1,N_st
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
! single => sij = 0
enddo
@ -1240,11 +1240,11 @@ compute_singles=.True.
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
call i_h_j_double_spin_complex( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
!DIR$ LOOP COUNT AVG(4)
do l=1,N_st
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
! same spin => sij = 0
enddo
@ -1324,7 +1324,7 @@ compute_singles=.True.
call i_h_j_single_spin_complex( tmp_det, tmp_det2, $N_int, 2, hij)
!DIR$ LOOP COUNT AVG(4)
do l=1,N_st
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
! single => sij = 0
enddo
@ -1355,12 +1355,12 @@ compute_singles=.True.
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
call i_h_j_double_spin_complex( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
!DIR$ LOOP COUNT AVG(4)
do l=1,N_st
!todo: check arg order conjg/noconjg
!todo: check arg order conjg/noconjg (should be okay)
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
! same spin => sij = 0
enddo
@ -1390,7 +1390,6 @@ compute_singles=.True.
sij = dcmplx(diag_S_mat_elem(tmp_det,$N_int),0.d0)
!DIR$ LOOP COUNT AVG(4)
do l=1,N_st
!todo: check arg order conjg/noconjg
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a)
s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a)
enddo