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 integer(ZMQ_PTR) :: zmq_to_qp_run_socket call new_parallel_job(zmq_to_qp_run_socket,'$subroutine') zmq_socket_pair = new_zmq_pair_socket(.True.) 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_zmq_pair_socket(zmq_socket_pair) call end_parallel_job(zmq_to_qp_run_socket,'$subroutine') $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) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) 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