From db3c8bb87bbfb1e4cb874f32a17468269d76e8d8 Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Thu, 1 Sep 2016 14:43:13 +0200 Subject: [PATCH 1/8] init - not working --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 64 ++- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 154 ++++++ plugins/Full_CI_ZMQ/selection.irp.f | 487 +----------------- plugins/Full_CI_ZMQ/selection_buffer.irp.f | 70 +++ plugins/Full_CI_ZMQ/selection_slave.irp.f | 3 +- src/Determinants/determinants.irp.f | 108 ++++ src/Determinants/slater_rules.irp.f | 137 +++-- 7 files changed, 499 insertions(+), 524 deletions(-) create mode 100644 plugins/Full_CI_ZMQ/run_selection_slave.irp.f create mode 100644 plugins/Full_CI_ZMQ/selection_buffer.irp.f diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 0577a408..98b0ec2e 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -53,14 +53,6 @@ program fci_zmq endif call diagonalize_CI call save_wavefunction - ! chk = 0_8 - ! do i=1, N_det - ! do k=1, N_int - ! chk = xor(psi_det(k,1,i), chk) - ! chk = xor(psi_det(k,2,i), chk) - ! end do - ! end do - ! print *, "CHK ", chk print *, 'N_det = ', N_det print *, 'N_states = ', N_states @@ -163,6 +155,60 @@ subroutine selection_dressing_slave_inproc(i) implicit none integer, intent(in) :: i - call selection_slaved(1,i,ci_electronic_energy) + call run_selection_slave(1,i,ci_electronic_energy) end +subroutine selection_collector(b, pt2) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + type(selection_buffer), intent(inout) :: b + double precision, intent(out) :: pt2(N_states) + double precision :: pt2_mwen(N_states) + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + integer :: done + real :: time, time0 + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) + done = 0 + more = 1 + pt2(:) = 0d0 + call CPU_TIME(time0) + do while (more == 1) + call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) + pt2 += pt2_mwen + do i=1, N + call add_to_selection_buffer(b, det(1,1,i), val(i)) + end do + + do i=1, ntask + if(task_id(i) == 0) then + print *, "Error in collector" + endif + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) + end do + done += ntask + call CPU_TIME(time) +! print *, "DONE" , done, time - time0 + end do + + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + call sort_selection_buffer(b) +end subroutine + diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f new file mode 100644 index 00000000..7bc1a7ef --- /dev/null +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -0,0 +1,154 @@ + +subroutine run_selection_slave(thread,iproc,energy) + use f77_zmq + use selection_types + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, task_id(1), ctask, ltask + character*(512) :: task + + 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) :: buf, buf2 + logical :: done + double precision :: pt2(N_states) + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + 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 disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + return + end if + buf%N = 0 + ctask = 1 + pt2 = 0d0 + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) + done = task_id(ctask) == 0 + if (done) then + ctask = ctask - 1 + else + integer :: i_generator, i_generator_start, i_generator_max, step, N + read (task,*) i_generator_start, i_generator_max, step, N + if(buf%N == 0) then + ! Only first time + call create_selection_buffer(N, N*2, buf) + call create_selection_buffer(N, N*3, buf2) + else + if(N /= buf%N) stop "N changed... wtf man??" + end if + !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) + !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) + do i_generator=i_generator_start,i_generator_max,step + call select_connected(i_generator,energy,pt2,buf) + enddo + endif + + if(done .or. ctask == size(task_id)) then + if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer" + do i=1, ctask + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) + end do + if(ctask > 0) then + call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) + do i=1,buf%cur + call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) + enddo + call sort_selection_buffer(buf2) + buf%mini = buf2%mini + pt2 = 0d0 + buf%cur = 0 + end if + ctask = 0 + end if + + if(done) exit + ctask = ctask + 1 + end do + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) +end subroutine + + +subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(in) :: pt2(N_states) + type(selection_buffer), intent(inout) :: b + integer, intent(in) :: ntask, task_id(*) + integer :: rc + + call sort_selection_buffer(b) + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE) + if(rc /= 8*N_states) stop "push" + + rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE) + if(rc /= 8*b%cur) stop "push" + + rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE) + if(rc /= bit_kind*N_int*2*b%cur) stop "push" + + rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + + rc = f77_zmq_send( zmq_socket_push, task_id(1), ntask*4, 0) + if(rc /= 4*ntask) stop "push" + +! Activate is zmq_socket_push is a REQ +! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) +end subroutine + + +subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, ntask) + use f77_zmq + use selection_types + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + double precision, intent(inout) :: pt2(N_states) + double precision, intent(out) :: val(*) + integer(bit_kind), intent(out) :: det(N_int, 2, *) + integer, intent(out) :: N, ntask, task_id(*) + integer :: rc, rn, i + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0) + if(rc /= 8*N_states) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0) + if(rc /= 8*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0) + if(rc /= bit_kind*N_int*2*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntask*4, 0) + if(rc /= 4*ntask) stop "pull" + +! Activate is zmq_socket_pull is a REP +! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index b31e1977..a34ef1ae 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -11,162 +11,8 @@ BEGIN_PROVIDER [ double precision, integral8, (mo_tot_num, mo_tot_num, mo_tot_n END_PROVIDER -subroutine selection_slaved(thread,iproc,energy) - use f77_zmq - use selection_types - implicit none - - double precision, intent(in) :: energy(N_states_diag) - integer, intent(in) :: thread, iproc - integer :: rc, i - - integer :: worker_id, task_id(1), ctask, ltask - character*(512) :: task - - 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) :: buf, buf2 - logical :: done - double precision :: pt2(N_states) - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - 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 disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_push_socket(zmq_socket_push,thread) - return - end if - buf%N = 0 - ctask = 1 - pt2 = 0d0 - - do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) - done = task_id(ctask) == 0 - if (done) then - ctask = ctask - 1 - else - integer :: i_generator, i_generator_start, i_generator_max, step, N - read (task,*) i_generator_start, i_generator_max, step, N - if(buf%N == 0) then - ! Only first time - call create_selection_buffer(N, N*2, buf) - call create_selection_buffer(N, N*3, buf2) - else - if(N /= buf%N) stop "N changed... wtf man??" - end if - !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) - !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) - do i_generator=i_generator_start,i_generator_max,step - call select_connected(i_generator,energy,pt2,buf) - enddo - endif - - if(done .or. ctask == size(task_id)) then - if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer" - do i=1, ctask - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) - end do - if(ctask > 0) then - call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) - do i=1,buf%cur - call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) - enddo - call sort_selection_buffer(buf2) - buf%mini = buf2%mini - pt2 = 0d0 - buf%cur = 0 - end if - ctask = 0 - end if - - if(done) exit - ctask = ctask + 1 - end do - call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_push_socket(zmq_socket_push,thread) -end subroutine - - -subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) - use f77_zmq - use selection_types - implicit none - - integer(ZMQ_PTR), intent(in) :: zmq_socket_push - double precision, intent(in) :: pt2(N_states) - type(selection_buffer), intent(inout) :: b - integer, intent(in) :: ntask, task_id(*) - integer :: rc - - call sort_selection_buffer(b) - - rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) - if(rc /= 4) stop "push" - rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE) - if(rc /= 8*N_states) stop "push" - - rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE) - if(rc /= 8*b%cur) stop "push" - - rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE) - if(rc /= bit_kind*N_int*2*b%cur) stop "push" - - rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE) - if(rc /= 4) stop "push" - - rc = f77_zmq_send( zmq_socket_push, task_id(1), ntask*4, 0) - if(rc /= 4*ntask) stop "push" - -! Activate is zmq_socket_push is a REQ -! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) -end subroutine - - -subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, ntask) - use f77_zmq - use selection_types - implicit none - integer(ZMQ_PTR), intent(in) :: zmq_socket_pull - double precision, intent(inout) :: pt2(N_states) - double precision, intent(out) :: val(*) - integer(bit_kind), intent(out) :: det(N_int, 2, *) - integer, intent(out) :: N, ntask, task_id(*) - integer :: rc, rn, i - - rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) - if(rc /= 4) stop "pull" - - rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0) - if(rc /= 8*N_states) stop "pull" - - rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0) - if(rc /= 8*N) stop "pull" - - rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0) - if(rc /= bit_kind*N_int*2*N) stop "pull" - - rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0) - if(rc /= 4) stop "pull" - - rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntask*4, 0) - if(rc /= 4*ntask) stop "pull" - -! Activate is zmq_socket_pull is a REP -! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) -end subroutine - - subroutine select_connected(i_generator,E0,pt2,b) - use f77_zmq + !use f77_zmq use bitmasks use selection_types implicit none @@ -199,133 +45,9 @@ subroutine select_connected(i_generator,E0,pt2,b) end -subroutine create_selection_buffer(N, siz, res) - use selection_types - implicit none - - integer, intent(in) :: N, siz - type(selection_buffer), intent(out) :: res - - allocate(res%det(N_int, 2, siz), res%val(siz)) - - res%val = 0d0 - res%det = 0_8 - res%N = N - res%mini = 0d0 - res%cur = 0 -end subroutine - - -subroutine add_to_selection_buffer(b, det, val) - use selection_types - implicit none - - type(selection_buffer), intent(inout) :: b - integer(bit_kind), intent(in) :: det(N_int, 2) - double precision, intent(in) :: val - integer :: i - - if(dabs(val) >= b%mini) then - b%cur += 1 - b%det(:,:,b%cur) = det(:,:) - b%val(b%cur) = val - if(b%cur == size(b%val)) then - call sort_selection_buffer(b) - end if - end if -end subroutine - - -subroutine sort_selection_buffer(b) - use selection_types - implicit none - - type(selection_buffer), intent(inout) :: b - double precision, allocatable :: vals(:), absval(:) - integer, allocatable :: iorder(:) - integer(bit_kind), allocatable :: detmp(:,:,:) - integer :: i, nmwen - logical, external :: detEq - nmwen = min(b%N, b%cur) - - - allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen)) - absval = -dabs(b%val(:b%cur)) - do i=1,b%cur - iorder(i) = i - end do - call dsort(absval, iorder, b%cur) - - do i=1, nmwen - detmp(:,:,i) = b%det(:,:,iorder(i)) - vals(i) = b%val(iorder(i)) - end do - b%det(:,:,:nmwen) = detmp(:,:,:) - b%det(:,:,nmwen+1:) = 0_bit_kind - b%val(:nmwen) = vals(:) - b%val(nmwen+1:) = 0d0 - b%mini = max(b%mini,dabs(b%val(b%N))) - b%cur = nmwen -end subroutine - - -subroutine selection_collector(b, pt2) - use f77_zmq - use selection_types - use bitmasks - implicit none - - - type(selection_buffer), intent(inout) :: b - double precision, intent(out) :: pt2(N_states) - double precision :: pt2_mwen(N_states) - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer :: msg_size, rc, more - integer :: acc, i, j, robin, N, ntask - double precision, allocatable :: val(:) - integer(bit_kind), allocatable :: det(:,:,:) - integer, allocatable :: task_id(:) - integer :: done - real :: time, time0 - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) - done = 0 - more = 1 - pt2(:) = 0d0 - call CPU_TIME(time0) - do while (more == 1) - call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) - pt2 += pt2_mwen - do i=1, N - call add_to_selection_buffer(b, det(1,1,i), val(i)) - end do - - do i=1, ntask - if(task_id(i) == 0) then - print *, "Error in collector" - endif - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) - end do - done += ntask - call CPU_TIME(time) -! print *, "DONE" , done, time - time0 - end do - - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - call sort_selection_buffer(b) -end subroutine - subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use f77_zmq + !use f77_zmq use bitmasks use selection_types implicit none @@ -477,7 +199,7 @@ end subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use f77_zmq + !use f77_zmq use bitmasks use selection_types implicit none @@ -647,13 +369,13 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p call check_past_s(exc_det, microlist(1,1,ptr_microlist(sporb)), N_microlist(sporb) - N_futur_microlist(sporb), nok, N_int) if(nok) cycle !DET DRIVEN -! if(N_futur_microlist(0) > 0) then -! call i_H_psi(exc_det,microlist(1,1,ptr_futur_microlist(0)),psi_coef_microlist(ptr_futur_microlist(0), 1),N_int,N_futur_microlist(0),psi_selectors_size*4,N_states,i_H_psi_value) -! end if + if(N_futur_microlist(0) > 0) then + call i_H_psi(exc_det,microlist(1,1,ptr_futur_microlist(0)),psi_coef_microlist(ptr_futur_microlist(0), 1),N_int,N_futur_microlist(0),psi_selectors_size*4,N_states,i_H_psi_value) + end if !INTEGRAL DRIVEN - do j=1, N_states - i_H_psi_value(j) = d0s(mod(p1-1, mo_tot_num)+1, mod(p2-1, mo_tot_num)+1, j) - end do +! do j=1, N_states +! i_H_psi_value(j) = d0s(mod(p1-1, mo_tot_num)+1, mod(p2-1, mo_tot_num)+1, j) +! end do if(N_futur_microlist(sporb) > 0) then @@ -681,7 +403,7 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p i_H_psi_value = i_H_psi_value + i_H_psi_value2 end if - if(.false.) then ! DET DRIVEN + if(.true.) then ! DET DRIVEN integer :: c1, c2 double precision :: hij c1 = ptr_futur_tmicrolist(p1) @@ -1071,7 +793,7 @@ subroutine create_microlist_double(minilist, i_cur, N_minilist, key_mask, microl ! end do ! end do ! end do - else if(.true. .and. n_element(1, i) + n_element(2, i) == 3) then ! INTEGRAL DRIVEN + else if(.false. .and. n_element(1, i) + n_element(2, i) == 3) then ! INTEGRAL DRIVEN ! -459.6399263191298 pweni = 0 do s = 1, 2 @@ -1166,14 +888,13 @@ subroutine get_d1(gen, banned, banned_pair, mat, mask, pwen, coefs) exc(1, 1, 2) = p(a1) exc(1, 2, sfix) = pfix - tmp_array = (/0, 0 ,s(i), p(i) /) - call apply_particle(mask, tmp_array, deth, ok, N_int) + call apply_particle(mask, 0, 0 ,s(i), p(i), deth, ok, N_int) do j=1,mo_tot_num mwen = j + (sm-1)*mo_tot_num if(lbanned(mwen)) cycle tmp_array = (/0,0,sm,j/) - call apply_particle(deth, tmp_array, det, ok, N_int) + call apply_particle(deth, 0, 0 ,s(i), p(i), det, ok, N_int) if(.not. ok) cycle mono = mwen == pwen(a1) .or. mwen == pwen(a2) @@ -1216,14 +937,13 @@ subroutine get_d1(gen, banned, banned_pair, mat, mask, pwen, coefs) exc(1, 1, sp) = min(h1, h2) exc(2, 1, sp) = max(h1, h2) - tmp_array = (/0, 0 ,s(i), p(i) /) - call apply_particle(mask, tmp_array, deth, ok, N_int) + call apply_particle(mask, 0, 0 ,s(i), p(i) , deth, ok, N_int) do j=1,mo_tot_num if(j == pfix) inv = -inv mwen = j + (sm-1)*mo_tot_num if(lbanned(mwen)) cycle - call apply_particle(deth, tmp_array, det, ok, N_int) + call apply_particle(deth, 0, 0 ,s(i), p(i) , det, ok, N_int) if(.not. ok) cycle mono = mwen == pwen(a1) .or. mwen == pwen(a2) @@ -1293,8 +1013,8 @@ subroutine get_d0(gen, banned, banned_pair, mat, mask, s1, s2, h1, h2, coefs) if(banned(p1 + ns1)) cycle if(p1 == p2) cycle if(banned_pair(p1 + ns1, p2 + ns2)) cycle - tmp_array = (/s1,p1,s2,p2/) - call apply_particle(mask, tmp_array, det2, ok, N_int) + !tmp_array = (/s1,p1,s2,p2/) + call apply_particle(mask, s1,p1,s2,p2, det2, ok, N_int) if(.not. ok) cycle mono = (hmi == p1 .or. hma == p2 .or. hmi == p2 .or. hma == p1) if(mono) then @@ -1325,8 +1045,8 @@ subroutine get_d0(gen, banned, banned_pair, mat, mask, s1, s2, h1, h2, coefs) do p1=1, mo_tot_num if(banned(p1 + ns1)) cycle if(banned_pair(p1 + ns1, p2 + ns2)) cycle - tmp_array = (/s1,p1,s2,p2/) - call apply_particle(mask, tmp_array, det2, ok, N_int) + !tmp_array = (/s1,p1,s2,p2/) + call apply_particle(mask, s1,p1,s2,p2, det2, ok, N_int) if(.not. ok) cycle mono = (h1 == p1 .or. h2 == p2) if(mono) then @@ -1349,174 +1069,6 @@ subroutine get_d0(gen, banned, banned_pair, mat, mask, s1, s2, h1, h2, coefs) end subroutine -subroutine apply_particle(det, exc, res, ok, Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint - integer, intent(in) :: exc(4) - integer :: s1, s2, p1, p2 - integer(bit_kind),intent(in) :: det(Nint, 2) - integer(bit_kind),intent(out) :: res(Nint, 2) - logical, intent(out) :: ok - integer :: ii, pos - - ok = .false. - s1 = exc(1) - p1 = exc(2) - s2 = exc(3) - p2 = exc(4) - res = det - - if(p1 /= 0) then - ii = (p1-1)/bit_kind_size + 1 - pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) - if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return - res(ii, s1) = ibset(res(ii, s1), pos) - end if - - ii = (p2-1)/bit_kind_size + 1 - pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) - if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return - res(ii, s2) = ibset(res(ii, s2), pos) - - ok = .true. -end subroutine - - -subroutine apply_hole(det, exc, res, ok, Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint - integer, intent(in) :: exc(4) - integer :: s1, s2, p1, p2 - integer(bit_kind),intent(in) :: det(Nint, 2) - integer(bit_kind),intent(out) :: res(Nint, 2) - logical, intent(out) :: ok - integer :: ii, pos - - ok = .false. - s1 = exc(1) - p1 = exc(2) - s2 = exc(3) - p2 = exc(4) - res = det - - if(p1 /= 0) then - ii = (p1-1)/bit_kind_size + 1 - pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) - if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return - res(ii, s1) = ibclr(res(ii, s1), pos) - end if - - ii = (p2-1)/bit_kind_size + 1 - pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) - if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return - res(ii, s2) = ibclr(res(ii, s2), pos) - - ok = .true. -end subroutine - - - -subroutine get_double_excitation_phase(det1,det2,exc,phase,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Returns the two excitation operators between two doubly excited determinants and the phase - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: det1(Nint,2) - integer(bit_kind), intent(in) :: det2(Nint,2) - integer, intent(in) :: exc(0:2,2,2) - double precision, intent(out) :: phase - integer :: tz - integer :: l, ispin, idx_hole, idx_particle, ishift - integer :: nperm - integer :: i,j,k,m,n - integer :: high, low - integer :: a,b,c,d - integer(bit_kind) :: hole, particle, tmp - double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) - - ASSERT (Nint > 0) - nperm = 0 - do ispin = 1,2 - select case (exc(0,1,ispin)) - case(0) - cycle - - case(1) - low = min(exc(1,1,ispin), exc(1,2,ispin)) - high = max(exc(1,1,ispin), exc(1,2,ispin)) - - ASSERT (low > 0) - j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) - n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) - ASSERT (high > 0) - k = ishft(high-1,-bit_kind_shift)+1 - m = iand(high-1,bit_kind_size-1)+1 - - if (j==k) then - nperm = nperm + popcnt(iand(det1(j,ispin), & - iand( ibset(0_bit_kind,m-1)-1_bit_kind, & - ibclr(-1_bit_kind,n)+1_bit_kind ) )) - else - nperm = nperm + popcnt(iand(det1(k,ispin), & - ibset(0_bit_kind,m-1)-1_bit_kind)) - if (n < bit_kind_size) then - nperm = nperm + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) - endif - do i=j+1,k-1 - nperm = nperm + popcnt(det1(i,ispin)) - end do - endif - - case (2) - - do i=1,2 - low = min(exc(i,1,ispin), exc(i,2,ispin)) - high = max(exc(i,1,ispin), exc(i,2,ispin)) - - ASSERT (low > 0) - j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) - n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) - ASSERT (high > 0) - k = ishft(high-1,-bit_kind_shift)+1 - m = iand(high-1,bit_kind_size-1)+1 - - if (j==k) then - nperm = nperm + popcnt(iand(det1(j,ispin), & - iand( ibset(0_bit_kind,m-1)-1_bit_kind, & - ibclr(-1_bit_kind,n)+1_bit_kind ) )) - else - nperm = nperm + popcnt(iand(det1(k,ispin), & - ibset(0_bit_kind,m-1)-1_bit_kind)) - if (n < bit_kind_size) then - nperm = nperm + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) - endif - do l=j+1,k-1 - nperm = nperm + popcnt(det1(l,ispin)) - end do - endif - - enddo - - a = min(exc(1,1,ispin), exc(1,2,ispin)) - b = max(exc(1,1,ispin), exc(1,2,ispin)) - c = min(exc(2,1,ispin), exc(2,2,ispin)) - d = max(exc(2,1,ispin), exc(2,2,ispin)) - if (c>a .and. cb) then - nperm = nperm + 1 - endif - exit - end select - - enddo - phase = phase_dble(iand(nperm,1)) -end - - - subroutine check_past(det, list, idx, N, cur, ok, Nint) implicit none use bitmasks @@ -1562,4 +1114,3 @@ subroutine check_past_s(det, list, N, ok, Nint) end if end do end subroutine - diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f new file mode 100644 index 00000000..2bcb11d3 --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -0,0 +1,70 @@ + +subroutine create_selection_buffer(N, siz, res) + use selection_types + implicit none + + integer, intent(in) :: N, siz + type(selection_buffer), intent(out) :: res + + allocate(res%det(N_int, 2, siz), res%val(siz)) + + res%val = 0d0 + res%det = 0_8 + res%N = N + res%mini = 0d0 + res%cur = 0 +end subroutine + + +subroutine add_to_selection_buffer(b, det, val) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + integer(bit_kind), intent(in) :: det(N_int, 2) + double precision, intent(in) :: val + integer :: i + + if(dabs(val) >= b%mini) then + b%cur += 1 + b%det(:,:,b%cur) = det(:,:) + b%val(b%cur) = val + if(b%cur == size(b%val)) then + call sort_selection_buffer(b) + end if + end if +end subroutine + + +subroutine sort_selection_buffer(b) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + double precision, allocatable :: vals(:), absval(:) + integer, allocatable :: iorder(:) + integer(bit_kind), allocatable :: detmp(:,:,:) + integer :: i, nmwen + logical, external :: detEq + nmwen = min(b%N, b%cur) + + + allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen)) + absval = -dabs(b%val(:b%cur)) + do i=1,b%cur + iorder(i) = i + end do + call dsort(absval, iorder, b%cur) + + do i=1, nmwen + detmp(:,:,i) = b%det(:,:,iorder(i)) + vals(i) = b%val(iorder(i)) + end do + b%det(:,:,:nmwen) = detmp(:,:,:) + b%det(:,:,nmwen+1:) = 0_bit_kind + b%val(:nmwen) = vals(:) + b%val(nmwen+1:) = 0d0 + b%mini = max(b%mini,dabs(b%val(b%N))) + b%cur = nmwen +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 7eeae798..ff87b479 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -9,7 +9,6 @@ program selection_slave call provide_everything call switch_qp_run_to_master call run_wf - end subroutine provide_everything @@ -80,6 +79,6 @@ subroutine selection_dressing_slave_tcp(i,energy) double precision, intent(in) :: energy(N_states_diag) integer, intent(in) :: i - call selection_slaved(0,i,energy) + call run_selection_slave(0,i,energy) end diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 63617352..258f5391 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -723,3 +723,111 @@ integer function detCmp(a,b,Nint) end function +subroutine apply_excitation(det, exc, res, ok, Nint) + use bitmasks + implicit none + + integer, intent(in) :: Nint + integer, intent(in) :: exc(0:2,2,2) + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: h1,p1,h2,p2,s1,s2,degree + integer :: ii, pos + + + ok = .false. + degree = exc(0,1,1) + exc(0,1,2) + + if(.not. (degree > 0 .and. degree <= 2)) then + print *, degree + print *, "apply ex" + STOP + endif + + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + res = det + + ii = (h1-1)/bit_kind_size + 1 + pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) ! mod 64 + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s1) = ibclr(res(ii, s1), pos) + + ii = (p1-1)/bit_kind_size + 1 + pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s1) = ibset(res(ii, s1), pos) + + if(degree == 2) then + ii = (h2-1)/bit_kind_size + 1 + pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s2) = ibclr(res(ii, s2), pos) + + ii = (p2-1)/bit_kind_size + 1 + pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s2) = ibset(res(ii, s2), pos) + endif + + ok = .true. +end subroutine + + +subroutine apply_particle(det, s1, p1, s2, p2, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: s1, p1, s2, p2 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + res = det + + if(p1 /= 0) then + ii = (p1-1)/bit_kind_size + 1 + pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s1) = ibset(res(ii, s1), pos) + end if + + ii = (p2-1)/bit_kind_size + 1 + pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s2) = ibset(res(ii, s2), pos) + + ok = .true. +end subroutine + + +subroutine apply_hole(det, s1, h1, s2, h2, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: s1, h1, s2, h2 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + res = det + + if(h1 /= 0) then + ii = (h1-1)/bit_kind_size + 1 + pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s1) = ibclr(res(ii, s1), pos) + end if + + ii = (h2-1)/bit_kind_size + 1 + pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s2) = ibclr(res(ii, s2), pos) + + ok = .true. +end subroutine + diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 133d9e52..99cd27b4 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1781,53 +1781,100 @@ subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) end -subroutine apply_excitation(det, exc, res, ok, Nint) +subroutine get_double_excitation_phase(det1,det2,exc,phase,Nint) use bitmasks implicit none - integer, intent(in) :: Nint - integer, intent(in) :: exc(0:2,2,2) - integer(bit_kind),intent(in) :: det(Nint, 2) - integer(bit_kind),intent(out) :: res(Nint, 2) - logical, intent(out) :: ok - integer :: h1,p1,h2,p2,s1,s2,degree - integer :: ii, pos - - - ok = .false. - degree = exc(0,1,1) + exc(0,1,2) - - if(.not. (degree > 0 .and. degree <= 2)) then - print *, degree - print *, "apply ex" - STOP - endif - - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - res = det - - ii = (h1-1)/bit_kind_size + 1 - pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) ! mod 64 - if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return - res(ii, s1) = ibclr(res(ii, s1), pos) - - ii = (p1-1)/bit_kind_size + 1 - pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) - if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return - res(ii, s1) = ibset(res(ii, s1), pos) - - if(degree == 2) then - ii = (h2-1)/bit_kind_size + 1 - pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1) - if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return - res(ii, s2) = ibclr(res(ii, s2), pos) - - ii = (p2-1)/bit_kind_size + 1 - pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) - if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return - res(ii, s2) = ibset(res(ii, s2), pos) - endif + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(in) :: det2(Nint,2) + integer, intent(in) :: exc(0:2,2,2) + double precision, intent(out) :: phase + integer :: tz + integer :: l, ispin, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) + + ASSERT (Nint > 0) + nperm = 0 + do ispin = 1,2 + select case (exc(0,1,ispin)) + case(0) + cycle + + case(1) + low = min(exc(1,1,ispin), exc(1,2,ispin)) + high = max(exc(1,1,ispin), exc(1,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high-1,bit_kind_size-1)+1 + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j,ispin), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k,ispin), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + if (n < bit_kind_size) then + nperm = nperm + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) + endif + do i=j+1,k-1 + nperm = nperm + popcnt(det1(i,ispin)) + end do + endif + + case (2) + + do i=1,2 + low = min(exc(i,1,ispin), exc(i,2,ispin)) + high = max(exc(i,1,ispin), exc(i,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high-1,bit_kind_size-1)+1 + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j,ispin), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k,ispin), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + if (n < bit_kind_size) then + nperm = nperm + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) + endif + do l=j+1,k-1 + nperm = nperm + popcnt(det1(l,ispin)) + end do + endif + + enddo + + a = min(exc(1,1,ispin), exc(1,2,ispin)) + b = max(exc(1,1,ispin), exc(1,2,ispin)) + c = min(exc(2,1,ispin), exc(2,2,ispin)) + d = max(exc(2,1,ispin), exc(2,2,ispin)) + if (c>a .and. cb) then + nperm = nperm + 1 + endif + exit + end select + + enddo + phase = phase_dble(iand(nperm,1)) +end + - ok = .true. -end subroutine From 18084047e4c9fccf1019624409ddc2ada80fa581 Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Mon, 5 Sep 2016 17:16:09 +0200 Subject: [PATCH 2/8] compiles - does not work --- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 2 + plugins/Full_CI_ZMQ/selection.irp.f | 1278 +++-------------- plugins/Full_CI_ZMQ/selection_double.irp.f | 512 +++++++ plugins/Full_CI_ZMQ/selection_single.irp.f | 333 +++++ src/Determinants/determinants.irp.f | 46 +- 5 files changed, 1053 insertions(+), 1118 deletions(-) create mode 100644 plugins/Full_CI_ZMQ/selection_double.irp.f create mode 100644 plugins/Full_CI_ZMQ/selection_single.irp.f diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 7bc1a7ef..36550116 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -152,3 +152,5 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, nt ! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) end subroutine + + diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index a34ef1ae..d3d8e30b 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,1116 +1,162 @@ - - -BEGIN_PROVIDER [ double precision, integral8, (mo_tot_num, mo_tot_num, mo_tot_num, mo_tot_num) ] - integral8 = 0d0 - integer :: h1, h2 - do h1=1, mo_tot_num - do h2=1, mo_tot_num - call get_mo_bielec_integrals_ij(h1, h2 ,mo_tot_num,integral8(1,1,h1,h2),mo_integrals_map) - end do - end do -END_PROVIDER - - -subroutine select_connected(i_generator,E0,pt2,b) - !use f77_zmq - use bitmasks - use selection_types - implicit none - integer, intent(in) :: i_generator - type(selection_buffer), intent(inout) :: b - double precision, intent(inout) :: pt2(N_states) - integer :: k,l - double precision, intent(in) :: E0(N_states) - - integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision :: fock_diag_tmp(2,mo_tot_num+1) - - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - do l=1,N_generators_bitmask - do k=1,N_int - hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) - hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) - particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) - particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) - - hole_mask(k,1) = ior(generators_bitmask(k,1,s_hole,l), generators_bitmask(k,1,s_part,l)) - hole_mask(k,2) = ior(generators_bitmask(k,2,s_hole,l), generators_bitmask(k,2,s_part,l)) - particle_mask(k,:) = hole_mask(k,:) - enddo - - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - enddo -end - - - -subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - !use f77_zmq - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_generator - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(inout) :: pt2(N_states) - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: E0(N_states) - type(selection_buffer), intent(inout) :: buf - - integer :: i,j,k,l - - integer :: msg_size - msg_size = bit_kind*N_int*2 - - ! Apply hole and particle masks - ! ----------------------------- - - integer(bit_kind) :: hole(N_int,2), particle(N_int,2) - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - ! Create excited determinants - ! --------------------------- - - integer :: ispin, other_spin - integer(bit_kind) :: exc_det(N_int,2), ion_det(N_int,2) - - do k=1,N_int - exc_det(k,1) = psi_det_generators(k,1,i_generator) - exc_det(k,2) = psi_det_generators(k,2,i_generator) - ion_det(k,1) = psi_det_generators(k,1,i_generator) - ion_det(k,2) = psi_det_generators(k,2,i_generator) - enddo - - - - integer :: ptr_microlist(0:mo_tot_num * 2 + 1), N_microlist(0:mo_tot_num * 2) - integer, allocatable :: idx_microlist(:) - integer(bit_kind), allocatable :: microlist(:, :, :) - double precision, allocatable :: psi_coef_microlist(:,:) - - allocate(microlist(N_int, 2, N_det_selectors * 3), psi_coef_microlist(psi_selectors_size * 3, N_states), idx_microlist(N_det_selectors * 3)) - - do ispin=1,2 - - - do i=1, N_holes(ispin) - ion_det(:,:) = psi_det_generators(:,:,i_generator) - integer :: i_hole - i_hole = hole_list(i,ispin) - - ! Apply the hole - integer :: j_hole, k_hole - k_hole = ishft(i_hole-1,-bit_kind_shift)+1 ! N_int - j_hole = i_hole-ishft(k_hole-1,bit_kind_shift)-1 ! bit index - ion_det(k_hole,ispin) = ibclr(ion_det(k_hole,ispin),j_hole) - - - call create_microlist_single(psi_selectors, i_generator, N_det_selectors, ion_det, microlist, idx_microlist, N_microlist, ptr_microlist, N_int) - - do j=1, ptr_microlist(mo_tot_num * 2 + 1) - 1 - psi_coef_microlist(j,:) = psi_selectors_coef_transp(:,idx_microlist(j)) - enddo - - if(ptr_microlist(mo_tot_num * 2 + 1) == 1) then - cycle - endif - - - do j=1,N_particles(ispin) - exc_det(:,:) = ion_det(:,:) - - integer :: i_particle - i_particle = particle_list(j,ispin) - - integer :: j_particle, k_particle - k_particle = ishft(i_particle-1,-bit_kind_shift)+1 ! N_int - j_particle = i_particle-ishft(k_particle-1,bit_kind_shift)-1 ! bit index - exc_det(k_particle,ispin) = ibset(exc_det(k_particle,ispin),j_particle) - - - logical, external :: is_in_wavefunction - logical :: nok - if (.not. is_in_wavefunction(exc_det,N_int)) then - double precision :: i_H_psi_value(N_states), i_H_psi_value2(N_states) - i_H_psi_value = 0d0 - i_H_psi_value2 = 0d0 - integer :: sporb - - - nok = .false. - sporb = i_particle + (ispin - 1) * mo_tot_num - - if(N_microlist(sporb) > 0) call check_past(exc_det, microlist(1,1,ptr_microlist(sporb)), idx_microlist(ptr_microlist(sporb)), N_microlist(sporb), i_generator, nok, N_int) - if(nok) cycle - - if(N_microlist(0) > 0) call i_H_psi(exc_det,microlist,psi_coef_microlist,N_int,N_microlist(0),psi_selectors_size*3,N_states,i_H_psi_value) - if(N_microlist(sporb) > 0) call i_H_psi(exc_det,microlist(1,1,ptr_microlist(sporb)),psi_coef_microlist(ptr_microlist(sporb), 1),N_int,N_microlist(sporb),psi_selectors_size*3,N_states,i_H_psi_value2) - i_H_psi_value(:) = i_H_psi_value(:) + i_H_psi_value2(:) - double precision :: Hii, diag_H_mat_elem_fock - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),exc_det,fock_diag_tmp,N_int) - - double precision :: delta_E, e_pert(N_states), e_pertm - e_pert(:) = 0d0 - e_pertm = 0d0 - - do k=1,N_states - if (i_H_psi_value(k) == 0.d0) cycle - delta_E = E0(k) - Hii - if (delta_E < 0.d0) then - e_pert(k) = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) - else - e_pert(k) = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) - endif - if(dabs(e_pert(k)) > dabs(e_pertm)) e_pertm = e_pert(k) - pt2(k) += e_pert(k) - enddo - call add_to_selection_buffer(buf, exc_det, e_pertm) - endif - - ! Reset exc_det - exc_det(k_particle,ispin) = psi_det_generators(k_particle,ispin,i_generator) - enddo ! j - - ! Reset ion_det - ion_det(k_hole,ispin) = psi_det_generators(k_hole,ispin,i_generator) - enddo ! i - enddo ! ispin -end - - - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - !use f77_zmq - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_generator - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(inout) :: pt2(N_states) - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: E0(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: isinwf(mo_tot_num*2, mo_tot_num*2) - double precision :: d0s(mo_tot_num, mo_tot_num, N_states) - - integer :: i,j,k,l,j1,j2,i1,i2,ib,jb - - integer :: msg_size - msg_size = bit_kind*N_int*2 - - ! Apply hole and particle masks - ! ----------------------------- - - integer(bit_kind) :: hole(N_int,2), particle(N_int,2) - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - ! Create excited determinants - ! --------------------------- - - integer :: ispin1, ispin2, other_spin - integer(bit_kind) :: exc_det(N_int,2), ion_det(N_int,2) - - - integer :: ptr_microlist(0:mo_tot_num * 2 + 1), N_microlist(0:mo_tot_num * 2) - double precision, allocatable :: psi_coef_microlist(:,:) - - integer :: ptr_tmicrolist(0:mo_tot_num * 2 + 1), N_tmicrolist(0:mo_tot_num * 2) - double precision, allocatable :: psi_coef_tmicrolist(:,:) - - integer, allocatable :: idx_tmicrolist(:), idx_microlist(:) - integer(bit_kind), allocatable :: microlist(:,:,:), tmicrolist(:,:,:) - - integer :: ptr_futur_microlist(0:mo_tot_num * 2 + 1), ptr_futur_tmicrolist(0:mo_tot_num * 2 + 1) - integer :: N_futur_microlist(0:mo_tot_num * 2), N_futur_tmicrolist(0:mo_tot_num * 2) - logical :: pastlink - - allocate(idx_tmicrolist(N_det_selectors * 3), idx_microlist(N_det_selectors * 4)) - allocate(microlist(N_int, 2, N_det_selectors * 4), tmicrolist(N_int, 2, N_det_selectors * 3)) - allocate(psi_coef_tmicrolist(psi_selectors_size * 3, N_states), psi_coef_microlist(psi_selectors_size * 4, N_states)) - - do k=1,N_int - exc_det(k,1) = psi_det_generators(k,1,i_generator) - exc_det(k,2) = psi_det_generators(k,2,i_generator) - ion_det(k,1) = psi_det_generators(k,1,i_generator) - ion_det(k,2) = psi_det_generators(k,2,i_generator) - enddo - - do ispin1=1,2 - do ispin2=1,ispin1 - integer :: i_hole1, i_hole2, j_hole, k_hole - do i1=N_holes(ispin1),1,-1 ! Generate low excitations first - if(ispin1 == ispin2) then - ib = i1+1 - else - ib = 1 - endif - do i2=N_holes(ispin2),ib,-1 ! Generate low excitations first - ion_det(:,:) = psi_det_generators(:,:,i_generator) - - i_hole1 = hole_list(i1,ispin1) - k_hole = ishft(i_hole1-1,-bit_kind_shift)+1 ! N_int - j_hole = i_hole1-ishft(k_hole-1,bit_kind_shift)-1 ! bit index - ion_det(k_hole,ispin1) = ibclr(ion_det(k_hole,ispin1),j_hole) - - i_hole2 = hole_list(i2,ispin2) - k_hole = ishft(i_hole2-1,-bit_kind_shift)+1 ! N_int - j_hole = i_hole2-ishft(k_hole-1,bit_kind_shift)-1 ! bit index - ion_det(k_hole,ispin2) = ibclr(ion_det(k_hole,ispin2),j_hole) - - call create_microlist_double(psi_selectors, i_generator, N_det_selectors, ion_det, & - microlist, idx_microlist, N_microlist, ptr_microlist, & - tmicrolist, idx_tmicrolist, N_tmicrolist, ptr_tmicrolist, & - isinwf, d0s, N_int) - - if(ptr_microlist(mo_tot_num * 2 + 1) == 1 .and. ptr_tmicrolist(mo_tot_num * 2 + 1) == 1) cycle - - call finish_isinwf(ion_det, psi_det_sorted(1,1,N_det_selectors+1), N_det - N_det_selectors, isinwf) - - - call create_futur_ptr(ptr_microlist, idx_microlist, ptr_futur_microlist, N_futur_microlist, i_generator) - call create_futur_ptr(ptr_tmicrolist, idx_tmicrolist, ptr_futur_tmicrolist, N_futur_tmicrolist, i_generator) - - - do j=1, ptr_microlist(mo_tot_num * 2 + 1) - 1 - psi_coef_microlist(j,:) = psi_selectors_coef_transp(:,idx_microlist(j)) - enddo - do j=1, ptr_tmicrolist(mo_tot_num * 2 + 1) - 1 - psi_coef_tmicrolist(j,:) = psi_selectors_coef_transp(:,idx_tmicrolist(j)) - enddo - - - ! Create particles - ! ---------------- - integer :: i_particle1, i_particle2, k_particle, j_particle - integer :: p1, p2, sporb, lorb - - do j1=1,N_particles(ispin1) - i_particle1 = particle_list(j1, ispin1) - p1 = i_particle1 + (ispin1 - 1) * mo_tot_num - if(N_tmicrolist(p1) > 0 .and. idx_tmicrolist(ptr_tmicrolist(p1)) < i_generator) cycle - jb = 1 - if(ispin1 == ispin2) jb = j1+1 - do j2=jb,N_particles(ispin2) - - i_particle2 = particle_list(j2, ispin2) - - - - p2 = i_particle2 + (ispin2 - 1) * mo_tot_num - if(N_tmicrolist(p2) > 0 .and. idx_tmicrolist(ptr_tmicrolist(p2)) < i_generator) cycle - if(isinwf(p1, p2)) cycle - exc_det = ion_det - - - if(N_microlist(p1) < N_microlist(p2)) then - sporb = p1 - lorb = p2 - else - sporb = p2 - lorb = p1 - endif - - - ! Apply the particle - k_particle = ishft(i_particle2-1,-bit_kind_shift)+1 ! N_int - j_particle = i_particle2-ishft(k_particle-1,bit_kind_shift)-1 ! bit index - exc_det(k_particle,ispin2) = ibset(exc_det(k_particle,ispin2),j_particle) - - ! Apply the particle - k_particle = ishft(i_particle1-1,-bit_kind_shift)+1 ! N_int - j_particle = i_particle1-ishft(k_particle-1,bit_kind_shift)-1 ! bit index - exc_det(k_particle,ispin1) = ibset(exc_det(k_particle,ispin1),j_particle) - - logical, external :: is_in_wavefunction - logical :: nok - ! Compute perturbative contribution and select determinant - double precision :: i_H_psi_value(N_states), i_H_psi_value2(N_states) - i_H_psi_value = 0d0 - i_H_psi_value2 = 0d0 - - nok = .false. - call check_past_s(exc_det, microlist(1,1,ptr_microlist(sporb)), N_microlist(sporb) - N_futur_microlist(sporb), nok, N_int) - if(nok) cycle - !DET DRIVEN - if(N_futur_microlist(0) > 0) then - call i_H_psi(exc_det,microlist(1,1,ptr_futur_microlist(0)),psi_coef_microlist(ptr_futur_microlist(0), 1),N_int,N_futur_microlist(0),psi_selectors_size*4,N_states,i_H_psi_value) - end if - !INTEGRAL DRIVEN -! do j=1, N_states -! i_H_psi_value(j) = d0s(mod(p1-1, mo_tot_num)+1, mod(p2-1, mo_tot_num)+1, j) -! end do - - - if(N_futur_microlist(sporb) > 0) then - !!! COMPUTE INTERSECTION - !!!!!!!!!!!!! -! if(dfloat(N_futur_microlist(lorb)) / dfloat(N_futur_microlist(sporb)) < 2d0) then -! c1 = ptr_futur_microlist(p1) -! c2 = ptr_futur_microlist(p2) -! do while(c1 < ptr_microlist(p1+1) .and. c2 < ptr_microlist(p2+1)) -! if(idx_microlist(c1) < idx_microlist(c2)) then -! c1 += 1 -! else if(idx_microlist(c1) > idx_microlist(c2)) then -! c2 += 1 -! else -! call i_H_j(exc_det,microlist(1,1,c1),N_int,hij) -! do j = 1, N_states -! i_H_psi_value2(j) = i_H_psi_value2(j) + psi_coef_microlist(c1,j)*hij -! end do -! c1 += 1 -! c2 += 1 -! endif -! end do -! else - call i_H_psi(exc_det,microlist(1,1,ptr_futur_microlist(sporb)),psi_coef_microlist(ptr_futur_microlist(sporb), 1),N_int,N_futur_microlist(sporb),psi_selectors_size*4,N_states,i_H_psi_value2) - i_H_psi_value = i_H_psi_value + i_H_psi_value2 - end if - - if(.true.) then ! DET DRIVEN - integer :: c1, c2 - double precision :: hij - c1 = ptr_futur_tmicrolist(p1) - c2 = ptr_futur_tmicrolist(p2) - do while(.true.) - if(c1 >= ptr_tmicrolist(p1+1) .or. c2 >= ptr_tmicrolist(p2+1)) then - if(ptr_tmicrolist(p1+1) /= c1) then - call i_H_psi(exc_det,tmicrolist(1,1,c1),psi_coef_tmicrolist(c1, 1),N_int, ptr_tmicrolist(p1+1)-c1 ,psi_selectors_size*3,N_states,i_H_psi_value2) - i_H_psi_value = i_H_psi_value + i_H_psi_value2 - end if - - if(ptr_tmicrolist(p2+1) /= c2) then - call i_H_psi(exc_det,tmicrolist(1,1,c2),psi_coef_tmicrolist(c2, 1),N_int, ptr_tmicrolist(p2+1)-c2 ,psi_selectors_size*3,N_states,i_H_psi_value2) - i_H_psi_value = i_H_psi_value + i_H_psi_value2 - endif - - exit - endif - - if(idx_tmicrolist(c1) < idx_tmicrolist(c2)) then - call i_H_j(exc_det,tmicrolist(1,1,c1),N_int,hij) - do j = 1, N_states - i_H_psi_value(j) = i_H_psi_value(j) + psi_coef_tmicrolist(c1,j)*hij - enddo - c1 += 1 - else - call i_H_j(exc_det,tmicrolist(1,1,c2),N_int,hij) - do j = 1, N_states - i_H_psi_value(j) = i_H_psi_value(j) + psi_coef_tmicrolist(c2,j)*hij - enddo - if(idx_tmicrolist(c1) == idx_tmicrolist(c2)) c1 = c1 + 1 - c2 += 1 - end if - enddo - end if - - double precision :: Hii, diag_H_mat_elem_fock - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),exc_det,fock_diag_tmp,N_int) - double precision :: delta_E, e_pert(N_states), e_pertm - e_pert(:) = 0d0 - e_pertm = 0d0 - - do k=1,N_states - if (i_H_psi_value(k) == 0.d0) cycle - delta_E = E0(k) - Hii - if (delta_E < 0.d0) then - e_pert(k) = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) - else - e_pert(k) = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) - endif - e_pertm += dabs(e_pert(k)) -! if(dabs(e_pert(k)) > dabs(e_pertm)) e_pertm = e_pert(k) - pt2(k) += e_pert(k) - enddo - if(dabs(e_pertm) > dabs(buf%mini)) then - call add_to_selection_buffer(buf, exc_det, e_pertm) - end if - enddo - enddo - enddo - enddo - enddo - enddo -end - - - -subroutine create_futur_ptr(ptr_microlist, idx_microlist, ptr_futur_microlist, N_futur_microlist, i_generator) - integer, intent(in) :: ptr_microlist(0:mo_tot_num * 2 + 1), idx_microlist(*), i_generator - integer, intent(out) :: ptr_futur_microlist(0:mo_tot_num * 2 + 1), N_futur_microlist(0:mo_tot_num * 2) - integer :: i, j - - N_futur_microlist = 0 - do i=0,mo_tot_num*2 - ptr_futur_microlist(i) = ptr_microlist(i+1) - do j=ptr_microlist(i), ptr_microlist(i+1) - 1 - if(idx_microlist(j) >= i_generator) then - ptr_futur_microlist(i) = j - N_futur_microlist(i) = ptr_microlist(i+1) - j - exit - end if - end do - end do -end subroutine - - -subroutine create_microlist_single(minilist, i_cur, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) - use bitmasks - integer, intent(in) :: Nint, i_cur, N_minilist - integer(bit_kind), intent(in) :: minilist(Nint,2,N_minilist), key_mask(Nint,2) - - integer, intent(out) :: N_microlist(0:mo_tot_num*2), ptr_microlist(0:mo_tot_num*2+1), idx_microlist(N_minilist*4) - integer(bit_kind), intent(out) :: microlist(Nint,2,N_minilist*4) - - integer :: i,j,k,s,nt,n_element(2) - integer :: list(Nint*bit_kind_size,2), cur_microlist(0:mo_tot_num*2+1) - integer(bit_kind) :: key_mask_neg(Nint,2), mobileMask(Nint,2) - integer :: mo_tot_num_2 - mo_tot_num_2 = mo_tot_num+mo_tot_num - - - do i=1,Nint - key_mask_neg(i,1) = not(key_mask(i,1)) - key_mask_neg(i,2) = not(key_mask(i,2)) - end do - - do i=0,mo_tot_num_2 - N_microlist(i) = 0 - enddo - - do i=1, N_minilist - nt = 0 - do j=1,Nint - mobileMask(j,1) = iand(key_mask_neg(j,1), minilist(j,1,i)) - mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i)) - nt += popcnt(mobileMask(j, 1)) + popcnt(mobileMask(j, 2)) - end do - - if(nt > 3) then !! TOO MANY DIFFERENCES - continue - else if(nt < 3) then - if(i < i_cur) then !!!!!!!!!!!!!!!!!!!!! DESACTIVADO - N_microlist(:) = 0 !!!! PAST LINKED TO EVERYBODY! - ptr_microlist(:) = 1 - return - else !! FUTUR LINKED TO EVERYBODY - N_microlist(0) = N_microlist(0) + 1 - endif - else - call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), Nint) - call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), Nint) - - do s=1,2 - do j=1,n_element(s) - nt = list(j,s) + mo_tot_num * (s-1) - N_microlist(nt) = N_microlist(nt) + 1 - end do - end do - endif - end do - - ptr_microlist(0) = 1 - do i=1,mo_tot_num_2+1 - ptr_microlist(i) = ptr_microlist(i-1) + N_microlist(i-1) - end do - - do i=0,mo_tot_num_2+1 - cur_microlist(i) = ptr_microlist(i) - end do - - - do i=1, N_minilist - do j=1,Nint - mobileMask(j,1) = iand(key_mask_neg(j,1), minilist(j,1,i)) - mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i)) - end do - - call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), Nint) - call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), Nint) - - - if(n_element(1) + n_element(2) < 3) then - idx_microlist(cur_microlist(0)) = i - do k=1,Nint - microlist(k,1,cur_microlist(0)) = minilist(k,1,i) - microlist(k,2,cur_microlist(0)) = minilist(k,2,i) - enddo - cur_microlist(0) = cur_microlist(0) + 1 - else if(n_element(1) + n_element(2) == 3) then - do s = 1, 2 - do j=1,n_element(s) - nt = list(j,s) + mo_tot_num * (s-1) - idx_microlist(cur_microlist(nt)) = i - do k=1,Nint - microlist(k,1,cur_microlist(nt)) = minilist(k,1,i) - microlist(k,2,cur_microlist(nt)) = minilist(k,2,i) - enddo - cur_microlist(nt) = cur_microlist(nt) + 1 - end do - end do - end if - end do -end subroutine - - -subroutine finish_isinwf(key_mask, keys, N_keys, isinwf) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: key_mask(N_int, 2), keys(N_int, 2, N_keys) - integer(bit_kind) :: key_mask_neg(N_int, 2) - integer(bit_kind) :: mobileMask(N_int, 2) - logical,intent(inout) :: isinwf(mo_tot_num*2, mo_tot_num*2) - integer, intent(in) :: N_keys - integer :: i,j,nt,nt2,list(2,2), n_element(2) - logical, external :: detEq - - do i=1,N_int - key_mask_neg(i,1) = not(key_mask(i,1)) - key_mask_neg(i,2) = not(key_mask(i,2)) - end do - - do i=1, N_keys - nt = 0 - - do j=1,N_int - mobileMask(j,1) = iand(key_mask_neg(j,1), keys(j,1,i)) - mobileMask(j,2) = iand(key_mask_neg(j,2), keys(j,2,i)) - nt += popcnt(mobileMask(j, 1)) + popcnt(mobileMask(j, 2)) - end do - - if(nt /= 2) cycle - - call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), N_int) - call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), N_int) - - if(n_element(1) >= 1) nt = list(1,1) - if(n_element(1) == 2) nt2 = list(2,1) - if(n_element(2) == 2) nt = list(2,2) + mo_tot_num - if(n_element(2) >= 1) nt2 = list(1,2) + mo_tot_num - - isinwf(nt, nt2) = .true. - isinwf(nt2, nt) = .true. - end do -end subroutine - - -subroutine create_microlist_double(minilist, i_cur, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, & - tmicrolist, idx_tmicrolist, N_tmicrolist, ptr_tmicrolist, & - isinwf, d0s, Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint, i_cur, N_minilist - integer(bit_kind), intent(in) :: minilist(Nint,2,N_minilist), key_mask(Nint,2) - - integer, intent(out) :: N_microlist(0:mo_tot_num*2), ptr_microlist(0:mo_tot_num*2+1), idx_microlist(N_minilist*4) - integer(bit_kind), intent(out) :: microlist(Nint,2,N_minilist*4) - - integer, intent(out) :: N_tmicrolist(0:mo_tot_num*2), ptr_tmicrolist(0:mo_tot_num*2+1), idx_tmicrolist(N_minilist*4) - integer(bit_kind), intent(out) :: tmicrolist(Nint,2,N_minilist*4) - - - integer :: i,j,k,s,nt,nt2 - integer, allocatable :: n_element(:,:), idx(:), list(:,:,:) - integer :: cur_microlist(0:mo_tot_num*2+1), cur_tmicrolist(0:mo_tot_num*2+1) - integer(bit_kind) :: key_mask_neg(Nint,2), mobileMask(Nint,2), tmp_det(Nint, 2) - integer :: mo_tot_num_2, pwen(4), pweni - logical,intent(out) :: isinwf(mo_tot_num*2, mo_tot_num*2) - double precision, intent(out) :: d0s(mo_tot_num, mo_tot_num, N_states) - double precision :: integ(mo_tot_num, mo_tot_num) - logical :: localbanned(mo_tot_num*2), banned(mo_tot_num*2), banned_pair(mo_tot_num*2, mo_tot_num*2), ok - banned = .false. - banned_pair = .false. - - allocate(list(4,2,N_minilist), n_element(2,N_minilist), idx(0:N_minilist)) - - isinwf = .false. - integ = 0d0 - d0s = 0d0 - mo_tot_num_2 = mo_tot_num+mo_tot_num - - idx(0) = 0 - do i=1,Nint - key_mask_neg(i,1) = not(key_mask(i,1)) - key_mask_neg(i,2) = not(key_mask(i,2)) - end do - - do i=0,mo_tot_num_2 - N_microlist(i) = 0 - N_tmicrolist(i) = 0 - enddo - - do i=1, N_minilist - nt = 0 - do j=1,Nint - mobileMask(j,1) = iand(key_mask_neg(j,1), minilist(j,1,i)) - mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i)) - nt += popcnt(mobileMask(j, 1)) + popcnt(mobileMask(j, 2)) - end do - - if(nt > 4) cycle !! TOO MANY DIFFERENCES - idx(0) += 1 - idx(idx(0)) = i - - call bitstring_to_list(mobileMask(1,1), list(1,1,idx(0)), n_element(1, idx(0)), Nint) - call bitstring_to_list(mobileMask(1,2), list(1,2,idx(0)), n_element(2, idx(0)), Nint) - - - if(nt == 2) then - if(i < i_cur) then - N_microlist(:) = 0 - ptr_microlist = 1 - N_tmicrolist = 0 - ptr_tmicrolist = 1 - return - else - N_microlist(0) = N_microlist(0) + 1 - endif - else - do s=1,2 - do j=1,n_element(s,idx(0)) - k = list(j,s,idx(0)) + mo_tot_num * (s-1) - if(nt == 4) N_microlist(k) = N_microlist(k) + 1 - if(nt == 3) then - N_tmicrolist(k) = N_tmicrolist(k) + 1 - if(idx(i) < i_cur) banned(nt) = .true. - end if - end do - end do - endif - end do - - ptr_microlist(0) = 1 - ptr_tmicrolist(0) = 1 - do i=1,mo_tot_num_2+1 - ptr_microlist(i) = ptr_microlist(i-1) + N_microlist(i-1) - ptr_tmicrolist(i) = ptr_tmicrolist(i-1) + N_tmicrolist(i-1) - end do - - do i=0,mo_tot_num_2+1 - cur_microlist(i) = ptr_microlist(i) - cur_tmicrolist(i) = ptr_tmicrolist(i) - end do - - - do i=1, idx(0) - if(n_element(1, i) + n_element(2, i) == 2) cycle - pweni = 0 - do s = 1, 2 - do j=1,n_element(s,i) - nt = list(j,s,i) + mo_tot_num * (s-1) - pweni += 1 - pwen(pweni) = nt - if(n_element(1,i) + n_element(2,i) == 4) then - idx_microlist(cur_microlist(nt)) = idx(i) - do k=1,Nint - microlist(k,1,cur_microlist(nt)) = minilist(k,1,idx(i)) - microlist(k,2,cur_microlist(nt)) = minilist(k,2,idx(i)) - enddo - cur_microlist(nt) = cur_microlist(nt) + 1 - else - idx_tmicrolist(cur_tmicrolist(nt)) = idx(i) - do k=1,Nint - tmicrolist(k,1,cur_tmicrolist(nt)) = minilist(k,1,idx(i)) - tmicrolist(k,2,cur_tmicrolist(nt)) = minilist(k,2,idx(i)) - enddo - cur_tmicrolist(nt) = cur_tmicrolist(nt) + 1 - endif - end do - end do - if(idx(i) < i_cur .and. pweni == 4) then - do j=1,4 - do k=j+1,4 - banned_pair(pwen(j), pwen(k)) = .true. - banned_pair(pwen(k), pwen(j)) = .true. - end do - end do - end if - end do - - - do i=1, idx(0) - if(n_element(1, i) + n_element(2, i) <= 2) then - idx_microlist(cur_microlist(0)) = idx(i) - do k=1,Nint - microlist(k,1,cur_microlist(0)) = minilist(k,1,idx(i)) - microlist(k,2,cur_microlist(0)) = minilist(k,2,idx(i)) - enddo - cur_microlist(0) = cur_microlist(0) + 1 - - if(n_element(1,i) >= 1) nt = list(1,1,i) - if(n_element(1,i) == 2) nt2 = list(2,1,i) - if(n_element(2,i) == 2) nt = list(2,2,i) + mo_tot_num - if(n_element(2,i) >= 1) nt2 = list(1,2,i) + mo_tot_num - - isinwf(nt, nt2) = .true. - isinwf(nt2, nt) = .true. - !!!! INTEGRAL DRIVEN -! !!!!!!!!!!!!!!!!!!!! - call get_d0(minilist(1,1,idx(i)), banned, banned_pair, d0s, key_mask, 1+(nt2-1)/mo_tot_num, 1+(nt-1)/mo_tot_num, & - mod(nt2-1, mo_tot_num)+1, mod(nt-1, mo_tot_num)+1, psi_selectors_coef_transp(1,idx(i))) - -! do j=1, N_states -! do nt2=1, mo_tot_num -! do nt=1, mo_tot_num -! d0s(nt,nt2,j) = d0s(nt,nt2,j) + (integ(nt,nt2) * psi_selectors_coef(idx(i), j)) !!! SUPPOSE MINILIST = SELECTORS !!!! -! end do -! end do -! end do - else if(.false. .and. n_element(1, i) + n_element(2, i) == 3) then ! INTEGRAL DRIVEN - ! -459.6399263191298 - pweni = 0 - do s = 1, 2 - do j=1,n_element(s,i) - nt = list(j,s,i) + mo_tot_num * (s-1) - pweni += 1 - pwen(pweni) = nt - end do - end do - - call get_d1(minilist(1,1,idx(i)), banned, banned_pair, d0s, key_mask, pwen, psi_selectors_coef_transp(1,idx(i))) - -! do k=1, N_states -! do nt2=1, mo_tot_num -! do nt=1, mo_tot_num -! d0s(nt,nt2,k) = d0s(nt,nt2,k) + (integ(nt,nt2) * psi_selectors_coef(idx(i), k)) !!! SUPPOSE MINILIST = SELECTORS !!!! -! end do -! end do -! end do - end if - end do - - -end subroutine - - -subroutine get_d1(gen, banned, banned_pair, mat, mask, pwen, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - logical, intent(in) :: banned(mo_tot_num*2), banned_pair(mo_tot_num*2, mo_tot_num*2) - integer(bit_kind) :: deth(N_int, 2), det(N_int, 2), i8 - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(mo_tot_num, mo_tot_num, N_states) - double precision :: hij, phase, inv, inv2 - integer, intent(in) :: pwen(3) - integer :: s(3), p(3), i, j, k, h1, h2, ns(2), sm, mwen, a1, a2, pwens(2), sp, st - integer :: sfix, pfix - integer :: exc(0:2, 2, 2) - logical :: lbanned(mo_tot_num*2) - logical :: ok, mono, ab - integer :: tmp_array(4) - - lbanned = banned - !mat = 0d0 - pwens = 0 - - ns = 0 - do sp=1,2 - do i=1, N_int - ns(sp) += popcnt(gen(i, sp)) - popcnt(mask(i, sp)) - i8 = iand(not(gen(i, sp)), mask(i, sp)) - if(i8 /= 0_8) then - sfix = sp - pfix = 1+trailz(i8) + bit_kind*8*(i-1) - end if - end do - end do - - - do i=1,3 - s(i) = 1+(pwen(i)-1)/mo_tot_num - p(i) = 1+mod(pwen(i)-1, mo_tot_num) - pwens(s(i)) += 1 - end do - - do i=1,3 - if(s(i) == 1 .and. ns(1) == 0) cycle - if(s(i) == 2 .and. ns(2) == 0) cycle - if(lbanned(pwen(i))) cycle - ab = pwens(s(i)) == 2 - - if(ns(1) == 1) sm = mod(s(i), 2) + 1 - if(ns(1) == 2) sm = 1 - if(ns(2) == 2) sm = 2 - - lbanned(pwen(i)) = .true. - - if(ab) then - if(s(mod(i,3)+1) == 2) then - a1 = mod(i, 3) + 1 - a2 = mod(i+1, 3) + 1 - else - a2 = mod(i,3)+1 - a1 = mod(i+1,3)+1 - end if - - exc(0, :, 1) = 1 - exc(0, :, 2) = 1 - exc(1, 1, 1) = p(a2) - exc(1, 1, 2) = p(a1) - exc(1, 2, sfix) = pfix - - call apply_particle(mask, 0, 0 ,s(i), p(i), deth, ok, N_int) - - do j=1,mo_tot_num - mwen = j + (sm-1)*mo_tot_num - if(lbanned(mwen)) cycle - tmp_array = (/0,0,sm,j/) - call apply_particle(deth, 0, 0 ,s(i), p(i), det, ok, N_int) - if(.not. ok) cycle - - mono = mwen == pwen(a1) .or. mwen == pwen(a2) - if(mono) then - call i_h_j(gen, det, N_int, hij) - else - exc(1, 2, sm) = j - call get_double_excitation_phase(gen, det, exc, phase, N_int) - if(sfix == 1) hij = integral8(j, pfix, p(a1), p(a2)) * phase - if(sfix == 2) hij = integral8(pfix, j, p(a1), p(a2)) * phase - end if - - if(ns(1) == 1) then - do st=1, N_states - if(sm == 2) mat(j, p(i), st) = mat(j, p(i), st) + hij * coefs(st) - if(sm == 1) mat(p(i), j, st) = mat(p(i), j, st) + hij * coefs(st) - end do - else - do st=1, N_states - mat(j, p(i), st) += hij * coefs(st) - mat(p(i), j, st) += hij * coefs(st) - end do - end if - end do - - else !! AA / BB - a1 = mod(i,3)+1 - a2 = mod(i+1,3)+1 - - h1 = p(a1) - h2 = p(a2) - inv = 1d0 - if(h1 > h2) inv = -1d0 - - if(pwens(s(i)) == 1) sp = mod(s(i), 2)+1 - if(pwens(s(i)) == 3) sp = s(i) - - exc(0, :, sp) = 2 - exc(0, :, mod(sp, 2)+1) = 0 - exc(1, 1, sp) = min(h1, h2) - exc(2, 1, sp) = max(h1, h2) - - call apply_particle(mask, 0, 0 ,s(i), p(i) , deth, ok, N_int) - - do j=1,mo_tot_num - if(j == pfix) inv = -inv - mwen = j + (sm-1)*mo_tot_num - if(lbanned(mwen)) cycle - call apply_particle(deth, 0, 0 ,s(i), p(i) , det, ok, N_int) - if(.not. ok) cycle - - mono = mwen == pwen(a1) .or. mwen == pwen(a2) - if(mono) then - call i_h_j(gen, det, N_int, hij) - else - exc(1, 2, sfix) = min(j,pfix) - exc(2, 2, sp) = max(j,pfix) - call get_double_excitation_phase(gen, det, exc, phase, N_int) - hij = (integral8(j, pfix, h1, h2) - integral8(pfix,j, h1, h2))*phase*inv - end if - if(ns(1) == 1) then - do st=1, N_states - if(sm == 2) mat(j, p(i), st) = mat(j, p(i), st) + hij * coefs(st) - if(sm == 1) mat(p(i), j, st) = mat(p(i), j, st) + hij * coefs(st) - end do - else - do st=1, N_states - mat(j, p(i), st) += hij * coefs(st) - mat(p(i), j, st) += hij * coefs(st) - end do - end if - end do - end if - end do - -end subroutine - - -subroutine get_d0(gen, banned, banned_pair, mat, mask, s1, s2, h1, h2, coefs) - use bitmasks - implicit none - - double precision, intent(inout) :: mat(mo_tot_num, mo_tot_num, N_states) - logical, intent(in) :: banned(mo_tot_num*2), banned_pair(mo_tot_num*2, mo_tot_num*2) - double precision :: mat_mwen(mo_tot_num, mo_tot_num) - double precision, intent(in) :: coefs(N_states) - integer, intent(in) :: h1, h2, s1, s2 - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(bit_kind) :: det1(N_int, 2), det2(N_int, 2) - logical :: ok, mono - double precision :: phase, phase2, inv, hij - integer :: p1, p2, hmi, hma, ns1, ns2, st - logical, external :: detEq - integer :: exc(0:2, 2, 2), exc2(0:2,2,2) - integer :: tmp_array(4) - - exc = 0 -! mat_mwen = integral8(:,:,h1,h2) - !call get_mo_bielec_integrals_ij(h1, h2 ,mo_tot_num,mat_mwen,mo_integrals_map) - - ns1 = mo_tot_num*(s1-1) - ns2 = mo_tot_num*(s2-1) - - !mat = 0d0 - if(s1 == s2) then - hmi = min(h1, h2) - hma = max(h1, h2) - inv = 1d0 - if(h1 > h2) inv = -1d0 - exc(0, :, s1) = 2 - exc(1, 1, s1) = hmi - exc(2, 1, s1) = hma - do p2=1,mo_tot_num - if(banned(p2 + ns2)) cycle - do p1=1,mo_tot_num - if(banned(p1 + ns1)) cycle - if(p1 == p2) cycle - if(banned_pair(p1 + ns1, p2 + ns2)) cycle - !tmp_array = (/s1,p1,s2,p2/) - call apply_particle(mask, s1,p1,s2,p2, det2, ok, N_int) - if(.not. ok) cycle - mono = (hmi == p1 .or. hma == p2 .or. hmi == p2 .or. hma == p1) - if(mono) then - - call i_h_j(gen, det2, N_int, hij) - do st=1, N_states - mat(p1, p2, st) += hij * coefs(st) - end do - else - exc(1, 2, s1) = min(p1, p2) - exc(2, 2, s2) = max(p2, p1) - call get_double_excitation_phase(gen, det2, exc, phase, N_int) - do st=1, N_states - mat(p1, p2, st) += coefs(st) * inv * (integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2)) * phase - end do - end if - end do - end do - else - exc(0, :, 1) = 1 - exc(0, :, 2) = 1 - if(s1 /= 2) stop "alpha beta inversified" - exc(1, 1, 1) = h2 - exc(1, 1, 2) = h1 - - do p2=1, mo_tot_num - if(banned(p2 + ns2)) cycle - do p1=1, mo_tot_num - if(banned(p1 + ns1)) cycle - if(banned_pair(p1 + ns1, p2 + ns2)) cycle - !tmp_array = (/s1,p1,s2,p2/) - call apply_particle(mask, s1,p1,s2,p2, det2, ok, N_int) - if(.not. ok) cycle - mono = (h1 == p1 .or. h2 == p2) - if(mono) then - call i_h_j(gen, det2, N_int, hij) - do st=1, N_states - mat(p1, p2, st) += hij * coefs(st) - end do - else - exc(1, 2, s1) = p1 - exc(1, 2, s2) = p2 - call get_double_excitation_phase(gen, det2, exc, phase, N_int) - do st=1, N_states - mat(p1, p2, st) += coefs(st) * integral8(p1, p2, h1, h2) * phase - end do - !mat(p1, p2) = integral8(p1, p2, h1, h2) * phase - end if - end do - end do - end if -end subroutine - - -subroutine check_past(det, list, idx, N, cur, ok, Nint) - implicit none - use bitmasks - - integer(bit_kind), intent(in) :: det(Nint, 2), list(Nint, 2, N) - integer, intent(in) :: Nint, idx(N), N, cur - logical, intent(out) :: ok - integer :: i,s,ni - - ok = .false. - do i=1,N - if(idx(i) >= cur) exit - s = 0 - do ni=1,Nint - s += popcnt(xor(det(ni,1), list(ni,1,i))) + popcnt(xor(det(ni,2), list(ni,2,i))) - end do - if(s <= 4) then - ok = .true. - return - end if - end do -end subroutine - - -subroutine check_past_s(det, list, N, ok, Nint) - implicit none - use bitmasks - - integer(bit_kind), intent(in) :: det(Nint, 2), list(Nint, 2, N) - integer, intent(in) :: Nint, N - logical, intent(out) :: ok - integer :: i,s,ni - - ok = .false. - do i=1,N - s = 0 - do ni=1,Nint - s += popcnt(xor(det(ni,1), list(ni,1,i))) + popcnt(xor(det(ni,2), list(ni,2,i))) - end do - if(s <= 4) then - ok = .true. - return - end if - end do -end subroutine +use bitmasks + +BEGIN_PROVIDER [ double precision, integral8, (mo_tot_num, mo_tot_num, mo_tot_num, mo_tot_num) ] + use bitmasks + implicit none + + integer :: h1, h2 + + integral8 = 0d0 + do h1=1, mo_tot_num + do h2=1, mo_tot_num + call get_mo_bielec_integrals_ij(h1, h2 ,mo_tot_num,integral8(1,1,h1,h2),mo_integrals_map) + end do + end do +END_PROVIDER + + +BEGIN_PROVIDER [ integer(bit_kind), psi_phasemask, (N_int, 2, N_det)] + use bitmasks + implicit none + + integer :: i + print *, "pro" + print *, "pross" + do i=1, N_det + call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert fail: "//msg + stop + end if +end subroutine + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(bit_kind), intent(out) :: phasemask(N_int, 2) + integer :: s, ni, i + logical :: change + + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask(ni, s) = ibset(phasemask(ni, s), i) + end do + end do + end do +end subroutine + + +subroutine select_connected(i_generator,E0,pt2,b) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + print *, "BEG" + + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + hole_mask(k,1) = ior(generators_bitmask(k,1,s_hole,l), generators_bitmask(k,1,s_part,l)) + hole_mask(k,2) = ior(generators_bitmask(k,2,s_hole,l), generators_bitmask(k,2,s_part,l)) + particle_mask(k,:) = hole_mask(k,:) + enddo + + print *, "sel" +! call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + print *, "poivre" + print *, b%cur, b%N + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + print *, b%cur, b%N + print *, "paprika" + enddo + print *, "safran" +end subroutine + + +subroutine spot_occupied(mask, bannedOrb) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2) + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer :: s, i, ne, list(mo_tot_num) + + do s=1,2 + call bitstring_to_list(mask(1,s), list, ne, N_int) + do i=1, ne + bannedOrb(list(i), s) = .true. + end do + end do +end subroutine + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: phasemask(N_int, 2) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + + !ASSERT(h1 <= h2 .and. p1 <= p2) + change = btest(phasemask(ishft(h1, bit_kind_shift), s1), iand(h1, 63_8)) + change = xor(change, btest(phasemask(ishft(p1, bit_kind_shift), s1), iand(p1, 63_8))) + + change = xor(change, btest(phasemask(ishft(h2, bit_kind_shift), s2), iand(h2, 63_8))) + change = xor(change, btest(phasemask(ishft(p2, bit_kind_shift), s2), iand(p2, 63_8))) + + get_phase_bi = 1d0 + if(s1 == s2) then + if(xor(change, max(h1, p1) > min(h2, p2))) get_phase_bi = -1d0 + else + if(change) get_phase_bi = -1d0 + end if +end subroutine + + +double precision function get_phase_mono(phasemask, s1, h1, p1) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: phasemask(N_int, 2) + integer, intent(in) :: s1, h1, p1 + logical :: change + + change = btest(phasemask(ishft(h1, bit_kind_shift), s1), iand(h1, 63_8)) + change = xor(change, btest(phasemask(ishft(p1, bit_kind_shift), s1), iand(p1, 63_8))) + + get_phase_mono = 1d0 + if(change) get_phase_mono = -1d0 +end subroutine + + + diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f new file mode 100644 index 00000000..f6a76141 --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_double.irp.f @@ -0,0 +1,512 @@ + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,i1,i2,ib,sp,k + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + do s1=1,2 + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + h2 = hole_list(i2,s2) + call apply_holes(psi_det_generators(1,1,i_generator), s1,h1,s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + bannedOrb = .false. + + call spot_isinwf(mask, psi_det_sorted, i_generator, N_det, banned, fullMatch) + if(fullMatch) cycle + call spot_occupied(mask, bannedOrb) + mat = 0d0 + call splash_pq(mask, sp, psi_det_sorted, i_generator, N_det_selectors, bannedOrb, banned, mat) + + call fill_buffer_double(i_generator, sp, h1, h2, banned, bannedOrb, fock_diag_tmp, E0, mat, buf) + end do + end do + end do + end do +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii + double precision, external :: diag_H_mat_elem_fock + + if(N_states > 1) stop "fill_buffer_double N_states > 1" + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + val = mat(1, p1, p2) + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + + delta_E = E0(1) - Hii + if (delta_E < 0.d0) then + e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + else + e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + endif + if(dabs(e_pert) > buf%mini) call add_to_selection_buffer(buf, det, e_pert) + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) ! intent out + + integer :: i, j, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(i < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(i == i_gen) mat = 0d0 + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(mo_tot_num, mo_tot_num, N_states) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2 + double precision :: hij, phase + + tip = p(0,1) * p(0,2) + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(tip == 3) then + putj = p(1, 2) + do i = 1, 3 + puti = p(i, ma) + + p1 = p(mod(i, 3) + 1, ma) + p2 = p(mod(i+1, 3) + 1, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + + if(ma == 1) then + mat(:, puti, putj) += coefs * hij + else + mat(:, putj, puti) += coefs * hij + end if + end do + else ! tip == 4 + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + p1 = p(mod(i, 2) + 1, 1) + p2 = p(mod(j, 2) + 1, 2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else !! AA/BB + + if(tip == 0) then + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(j == i+1) then + p1 = p(mod(j, 4) + 1, ma) + p2 = p(mod(j+1, 4) + 1, ma) + else if(j == i+2) then + p1 = p(mod(i, 4) + 1, ma) + p2 = p(mod(j, 4) + 1, ma) + else + p1 = 2 + p2 = 3 + end if + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + p2 = p(1, mi) + do i=1,3 + p1 = p(i, ma) + puti = p(mod(i, 3) + 1, ma) + putj = p(mod(i+1, 3) + 1, ma) + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, ma, mi, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + p1 = p(1, mi) + p2 = p(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if +end subroutine + + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, ho, pa, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num) + double precision, external :: get_phase_bi + + logical :: lbanned(mo_tot_num, 2), ok + integer :: ms, i, i1, i2, j, hole, tmp, s(3), p(3) + + integer, intent(in) :: ho(0:2,2), pa(0:4,2), sp + + do i = 1, pa(0,1) + s(i) = 1 + p(i) = pa(i, 1) + end do + + j = i + + do i = 1, pa(0,2) + s(j) = 2 + p(j) = pa(i, 2) + j += 1 + end do + + if(ho(0,1) == 1) then + hole = ho(1,1) + else + hole = ho(1,2) + end if + + lbanned = bannedOrb + + do i=1, 3 + lbanned(p(i), s(i)) = .true. + end do + + do i=1, 3 + if(lbanned(p(i), s(i))) cycle + if(sp /= 3 .and. sp /= s(i)) cycle + ms = sp + if(sp == 3) ms = mod(s(i), 2) + 1 + i1 = mod(i,3)+1 + i2 = mod(i+1,3)+1 + + if(s(i1) /= s(i2)) then + if(s(i1) /= ms) then + tmp = i1 + i1 = i2 + i2 = tmp + end if + tmp_row = 0d0 + do j=1,mo_tot_num + if(lbanned(j, s(i))) cycle + tmp_row(:, j) += coefs * integral8(p(i1), p(i2), j, hole) * get_phase_bi(phasemask, 1, 2, j, p(i1), hole, p(i2)) + end do + if(ms == 1) then + mat(:, :, p(i)) += tmp_row + else + mat(:, p(i), :) += tmp_row + end if + else + do j=1,mo_tot_num + if(lbanned(j, s(i))) cycle + tmp_row(:, j) += coefs * (integral8(p(i1), p(i2), j, hole) - integral8(p(i2), p(i1), j, hole)) * get_phase_bi(phasemask, 1, 2, j, p(i1), hole, p(i2)) + end do + mat(:, :p(i), p(i)) += tmp_row(:, :p(i)) + mat(:, p(i), p(i):) += tmp_row(:, p(i):) + end if + end do + !! MONO + do i=1, 2 + do j=i+1,3 + if(bannedOrb(p(i), s(i)) .or. bannedOrb(p(j), s(j))) cycle + if((s(i) /= s(j) .or. sp /= s(i)) .and. (s(i) == s(j) .or. sp /= 3)) cycle + call apply_particles(mask, s(i), p(i), s(j), p(j), det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + + if(s(i) == s(j)) then + mat(:, p(i), p(j)) += coefs * hij + else if(s(i) == 1) then + mat(:, p(i), p(j)) += coefs * hij + else + mat(:, p(j), p(i)) += coefs * hij + end if + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2), phasemask(N_int, 2) + logical, intent(in) :: bannedOrb(mo_tot_num), banned(mo_tot_num, mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2 + double precision :: hij + double precision, external :: get_phase_bi + logical :: ok + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(i)) cycle + do p2=1, mo_tot_num + if(bannedOrb(j)) cycle + if(banned(i, j)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + else + mat(:, p1, p2) += coefs * integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + end do + end do + else ! AA BB + s = 1 + if(p(0,2) == 2) s =2 + h1 = p(1,s) + h2 = p(2,s) + do p1=1, mo_tot_num + if(bannedOrb(i)) cycle + do p2=p1+1, mo_tot_num + if(bannedOrb(j)) cycle + if(banned(i, j)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2 .or. p1 == h2 .or. p2 == h1) then + call apply_particles(mask, s,p1,s,p2, det, ok, N_int) + ASSERT(ok) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + else + mat(:, p1, p2) += coefs * (integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2))* get_phase_bi(phasemask, s, s, h1, p1, h2, p2) + end if + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 1)) cycle genl + end do + + if(i < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f new file mode 100644 index 00000000..a2409135 --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_single.irp.f @@ -0,0 +1,333 @@ + + +subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + bannedOrb = .false. + + call spot_hasBeen(mask, sp, psi_det_sorted, i_generator, N_det, bannedOrb, fullMatch) + + if(fullMatch) cycle + call spot_occupied(mask, bannedOrb) + vect = 0d0 + call splash_p(mask, sp, psi_det_sorted(1,1,i_generator), N_det_selectors - i_generator + 1, bannedOrb, vect) + call fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii + double precision, external :: diag_H_mat_elem_fock + + if(N_states > 1) stop "fill_buffer_single N_states > 1" + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, s1, p1, det, ok, N_int) + val = vect(1, p1) + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + + delta_E = E0(1) - Hii + if (delta_E < 0.d0) then + e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + else + e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + endif + if(dabs(e_pert) > buf%mini) call add_to_selection_buffer(buf, det, e_pert) + end do +end subroutine + + +subroutine splash_p(mask, sp, det, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + else + call get_m0(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), phasemask(N_int, 2), mask(N_int, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi + + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + p1 = p(mod(i,3) + 1, sp) + p2 = p(mod(i+1,3) + 1, sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, p(i,sp)) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = mod(sp,2)+1 + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + pmob = p(mod(j,2)+1, sp) + hij = integral8(hfix, hmob, pfix, pmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + sfix = mod(sp,2)+1 + hij = integral8(p(1,sfix), p(2,sfix), h(1,sfix), h(2,sfix)) + hij *= get_phase_bi(phasemask, sfix, sfix, h(1,sfix), p(1,sfix), h(2,sfix), p(2,sfix)) + vect(:, puti) += hij * coefs + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), phasemask(N_int, 2), mask(N_int, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + p1 = p(1, sp) + lbanned(p1) = .true. + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(hole, i, p1, p2) - integral8(i, hole, p1, p2)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(hole, i, p1, p2) - integral8(i, hole, p1, p2)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(i,hole,p1,p2) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + !MONO + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs + + if(sp == sh) then + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + end if +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), phasemask(N_int, 2), mask(N_int, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(1, i) = vect(1, i) + hij * coefs(1) + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do genl +end subroutine + + diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 258f5391..d0827f3b 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -774,7 +774,7 @@ subroutine apply_excitation(det, exc, res, ok, Nint) end subroutine -subroutine apply_particle(det, s1, p1, s2, p2, res, ok, Nint) +subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint) use bitmasks implicit none integer, intent(in) :: Nint @@ -803,7 +803,7 @@ subroutine apply_particle(det, s1, p1, s2, p2, res, ok, Nint) end subroutine -subroutine apply_hole(det, s1, h1, s2, h2, res, ok, Nint) +subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint) use bitmasks implicit none integer, intent(in) :: Nint @@ -831,3 +831,45 @@ subroutine apply_hole(det, s1, h1, s2, h2, res, ok, Nint) ok = .true. end subroutine +subroutine apply_particle(det, s1, p1, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: s1, p1 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + res = det + + ii = (p1-1)/bit_kind_size + 1 + pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s1) = ibset(res(ii, s1), pos) + + ok = .true. +end subroutine + + +subroutine apply_hole(det, s1, h1, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: s1, h1 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + res = det + + ii = (h1-1)/bit_kind_size + 1 + pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s1) = ibclr(res(ii, s1), pos) + + ok = .true. +end subroutine \ No newline at end of file From 497a6a0f297f42597f7a6a5609156b3191b33bee Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Mon, 5 Sep 2016 17:18:01 +0200 Subject: [PATCH 3/8] removed prints --- plugins/Full_CI_ZMQ/selection.irp.f | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index d3d8e30b..32e08086 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -20,8 +20,6 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_phasemask, (N_int, 2, N_det)] implicit none integer :: i - print *, "pro" - print *, "pross" do i=1, N_det call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) end do @@ -73,8 +71,6 @@ subroutine select_connected(i_generator,E0,pt2,b) integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) double precision :: fock_diag_tmp(2,mo_tot_num+1) - print *, "BEG" - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) @@ -90,15 +86,9 @@ subroutine select_connected(i_generator,E0,pt2,b) particle_mask(k,:) = hole_mask(k,:) enddo - print *, "sel" -! call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - print *, "poivre" - print *, b%cur, b%N + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - print *, b%cur, b%N - print *, "paprika" enddo - print *, "safran" end subroutine From 418c096af78815a9a6d57cd3d02d0e6a43a44f8f Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Tue, 6 Sep 2016 09:19:54 +0200 Subject: [PATCH 4/8] Full_CI was missing from Full_CI_ZMQ children modules --- plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES index 1e5dbf4e..cb6ff46e 100644 --- a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full ZMQ +Perturbation Selectors_full Generators_full ZMQ Full_CI From 2b35d4b863a888aa544ddde9e18bcc6d9a1ad085 Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Thu, 8 Sep 2016 10:12:28 +0200 Subject: [PATCH 5/8] working debug version --- config/ifort.cfg | 4 +- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 12 +- plugins/Full_CI_ZMQ/selection.irp.f | 43 +-- plugins/Full_CI_ZMQ/selection_double.irp.f | 422 ++++++++++++++------- plugins/Full_CI_ZMQ/selection_single.irp.f | 139 ++++--- 5 files changed, 409 insertions(+), 211 deletions(-) diff --git a/config/ifort.cfg b/config/ifort.cfg index 5002ae89..d3a5f7b6 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags @@ -32,7 +32,7 @@ OPENMP : 1 ; Append OpenMP flags # [OPT] FC : -traceback -FCFLAGS : -xHost -O2 -ip -ftz -g +FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g # Profiling flags ################# diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 98b0ec2e..3dff6ef8 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -1,11 +1,12 @@ program fci_zmq implicit none - integer :: i,k + integer :: i,j,k logical, external :: detEq double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) integer :: N_st, degree integer(bit_kind) :: chk + N_st = N_states allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st)) @@ -78,6 +79,15 @@ program fci_zmq endif E_CI_before = CI_energy call ezfio_set_full_ci_energy(CI_energy) + print *, N_det , N_det_max,maxval(abs(pt2(1:N_st))), pt2_max + do i=1, N_det + call assert(popcnt(psi_det_sorted(1,2,i)) == 9, "nelec...") + call assert(popcnt(psi_det_sorted(1,1,i)) == 9, "nelec...") + !call debug_det(psi_det_sorted(1,1,i), N_int) + do j=1,i-1 + call assert(.not. detEq(psi_det_sorted(1,1,i), psi_det_sorted(1,1,j), N_int), "OOQSDSD") + end do + end do enddo N_det = min(N_det_max,N_det) touch N_det psi_det psi_coef diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 32e08086..0d7b3f25 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -46,6 +46,7 @@ subroutine get_mask_phase(det, phasemask) integer :: s, ni, i logical :: change + phasemask = 0_8 do s=1,2 change = .false. do ni=1,N_int @@ -71,7 +72,6 @@ subroutine select_connected(i_generator,E0,pt2,b) integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) double precision :: fock_diag_tmp(2,mo_tot_num+1) - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) do l=1,N_generators_bitmask @@ -85,7 +85,6 @@ subroutine select_connected(i_generator,E0,pt2,b) hole_mask(k,2) = ior(generators_bitmask(k,2,s_hole,l), generators_bitmask(k,2,s_part,l)) particle_mask(k,:) = hole_mask(k,:) enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) enddo @@ -96,15 +95,13 @@ subroutine spot_occupied(mask, bannedOrb) use bitmasks implicit none - integer(bit_kind),intent(in) :: mask(N_int, 2) - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer :: s, i, ne, list(mo_tot_num) + integer(bit_kind),intent(in) :: mask(N_int) + logical, intent(inout) :: bannedOrb(mo_tot_num) + integer :: i, ne, list(mo_tot_num) - do s=1,2 - call bitstring_to_list(mask(1,s), list, ne, N_int) - do i=1, ne - bannedOrb(list(i), s) = .true. - end do + call bitstring_to_list(mask, list, ne, N_int) + do i=1, ne + bannedOrb(list(i)) = .true. end do end subroutine @@ -116,20 +113,21 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) integer(bit_kind), intent(in) :: phasemask(N_int, 2) integer, intent(in) :: s1, s2, h1, h2, p1, p2 logical :: change + integer :: np + double precision, parameter :: res(0:1) = (/1d0, -1d0/) - !ASSERT(h1 <= h2 .and. p1 <= p2) - change = btest(phasemask(ishft(h1, bit_kind_shift), s1), iand(h1, 63_8)) - change = xor(change, btest(phasemask(ishft(p1, bit_kind_shift), s1), iand(p1, 63_8))) + call assert(s1 /= s2 .or. (h1 <= h2 .and. p1 <= p2), irp_here) + np = 0 + change = btest(phasemask(1+ishft(h1, -6), s1), iand(h1-1, 63)) + change = xor(change, btest(phasemask(1+ishft(p1, -6), s1), iand(p1-1, 63))) + if(xor(change, p1 < h1)) np = 1 - change = xor(change, btest(phasemask(ishft(h2, bit_kind_shift), s2), iand(h2, 63_8))) - change = xor(change, btest(phasemask(ishft(p2, bit_kind_shift), s2), iand(p2, 63_8))) - - get_phase_bi = 1d0 - if(s1 == s2) then - if(xor(change, max(h1, p1) > min(h2, p2))) get_phase_bi = -1d0 - else - if(change) get_phase_bi = -1d0 - end if + change = btest(phasemask(1+ishft(h2, -6), s2), iand(h2-1, 63)) + change = xor(change, btest(phasemask(1+ishft(p2, -6), s2), iand(p2-1, 63))) + if(xor(change, p2 < h2)) np = np + 1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1 + get_phase_bi = res(iand(np,1)) end subroutine @@ -140,6 +138,7 @@ double precision function get_phase_mono(phasemask, s1, h1, p1) integer(bit_kind), intent(in) :: phasemask(N_int, 2) integer, intent(in) :: s1, h1, p1 logical :: change + stop "phase moni BUGGED" change = btest(phasemask(ishft(h1, bit_kind_shift), s1), iand(h1, 63_8)) change = xor(change, btest(phasemask(ishft(p1, bit_kind_shift), s1), iand(p1, 63_8))) diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f index f6a76141..676cefae 100644 --- a/plugins/Full_CI_ZMQ/selection_double.irp.f +++ b/plugins/Full_CI_ZMQ/selection_double.irp.f @@ -30,7 +30,7 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - + call assert(psi_det_generators(1,1,i_generator) == psi_det_sorted(1,1,i_generator), "sorted selex") do s1=1,2 do s2=s1,2 sp = s1 @@ -42,20 +42,24 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p h1 = hole_list(i1,s1) h2 = hole_list(i2,s2) call apply_holes(psi_det_generators(1,1,i_generator), s1,h1,s2,h2, mask, ok, N_int) - + call assert(ok, irp_here) + logical :: banned(mo_tot_num, mo_tot_num) logical :: bannedOrb(mo_tot_num, 2) banned = .false. bannedOrb = .false. - + bannedOrb(h1, s1) = .true. + bannedOrb(h2, s2) = .true. + call spot_isinwf(mask, psi_det_sorted, i_generator, N_det, banned, fullMatch) if(fullMatch) cycle - call spot_occupied(mask, bannedOrb) + if(sp /= 2) call spot_occupied(mask(1,1), bannedOrb(1,1)) + if(sp /= 1) call spot_occupied(mask(1,2), bannedOrb(1,2)) + mat = 0d0 call splash_pq(mask, sp, psi_det_sorted, i_generator, N_det_selectors, bannedOrb, banned, mat) - - call fill_buffer_double(i_generator, sp, h1, h2, banned, bannedOrb, fock_diag_tmp, E0, mat, buf) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) end do end do end do @@ -63,7 +67,7 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p end subroutine -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, mat, buf) +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) use bitmasks use selection_types implicit none @@ -73,13 +77,16 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) double precision, intent(in) :: fock_diag_tmp(mo_tot_num) double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) type(selection_buffer), intent(inout) :: buf logical :: ok - integer :: s1, s2, p1, p2, ib + integer :: s1, s2, p1, p2, ib, j integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) double precision :: e_pert, delta_E, val, Hii double precision, external :: diag_H_mat_elem_fock + logical, external :: detEq + if(N_states > 1) stop "fill_buffer_double N_states > 1" if(sp == 3) then @@ -91,7 +98,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d end if call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - + call assert(ok, "sosoqs") do p1=1,mo_tot_num if(bannedOrb(p1, s1)) cycle ib = 1 @@ -101,6 +108,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if(banned(p1,p2)) cycle if(mat(1, p1, p2) == 0d0) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call assert(ok, "ododod") val = mat(1, p1, p2) Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) @@ -111,7 +119,17 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d else e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) endif - if(dabs(e_pert) > buf%mini) call add_to_selection_buffer(buf, det, e_pert) + pt2(1) += e_pert + if(dabs(e_pert) > buf%mini) then + do j=1,buf%cur-1 + if(detEq(buf%det(1,1,j), det, N_int)) then + print *, "tops" + print *, i_generator, s1, s2, h1, h2,p1,p2 + stop + end if + end do + call add_to_selection_buffer(buf, det, e_pert) + end if end do end do end subroutine @@ -124,11 +142,12 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat) integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) integer, intent(in) :: sp, i_gen, N_sel logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) ! intent out + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) integer :: i, j, h(0:2,2), p(0:4,2), nt integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - + + mat = 0d0 do i=1,N_int negMask(i,1) = not(mask(i,1)) @@ -155,18 +174,19 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat) call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - + + call assert(nt >= 2, irp_here//"qsd") if(i < i_gen) then if(nt == 4) call past_d2(banned, p, sp) if(nt == 3) call past_d1(bannedOrb, p) + call assert(nt /= 2, "should have been discarded") else - if(i == i_gen) mat = 0d0 if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + call get_d2(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + call get_d1(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) else - call get_d0(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + call get_d0(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) end if end if end do @@ -180,98 +200,145 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int, 2) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(mo_tot_num, mo_tot_num, N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) integer, intent(in) :: h(0:2,2), p(0:4,2), sp double precision, external :: get_phase_bi integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2 + integer :: h1, h2, p1, p2, i1, i2 double precision :: hij, phase + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + tip = p(0,1) * p(0,2) + call assert(p(0,1) + p(0,2) == 4, irp_here//"df") ma = sp if(p(0,1) > p(0,2)) ma = 1 if(p(0,1) < p(0,2)) ma = 2 mi = mod(ma, 2) + 1 - + + !print *, "d2 SPtip", SP, tip if(sp == 3) then if(tip == 3) then - putj = p(1, 2) + puti = p(1, mi) do i = 1, 3 - puti = p(i, ma) + putj = p(i, ma) + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + call assert(h(0,ma) == 2, "dmdmd") + call assert(p(0, ma) == 3, "dmdm2") + h1 = h(1, ma) + h2 = h(2, ma) - p1 = p(mod(i, 3) + 1, ma) - p2 = p(mod(i+1, 3) + 1, ma) hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - + call debug_hij(hij, gen, mask, mi, ma, puti, putj) if(ma == 1) then - mat(:, puti, putj) += coefs * hij - else mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij end if end do - else ! tip == 4 + else + call assert(tip == 4, "df") do i = 1,2 do j = 1,2 puti = p(i, 1) putj = p(j, 2) - p1 = p(mod(i, 2) + 1, 1) - p2 = p(mod(j, 2) + 1, 2) + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + call debug_hij(hij, gen, mask, 1, 2, puti, putj) mat(:, puti, putj) += coefs * hij end do end do end if - else !! AA/BB - + else if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) do i=1,3 puti = p(i, ma) do j=i+1,4 putj = p(j, ma) - if(j == i+1) then - p1 = p(mod(j, 4) + 1, ma) - p2 = p(mod(j+1, 4) + 1, ma) - else if(j == i+2) then - p1 = p(mod(i, 4) + 1, ma) - p2 = p(mod(j, 4) + 1, ma) - else - p1 = 2 - p2 = 3 - end if - + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + call debug_hij(hij, gen, mask, ma, ma, puti, putj) mat(:, puti, putj) += coefs * hij end do end do else if(tip == 3) then - p2 = p(1, mi) + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + call assert(ma == sp, "dldl") do i=1,3 - p1 = p(i, ma) - puti = p(mod(i, 3) + 1, ma) - putj = p(mod(i+1, 3) + 1, ma) - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, ma, mi, h1, p1, h2, p2) + p2 = p(i, ma) + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + call debug_hij(hij, gen, mask, ma, ma, puti, putj) mat(:, min(puti, putj), max(puti, putj)) += coefs * hij end do else ! tip == 4 + call assert(tip == 4, "qsdf") puti = p(1, sp) putj = p(2, sp) p1 = p(1, mi) p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + call debug_hij(hij, gen, mask,ma,ma, puti, putj) mat(:, puti, putj) += coefs * hij end if end if end subroutine +subroutine debug_hij(hij, gen, mask, s1, s2, p1, p2) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int,2), mask(N_int,2) + double precision, intent(in) :: hij + integer, intent(in) :: s1, s2, p1, p2 + integer(bit_kind) :: det(N_int,2) + double precision :: hij_ref, phase_ref + logical :: ok + integer :: degree + integer :: exc(0:2,2,2) -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, ho, pa, sp, coefs) + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call assert(ok, "nokey") + call i_H_j_phase_out(gen,det,N_int,hij_ref,phase_ref,exc,degree) + if(hij /= hij_ref) then + print *, hij, hij_ref + print *, s1, s2, p1, p2 + call debug_det(gen, N_int) + call debug_det(mask, N_int) + stop + end if + + ! print *, "fourar", hij, hij_ref,s1,s2 +end function + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) use bitmasks implicit none @@ -280,89 +347,157 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, ho, pa, sp, coef integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) double precision, external :: get_phase_bi logical :: lbanned(mo_tot_num, 2), ok - integer :: ms, i, i1, i2, j, hole, tmp, s(3), p(3) + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, intent(in) :: ho(0:2,2), pa(0:4,2), sp - - do i = 1, pa(0,1) - s(i) = 1 - p(i) = pa(i, 1) - end do - - j = i - - do i = 1, pa(0,2) - s(j) = 2 - p(j) = pa(i, 2) - j += 1 - end do - - if(ho(0,1) == 1) then - hole = ho(1,1) - else - hole = ho(1,2) - end if lbanned = bannedOrb - - do i=1, 3 - lbanned(p(i), s(i)) = .true. + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + !print *, "d1 SP", sp, p(0,1)*p(0,2) - do i=1, 3 - if(lbanned(p(i), s(i))) cycle - if(sp /= 3 .and. sp /= s(i)) cycle - ms = sp - if(sp == 3) ms = mod(s(i), 2) + 1 - i1 = mod(i,3)+1 - i2 = mod(i+1,3)+1 - - if(s(i1) /= s(i2)) then - if(s(i1) /= ms) then - tmp = i1 - i1 = i2 - i2 = tmp - end if + if(sp == 3) then + !move MA + call assert(p(0,1)*p(0,2) == 2, "ddmmm") + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then tmp_row = 0d0 - do j=1,mo_tot_num - if(lbanned(j, s(i))) cycle - tmp_row(:, j) += coefs * integral8(p(i1), p(i2), j, hole) * get_phase_bi(phasemask, 1, 2, j, p(i1), hole, p(i2)) + do putj=1, hfix-1 + if(lbanned(putj, ma)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + call debug_hij(hij, gen, mask, mi, ma, puti, putj) + tmp_row(:,putj) += hij * coefs end do - if(ms == 1) then - mat(:, :, p(i)) += tmp_row - else - mat(:, p(i), :) += tmp_row - end if - else - do j=1,mo_tot_num - if(lbanned(j, s(i))) cycle - tmp_row(:, j) += coefs * (integral8(p(i1), p(i2), j, hole) - integral8(p(i2), p(i1), j, hole)) * get_phase_bi(phasemask, 1, 2, j, p(i1), hole, p(i2)) + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + call debug_hij(hij, gen, mask, mi, ma, puti, putj) + tmp_row(:,putj) += hij * coefs end do - mat(:, :p(i), p(i)) += tmp_row(:, :p(i)) - mat(:, p(i), p(i):) += tmp_row(:, p(i):) - end if - end do - !! MONO - do i=1, 2 - do j=i+1,3 - if(bannedOrb(p(i), s(i)) .or. bannedOrb(p(j), s(j))) cycle - if((s(i) /= s(j) .or. sp /= s(i)) .and. (s(i) == s(j) .or. sp /= 3)) cycle - call apply_particles(mask, s(i), p(i), s(j), p(j), det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - if(s(i) == s(j)) then - mat(:, p(i), p(j)) += coefs * hij - else if(s(i) == 1) then - mat(:, p(i), p(j)) += coefs * hij + if(ma == 1) then + mat(:,:,puti) += tmp_row(:,:) else - mat(:, p(j), p(i)) += coefs * hij + mat(:,puti,:) += tmp_row(:,:) end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + call debug_hij(hij, gen, mask, mi, ma, puti, putj) + tmp_row(:,puti) += hij * coefs + putj = p2 + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + call debug_hij(hij, gen, mask, mi, ma, puti, putj) + tmp_row2(:,puti) += hij * coefs + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + call debug_hij(hij, gen, mask, ma, ma, puti, putj) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + call debug_hij(hij, gen, mask, ma, ma, puti, putj) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + call assert(sp == ma, "sp == ma") + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + call debug_hij(hij, gen, mask, ma, ma, putj, puti) + tmp_row(:,puti) += hij * coefs + + putj = p1 + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + call debug_hij(hij, gen, mask, ma, ma, putj, puti) + tmp_row2(:,puti) += hij * coefs + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do end do - end do end subroutine @@ -373,51 +508,57 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2), phasemask(N_int, 2) - logical, intent(in) :: bannedOrb(mo_tot_num), banned(mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) integer, intent(in) :: h(0:2,2), p(0:4,2), sp - integer :: i, j, s, h1, h2, p1, p2 - double precision :: hij + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase double precision, external :: get_phase_bi logical :: ok + !print *, "d0 SP", sp + if(sp == 3) then ! AB h1 = p(1,1) h2 = p(1,2) do p1=1, mo_tot_num - if(bannedOrb(i)) cycle + if(bannedOrb(p1, 1)) cycle do p2=1, mo_tot_num - if(bannedOrb(j)) cycle - if(banned(i, j)) cycle ! rentable? + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2)) cycle ! rentable? if(p1 == h1 .or. p2 == h2) then call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call assert(ok, "zsdq") call i_h_j(gen, det, N_int, hij) mat(:, p1, p2) += coefs * hij else - mat(:, p1, p2) += coefs * integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + call debug_hij(hij, gen, mask, 1, 2, p1, p2) + mat(:, p1, p2) += coefs * hij end if end do end do else ! AA BB - s = 1 - if(p(0,2) == 2) s =2 - h1 = p(1,s) - h2 = p(2,s) - do p1=1, mo_tot_num - if(bannedOrb(i)) cycle - do p2=p1+1, mo_tot_num - if(bannedOrb(j)) cycle - if(banned(i, j)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2 .or. p1 == h2 .or. p2 == h1) then - call apply_particles(mask, s,p1,s,p2, det, ok, N_int) - ASSERT(ok) + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call ASSERT(ok, "ssss") call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij + mat(:, puti, putj) += coefs * hij else - mat(:, p1, p2) += coefs * (integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2))* get_phase_bi(phasemask, s, s, h1, p1, h2, p2) + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + mat(:, puti, putj) += coefs * hij + call debug_hij(hij, gen, mask, sp, sp, puti, putj) end if end do end do @@ -490,7 +631,7 @@ subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch) genl : do i=1, N do j=1, N_int if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl end do if(i < i_gen) then @@ -505,7 +646,8 @@ subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch) call bitstring_to_list(myMask(1,1), list(1), na, N_int) call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - + call assert(na + nb == 2, "oyo") + call assert(na == 1 .or. list(1) < list(2), "sqdsmmmm") banned(list(1), list(2)) = .true. end do genl end subroutine diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f index a2409135..89f2b1ec 100644 --- a/plugins/Full_CI_ZMQ/selection_single.irp.f +++ b/plugins/Full_CI_ZMQ/selection_single.irp.f @@ -1,13 +1,13 @@ -subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) use bitmasks use selection_types implicit none BEGIN_DOC ! Select determinants connected to i_det by H END_DOC - integer, intent(in) :: i_generator + integer, intent(in) :: i_gen integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) double precision, intent(in) :: fock_diag_tmp(mo_tot_num) double precision, intent(in) :: E0(N_states) @@ -23,10 +23,10 @@ subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) enddo ! Create lists of holes and particles @@ -39,27 +39,25 @@ subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - do sp=1,2 do i=1, N_holes(sp) h1 = hole_list(i,sp) - call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) - + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + call assert(ok, irp_here) bannedOrb = .false. - - call spot_hasBeen(mask, sp, psi_det_sorted, i_generator, N_det, bannedOrb, fullMatch) - + bannedOrb(h1) = .true. + call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) if(fullMatch) cycle - call spot_occupied(mask, bannedOrb) + call spot_occupied(mask(1,sp), bannedOrb) vect = 0d0 - call splash_p(mask, sp, psi_det_sorted(1,1,i_generator), N_det_selectors - i_generator + 1, bannedOrb, vect) - call fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, vect, buf) + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) end do enddo end subroutine -subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, vect, buf) +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) use bitmasks use selection_types implicit none @@ -69,6 +67,7 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: fock_diag_tmp(mo_tot_num) double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) type(selection_buffer), intent(inout) :: buf logical :: ok integer :: s1, s2, p1, p2, ib @@ -83,7 +82,7 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, do p1=1,mo_tot_num if(bannedOrb(p1)) cycle if(vect(1, p1) == 0d0) cycle - call apply_particle(mask, s1, p1, det, ok, N_int) + call apply_particle(mask, sp, p1, det, ok, N_int) val = vect(1, p1) Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) @@ -94,16 +93,18 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, else e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) endif + pt2(1) += e_pert if(dabs(e_pert) > buf%mini) call add_to_selection_buffer(buf, det, e_pert) end do end subroutine -subroutine splash_p(mask, sp, det, N_sel, bannedOrb, vect) +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) use bitmasks implicit none - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel), phasemask(N_int,2,N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) integer, intent(in) :: sp, N_sel logical, intent(inout) :: bannedOrb(mo_tot_num) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -138,11 +139,11 @@ subroutine splash_p(mask, sp, det, N_sel, bannedOrb, vect) call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) if(nt == 3) then - call get_m2(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) else if(nt == 2) then - call get_m1(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) else - call get_m0(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, psi_selectors_coef_transp(1, i)) + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) end if end do end subroutine @@ -161,34 +162,44 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) double precision :: hij double precision, external :: get_phase_bi + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) if(h(0,sp) == 2) then h1 = h(1, sp) h2 = h(2, sp) do i=1,3 - p1 = p(mod(i,3) + 1, sp) - p2 = p(mod(i+1,3) + 1, sp) + puti = p(i, sp) + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, p(i,sp)) += hij * coefs + call debug_hij_mo(hij, gen, mask, sp, puti) + vect(:, puti) += hij * coefs end do else if(h(0,sp) == 1) then - sfix = mod(sp,2)+1 + sfix = turn2(sp) hfix = h(1,sfix) pfix = p(1,sfix) hmob = h(1,sp) do j=1,2 puti = p(j, sp) - pmob = p(mod(j,2)+1, sp) - hij = integral8(hfix, hmob, pfix, pmob) + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + call debug_hij_mo(hij, gen, mask, sp, puti) vect(:, puti) += hij * coefs end do else puti = p(1,sp) - sfix = mod(sp,2)+1 - hij = integral8(p(1,sfix), p(2,sfix), h(1,sfix), h(2,sfix)) - hij *= get_phase_bi(phasemask, sfix, sfix, h(1,sfix), p(1,sfix), h(2,sfix), p(2,sfix)) + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + call debug_hij_mo(hij, gen, mask, sp, puti) vect(:, puti) += hij * coefs end if end subroutine @@ -214,8 +225,11 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) sh = 1 if(h(0,2) == 1) sh = 2 hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + p1 = p(1, sp) - lbanned(p1) = .true. if(sp == sh) then p2 = p(2, sp) @@ -223,37 +237,40 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) do i=1,hole-1 if(lbanned(i)) cycle - hij = (integral8(hole, i, p1, p2) - integral8(i, hole, p1, p2)) + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + call debug_hij_mo(hij, gen, mask, sp, i) vect(:,i) += hij * coefs end do do i=hole+1,mo_tot_num if(lbanned(i)) cycle - hij = (integral8(hole, i, p1, p2) - integral8(i, hole, p1, p2)) + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + call debug_hij_mo(hij, gen, mask, sp, i) vect(:,i) += hij * coefs end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call assert(ok, "OKE223") + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs else p2 = p(1, sh) do i=1,mo_tot_num if(lbanned(i)) cycle - hij = integral8(i,hole,p1,p2) + hij = integral8(p1, p2, i, hole) hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + call debug_hij_mo(hij, gen, mask, sp, i) vect(:,i) += hij * coefs end do end if - - !MONO - - call apply_particle(mask, sp, p1, det, ok, N_int) + + call apply_particle(mask, sp, p1, det, ok, N_int) + call assert(ok, "OKQQE2") call i_h_j(gen, det, N_int, hij) vect(:, p1) += hij * coefs - - if(sp == sh) then - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - end if + + !print *, "endouille" end subroutine @@ -276,8 +293,9 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) do i=1,mo_tot_num if(lbanned(i)) cycle call apply_particle(mask, sp, i, det, ok, N_int) + call assert(ok, "qsdo") call i_h_j(gen, det, N_int, hij) - vect(1, i) = vect(1, i) + hij * coefs(1) + vect(:, i) += hij * coefs end do end subroutine @@ -331,3 +349,32 @@ subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) end subroutine + +subroutine debug_hij_mo(hij, gen, mask, s1, p1) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int,2), mask(N_int,2) + double precision, intent(in) :: hij + integer, intent(in) :: s1, p1 + integer(bit_kind) :: det(N_int,2) + double precision :: hij_ref, phase_ref + logical :: ok + integer :: degree + integer :: exc(0:2,2,2) + logical, external :: detEq + + call apply_particle(mask, s1, p1, det, ok, N_int) + call assert(ok, "nokey_mo") + call assert(.not. detEq(det, gen, N_int), "Hii ...") + call i_H_j_phase_out(gen,det,N_int,hij_ref,phase_ref,exc,degree) + if(hij /= hij_ref) then + print *, hij, hij_ref + print *, s1, p1 + call debug_det(gen, N_int) + call debug_det(mask, N_int) + call debug_det(det, N_int) + stop + end if +end function + From 741b5deaba57c7ddee62418028867322a9142a35 Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Thu, 8 Sep 2016 12:27:37 +0200 Subject: [PATCH 6/8] removed debug checks --- plugins/Full_CI_ZMQ/selection_double.irp.f | 66 +++++++++++----------- plugins/Full_CI_ZMQ/selection_single.irp.f | 22 ++++---- 2 files changed, 44 insertions(+), 44 deletions(-) diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f index 676cefae..268d9cbf 100644 --- a/plugins/Full_CI_ZMQ/selection_double.irp.f +++ b/plugins/Full_CI_ZMQ/selection_double.irp.f @@ -30,7 +30,7 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - call assert(psi_det_generators(1,1,i_generator) == psi_det_sorted(1,1,i_generator), "sorted selex") + !call assert(psi_det_generators(1,1,i_generator) == psi_det_sorted(1,1,i_generator), "sorted selex") do s1=1,2 do s2=s1,2 sp = s1 @@ -42,7 +42,7 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p h1 = hole_list(i1,s1) h2 = hole_list(i2,s2) call apply_holes(psi_det_generators(1,1,i_generator), s1,h1,s2,h2, mask, ok, N_int) - call assert(ok, irp_here) + !call assert(ok, irp_here) logical :: banned(mo_tot_num, mo_tot_num) logical :: bannedOrb(mo_tot_num, 2) @@ -98,7 +98,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d end if call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - call assert(ok, "sosoqs") + !call assert(ok, "sosoqs") do p1=1,mo_tot_num if(bannedOrb(p1, s1)) cycle ib = 1 @@ -108,7 +108,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if(banned(p1,p2)) cycle if(mat(1, p1, p2) == 0d0) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call assert(ok, "ododod") + !call assert(ok, "ododod") val = mat(1, p1, p2) Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) @@ -175,11 +175,11 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat) call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - call assert(nt >= 2, irp_here//"qsd") + !call assert(nt >= 2, irp_here//"qsd") if(i < i_gen) then if(nt == 4) call past_d2(banned, p, sp) if(nt == 3) call past_d1(bannedOrb, p) - call assert(nt /= 2, "should have been discarded") + !call assert(nt /= 2, "should have been discarded") else if(nt == 4) then call get_d2(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) @@ -215,7 +215,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) tip = p(0,1) * p(0,2) - call assert(p(0,1) + p(0,2) == 4, irp_here//"df") + !call assert(p(0,1) + p(0,2) == 4, irp_here//"df") ma = sp if(p(0,1) > p(0,2)) ma = 1 if(p(0,1) < p(0,2)) ma = 2 @@ -231,14 +231,14 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) i2 = turn3(2,i) p1 = p(i1, ma) p2 = p(i2, ma) - call assert(h(0,ma) == 2, "dmdmd") - call assert(p(0, ma) == 3, "dmdm2") + !call assert(h(0,ma) == 2, "dmdmd") + !call assert(p(0, ma) == 3, "dmdm2") h1 = h(1, ma) h2 = h(2, ma) hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - call debug_hij(hij, gen, mask, mi, ma, puti, putj) + !call debug_hij(hij, gen, mask, mi, ma, puti, putj) if(ma == 1) then mat(:, putj, puti) += coefs * hij else @@ -246,7 +246,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) end if end do else - call assert(tip == 4, "df") + !call assert(tip == 4, "df") do i = 1,2 do j = 1,2 puti = p(i, 1) @@ -257,7 +257,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) h2 = h(1,2) hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - call debug_hij(hij, gen, mask, 1, 2, puti, putj) + !call debug_hij(hij, gen, mask, 1, 2, puti, putj) mat(:, puti, putj) += coefs * hij end do @@ -277,7 +277,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) p1 = p(i1, ma) p2 = p(i2, ma) hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - call debug_hij(hij, gen, mask, ma, ma, puti, putj) + !call debug_hij(hij, gen, mask, ma, ma, puti, putj) mat(:, puti, putj) += coefs * hij end do end do @@ -285,17 +285,17 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) h1 = h(1, mi) h2 = h(1, ma) p1 = p(1, mi) - call assert(ma == sp, "dldl") + !call assert(ma == sp, "dldl") do i=1,3 p2 = p(i, ma) puti = p(turn3(1,i), ma) putj = p(turn3(2,i), ma) hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - call debug_hij(hij, gen, mask, ma, ma, puti, putj) + !call debug_hij(hij, gen, mask, ma, ma, puti, putj) mat(:, min(puti, putj), max(puti, putj)) += coefs * hij end do else ! tip == 4 - call assert(tip == 4, "qsdf") + !call assert(tip == 4, "qsdf") puti = p(1, sp) putj = p(2, sp) p1 = p(1, mi) @@ -303,7 +303,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) h1 = h(1, mi) h2 = h(2, mi) hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - call debug_hij(hij, gen, mask,ma,ma, puti, putj) + !call debug_hij(hij, gen, mask,ma,ma, puti, putj) mat(:, puti, putj) += coefs * hij end if end if @@ -324,7 +324,7 @@ subroutine debug_hij(hij, gen, mask, s1, s2, p1, p2) integer :: exc(0:2,2,2) call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call assert(ok, "nokey") + !call assert(ok, "nokey") call i_H_j_phase_out(gen,det,N_int,hij_ref,phase_ref,exc,degree) if(hij /= hij_ref) then print *, hij, hij_ref @@ -375,7 +375,7 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) if(sp == 3) then !move MA - call assert(p(0,1)*p(0,2) == 2, "ddmmm") + !call assert(p(0,1)*p(0,2) == 2, "ddmmm") puti = p(1,mi) hfix = h(1,ma) p1 = p(1,ma) @@ -385,13 +385,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) do putj=1, hfix-1 if(lbanned(putj, ma)) cycle hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - call debug_hij(hij, gen, mask, mi, ma, puti, putj) + !call debug_hij(hij, gen, mask, mi, ma, puti, putj) tmp_row(:,putj) += hij * coefs end do do putj=hfix+1, mo_tot_num if(lbanned(putj, ma)) cycle hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - call debug_hij(hij, gen, mask, mi, ma, puti, putj) + !call debug_hij(hij, gen, mask, mi, ma, puti, putj) tmp_row(:,putj) += hij * coefs end do @@ -411,11 +411,11 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) !p1 fixed putj = p1 hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - call debug_hij(hij, gen, mask, mi, ma, puti, putj) + !call debug_hij(hij, gen, mask, mi, ma, puti, putj) tmp_row(:,puti) += hij * coefs putj = p2 hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - call debug_hij(hij, gen, mask, mi, ma, puti, putj) + !call debug_hij(hij, gen, mask, mi, ma, puti, putj) tmp_row2(:,puti) += hij * coefs end do @@ -437,13 +437,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) do putj=1,hfix-1 if(lbanned(putj,ma)) cycle hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - call debug_hij(hij, gen, mask, ma, ma, puti, putj) + !call debug_hij(hij, gen, mask, ma, ma, puti, putj) tmp_row(:,putj) += hij * coefs end do do putj=hfix+1,mo_tot_num if(lbanned(putj,ma)) cycle hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - call debug_hij(hij, gen, mask, ma, ma, puti, putj) + !call debug_hij(hij, gen, mask, ma, ma, puti, putj) tmp_row(:,putj) += hij * coefs end do @@ -451,7 +451,7 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) mat(:, puti, puti:) += tmp_row(:,puti:) end do else - call assert(sp == ma, "sp == ma") + !call assert(sp == ma, "sp == ma") hfix = h(1,mi) pfix = p(1,mi) p1 = p(1,ma) @@ -462,12 +462,12 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) if(lbanned(puti,ma)) cycle putj = p2 hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - call debug_hij(hij, gen, mask, ma, ma, putj, puti) + !call debug_hij(hij, gen, mask, ma, ma, putj, puti) tmp_row(:,puti) += hij * coefs putj = p1 hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - call debug_hij(hij, gen, mask, ma, ma, putj, puti) + !call debug_hij(hij, gen, mask, ma, ma, putj, puti) tmp_row2(:,puti) += hij * coefs end do mat(:,:p2-1,p2) += tmp_row(:,:p2-1) @@ -531,13 +531,13 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) if(banned(p1, p2)) cycle ! rentable? if(p1 == h1 .or. p2 == h2) then call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call assert(ok, "zsdq") + !call assert(ok, "zsdq") call i_h_j(gen, det, N_int, hij) mat(:, p1, p2) += coefs * hij else hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - call debug_hij(hij, gen, mask, 1, 2, p1, p2) + !call debug_hij(hij, gen, mask, 1, 2, p1, p2) mat(:, p1, p2) += coefs * hij end if end do @@ -558,7 +558,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) else hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) mat(:, puti, putj) += coefs * hij - call debug_hij(hij, gen, mask, sp, sp, puti, putj) + !call debug_hij(hij, gen, mask, sp, sp, puti, putj) end if end do end do @@ -646,8 +646,8 @@ subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch) call bitstring_to_list(myMask(1,1), list(1), na, N_int) call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - call assert(na + nb == 2, "oyo") - call assert(na == 1 .or. list(1) < list(2), "sqdsmmmm") + !call assert(na + nb == 2, "oyo") + !call assert(na == 1 .or. list(1) < list(2), "sqdsmmmm") banned(list(1), list(2)) = .true. end do genl end subroutine diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f index 89f2b1ec..b9f53766 100644 --- a/plugins/Full_CI_ZMQ/selection_single.irp.f +++ b/plugins/Full_CI_ZMQ/selection_single.irp.f @@ -43,7 +43,7 @@ subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf do i=1, N_holes(sp) h1 = hole_list(i,sp) call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) - call assert(ok, irp_here) + !call assert(ok, irp_here) bannedOrb = .false. bannedOrb(h1) = .true. call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) @@ -174,7 +174,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) p2 = p(turn3_2(2,i), sp) hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - call debug_hij_mo(hij, gen, mask, sp, puti) + !call debug_hij_mo(hij, gen, mask, sp, puti) vect(:, puti) += hij * coefs end do else if(h(0,sp) == 1) then @@ -187,7 +187,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) pmob = p(turn2(j), sp) hij = integral8(pfix, pmob, hfix, hmob) hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - call debug_hij_mo(hij, gen, mask, sp, puti) + !call debug_hij_mo(hij, gen, mask, sp, puti) vect(:, puti) += hij * coefs end do else @@ -199,7 +199,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) h2 = h(2,sfix) hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - call debug_hij_mo(hij, gen, mask, sp, puti) + !call debug_hij_mo(hij, gen, mask, sp, puti) vect(:, puti) += hij * coefs end if end subroutine @@ -239,7 +239,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) if(lbanned(i)) cycle hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - call debug_hij_mo(hij, gen, mask, sp, i) + !call debug_hij_mo(hij, gen, mask, sp, i) vect(:,i) += hij * coefs end do do i=hole+1,mo_tot_num @@ -251,7 +251,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) end do call apply_particle(mask, sp, p2, det, ok, N_int) - call assert(ok, "OKE223") + !call assert(ok, "OKE223") call i_h_j(gen, det, N_int, hij) vect(:, p2) += hij * coefs else @@ -260,13 +260,13 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) if(lbanned(i)) cycle hij = integral8(p1, p2, i, hole) hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - call debug_hij_mo(hij, gen, mask, sp, i) + !call debug_hij_mo(hij, gen, mask, sp, i) vect(:,i) += hij * coefs end do end if call apply_particle(mask, sp, p1, det, ok, N_int) - call assert(ok, "OKQQE2") + !call assert(ok, "OKQQE2") call i_h_j(gen, det, N_int, hij) vect(:, p1) += hij * coefs @@ -293,7 +293,7 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) do i=1,mo_tot_num if(lbanned(i)) cycle call apply_particle(mask, sp, i, det, ok, N_int) - call assert(ok, "qsdo") + !call assert(ok, "qsdo") call i_h_j(gen, det, N_int, hij) vect(:, i) += hij * coefs end do @@ -365,8 +365,8 @@ subroutine debug_hij_mo(hij, gen, mask, s1, p1) logical, external :: detEq call apply_particle(mask, s1, p1, det, ok, N_int) - call assert(ok, "nokey_mo") - call assert(.not. detEq(det, gen, N_int), "Hii ...") + !call assert(ok, "nokey_mo") + !call assert(.not. detEq(det, gen, N_int), "Hii ...") call i_H_j_phase_out(gen,det,N_int,hij_ref,phase_ref,exc,degree) if(hij /= hij_ref) then print *, hij, hij_ref From 90b84581b06ff96f8c97e6fd9d6c517f428bbbcd Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Thu, 8 Sep 2016 15:22:09 +0200 Subject: [PATCH 7/8] enforced electron pair ban --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 9 -- plugins/Full_CI_ZMQ/selection.irp.f | 30 +++-- plugins/Full_CI_ZMQ/selection_double.irp.f | 133 ++++++++++++++------- plugins/Full_CI_ZMQ/selection_single.irp.f | 30 +++-- 4 files changed, 127 insertions(+), 75 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 3dff6ef8..16009b65 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -79,15 +79,6 @@ program fci_zmq endif E_CI_before = CI_energy call ezfio_set_full_ci_energy(CI_energy) - print *, N_det , N_det_max,maxval(abs(pt2(1:N_st))), pt2_max - do i=1, N_det - call assert(popcnt(psi_det_sorted(1,2,i)) == 9, "nelec...") - call assert(popcnt(psi_det_sorted(1,1,i)) == 9, "nelec...") - !call debug_det(psi_det_sorted(1,1,i), N_int) - do j=1,i-1 - call assert(.not. detEq(psi_det_sorted(1,1,i), psi_det_sorted(1,1,j), N_int), "OOQSDSD") - end do - end do enddo N_det = min(N_det_max,N_det) touch N_det psi_det psi_coef diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 0d7b3f25..43d252bd 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,18 +1,28 @@ use bitmasks -BEGIN_PROVIDER [ double precision, integral8, (mo_tot_num, mo_tot_num, mo_tot_num, mo_tot_num) ] - use bitmasks +! BEGIN_PROVIDER [ double precision, integral8, (mo_tot_num, mo_tot_num, mo_tot_num, mo_tot_num) ] +! use bitmasks +! implicit none +! +! integer :: h1, h2 +! +! integral8 = 0d0 +! do h1=1, mo_tot_num +! do h2=1, mo_tot_num +! call get_mo_bielec_integrals_ij(h1, h2 ,mo_tot_num,integral8(1,1,h1,h2),mo_integrals_map) +! end do +! end do +! END_PROVIDER + + +double precision function integral8(i,j,k,l) implicit none - integer :: h1, h2 + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral - integral8 = 0d0 - do h1=1, mo_tot_num - do h2=1, mo_tot_num - call get_mo_bielec_integrals_ij(h1, h2 ,mo_tot_num,integral8(1,1,h1,h2),mo_integrals_map) - end do - end do -END_PROVIDER + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) +end function BEGIN_PROVIDER [ integer(bit_kind), psi_phasemask, (N_int, 2, N_det)] diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f index 268d9cbf..4c938951 100644 --- a/plugins/Full_CI_ZMQ/selection_double.irp.f +++ b/plugins/Full_CI_ZMQ/selection_double.irp.f @@ -44,7 +44,7 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p call apply_holes(psi_det_generators(1,1,i_generator), s1,h1,s2,h2, mask, ok, N_int) !call assert(ok, irp_here) - logical :: banned(mo_tot_num, mo_tot_num) + logical :: banned(mo_tot_num, mo_tot_num,2) logical :: bannedOrb(mo_tot_num, 2) banned = .false. @@ -121,13 +121,13 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d endif pt2(1) += e_pert if(dabs(e_pert) > buf%mini) then - do j=1,buf%cur-1 - if(detEq(buf%det(1,1,j), det, N_int)) then - print *, "tops" - print *, i_generator, s1, s2, h1, h2,p1,p2 - stop - end if - end do +! do j=1,buf%cur-1 +! if(detEq(buf%det(1,1,j), det, N_int)) then +! print *, "tops" +! print *, i_generator, s1, s2, h1, h2,p1,p2 +! stop +! end if +! end do call add_to_selection_buffer(buf, det, e_pert) end if end do @@ -141,13 +141,15 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat) integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: i, j, h(0:2,2), p(0:4,2), nt + integer :: i, j, k, l, h(0:2,2), p(0:4,2), nt integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - + logical :: bandon + mat = 0d0 + bandon = .false. do i=1,N_int negMask(i,1) = not(mask(i,1)) @@ -181,6 +183,18 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat) if(nt == 3) call past_d1(bannedOrb, p) !call assert(nt /= 2, "should have been discarded") else + if(i == i_gen) then + bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if if(nt == 4) then call get_d2(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i)) else if(nt == 3) then @@ -190,6 +204,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat) end if end if end do + call assert(bandon, "BANDON") end subroutine @@ -198,12 +213,12 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) integer, intent(in) :: h(0:2,2), p(0:4,2), sp - double precision, external :: get_phase_bi + double precision, external :: get_phase_bi, integral8 integer :: i, j, tip, ma, mi, puti, putj integer :: h1, h2, p1, p2, i1, i2 @@ -212,7 +227,9 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) integer, parameter :: turn2(2) = (/2, 1/) integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - + + integer :: bant + bant = 1 tip = p(0,1) * p(0,2) !call assert(p(0,1) + p(0,2) == 4, irp_here//"df") @@ -223,6 +240,8 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) !print *, "d2 SPtip", SP, tip if(sp == 3) then + if(ma == 2) bant = 2 + if(tip == 3) then puti = p(1, mi) do i = 1, 3 @@ -236,7 +255,8 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) h1 = h(1, ma) h2 = h(2, ma) - + if(banned(putj,puti,bant)) cycle + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) !call debug_hij(hij, gen, mask, mi, ma, puti, putj) if(ma == 1) then @@ -255,7 +275,9 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) p2 = p(turn2(j), 2) h1 = h(1,1) h2 = h(1,2) - + + if(banned(puti,putj,bant)) cycle + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) !call debug_hij(hij, gen, mask, 1, 2, puti, putj) @@ -276,6 +298,9 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) i2 = turn2d(2, i, j) p1 = p(i1, ma) p2 = p(i2, ma) + + if(banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) !call debug_hij(hij, gen, mask, ma, ma, puti, putj) mat(:, puti, putj) += coefs * hij @@ -290,6 +315,9 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) p2 = p(i, ma) puti = p(turn3(1,i), ma) putj = p(turn3(2,i), ma) + + if(banned(puti,putj,1)) cycle + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) !call debug_hij(hij, gen, mask, ma, ma, puti, putj) mat(:, min(puti, putj), max(puti, putj)) += coefs * hij @@ -302,9 +330,12 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) p2 = p(2, mi) h1 = h(1, mi) h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - !call debug_hij(hij, gen, mask,ma,ma, puti, putj) - mat(:, puti, putj) += coefs * hij + + if(.not. banned(puti,putj,1)) then + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + !call debug_hij(hij, gen, mask,ma,ma, puti, putj) + mat(:, puti, putj) += coefs * hij + end if end if end if end subroutine @@ -343,12 +374,12 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi + double precision, external :: get_phase_bi, integral8 logical :: lbanned(mo_tot_num, 2), ok integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib @@ -358,7 +389,9 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) integer, parameter :: turn2(2) = (/2,1/) integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - + integer :: bant + + lbanned = bannedOrb do i=1, p(0,1) @@ -371,11 +404,14 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) ma = 1 if(p(0,2) >= 2) ma = 2 mi = turn2(ma) + + bant = 1 !print *, "d1 SP", sp, p(0,1)*p(0,2) if(sp == 3) then !move MA !call assert(p(0,1)*p(0,2) == 2, "ddmmm") + if(ma == 2) bant = 2 puti = p(1,mi) hfix = h(1,ma) p1 = p(1,ma) @@ -383,13 +419,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) if(.not. bannedOrb(puti, mi)) then tmp_row = 0d0 do putj=1, hfix-1 - if(lbanned(putj, ma)) cycle + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) !call debug_hij(hij, gen, mask, mi, ma, puti, putj) tmp_row(:,putj) += hij * coefs end do do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma)) cycle + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) !call debug_hij(hij, gen, mask, mi, ma, puti, putj) tmp_row(:,putj) += hij * coefs @@ -410,13 +446,18 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) if(lbanned(puti,mi)) cycle !p1 fixed putj = p1 - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + !call debug_hij(hij, gen, mask, mi, ma, puti, putj) - tmp_row(:,puti) += hij * coefs putj = p2 - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - !call debug_hij(hij, gen, mask, mi, ma, puti, putj) - tmp_row2(:,puti) += hij * coefs + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + !call debug_hij(hij, gen, mask, mi, ma, puti, putj) + tmp_row2(:,puti) += hij * coefs + end if end do if(mi == 1) then @@ -435,13 +476,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) p2 = p(turn3(2,i), ma) tmp_row = 0d0 do putj=1,hfix-1 - if(lbanned(putj,ma)) cycle + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) !call debug_hij(hij, gen, mask, ma, ma, puti, putj) tmp_row(:,putj) += hij * coefs end do do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma)) cycle + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) !call debug_hij(hij, gen, mask, ma, ma, puti, putj) tmp_row(:,putj) += hij * coefs @@ -461,14 +502,18 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) do puti=1,mo_tot_num if(lbanned(puti,ma)) cycle putj = p2 - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - !call debug_hij(hij, gen, mask, ma, ma, putj, puti) - tmp_row(:,puti) += hij * coefs + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + !call debug_hij(hij, gen, mask, ma, ma, putj, puti) + tmp_row(:,puti) += hij * coefs + end if putj = p1 - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - !call debug_hij(hij, gen, mask, ma, ma, putj, puti) - tmp_row2(:,puti) += hij * coefs + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + !call debug_hij(hij, gen, mask, ma, ma, putj, puti) + tmp_row2(:,puti) += hij * coefs + end if end do mat(:,:p2-1,p2) += tmp_row(:,:p2-1) mat(:,p2,p2:) += tmp_row(:,p2:) @@ -492,7 +537,7 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) do i2=ib,p(0,s2) p1 = p(i1,s1) p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2)) cycle + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) call i_h_j(gen, det, N_int, hij) mat(:, p1, p2) += coefs * hij @@ -508,7 +553,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2), phasemask(N_int, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) @@ -516,9 +561,12 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) integer :: i, j, s, h1, h2, p1, p2, puti, putj double precision :: hij, phase - double precision, external :: get_phase_bi + double precision, external :: get_phase_bi, integral8 logical :: ok + integer :: bant + bant = 1 + !print *, "d0 SP", sp if(sp == 3) then ! AB @@ -528,7 +576,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) if(bannedOrb(p1, 1)) cycle do p2=1, mo_tot_num if(bannedOrb(p2,2)) cycle - if(banned(p1, p2)) cycle ! rentable? + if(banned(p1, p2, bant)) cycle ! rentable? if(p1 == h1 .or. p2 == h2) then call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) !call assert(ok, "zsdq") @@ -549,10 +597,9 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) if(bannedOrb(puti, sp)) cycle do putj=puti+1, mo_tot_num if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj)) cycle ! rentable? + if(banned(puti, putj, bant)) cycle ! rentable? if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call ASSERT(ok, "ssss") call i_h_j(gen, det, N_int, hij) mat(:, puti, putj) += coefs * hij else diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f index b9f53766..79fe91c1 100644 --- a/plugins/Full_CI_ZMQ/selection_single.irp.f +++ b/plugins/Full_CI_ZMQ/selection_single.irp.f @@ -160,7 +160,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti double precision :: hij - double precision, external :: get_phase_bi + double precision, external :: get_phase_bi, integral8 integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) integer, parameter :: turn2(2) = (/2,1/) @@ -170,6 +170,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) h2 = h(2, sp) do i=1,3 puti = p(i, sp) + if(bannedOrb(puti)) cycle p1 = p(turn3_2(1,i), sp) p2 = p(turn3_2(2,i), sp) hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) @@ -184,6 +185,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) hmob = h(1,sp) do j=1,2 puti = p(j, sp) + if(bannedOrb(puti)) cycle pmob = p(turn2(j), sp) hij = integral8(pfix, pmob, hfix, hmob) hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) @@ -192,15 +194,17 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) end do else puti = p(1,sp) - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - !call debug_hij_mo(hij, gen, mask, sp, puti) - vect(:, puti) += hij * coefs + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + !call debug_hij_mo(hij, gen, mask, sp, puti) + vect(:, puti) += hij * coefs + end if end if end subroutine @@ -219,7 +223,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) logical :: ok, lbanned(mo_tot_num) integer(bit_kind) :: det(N_int, 2) double precision :: hij - double precision, external :: get_phase_bi + double precision, external :: get_phase_bi, integral8 lbanned = bannedOrb sh = 1 @@ -246,7 +250,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) if(lbanned(i)) cycle hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - call debug_hij_mo(hij, gen, mask, sp, i) + !call debug_hij_mo(hij, gen, mask, sp, i) vect(:,i) += hij * coefs end do @@ -363,7 +367,7 @@ subroutine debug_hij_mo(hij, gen, mask, s1, p1) integer :: degree integer :: exc(0:2,2,2) logical, external :: detEq - + call apply_particle(mask, s1, p1, det, ok, N_int) !call assert(ok, "nokey_mo") !call assert(.not. detEq(det, gen, N_int), "Hii ...") From e78f316936e0d45fb99110c2098aeeb2082cf11e Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Thu, 8 Sep 2016 17:34:56 +0200 Subject: [PATCH 8/8] changed phasemask representation --- plugins/Full_CI_ZMQ/selection.irp.f | 57 +++++++++------------- plugins/Full_CI_ZMQ/selection_double.irp.f | 36 ++++++-------- plugins/Full_CI_ZMQ/selection_single.irp.f | 12 +++-- 3 files changed, 47 insertions(+), 58 deletions(-) diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 43d252bd..c1f529dc 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -25,7 +25,7 @@ double precision function integral8(i,j,k,l) end function -BEGIN_PROVIDER [ integer(bit_kind), psi_phasemask, (N_int, 2, N_det)] +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] use bitmasks implicit none @@ -52,17 +52,19 @@ subroutine get_mask_phase(det, phasemask) implicit none integer(bit_kind), intent(in) :: det(N_int, 2) - integer(bit_kind), intent(out) :: phasemask(N_int, 2) + integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) integer :: s, ni, i logical :: change - phasemask = 0_8 +! phasemask = 0_8 + phasemask = 0_1 do s=1,2 change = .false. do ni=1,N_int do i=0,bit_kind_size-1 if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask(ni, s) = ibset(phasemask(ni, s), i) +! if(change) phasemask(ni, s) = ibset(phasemask(ni, s), i) + if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 end do end do end do @@ -120,41 +122,28 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) use bitmasks implicit none - integer(bit_kind), intent(in) :: phasemask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) integer, intent(in) :: s1, s2, h1, h2, p1, p2 logical :: change - integer :: np + integer(1) :: np double precision, parameter :: res(0:1) = (/1d0, -1d0/) - call assert(s1 /= s2 .or. (h1 <= h2 .and. p1 <= p2), irp_here) - np = 0 - change = btest(phasemask(1+ishft(h1, -6), s1), iand(h1-1, 63)) - change = xor(change, btest(phasemask(1+ishft(p1, -6), s1), iand(p1-1, 63))) - if(xor(change, p1 < h1)) np = 1 - - change = btest(phasemask(1+ishft(h2, -6), s2), iand(h2-1, 63)) - change = xor(change, btest(phasemask(1+ishft(p2, -6), s2), iand(p2-1, 63))) - if(xor(change, p2 < h2)) np = np + 1 +! call assert(s1 /= s2 .or. (h1 <= h2 .and. p1 <= p2), irp_here) +! np = 0 +! change = btest(phasemask(1+ishft(h1, -6), s1), iand(h1-1, 63)) +! change = xor(change, btest(phasemask(1+ishft(p1, -6), s1), iand(p1-1, 63))) +! if(xor(change, p1 < h1)) np = 1 +! +! change = btest(phasemask(1+ishft(h2, -6), s2), iand(h2-1, 63)) +! change = xor(change, btest(phasemask(1+ishft(p2, -6), s2), iand(p2-1, 63))) +! if(xor(change, p2 < h2)) np = np + 1 - if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1 - get_phase_bi = res(iand(np,1)) -end subroutine - - -double precision function get_phase_mono(phasemask, s1, h1, p1) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: phasemask(N_int, 2) - integer, intent(in) :: s1, h1, p1 - logical :: change - stop "phase moni BUGGED" - - change = btest(phasemask(ishft(h1, bit_kind_shift), s1), iand(h1, 63_8)) - change = xor(change, btest(phasemask(ishft(p1, bit_kind_shift), s1), iand(p1, 63_8))) - - get_phase_mono = 1d0 - if(change) get_phase_mono = -1d0 + np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) + if(p1 < h1) np = np + 1_1 + if(p2 < h2) np = np + 1_1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 + get_phase_bi = res(iand(np,1_1)) end subroutine diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f index 4c938951..d31f9a6a 100644 --- a/plugins/Full_CI_ZMQ/selection_double.irp.f +++ b/plugins/Full_CI_ZMQ/selection_double.irp.f @@ -212,7 +212,8 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) use bitmasks implicit none - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int, 2) + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) @@ -246,16 +247,13 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) puti = p(1, mi) do i = 1, 3 putj = p(i, ma) + if(banned(putj,puti,bant)) cycle i1 = turn3(1,i) i2 = turn3(2,i) p1 = p(i1, ma) p2 = p(i2, ma) - !call assert(h(0,ma) == 2, "dmdmd") - !call assert(p(0, ma) == 3, "dmdm2") h1 = h(1, ma) h2 = h(2, ma) - - if(banned(putj,puti,bant)) cycle hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) !call debug_hij(hij, gen, mask, mi, ma, puti, putj) @@ -271,16 +269,15 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) do j = 1,2 puti = p(i, 1) putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle p1 = p(turn2(i), 1) p2 = p(turn2(j), 2) h1 = h(1,1) h2 = h(1,2) - if(banned(puti,putj,bant)) cycle - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) !call debug_hij(hij, gen, mask, 1, 2, puti, putj) - mat(:, puti, putj) += coefs * hij end do end do @@ -294,13 +291,12 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) puti = p(i, ma) do j=i+1,4 putj = p(j, ma) + if(banned(puti,putj,1)) cycle + i1 = turn2d(1, i, j) i2 = turn2d(2, i, j) p1 = p(i1, ma) p2 = p(i2, ma) - - if(banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) !call debug_hij(hij, gen, mask, ma, ma, puti, putj) mat(:, puti, putj) += coefs * hij @@ -312,11 +308,10 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) p1 = p(1, mi) !call assert(ma == sp, "dldl") do i=1,3 - p2 = p(i, ma) puti = p(turn3(1,i), ma) putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle + p2 = p(i, ma) hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) !call debug_hij(hij, gen, mask, ma, ma, puti, putj) @@ -326,12 +321,11 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) !call assert(tip == 4, "qsdf") puti = p(1, sp) putj = p(2, sp) - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) !call debug_hij(hij, gen, mask,ma,ma, puti, putj) mat(:, puti, putj) += coefs * hij @@ -373,7 +367,8 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) use bitmasks implicit none - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int, 2) + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) @@ -552,7 +547,8 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) use bitmasks implicit none - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2), phasemask(N_int, 2) + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f index 79fe91c1..a49ae879 100644 --- a/plugins/Full_CI_ZMQ/selection_single.irp.f +++ b/plugins/Full_CI_ZMQ/selection_single.irp.f @@ -103,7 +103,8 @@ subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) use bitmasks implicit none - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel), phasemask(N_int,2,N_sel) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) double precision, intent(in) :: coefs(N_states, N_sel) integer, intent(in) :: sp, N_sel logical, intent(inout) :: bannedOrb(mo_tot_num) @@ -153,7 +154,8 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) use bitmasks implicit none - integer(bit_kind), intent(in) :: gen(N_int, 2), phasemask(N_int, 2), mask(N_int, 2) + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -214,7 +216,8 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) use bitmasks implicit none - integer(bit_kind), intent(in) :: gen(N_int, 2), phasemask(N_int, 2), mask(N_int, 2) + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -282,7 +285,8 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) use bitmasks implicit none - integer(bit_kind), intent(in) :: gen(N_int, 2), phasemask(N_int, 2), mask(N_int, 2) + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num)