LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-07-23 11:17:33 +02:00
Code Issues Releases Wiki Activity

shifted-bk selection iterates

Browse Source
This commit is contained in:
Yann Garniron 2018-05-14 13:00:04 +02:00
parent 9823fed7be
commit 7cc33f1ab3
8 changed files with 102 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
plugins/dress_zmq/dress_slave.irp.f
View File

@ -56,7 +56,6 @@ subroutine run_wf
! call dress_slave_tcp(i+1, energy)
call dress_slave_tcp(0, energy)
!!$OMP END PARALLEL
print *, 'dress done'
endif
end do

40
plugins/dress_zmq/dress_stoch_routines.irp.f
View File

@ -122,14 +122,6 @@ subroutine ZMQ_dress(E, dress, delta_out, delta_s2_out, relative_error)
block(block_i) = dress_jobs(i)
end if
end do
print *, "ACTUAL TASK NUM", ntas
!stop
!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
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
@ -196,7 +188,7 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
double precision, save :: time0 = -1.d0
double precision :: time
double precision, external :: omp_get_wtime
integer :: cur_cp
integer :: cur_cp, last_cp
integer :: delta_loc_cur, is, N_buf(3)
integer, allocatable :: int_buf(:), agreg_for_cp(:)
double precision, allocatable :: double_buf(:)
@ -222,8 +214,6 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
call wall_time(time0)
endif
logical :: loop, floop
integer :: finalcp
finalcp = N_cp*2
floop = .true.
loop = .true.
@ -232,29 +222,23 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
call pull_dress_results(zmq_socket_pull, ind, cur_cp, delta_loc, int_buf, double_buf, det_buf, N_buf, task_id, dress_mwen)
if(floop) then
call wall_time(time)
print *, "FIRST PULL", time-time0
time0 = time
floop = .false.
end if
if(cur_cp == -1 .and. ind == N_det_generators) then
call wall_time(time)
print *, "FINISHED_CPL", N_cp-1, time-time0
end if
if(cur_cp == -1) then
!print *, "TASK DEL", task_id
call dress_pulled(ind, int_buf, double_buf, det_buf, N_buf)
if (zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,1,more) == -1) then
print *, "TASK ID", task_id
stop 'Unable to delete tasks'
endif
!if(more == 0) stop 'loop = .false.' !!!!!!!!!!!!!!!!
if(more == 0) loop = .false. !stop 'loop = .false.' !!!!!!!!!!!!!!!!
dress_detail(:, ind) = dress_mwen(:)
else if(cur_cp > 0) then
if(ind == 0) cycle
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
do i=1,N_det
cp(:,i,cur_cp,1) += delta_loc(:,i,1)
@ -273,8 +257,7 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
call wall_time(time)
print *, "FINISHED_CP", cur_cp, time-time0
last_cp = cur_cp
double precision :: su, su2, eqt, avg, E0, val
integer, external :: zmq_abort
@ -296,7 +279,7 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
end if
print '(2X, F16.7, 2X, G16.3, 2X, F16.4, A20)', avg+E(istate)+E0, eqt, time-time0, ''
if ((dabs(eqt) < relative_error .and. cps_N(cur_cp) >= 30) .or. cur_cp == N_cp) then
if ((dabs(eqt) < relative_error .and. cps_N(cur_cp) >= 30) .or. cur_cp == cur_cp-2) then
! Termination
print *, "TERMINATE"
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
@ -305,18 +288,14 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
print *, irp_here, ': Error in sending abort signal (2)'
endif
endif
exit pullLoop
endif
end if
end do pullLoop
print *, "exited"
delta(:,:) = cp(:,:,last_cp,1)
delta_s2(:,:) = cp(:,:,last_cp,2)
delta(:,:) = cp(:,:,cur_cp,1)
delta_s2(:,:) = cp(:,:,cur_cp,2)
dress(istate) = E(istate)+E0
dress(istate) = E(istate)+E0+avg
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
end subroutine
@ -405,13 +384,11 @@ END_PROVIDER
integer :: fragsize
fragsize = N_det_generators / ((N_cps_max-1+1)*(N_cps_max-1+2)/2)
print *, "FRAGSIZE", fragsize
do i=1,N_cps_max
cp_limit(i) = fragsize * i * (i+1) / 2
end do
cp_limit(N_cps_max) = N_det*2
print *, "CP_LIMIT", cp_limit
N_dress_jobs = first_det_of_comb - 1
do i=1, N_dress_jobs
@ -420,7 +397,7 @@ END_PROVIDER
end do
l=first_det_of_comb
call random_seed(put=(/321,654,65,321,65/))
call random_seed(put=(/321,654,65,321,65,321,654,65,321,65321,654,65,321,65321,654,65,321,65321,654,65,321,65/))
call RANDOM_NUMBER(comb)
lfiller = 1
nfiller = 1
@ -432,7 +409,6 @@ END_PROVIDER
!if(N_dress_jobs / gen_per_cp > (cur_cp-1) .or. N_dress_jobs == N_det_generators) then
if(N_dress_jobs > cp_limit(cur_cp) .or. N_dress_jobs == N_det_generators) then
print *, "END CUR_CP", cur_cp, N_dress_jobs
first_cp(cur_cp+1) = N_dress_jobs
done_cp_at(N_dress_jobs) = cur_cp
cps_N(cur_cp) = dfloat(i)

2
plugins/dress_zmq/dressing.irp.f
View File

@ -100,7 +100,7 @@ BEGIN_PROVIDER [ double precision, delta_ij_tmp, (N_states,N_det_delta_ij,2) ]
! else
! errr = 1d-4
! end if
relative_error = 0d0! 1.d-5
relative_error = 1.d-5
call write_double(6,relative_error,"Convergence of the stochastic algorithm")

7
plugins/dress_zmq/dressing_vector.irp.f
View File

@ -9,14 +9,16 @@
integer :: i,ii,k,j, l
double precision :: f, tmp
double precision, external :: u_dot_v
logical, external :: detEq
dressing_column_h(:,:) = 0.d0
dressing_column_s(:,:) = 0.d0
do k=1,N_states
do j = 1, n_det
dressing_column_h(j,k) = delta_ij(k,j,1)
dressing_column_s(j,k) = delta_ij(k,j,2)
dressing_column_s(j,k) = delta_ij(k,j,2)
! print *, j, delta_ij(k,j,:)
enddo
! tmp = u_dot_v(dressing_column_h(1,k), psi_coef(1,k), N_det) &
! - dressing_column_h(l,k) * psi_coef(l,k)
@ -25,6 +27,5 @@
! - dressing_column_s(l,k) * psi_coef(l,k)
! dressing_column_s(l,k) -= tmp * f
enddo
END_PROVIDER

149
plugins/dress_zmq/run_dress_slave.irp.f
View File

@ -81,8 +81,10 @@ subroutine run_dress_slave(thread,iproce,energy)
done_for = 0
double precision :: hij, sij
call i_h_j_s2(psi_det(1,1,1),psi_det(1,1,2),N_int,hij, sij)
print *, E0_denominator(1)
!call i_h_j_s2(psi_det(1,1,1),psi_det(1,1,2),N_int,hij, sij)
hij = E0_denominator(1) !PROVIDE BEFORE OMP PARALLEL
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(int_buf, double_buf, det_buf, delta_ij_loc, task, task_id) &
!$OMP PRIVATE(lastSendable, toothMwen, fracted, fac) &
@ -93,7 +95,6 @@ subroutine run_dress_slave(thread,iproce,energy)
zmq_socket_push = new_zmq_push_socket(thread)
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
if(worker_id == -1) then
print *, "WORKER -1"
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
stop "WORKER -1"
@ -106,18 +107,54 @@ subroutine run_dress_slave(thread,iproce,energy)
allocate(det_buf(N_int, 2, N_dress_det_buffer))
allocate(delta_ij_loc(N_states,N_det,2))
do
!!1$OMP CRITICAL (SENDAGE)
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
!!1$OMP END CRITICAL (SENDAGE)
task = task//" 0"
if(task_id == 0) then
print *, "DONEDONE"
exit !! LAST MESSAGE ???
if(task_id == 0) exit
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
if(task_id /= 0) then
read (task,*) subset, i_generator
!$OMP ATOMIC
done_for(done_cp_at_det(i_generator)) += 1
delta_ij_loc(:,:,:) = 0d0
call generator_start(i_generator, iproc)
call alpha_callback(delta_ij_loc, i_generator, subset, iproc)
call generator_done(i_generator, int_buf, double_buf, det_buf, N_buf, iproc)
do i=1,N_cp
fac = cps(i_generator, i) * dress_weight_inv(i_generator) * comb_step
if(fac == 0d0) cycle
call omp_set_lock(lck_sto(i))
cp(:,:,i,1) += (delta_ij_loc(:,:,1) * fac)
cp(:,:,i,2) += (delta_ij_loc(:,:,2) * fac)
call omp_unset_lock(lck_sto(i))
end do
toothMwen = tooth_of_det(i_generator)
fracted = (toothMwen /= 0)
if(fracted) fracted = (i_generator == first_det_of_teeth(toothMwen))
if(fracted) then
call omp_set_lock(lck_det(toothMwen))
call omp_set_lock(lck_det(toothMwen-1))
delta_det(:,:,toothMwen-1, 1) += delta_ij_loc(:,:,1) * (1d0-fractage(toothMwen))
delta_det(:,:,toothMwen-1, 2) += delta_ij_loc(:,:,2) * (1d0-fractage(toothMwen))
delta_det(:,:,toothMwen , 1) += delta_ij_loc(:,:,1) * (fractage(toothMwen))
delta_det(:,:,toothMwen , 2) += delta_ij_loc(:,:,2) * (fractage(toothMwen))
call omp_unset_lock(lck_det(toothMwen))
call omp_unset_lock(lck_det(toothMwen-1))
else
call omp_set_lock(lck_det(toothMwen))
delta_det(:,:,toothMwen , 1) += delta_ij_loc(:,:,1)
delta_det(:,:,toothMwen , 2) += delta_ij_loc(:,:,2)
call omp_unset_lock(lck_det(toothMwen))
end if
call push_dress_results(zmq_socket_push, i_generator, -1, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, task_id)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
lastCp(iproc) = done_cp_at_det(i_generator)
end if
read (task,*) subset, i_generator
if(done_cp_at_det(i_generator) < lastCp(iproc)) stop 'loop = .false.'
!$OMP CRITICAL
send = .false.
lastSendable = N_cp*2
@ -125,18 +162,17 @@ subroutine run_dress_slave(thread,iproce,energy)
lastSendable = min(lastCp(i), lastSendable)
end do
lastSendable -= 1
if(lastSendable > lastSent) then
if(lastSendable > lastSent .or. (lastSendable == N_cp-1 .and. lastSent /= N_cp-1)) then
lastSent = lastSendable
cur_cp = lastSent
send = .true.
end if
!$OMP END CRITICAL
if(send) then
!!1$OMP CRITICAL
N_buf = (/0,1,0/)
delta_ij_loc = 0d0
cur_cp = lastSent
if(cur_cp < 1) stop "cur_cp < 1"
do i=1,cur_cp
delta_ij_loc(:,:,:) += cp(:,:,i,:)
@ -146,61 +182,13 @@ subroutine run_dress_slave(thread,iproce,energy)
do i=cp_first_tooth(cur_cp)-1,0,-1
delta_ij_loc(:,:,:) = delta_ij_loc(:,:,:) +delta_det(:,:,i,:)
end do
!!1$OMP END CRITICAL
!!1$OMP CRITICAL (SENDAGE)
call push_dress_results(zmq_socket_push, done_for(cur_cp), cur_cp, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, -1)
!!1$OMP END CRITICAL (SENDAGE)
end if
!$OMP ATOMIC
done_for(done_cp_at_det(i_generator)) += 1
delta_ij_loc(:,:,:) = 0d0
call generator_start(i_generator, iproc)
call alpha_callback(delta_ij_loc, i_generator, subset, iproc)
call generator_done(i_generator, int_buf, double_buf, det_buf, N_buf, iproc)
!!1$OMP CRITICAL
do i=1,N_cp
fac = cps(i_generator, i) * dress_weight_inv(i_generator) * comb_step
if(fac == 0d0) cycle
call omp_set_lock(lck_sto(i))
cp(:,:,i,1) += (delta_ij_loc(:,:,1) * fac)
cp(:,:,i,2) += (delta_ij_loc(:,:,2) * fac)
call omp_unset_lock(lck_sto(i))
end do
toothMwen = tooth_of_det(i_generator)
fracted = (toothMwen /= 0)
if(fracted) fracted = (i_generator == first_det_of_teeth(toothMwen))
if(fracted) then
call omp_set_lock(lck_det(toothMwen))
call omp_set_lock(lck_det(toothMwen-1))
delta_det(:,:,toothMwen-1, 1) += delta_ij_loc(:,:,1) * (1d0-fractage(toothMwen))
delta_det(:,:,toothMwen-1, 2) += delta_ij_loc(:,:,2) * (1d0-fractage(toothMwen))
delta_det(:,:,toothMwen , 1) += delta_ij_loc(:,:,1) * (fractage(toothMwen))
delta_det(:,:,toothMwen , 2) += delta_ij_loc(:,:,2) * (fractage(toothMwen))
call omp_unset_lock(lck_det(toothMwen))
call omp_unset_lock(lck_det(toothMwen-1))
else
call omp_set_lock(lck_det(toothMwen))
delta_det(:,:,toothMwen , 1) += delta_ij_loc(:,:,1)
delta_det(:,:,toothMwen , 2) += delta_ij_loc(:,:,2)
call omp_unset_lock(lck_det(toothMwen))
end if
!!!&$OMP END CRITICAL
!!1$OMP CRITICAL (SENDAGE)
call push_dress_results(zmq_socket_push, i_generator, -1, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, task_id)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
!!1$OMP END CRITICAL (SENDAGE)
lastCp(iproc) = done_cp_at_det(i_generator)
if(task_id == 0) exit
end do
call sleep(10)
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
!$OMP END PARALLEL
@ -211,7 +199,6 @@ subroutine run_dress_slave(thread,iproce,energy)
do i=0,comb_teeth+1
call omp_destroy_lock(lck_det(i))
end do
stop
end subroutine
@ -220,7 +207,8 @@ end subroutine
subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf, double_buf, det_buf, N_bufi, task_id)
use f77_zmq
implicit none
integer, parameter :: sendt = 4
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
double precision, intent(inout) :: delta_loc(N_states, N_det, 2)
real(kind=4), allocatable :: delta_loc4(:,:,:)
@ -232,7 +220,7 @@ subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf,
integer, intent(in) :: ind, cur_cp, task_id
integer :: rc, i, j, k, l
double precision :: contrib(N_states)
real(4), allocatable :: r4buf(:,:,:)
real(sendt), allocatable :: r4buf(:,:,:)
rc = f77_zmq_send( zmq_socket_push, ind, 4, ZMQ_SNDMORE)
if(rc /= 4) stop "push"
@ -246,16 +234,16 @@ subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf,
do i=1,2
do j=1,N_det
do k=1,N_states
r4buf(k,j,i) = real(delta_loc(k,j,i), 4)
r4buf(k,j,i) = real(delta_loc(k,j,i), sendt)
end do
end do
end do
rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,1), 4*N_states*N_det, ZMQ_SNDMORE)
if(rc /= 4*N_states*N_det) stop "push"
rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,1), sendt*N_states*N_det, ZMQ_SNDMORE)
if(rc /= sendt*N_states*N_det) stop "push"
rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,2), 4*N_states*N_det, ZMQ_SNDMORE)
if(rc /= 4*N_states*N_det) stop "push"
rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,2), sendt*N_states*N_det, ZMQ_SNDMORE)
if(rc /= sendt*N_states*N_det) stop "push"
else
contrib = 0d0
do i=1,N_det
@ -266,7 +254,7 @@ subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf,
if(rc /= 8*N_states) stop "push"
N_buf = N_bufi
N_buf = (/0,1,0/)
!N_buf = (/0,1,0/)
rc = f77_zmq_send( zmq_socket_push, N_buf, 4*3, ZMQ_SNDMORE)
if(rc /= 4*3) stop "push5"
@ -313,6 +301,7 @@ END_PROVIDER
subroutine pull_dress_results(zmq_socket_pull, ind, cur_cp, delta_loc, int_buf, double_buf, det_buf, N_buf, task_id, contrib)
use f77_zmq
implicit none
integer, parameter :: sendt = 4
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer, intent(out) :: cur_cp
double precision, intent(inout) :: delta_loc(N_states, N_det, 2)
@ -335,11 +324,11 @@ subroutine pull_dress_results(zmq_socket_pull, ind, cur_cp, delta_loc, int_buf,
if(cur_cp /= -1) then
rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,1), N_states*4*N_det, 0)
if(rc /= 4*N_states*N_det) stop "pullc"
rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,1), N_states*sendt*N_det, 0)
if(rc /= sendt*N_states*N_det) stop "pullc"
rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,2), N_states*4*N_det, 0)
if(rc /= 4*N_states*N_det) stop "pulld"
rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,2), N_states*sendt*N_det, 0)
if(rc /= sendt*N_states*N_det) stop "pulld"
do i=1,2
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(j,k)

16
plugins/shiftedbk/selection_buffer.irp.f
View File

@ -8,7 +8,6 @@ subroutine create_selection_buffer(N, siz_, res)
integer :: siz
siz = max(siz_,1)
allocate(res%det(N_int, 2, siz), res%val(siz))
res%val(:) = 0d0
@ -18,19 +17,6 @@ subroutine create_selection_buffer(N, siz_, res)
res%cur = 0
end subroutine
subroutine reset_selection_buffer(res)
use selection_types
implicit none
type(selection_buffer), intent(out) :: res
res%val(:) = 0d0
res%det(:,:,:) = 0_8
res%mini = 0d0
res%cur = 0
end subroutine
subroutine delete_selection_buffer(b)
use selection_types
implicit none
@ -53,7 +39,7 @@ subroutine add_to_selection_buffer(b, det, val)
double precision, intent(in) :: val
integer :: i
if(b%N > 0 .and. val < b%mini) then
if(b%N > 0 .and. val <= b%mini) then
b%cur += 1
b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2)
b%val(b%cur) = val

9
plugins/shiftedbk/selection_types.f90 Normal file
View File

@ -0,0 +1,9 @@
module selection_types
type selection_buffer
integer :: N, cur
integer(8) , pointer :: det(:,:,:)
double precision, pointer :: val(:)
double precision :: mini
endtype
end module

16
plugins/shiftedbk/shifted_bk_routines.irp.f
View File

@ -33,7 +33,6 @@ END_PROVIDER
END_PROVIDER
<<<<<<< HEAD
BEGIN_PROVIDER [ integer, N_dress_int_buffer ]
&BEGIN_PROVIDER [ integer, N_dress_double_buffer ]
&BEGIN_PROVIDER [ integer, N_dress_det_buffer ]
@ -197,14 +196,15 @@ subroutine undress_with_alpha(old_generators, old_det_gen, alpha, n_alpha)
c_alpha(:,1) += c_alpha(:,i)
end do
delta_ij_tmp(:,:,:) -= delta_ij_loc(:,:,:,1)
delta_ij_tmp(:,:,1) -= delta_ij_loc(:,:,1,1)
delta_ij_tmp(:,:,2) -= delta_ij_loc(:,:,2,1)
print *, "SUM ALPHA2 PRE", global_sum_alpha2
!print *, "SUM ALPHA2 PRE", global_sum_alpha2
!global_sum_alpha2(:) -= c_alpha(:,1)
print *, "SUM ALPHA2 POST", c_alpha(:,1)
print *, "SUM C_ALPHA^2 ", global_sum_alpha2(:)
print *, "*** DRESSINS DIVIDED BY 1+SUM C_ALPHA^2 ***"
do i=1,N_states
! delta_ij_tmp(i,:,:) = delta_ij_tmp(i,:,:) / (1d0 + global_sum_alpha2(i))
delta_ij_tmp(i,:,:) = delta_ij_tmp(i,:,:) / (1d0 + global_sum_alpha2(i))
end do
global_sum_alpha2 = 0d0
end subroutine
@ -257,6 +257,10 @@ subroutine dress_with_alpha_(Nstates,Ndet,Nint,delta_ij_loc,minilist, det_minili
do l_sd=1,n_minilist
hdress = c_alpha(i) * a_h_i(l_sd, iproc)
sdress = c_alpha(i) * a_s2_i(l_sd, iproc)
!if(c_alpha(i) * a_s2_i(l_sd, iproc) > 1d-1) then
! call debug_det(det_minilist(1,1,l_sd), N_int)
! call debug_det(alpha,N_int)
!end if
delta_ij_loc(i, minilist(l_sd), 1) += hdress
delta_ij_loc(i, minilist(l_sd), 2) += sdress
end do