mirror of
https://github.com/LCPQ/quantum_package
synced 2024-11-07 06:33:53 +01:00
249 lines
7.8 KiB
Fortran
249 lines
7.8 KiB
Fortran
|
subroutine $subroutine($params_main)
|
||
|
|
implicit none
|
||
|
|
use omp_lib
|
||
|
|
use bitmasks
|
||
|
|
use f77_zmq
|
||
|
|
BEGIN_DOC
|
||
|
|
! Calls H_apply on the HF determinant and selects all connected single and double
|
||
|
|
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
|
||
|
|
END_DOC
|
||
|
|
|
||
|
|
$decls_main
|
||
|
|
|
||
|
|
integer :: i_generator
|
||
|
|
double precision :: wall_0, wall_1
|
||
|
|
integer(omp_lock_kind) :: lck
|
||
|
|
integer(bit_kind), allocatable :: mask(:,:,:)
|
||
|
|
integer :: ispin, k
|
||
|
|
integer :: rc
|
||
|
|
character*(512) :: task
|
||
|
|
double precision, allocatable :: fock_diag_tmp(:,:)
|
||
|
|
|
||
|
|
$initialization
|
||
|
|
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators
|
||
|
|
|
||
|
|
integer(ZMQ_PTR), external :: new_zmq_pair_socket
|
||
|
|
integer(ZMQ_PTR) :: zmq_socket_pair
|
||
|
|
zmq_socket_pair = new_zmq_pair_socket(.True.)
|
||
|
|
|
||
|
|
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||
|
|
call new_parallel_job(zmq_to_qp_run_socket,'$subroutine')
|
||
|
|
|
||
|
|
call zmq_put_psi(zmq_to_qp_run_socket,1)
|
||
|
|
|
||
|
|
do i_generator=N_det_generators,1,-1
|
||
|
|
$skip
|
||
|
|
write(task,*) i_generator
|
||
|
|
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
|
||
|
|
enddo
|
||
|
|
|
||
|
|
integer(ZMQ_PTR) :: collector_thread
|
||
|
|
external :: $subroutine_collector
|
||
|
|
rc = pthread_create(collector_thread, $subroutine_collector)
|
||
|
|
|
||
|
|
!$OMP PARALLEL DEFAULT(private)
|
||
|
|
!$OMP TASK PRIVATE(rc)
|
||
|
|
rc = omp_get_thread_num()
|
||
|
|
call $subroutine_slave_inproc(rc)
|
||
|
|
!$OMP END TASK
|
||
|
|
!$OMP TASKWAIT
|
||
|
|
!$OMP END PARALLEL
|
||
|
|
|
||
|
|
|
||
|
|
integer :: n, task_id
|
||
|
|
call pull_pt2(zmq_socket_pair, pt2, norm_pert, H_pert_diag, N_st, n, task_id)
|
||
|
|
|
||
|
|
rc = pthread_join(collector_thread)
|
||
|
|
|
||
|
|
call end_parallel_job(zmq_to_qp_run_socket,'$subroutine')
|
||
|
|
|
||
|
|
rc = f77_zmq_close(zmq_socket_pair)
|
||
|
|
if (rc /= 0) then
|
||
|
|
print *, 'f77_zmq_close(zmq_socket_pair)'
|
||
|
|
stop 'error'
|
||
|
|
endif
|
||
|
|
|
||
|
|
$copy_buffer
|
||
|
|
$generate_psi_guess
|
||
|
|
|
||
|
|
end
|
||
|
|
|
||
|
|
subroutine $subroutine_slave_tcp(iproc)
|
||
|
|
implicit none
|
||
|
|
integer, intent(in) :: iproc
|
||
|
|
BEGIN_DOC
|
||
|
|
! Computes a buffer over the network
|
||
|
|
END_DOC
|
||
|
|
call $subroutine_slave(0,iproc)
|
||
|
|
end
|
||
|
|
|
||
|
|
subroutine $subroutine_slave_inproc(iproc)
|
||
|
|
implicit none
|
||
|
|
integer, intent(in) :: iproc
|
||
|
|
BEGIN_DOC
|
||
|
|
! Computes a buffer using threads
|
||
|
|
END_DOC
|
||
|
|
call $subroutine_slave(1,iproc)
|
||
|
|
end
|
||
|
|
|
||
|
|
|
||
|
|
subroutine $subroutine_slave(thread, iproc)
|
||
|
|
implicit none
|
||
|
|
use omp_lib
|
||
|
|
use bitmasks
|
||
|
|
use f77_zmq
|
||
|
|
integer, intent(in) :: thread
|
||
|
|
BEGIN_DOC
|
||
|
|
! Calls H_apply on the HF determinant and selects all connected single and double
|
||
|
|
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
|
||
|
|
END_DOC
|
||
|
|
|
||
|
|
integer, intent(in) :: iproc
|
||
|
|
integer :: i_generator
|
||
|
|
double precision :: wall_0, wall_1
|
||
|
|
integer(bit_kind), allocatable :: mask(:,:,:)
|
||
|
|
integer :: ispin, k
|
||
|
|
double precision, allocatable :: fock_diag_tmp(:,:)
|
||
|
|
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
|
||
|
|
|
||
|
|
integer :: worker_id, task_id, rc, N_st
|
||
|
|
character*(512) :: task
|
||
|
|
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||
|
|
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||
|
|
integer(ZMQ_PTR),external :: new_zmq_push_socket
|
||
|
|
integer(ZMQ_PTR) :: zmq_socket_push
|
||
|
|
|
||
|
|
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||
|
|
zmq_socket_push = new_zmq_push_socket(thread)
|
||
|
|
|
||
|
|
|
||
|
|
N_st = N_states
|
||
|
|
allocate( pt2(N_st), norm_pert(N_st), H_pert_diag(N_st), &
|
||
|
|
mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
|
||
|
|
|
||
|
|
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
|
||
|
|
|
||
|
|
do
|
||
|
|
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
|
||
|
|
if (task_id == 0) exit
|
||
|
|
read(task,*) i_generator
|
||
|
|
|
||
|
|
! Compute diagonal of the Fock matrix
|
||
|
|
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
|
||
|
|
|
||
|
|
pt2 = 0.d0
|
||
|
|
norm_pert = 0.d0
|
||
|
|
H_pert_diag = 0.d0
|
||
|
|
|
||
|
|
! Create bit masks for holes and particles
|
||
|
|
do ispin=1,2
|
||
|
|
do k=1,N_int
|
||
|
|
mask(k,ispin,s_hole) = &
|
||
|
|
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
|
||
|
|
psi_det_generators(k,ispin,i_generator) )
|
||
|
|
mask(k,ispin,s_part) = &
|
||
|
|
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
|
||
|
|
not(psi_det_generators(k,ispin,i_generator)) )
|
||
|
|
mask(k,ispin,d_hole1) = &
|
||
|
|
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
|
||
|
|
psi_det_generators(k,ispin,i_generator) )
|
||
|
|
mask(k,ispin,d_part1) = &
|
||
|
|
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
|
||
|
|
not(psi_det_generators(k,ispin,i_generator)) )
|
||
|
|
mask(k,ispin,d_hole2) = &
|
||
|
|
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
|
||
|
|
psi_det_generators(k,ispin,i_generator) )
|
||
|
|
mask(k,ispin,d_part2) = &
|
||
|
|
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
|
||
|
|
not (psi_det_generators(k,ispin,i_generator)) )
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
|
||
|
|
if($do_double_excitations)then
|
||
|
|
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
|
||
|
|
psi_det_generators(1,1,1), &
|
||
|
|
mask(1,1,d_hole1), mask(1,1,d_part1), &
|
||
|
|
mask(1,1,d_hole2), mask(1,1,d_part2), &
|
||
|
|
fock_diag_tmp, i_generator, iproc $params_post)
|
||
|
|
endif
|
||
|
|
if($do_mono_excitations)then
|
||
|
|
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
|
||
|
|
mask(1,1,s_hole ), mask(1,1,s_part ), &
|
||
|
|
fock_diag_tmp, i_generator, iproc $params_post)
|
||
|
|
endif
|
||
|
|
|
||
|
|
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,1)
|
||
|
|
call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id)
|
||
|
|
|
||
|
|
enddo
|
||
|
|
|
||
|
|
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
|
||
|
|
|
||
|
|
deallocate( mask, fock_diag_tmp, pt2, norm_pert, H_pert_diag )
|
||
|
|
|
||
|
|
call end_zmq_push_socket(zmq_socket_push,thread)
|
||
|
|
|
||
|
|
end
|
||
|
|
|
||
|
|
subroutine $subroutine_collector
|
||
|
|
use f77_zmq
|
||
|
|
implicit none
|
||
|
|
BEGIN_DOC
|
||
|
|
! Collects results from the selection
|
||
|
|
END_DOC
|
||
|
|
|
||
|
|
integer :: k, rc
|
||
|
|
|
||
|
|
integer(ZMQ_PTR), external :: new_zmq_pull_socket
|
||
|
|
integer(ZMQ_PTR) :: zmq_socket_pull
|
||
|
|
integer*8 :: control, accu
|
||
|
|
integer :: n, more, task_id
|
||
|
|
|
||
|
|
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||
|
|
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||
|
|
|
||
|
|
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||
|
|
zmq_socket_pull = new_zmq_pull_socket()
|
||
|
|
|
||
|
|
double precision, allocatable :: pt2(:,:), norm_pert(:,:), H_pert_diag(:,:)
|
||
|
|
allocate ( pt2(N_states,2), norm_pert(N_states,2), H_pert_diag(N_states,2))
|
||
|
|
|
||
|
|
pt2 = 0.d0
|
||
|
|
norm_pert = 0.d0
|
||
|
|
H_pert_diag = 0.d0
|
||
|
|
accu = 0_8
|
||
|
|
more = 1
|
||
|
|
do while (more == 1)
|
||
|
|
|
||
|
|
call pull_pt2(zmq_socket_pull, pt2, norm_pert, H_pert_diag, N_states, n, task_id)
|
||
|
|
if (n > 0) then
|
||
|
|
do k=1,N_states
|
||
|
|
pt2(k,2) = pt2(k,1) + pt2(k,2)
|
||
|
|
norm_pert(k,2) = norm_pert(k,1) + norm_pert(k,2)
|
||
|
|
H_pert_diag(k,2) = H_pert_diag(k,1) + H_pert_diag(k,2)
|
||
|
|
enddo
|
||
|
|
accu = accu + 1_8
|
||
|
|
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
|
||
|
|
endif
|
||
|
|
|
||
|
|
enddo
|
||
|
|
|
||
|
|
call end_zmq_pull_socket(zmq_socket_pull)
|
||
|
|
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||
|
|
|
||
|
|
|
||
|
|
integer(ZMQ_PTR), external :: new_zmq_pair_socket
|
||
|
|
integer(ZMQ_PTR) :: socket_result
|
||
|
|
|
||
|
|
socket_result = new_zmq_pair_socket(.False.)
|
||
|
|
|
||
|
|
call push_pt2(socket_result, pt2(1,2), norm_pert(1,2), H_pert_diag(1,2), N_states,0)
|
||
|
|
|
||
|
|
deallocate ( pt2, norm_pert, H_pert_diag)
|
||
|
|
|
||
|
|
call end_zmq_pair_socket(socket_result)
|
||
|
|
|
||
|
|
end
|
||
|
|
|
||
|
|
|