From 7cc33f1ab385f377ac597328fb613d31d10f9e85 Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Mon, 14 May 2018 13:00:04 +0200 Subject: [PATCH] shifted-bk selection iterates --- plugins/dress_zmq/dress_slave.irp.f | 1 - plugins/dress_zmq/dress_stoch_routines.irp.f | 40 +---- plugins/dress_zmq/dressing.irp.f | 2 +- plugins/dress_zmq/dressing_vector.irp.f | 7 +- plugins/dress_zmq/run_dress_slave.irp.f | 149 +++++++++---------- plugins/shiftedbk/selection_buffer.irp.f | 16 +- plugins/shiftedbk/selection_types.f90 | 9 ++ plugins/shiftedbk/shifted_bk_routines.irp.f | 16 +- 8 files changed, 102 insertions(+), 138 deletions(-) create mode 100644 plugins/shiftedbk/selection_types.f90 diff --git a/plugins/dress_zmq/dress_slave.irp.f b/plugins/dress_zmq/dress_slave.irp.f index b752507b..75c31422 100644 --- a/plugins/dress_zmq/dress_slave.irp.f +++ b/plugins/dress_zmq/dress_slave.irp.f @@ -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 diff --git a/plugins/dress_zmq/dress_stoch_routines.irp.f b/plugins/dress_zmq/dress_stoch_routines.irp.f index 106025cb..d8fec690 100644 --- a/plugins/dress_zmq/dress_stoch_routines.irp.f +++ b/plugins/dress_zmq/dress_stoch_routines.irp.f @@ -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) diff --git a/plugins/dress_zmq/dressing.irp.f b/plugins/dress_zmq/dressing.irp.f index 85279029..bbca0c39 100644 --- a/plugins/dress_zmq/dressing.irp.f +++ b/plugins/dress_zmq/dressing.irp.f @@ -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") diff --git a/plugins/dress_zmq/dressing_vector.irp.f b/plugins/dress_zmq/dressing_vector.irp.f index 5a8fee3b..5a528c36 100644 --- a/plugins/dress_zmq/dressing_vector.irp.f +++ b/plugins/dress_zmq/dressing_vector.irp.f @@ -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 diff --git a/plugins/dress_zmq/run_dress_slave.irp.f b/plugins/dress_zmq/run_dress_slave.irp.f index 339f78b7..7135c9cf 100644 --- a/plugins/dress_zmq/run_dress_slave.irp.f +++ b/plugins/dress_zmq/run_dress_slave.irp.f @@ -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) diff --git a/plugins/shiftedbk/selection_buffer.irp.f b/plugins/shiftedbk/selection_buffer.irp.f index 23f83f02..17410b7b 100644 --- a/plugins/shiftedbk/selection_buffer.irp.f +++ b/plugins/shiftedbk/selection_buffer.irp.f @@ -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 diff --git a/plugins/shiftedbk/selection_types.f90 b/plugins/shiftedbk/selection_types.f90 new file mode 100644 index 00000000..29e48524 --- /dev/null +++ b/plugins/shiftedbk/selection_types.f90 @@ -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 + diff --git a/plugins/shiftedbk/shifted_bk_routines.irp.f b/plugins/shiftedbk/shifted_bk_routines.irp.f index 6dec4bb7..c022a88d 100644 --- a/plugins/shiftedbk/shifted_bk_routines.irp.f +++ b/plugins/shiftedbk/shifted_bk_routines.irp.f @@ -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