LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2025-02-17 06:04:04 +01:00
Code Releases Activity

Merge branch 'develop' of https://github.com/QuantumPackage/qp2 into develop

Browse Source
This commit is contained in:
eginer 2019-02-06 15:27:59 +01:00
commit 4759309d11
27 changed files with 532 additions and 313 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
INSTALL.rst
View File

@ -210,6 +210,12 @@ Zlib
make
make install
With Debian or Ubuntu, you can use
.. code:: bash
sudo apt install zlib1g-dev
OCaml
@ -217,6 +223,13 @@ OCaml
*OCaml* is a general purpose programming language with an emphasis on expressiveness and safety.
* The following packages are required (Debian or Ubuntu):
.. code:: bash
sudo apt install libncurses5-dev pkg-config libgmp3-dev m4
* Download the installer of the OPAM package manager here :
`<https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh>`_
and move it in the :file:`${QP_ROOT}/external` directory

14
REPLACE
View File

@ -183,3 +183,17 @@ qp_name save_one_body_dm -r save_one_e_dm
qp_name ezfio_set_aux_quantities_data_one_e_alpha_dm_mo -r ezfio_set_aux_quantities_data_one_e_dm_alpha_mo
qp_name ezfio_set_aux_quantities_data_one_e_beta_dm_mo -r ezfio_set_aux_quantities_data_one_e_dm_beta_mo
qp_name two_electron_energy -r two_e_energy
qp_name do_mono_excitation -r do_single_excitation
qp_name get_mono_excitation -r get_single_excitation
qp_name get_mono_excitation_from_fock -r get_single_excitation_from_fock
qp_name is_connected_to_by_mono -r is_connected_to_by_single
qp_name connected_to_ref_by_mono -r connected_to_ref_by_single
qp_name mono_excitation_wee -r single_excitation_wee
qp_name get_mono_excitation_spin
qp_name get_mono_excitation_spin -r get_single_excitation_spin
qp_name get_excitation_degree_vector_mono -r get_excitation_degree_vector_single
qp_name get_excitation_degree_vector_mono_or_exchange -r get_excitation_degree_vector_single_or_exchange_or_exchange
qp_name get_excitation_degree_vector_single_or_exchange_or_exchange -r get_excitation_degree_vector_single_or_exchange
qp_name get_excitation_degree_vector_mono_or_exchange_verbose -r get_excitation_degree_vector_single_or_exchange_verbose
qp_name i_h_j_mono_spin -r i_h_j_single_spin
qp_name i_Wee_j_mono -r i_Wee_j_single

4
TODO
View File

@ -49,8 +49,6 @@ Refaire les benchmarks
# Documentation de qpsh
# Documentation de /etc
# Extrapolation qui prend aussi en compe la variance? a tester
Parler dans le papier de rPT2
# Toto
Re-design de qp command
@ -58,3 +56,5 @@ Re-design de qp command
Doc: plugins et qp_plugins
Ajouter les symetries dans devel
Compiler ezfio avec openmp

19
configure vendored
View File

@ -361,23 +361,24 @@ EOF
done
source quantum_package.rc
NINJA=$(find_exe ninja)
if [[ ${NINJA} = $(not_found) ]] ; then
error "Ninja is not installed."
error "Ninja (ninja) is not installed."
fail
fi
IRPF90=$(find_exe irpf90)
if [[ ${IRPF90} = $(not_found) ]] ; then
error "IRPf90 is not installed."
error "IRPf90 (irpf90) is not installed."
fail
fi
ZEROMQ=$(find_lib -lzmq)
if [[ ${ZEROMQ} = $(not_found) ]] ; then
error "ZeroMQ is not installed."
error "ZeroMQ (zeromq) is not installed."
fail
fi
@ -395,31 +396,31 @@ fi
OCAML=$(find_exe ocaml)
if [[ ${OCAML} = $(not_found) ]] ; then
error "OCaml compiler is not installed."
error "OCaml (ocaml) compiler is not installed."
fail
fi
EZFIO=$(find_dir "${QP_ROOT}"/external/ezfio)
if [[ ${EZFIO} = $(not_found) ]] ; then
error "EZFIO is not installed."
error "EZFIO (ezfio) is not installed."
fail
fi
ZLIB=$(find_lib -lz)
if [[ ${ZLIB} = $(not_found) ]] ; then
error "Zlib is not installed."
error "Zlib (zlib) is not installed."
fail
fi
DOCOPT=$(find_python_lib docopt)
if [[ ${DOCOPT} = $(not_found) ]] ; then
error "docopt is not installed."
error "docopt (docopt) is not installed."
fail
fi
RESULTSFILE=$(find_python_lib resultsFile)
if [[ ${RESULTSFILE} = $(not_found) ]] ; then
error "resultsFile is not installed."
error "resultsFile (resultsFile) is not installed."
fail
fi

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

@ -10,13 +10,20 @@ END_PROVIDER
&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ]
implicit none
logical, external :: testTeethBuilding
integer :: i
integer :: e
e = elec_num - n_core_orb * 2
pt2_n_tasks_max = 1+min((e*(e-1)), int(dsqrt(dble(N_det_selectors)))/10)
do i=1,N_det_generators
pt2_F(i) = 1 + int(dble(pt2_n_tasks_max)*dabs(maxval(psi_coef_sorted_gen(i,:)))**(0.75d0))
integer :: i,j
pt2_n_tasks_max = elec_beta_num*elec_beta_num + elec_alpha_num*elec_beta_num - n_core_orb*2
pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000)
call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max')
pt2_F(:) = int(sqrt(float(pt2_n_tasks_max)))
do i=1,pt2_n_0(1+pt2_N_teeth/4)
pt2_F(i) = pt2_n_tasks_max
enddo
do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/4), N_det_generators
pt2_F(i) = 1
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, pt2_N_teeth ]
@ -54,17 +61,16 @@ logical function testTeethBuilding(minF, N)
allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
do i=1,N_det_generators
tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
enddo
double precision :: norm
norm = 0.d0
double precision :: norm
do i=N_det_generators,1,-1
norm += tilde_w(i)
tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
psi_coef_sorted_gen(i,pt2_stoch_istate)
norm = norm + tilde_w(i)
enddo
tilde_w(:) = tilde_w(:) / norm
f = 1.d0/norm
tilde_w(:) = tilde_w(:) * f
tilde_cW(0) = -1.d0
do i=1,N_det_generators
@ -74,10 +80,14 @@ logical function testTeethBuilding(minF, N)
n0 = 0
testTeethBuilding = .false.
double precision :: f
integer :: minFN
minFN = N_det_generators - minF * N
f = 1.d0/dble(N)
do
u0 = tilde_cW(n0)
r = tilde_cW(n0 + minF)
Wt = (1d0 - u0) / dble(N)
Wt = (1d0 - u0) * f
if (dabs(Wt) <= 1.d-3) then
return
endif
@ -86,7 +96,8 @@ logical function testTeethBuilding(minF, N)
return
end if
n0 += 1
if(N_det_generators - n0 < minF * N) then
! if(N_det_generators - n0 < minF * N) then
if(n0 > minFN) then
return
end if
end do
@ -103,7 +114,6 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
integer, intent(in) :: N_in
integer, external :: omp_get_thread_num
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)
@ -111,7 +121,6 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
integer :: i, N
double precision, external :: omp_get_wtime
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
@ -120,9 +129,9 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
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 psi_det_sorted
PROVIDE psi_det_hii
PROVIDE psi_det_hii N_generators_bitmask
if (s2_eig) then
if (h0_type == 'SOP') then
PROVIDE psi_occ_pattern_hii det_to_occ_pattern
endif
@ -136,6 +145,10 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
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))
@ -279,6 +292,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
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()
@ -326,6 +340,7 @@ subroutine pt2_slave_inproc(i)
implicit none
integer, intent(in) :: i
PROVIDE global_selection_buffer
call run_pt2_slave(1,i,pt2_e0_denominator)
end
@ -359,7 +374,6 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc
integer, allocatable :: task_id(:)
integer, allocatable :: index(:)
double precision, external :: omp_get_wtime
double precision :: v, x, x2, x3, avg, avg2, avg3, eqt, E0, v0, n0
double precision :: time, time1, time0
@ -425,7 +439,6 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc
stop_now = .false.
do while (n <= N_det_generators)
if(f(pt2_J(n)) == 0) then
!print *, 'f(pt2_J(n)) == 0'
d(pt2_J(n)) = .true.
do while(d(U+1))
U += 1
@ -478,6 +491,7 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc
pt2(pt2_stoch_istate) = avg
variance(pt2_stoch_istate) = avg2
norm(pt2_stoch_istate) = avg3
call wall_time(time)
! 1/(N-1.5) : see Brugger, The American Statistician (23) 4 p. 32 (1969)
if(c > 2) then
eqt = dabs((S2(t) / c) - (S(t)/c)**2) ! dabs for numerical stability
@ -498,7 +512,6 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc
endif
endif
endif
call wall_time(time)
end if
n += 1
else if(more == 0) then
@ -506,21 +519,21 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc
else
call pull_pt2_results(zmq_socket_pull, index, eI_task, vI_task, nI_task, task_id, n_tasks, b2)
if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then
stop 'Unable to delete tasks'
stop 'PT2: Unable to delete tasks (send)'
endif
do i=1,n_tasks
eI(:, index(i)) += eI_task(:,i)
vI(:, index(i)) += vI_task(:,i)
nI(:, index(i)) += nI_task(:,i)
eI(1:N_states, index(i)) += eI_task(1:N_states,i)
vI(1:N_states, index(i)) += vI_task(1:N_states,i)
nI(1:N_states, index(i)) += nI_task(1:N_states,i)
f(index(i)) -= 1
end do
do i=1, b2%cur
call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
! We assume the pulled buffer is sorted
if (b2%val(i) > b%mini) exit
call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
end do
if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
stop 'Unable to delete tasks'
stop 'PT2: Unable to delete tasks (recv)'
endif
end if
end do

414
src/cipsi/run_pt2_slave.irp.f
View File

@ -1,6 +1,46 @@
use omp_lib
use selection_types
use f77_zmq
BEGIN_PROVIDER [ integer(omp_lock_kind), global_selection_buffer_lock ]
use omp_lib
implicit none
BEGIN_DOC
! Global buffer for the OpenMP selection
END_DOC
call omp_init_lock(global_selection_buffer_lock)
END_PROVIDER
BEGIN_PROVIDER [ type(selection_buffer), global_selection_buffer ]
use omp_lib
implicit none
BEGIN_DOC
! Global buffer for the OpenMP selection
END_DOC
call omp_set_lock(global_selection_buffer_lock)
call delete_selection_buffer(global_selection_buffer)
call create_selection_buffer(N_det_generators, 2*N_det_generators, &
global_selection_buffer)
call omp_unset_lock(global_selection_buffer_lock)
END_PROVIDER
subroutine run_pt2_slave(thread,iproc,energy)
use f77_zmq
use selection_types
use selection_types
use f77_zmq
implicit none
double precision, intent(in) :: energy(N_states_diag)
integer, intent(in) :: thread, iproc
if (N_det > nproc*(elec_alpha_num * (mo_num-elec_alpha_num))**2) then
call run_pt2_slave_large(thread,iproc,energy)
else
call run_pt2_slave_small(thread,iproc,energy)
endif
end
subroutine run_pt2_slave_small(thread,iproc,energy)
use selection_types
use f77_zmq
implicit none
double precision, intent(in) :: energy(N_states_diag)
@ -24,14 +64,9 @@ subroutine run_pt2_slave(thread,iproc,energy)
integer :: n_tasks, k, N
integer, allocatable :: i_generator(:), subset(:)
double precision :: rss
double precision, external :: memory_of_double, memory_of_int
integer :: bsize ! Size of selection buffers
logical :: sending
rss = memory_of_int(pt2_n_tasks_max)*67.d0
rss += memory_of_double(pt2_n_tasks_max)*(N_states*3)
call check_mem(rss,irp_here)
! logical :: sending
allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max))
allocate(pt2(N_states,pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max))
@ -52,9 +87,8 @@ subroutine run_pt2_slave(thread,iproc,energy)
buffer_ready = .False.
n_tasks = 1
sending = .False.
! sending = .False.
done = .False.
n_tasks = 1
do while (.not.done)
n_tasks = max(1,n_tasks)
@ -79,7 +113,130 @@ subroutine run_pt2_slave(thread,iproc,energy)
call create_selection_buffer(bsize, bsize*2, b)
buffer_ready = .True.
else
ASSERT (N == b%N)
ASSERT (b%N == bsize)
endif
double precision :: time0, time1
call wall_time(time0)
do k=1,n_tasks
pt2(:,k) = 0.d0
variance(:,k) = 0.d0
norm(:,k) = 0.d0
b%cur = 0
!double precision :: time2
!call wall_time(time2)
call select_connected(i_generator(k),energy,pt2(1,k),variance(1,k),norm(1,k),b,subset(k),pt2_F(i_generator(k)))
!call wall_time(time1)
!print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1))
enddo
call wall_time(time1)
!print *, '-->', i_generator(1), time1-time0, n_tasks
integer, external :: tasks_done_to_taskserver
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
done = .true.
endif
call sort_selection_buffer(b)
call push_pt2_results(zmq_socket_push, i_generator, pt2, variance, norm, b, task_id, n_tasks)
b%cur=0
! ! Try to adjust n_tasks around nproc/2 seconds per job
! n_tasks = min(2*n_tasks,int( dble(n_tasks * nproc/2) / (time1 - time0 + 1.d0)))
n_tasks = 1
end do
integer, external :: disconnect_from_taskserver
do i=1,300
if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) /= -2) exit
call sleep(1)
print *, 'Retry disconnect...'
end do
call end_zmq_push_socket(zmq_socket_push,thread)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
if (buffer_ready) then
call delete_selection_buffer(b)
endif
end subroutine
subroutine run_pt2_slave_large(thread,iproc,energy)
use selection_types
use f77_zmq
implicit none
double precision, intent(in) :: energy(N_states_diag)
integer, intent(in) :: thread, iproc
integer :: rc, i
integer :: worker_id, ctask, ltask
character*(512), allocatable :: task(:)
integer, allocatable :: task_id(:)
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
type(selection_buffer) :: b
logical :: done, buffer_ready
double precision,allocatable :: pt2(:,:), variance(:,:), norm(:,:)
integer :: n_tasks, k, N
integer, allocatable :: i_generator(:), subset(:)
integer :: bsize ! Size of selection buffers
logical :: sending
PROVIDE global_selection_buffer global_selection_buffer_lock
allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max))
allocate(pt2(N_states,pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max))
allocate(variance(N_states,pt2_n_tasks_max))
allocate(norm(N_states,pt2_n_tasks_max))
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
integer, external :: connect_to_taskserver
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
return
endif
zmq_socket_push = new_zmq_push_socket(thread)
b%N = 0
buffer_ready = .False.
n_tasks = 1
sending = .False.
done = .False.
do while (.not.done)
n_tasks = max(1,n_tasks)
n_tasks = min(pt2_n_tasks_max,n_tasks)
integer, external :: get_tasks_from_taskserver
if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then
exit
endif
done = task_id(n_tasks) == 0
if (done) then
n_tasks = n_tasks-1
endif
if (n_tasks == 0) exit
do k=1,n_tasks
read (task(k),*) subset(k), i_generator(k), N
enddo
if (b%N == 0) then
! Only first time
bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
call create_selection_buffer(bsize, bsize*2, b)
buffer_ready = .True.
else
ASSERT (b%N == bsize)
endif
double precision :: time0, time1
@ -104,11 +261,23 @@ subroutine run_pt2_slave(thread,iproc,energy)
endif
call sort_selection_buffer(b)
call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
call push_pt2_results_async_send(zmq_socket_push, i_generator, pt2, variance, norm, b, task_id, n_tasks,sending)
call omp_set_lock(global_selection_buffer_lock)
global_selection_buffer%mini = b%mini
call merge_selection_buffers(b,global_selection_buffer)
b%cur=0
call omp_unset_lock(global_selection_buffer_lock)
if ( iproc == 1 ) then
call omp_set_lock(global_selection_buffer_lock)
call push_pt2_results_async_send(zmq_socket_push, i_generator, pt2, variance, norm, global_selection_buffer, task_id, n_tasks,sending)
global_selection_buffer%cur = 0
call omp_unset_lock(global_selection_buffer_lock)
else
call push_pt2_results_async_send(zmq_socket_push, i_generator, pt2, variance, norm, b, task_id, n_tasks,sending)
endif
! Try to adjust n_tasks around nproc/2 seconds per job
n_tasks = min(2*n_tasks,int( dble(n_tasks * nproc/2) / (time1 - time0 + 1.d0)))
! ! Try to adjust n_tasks around nproc/2 seconds per job
! n_tasks = min(2*n_tasks,int( dble(n_tasks * nproc/2) / (time1 - time0 + 1.d0)))
n_tasks = 1
end do
call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
@ -124,12 +293,13 @@ subroutine run_pt2_slave(thread,iproc,energy)
if (buffer_ready) then
call delete_selection_buffer(b)
endif
FREE global_selection_buffer
end subroutine
subroutine push_pt2_results(zmq_socket_push, index, pt2, variance, norm, b, task_id, n_tasks)
use f77_zmq
use selection_types
use selection_types
use f77_zmq
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
@ -138,99 +308,17 @@ subroutine push_pt2_results(zmq_socket_push, index, pt2, variance, norm, b, task
double precision, intent(in) :: norm(N_states,n_tasks)
integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks)
type(selection_buffer), intent(inout) :: b
integer :: rc
rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 4) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, index, 4*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 4*n_tasks) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 8*N_states*n_tasks) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, variance, 8*N_states*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 8*N_states*n_tasks) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, norm, 8*N_states*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 8*N_states*n_tasks) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, task_id, n_tasks*4, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 4*n_tasks) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 4) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, b%val, 8*b%cur, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 8*b%cur) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, b%det, bit_kind*N_int*2*b%cur, 0)
if (rc == -1) then
return
else if(rc /= N_int*2*8*b%cur) then
stop 'push'
endif
! Activate is zmq_socket_push is a REQ
IRP_IF ZMQ_PUSH
IRP_ELSE
character*(2) :: ok
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
if (rc == -1) then
return
else if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
print *, irp_here//': error in receiving ok'
stop -1
endif
IRP_ENDIF
logical :: sending
sending = .False.
call push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, norm, b, task_id, n_tasks, sending)
call push_pt2_results_async_recv(zmq_socket_push, b%mini, sending)
end subroutine
subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, norm, b, task_id, n_tasks, sending)
use f77_zmq
use selection_types
use selection_types
use f77_zmq
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
@ -241,6 +329,7 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, no
type(selection_buffer), intent(inout) :: b
logical, intent(inout) :: sending
integer :: rc
integer*8 :: rc8
if (sending) then
print *, irp_here, ': sending is true'
@ -250,6 +339,8 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, no
rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 1
return
else if(rc /= 4) then
stop 'push'
@ -258,6 +349,8 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, no
rc = f77_zmq_send( zmq_socket_push, index, 4*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 2
return
else if(rc /= 4*n_tasks) then
stop 'push'
@ -266,6 +359,8 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, no
rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 3
return
else if(rc /= 8*N_states*n_tasks) then
stop 'push'
@ -274,6 +369,8 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, no
rc = f77_zmq_send( zmq_socket_push, variance, 8*N_states*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 4
return
else if(rc /= 8*N_states*n_tasks) then
stop 'push'
@ -282,6 +379,8 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, no
rc = f77_zmq_send( zmq_socket_push, norm, 8*N_states*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 5
return
else if(rc /= 8*N_states*n_tasks) then
stop 'push'
@ -290,40 +389,63 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, no
rc = f77_zmq_send( zmq_socket_push, task_id, n_tasks*4, ZMQ_SNDMORE)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 6
return
else if(rc /= 4*n_tasks) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 4) then
stop 'push'
endif
if (b%cur == 0) then
rc = f77_zmq_send( zmq_socket_push, b%cur, 4, 0)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 7
return
else if(rc /= 4) then
stop 'push'
endif
else
rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 7
return
else if(rc /= 4) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, b%val, 8*b%cur, ZMQ_SNDMORE)
if (rc == -1) then
return
else if(rc /= 8*b%cur) then
stop 'push'
endif
rc8 = f77_zmq_send8( zmq_socket_push, b%val, 8_8*int(b%cur,8), ZMQ_SNDMORE)
if (rc8 == -1_8) then
print *, irp_here, ': error sending result'
stop 8
return
else if(rc8 /= 8_8*int(b%cur,8)) then
stop 'push'
endif
rc = f77_zmq_send( zmq_socket_push, b%det, bit_kind*N_int*2*b%cur, 0)
if (rc == -1) then
return
else if(rc /= N_int*2*8*b%cur) then
stop 'push'
rc8 = f77_zmq_send8( zmq_socket_push, b%det, int(bit_kind*N_int*2,8)*int(b%cur,8), 0)
if (rc8 == -1_8) then
print *, irp_here, ': error sending result'
stop 9
return
else if(rc8 /= int(N_int*2*8,8)*int(b%cur,8)) then
stop 'push'
endif
endif
end subroutine
subroutine push_pt2_results_async_recv(zmq_socket_push,mini,sending)
use f77_zmq
use selection_types
use selection_types
use f77_zmq
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
@ -339,12 +461,22 @@ IRP_ELSE
character*(2) :: ok
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 10
return
else if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
print *, irp_here//': error in receiving ok'
stop -1
endif
rc = f77_zmq_recv( zmq_socket_push, mini, 8, 0)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 11
return
else if (rc /= 8) then
print *, irp_here//': error in receiving mini'
stop 12
endif
IRP_ENDIF
sending = .False.
end subroutine
@ -352,8 +484,8 @@ end subroutine
subroutine pull_pt2_results(zmq_socket_pull, index, pt2, variance, norm, task_id, n_tasks, b)
use f77_zmq
use selection_types
use selection_types
use f77_zmq
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
double precision, intent(inout) :: pt2(N_states,*)
@ -363,6 +495,7 @@ subroutine pull_pt2_results(zmq_socket_pull, index, pt2, variance, norm, task_id
integer, intent(out) :: index(*)
integer, intent(out) :: n_tasks, task_id(*)
integer :: rc, rn, i
integer*8 :: rc8
rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0)
if (rc == -1) then
@ -420,22 +553,25 @@ subroutine pull_pt2_results(zmq_socket_pull, index, pt2, variance, norm, task_id
stop 'pull'
endif
rc = f77_zmq_recv( zmq_socket_pull, b%val, 8*b%cur, 0)
if (rc == -1) then
n_tasks = 1
task_id(1) = 0
else if(rc /= 8*b%cur) then
stop 'pull'
endif
if (b%cur > 0) then
rc = f77_zmq_recv( zmq_socket_pull, b%det, bit_kind*N_int*2*b%cur, 0)
if (rc == -1) then
n_tasks = 1
task_id(1) = 0
else if(rc /= N_int*2*8*b%cur) then
stop 'pull'
endif
rc8 = f77_zmq_recv8( zmq_socket_pull, b%val, 8_8*int(b%cur,8), 0)
if (rc8 == -1_8) then
n_tasks = 1
task_id(1) = 0
else if(rc8 /= 8_8*int(b%cur,8)) then
stop 'pull'
endif
rc8 = f77_zmq_recv8( zmq_socket_pull, b%det, int(bit_kind*N_int*2,8)*int(b%cur,8), 0)
if (rc8 == -1_8) then
n_tasks = 1
task_id(1) = 0
else if(rc8 /= int(N_int*2*8,8)*int(b%cur,8)) then
stop 'pull'
endif
endif
! Activate is zmq_socket_pull is a REP
IRP_IF ZMQ_PUSH

12
src/cipsi/selection_buffer.irp.f
View File

@ -37,6 +37,11 @@ subroutine delete_selection_buffer(b)
if (associated(b%val)) then
deallocate(b%val)
endif
NULLIFY(b%det)
NULLIFY(b%val)
b%cur = 0
b%mini = 0.d0
b%N = 0
end
@ -69,7 +74,7 @@ subroutine merge_selection_buffers(b1, b2)
type(selection_buffer), intent(inout) :: b2
integer(bit_kind), pointer :: detmp(:,:,:)
double precision, pointer :: val(:)
integer :: i, i1, i2, k, nmwen
integer :: i, i1, i2, k, nmwen, sze
if (b1%cur == 0) return
do while (b1%val(b1%cur) > b2%mini)
b1%cur = b1%cur-1
@ -80,9 +85,10 @@ subroutine merge_selection_buffers(b1, b2)
nmwen = min(b1%N, b1%cur+b2%cur)
double precision :: rss
double precision, external :: memory_of_double
rss = memory_of_double(size(b1%val)) + 2*N_int*memory_of_double(size(b1%det,3))
sze = max(size(b1%val), size(b2%val))
rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze)
call check_mem(rss,irp_here)
allocate( val(size(b1%val)), detmp(N_int, 2, size(b1%det,3)) )
allocate(val(sze), detmp(N_int, 2, sze))
i1=1
i2=1
do i=1,nmwen

49
src/cipsi/slave_cipsi.irp.f
View File

@ -232,6 +232,7 @@ subroutine run_slave_main
endif
IRP_ENDIF
IRP_IF MPI_DEBUG
call mpi_print('Entering OpenMP section')
IRP_ENDIF
@ -251,7 +252,7 @@ subroutine run_slave_main
+ 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
+ 2.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
+ 3.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
@ -272,29 +273,37 @@ subroutine run_slave_main
nproc_target = nproc_target - 1
enddo
if (N_det > 100000) then
if (mpi_master) then
print *, 'N_det', N_det
print *, 'N_det_generators', N_det_generators
print *, 'N_det_selectors', N_det_selectors
print *, 'pt2_e0_denominator', pt2_e0_denominator
print *, 'pt2_stoch_istate', pt2_stoch_istate
print *, 'state_average_weight', state_average_weight
print *, 'Number of threads', nproc_target
PROVIDE psi_det_hii
if (s2_eig) then
PROVIDE psi_occ_pattern_hii det_to_occ_pattern
if (mpi_master) then
print *, 'N_det', N_det
print *, 'N_det_generators', N_det_generators
print *, 'N_det_selectors', N_det_selectors
print *, 'pt2_e0_denominator', pt2_e0_denominator
print *, 'pt2_stoch_istate', pt2_stoch_istate
print *, 'state_average_weight', state_average_weight
print *, 'Number of threads', nproc_target
endif
endif
!$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target+1)
i = omp_get_thread_num()
call run_pt2_slave(0,i,pt2_e0_denominator)
!$OMP END PARALLEL
if (h0_type == 'SOP') then
PROVIDE det_to_occ_pattern
endif
PROVIDE global_selection_buffer
if (mpi_master) then
print *, 'Running PT2'
endif
!$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target+1)
i = omp_get_thread_num()
call run_pt2_slave(0,i,pt2_e0_denominator)
!$OMP END PARALLEL
FREE state_average_weight
print *, mpi_rank, ': PT2 done'
print *, '-------'
endif
endif
FREE state_average_weight
print *, mpi_rank, ': PT2 done'
IRP_IF MPI
call MPI_BARRIER(MPI_COMM_WORLD, ierr)

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

@ -359,7 +359,7 @@ subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull, v0, s0, sze
do while (more == 1)
call davidson_pull_results(zmq_socket_pull, v_t, s_t, imin, imax, task_id)
if (zmq_delete_task_async_send(zmq_to_qp_run_socket,task_id,sending) == -1) then
stop 'Unable to delete task'
stop 'davidson: Unable to delete task (send)'
endif
do j=1,N_st
do i=imin,imax
@ -368,7 +368,7 @@ subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull, v0, s0, sze
enddo
enddo
if (zmq_delete_task_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
stop 'Unable to delete task'
stop 'davidson: Unable to delete task (recv)'
endif
end do
deallocate(v_t,s_t)

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

@ -202,6 +202,8 @@ subroutine diagonalize_CI
psi_coef(i,j) = CI_eigenvectors(i,j)
enddo
enddo
psi_energy(1:N_states) = CI_electronic_energy(1:N_states)
psi_s2(1:N_states) = CI_s2(1:N_states)
SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_s2
SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_s2 psi_energy psi_s2
end

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

@ -41,13 +41,27 @@ subroutine u_0_H_u_0(e_0,s_0,u_0,n,keys_tmp,Nint,N_st,sze)
double precision, allocatable :: v_0(:,:), s_vec(:,:), u_1(:,:)
double precision :: u_dot_u,u_dot_v,diag_H_mat_elem
integer :: i,j
integer :: i,j, istate
if ((n > 100000).and.distributed_davidson) then
allocate (v_0(n,N_states_diag),s_vec(n,N_states_diag), u_1(n,N_states_diag))
u_1(:,:) = 0.d0
u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
call H_S2_u_0_nstates_zmq(v_0,s_vec,u_1,N_states_diag,n)
else if (n < n_det_max_full) then
allocate (v_0(n,N_st),s_vec(n,N_st), u_1(n,N_st))
v_0(:,:) = 0.d0
u_1(:,:) = 0.d0
s_vec(:,:) = 0.d0
u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
do istate = 1,N_st
do j=1,n
do i=1,n
v_0(i,istate) = v_0(i,istate) + h_matrix_all_dets(i,j) * u_0(j,istate)
s_vec(i,istate) = s_vec(i,istate) + S2_matrix_all_dets(i,j) * u_0(j,istate)
enddo
enddo
enddo
else
allocate (v_0(n,N_st),s_vec(n,N_st),u_1(n,N_st))
u_1(:,:) = 0.d0
@ -469,7 +483,7 @@ compute_singles=.True.
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
call i_H_j_mono_spin( tmp_det, tmp_det2, $N_int, 1, hij)
call i_h_j_single_spin( tmp_det, tmp_det2, $N_int, 1, hij)
!DIR$ LOOP COUNT AVG(4)
do l=1,N_st
@ -554,7 +568,7 @@ compute_singles=.True.
ASSERT (lcol <= N_det_beta_unique)
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
call i_H_j_mono_spin( tmp_det, tmp_det2, $N_int, 2, hij)
call i_h_j_single_spin( tmp_det, tmp_det2, $N_int, 2, hij)
l_a = psi_bilinear_matrix_transp_order(l_b)
ASSERT (l_a <= N_det)
!DIR$ LOOP COUNT AVG(4)

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

@ -304,7 +304,7 @@ subroutine H_S2_u_0_two_e_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
call i_Wee_j_mono( tmp_det, tmp_det2, $N_int, 1, hij)
call i_Wee_j_single( tmp_det, tmp_det2, $N_int, 1, hij)
do l=1,N_st
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
@ -384,7 +384,7 @@ subroutine H_S2_u_0_two_e_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart
ASSERT (lcol <= N_det_beta_unique)
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
call i_Wee_j_mono( tmp_det, tmp_det2, $N_int, 2, hij)
call i_Wee_j_single( tmp_det, tmp_det2, $N_int, 2, hij)
l_a = psi_bilinear_matrix_transp_order(l_b)
ASSERT (l_a <= N_det)
do l=1,N_st

18
src/determinants/connected_to_ref.irp.f
View File

@ -185,7 +185,7 @@ end
logical function is_connected_to_by_mono(key,keys,Nint,Ndet)
logical function is_connected_to_by_single(key,keys,Nint,Ndet)
use bitmasks
implicit none
BEGIN_DOC
@ -202,7 +202,7 @@ logical function is_connected_to_by_mono(key,keys,Nint,Ndet)
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
is_connected_to_by_mono = .false.
is_connected_to_by_single = .false.
do i=1,Ndet
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
@ -214,7 +214,7 @@ logical function is_connected_to_by_mono(key,keys,Nint,Ndet)
if (degree_x2 > 2) then
cycle
else
is_connected_to_by_mono = .true.
is_connected_to_by_single = .true.
return
endif
enddo
@ -333,7 +333,7 @@ end
integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet)
integer function connected_to_ref_by_single(key,keys,Nint,N_past_in,Ndet)
use bitmasks
implicit none
BEGIN_DOC
@ -368,7 +368,7 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet)
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
connected_to_ref_by_mono = 0
connected_to_ref_by_single = 0
N_past = max(1,N_past_in)
if (Nint == 1) then
@ -380,7 +380,7 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet)
else if (degree_x2 == 4)then
cycle
else if(degree_x2 == 2)then
connected_to_ref_by_mono = i
connected_to_ref_by_single = i
return
endif
enddo
@ -400,7 +400,7 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet)
else if (degree_x2 == 4)then
cycle
else if(degree_x2 == 2)then
connected_to_ref_by_mono = i
connected_to_ref_by_single = i
return
endif
enddo
@ -421,7 +421,7 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet)
else if (degree_x2 == 4)then
cycle
else if(degree_x2 == 2)then
connected_to_ref_by_mono = i
connected_to_ref_by_single = i
return
endif
enddo
@ -442,7 +442,7 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet)
else if (degree_x2 == 4)then
cycle
else if(degree_x2 == 2)then
connected_to_ref_by_mono = i
connected_to_ref_by_single = i
return
endif
enddo

2
src/determinants/create_excitations.irp.f
View File

@ -1,4 +1,4 @@
subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok)
subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok)
implicit none
BEGIN_DOC
! Apply the single excitation operator : a^{dager}_(i_particle) a_(i_hole) of spin = ispin

4
src/determinants/density_matrix.irp.f
View File

@ -150,7 +150,7 @@ END_PROVIDER