diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index e487d39b..94ed962b 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -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 diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index b5d9cce9..29cbc2d9 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -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 diff --git a/src/cipsi/zmq_selection.irp.f b/src/cipsi/zmq_selection.irp.f index d87c68a0..059166fa 100644 --- a/src/cipsi/zmq_selection.irp.f +++ b/src/cipsi/zmq_selection.irp.f @@ -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 diff --git a/src/davidson/davidson_parallel.irp.f b/src/davidson/davidson_parallel.irp.f index 583eb937..128f3156 100644 --- a/src/davidson/davidson_parallel.irp.f +++ b/src/davidson/davidson_parallel.irp.f @@ -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 diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f index a2599461..13152fdd 100644 --- a/src/davidson/diagonalize_ci.irp.f +++ b/src/davidson/diagonalize_ci.irp.f @@ -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 diff --git a/src/davidson/u0_h_u0.irp.f b/src/davidson/u0_h_u0.irp.f index 576b3a65..ac98c362 100644 --- a/src/davidson/u0_h_u0.irp.f +++ b/src/davidson/u0_h_u0.irp.f @@ -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