mirror of
https://github.com/LCPQ/quantum_package
synced 2024-08-26 14:31:44 +02:00
shifted-bk selection iterates
This commit is contained in:
parent
9823fed7be
commit
7cc33f1ab3
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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")
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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
9
plugins/shiftedbk/selection_types.f90
Normal 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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user