diff --git a/src/cipsi_tc_bi_ortho/EZFIO.cfg b/src/cipsi_tc_bi_ortho/EZFIO.cfg new file mode 100644 index 00000000..7fcf19eb --- /dev/null +++ b/src/cipsi_tc_bi_ortho/EZFIO.cfg @@ -0,0 +1,36 @@ +[save_wf_after_selection] +type: logical +doc: If true, saves the wave function after the selection, before the diagonalization +interface: ezfio,provider,ocaml +default: False + +[seniority_max] +type: integer +doc: Maximum number of allowed open shells. Using -1 selects all determinants +interface: ezfio,ocaml,provider +default: -1 + +[excitation_ref] +type: integer +doc: 1: Hartree-Fock determinant, 2:All determinants of the dominant configuration +interface: ezfio,ocaml,provider +default: 1 + +[excitation_max] +type: integer +doc: Maximum number of excitation with respect to the Hartree-Fock determinant. Using -1 selects all determinants +interface: ezfio,ocaml,provider +default: -1 + +[excitation_alpha_max] +type: integer +doc: Maximum number of excitation for alpha determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants +interface: ezfio,ocaml,provider +default: -1 + +[excitation_beta_max] +type: integer +doc: Maximum number of excitation for beta determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants +interface: ezfio,ocaml,provider +default: -1 + diff --git a/src/cipsi_tc_bi_ortho/NEED b/src/cipsi_tc_bi_ortho/NEED new file mode 100644 index 00000000..4dd1af36 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/NEED @@ -0,0 +1,6 @@ +mpi +perturbation +zmq +iterations_tc +csf +tc_bi_ortho diff --git a/src/cipsi_tc_bi_ortho/cipsi.irp.f b/src/cipsi_tc_bi_ortho/cipsi.irp.f new file mode 100644 index 00000000..b1941068 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/cipsi.irp.f @@ -0,0 +1,136 @@ +subroutine run_cipsi + + BEGIN_DOC + ! Selected Full Configuration Interaction with deterministic selection and + ! stochastic PT2. + END_DOC + + use selection_types + + implicit none + + integer :: i,j,k,ndet + type(pt2_type) :: pt2_data, pt2_data_err + double precision, allocatable :: zeros(:) + integer :: to_select + logical, external :: qp_stop + + double precision :: threshold_generators_save + double precision :: rss + double precision, external :: memory_of_double + double precision :: correlation_energy_ratio,E_denom,E_tc,norm + + PROVIDE H_apply_buffer_allocated distributed_davidson + + print*,'Diagonal elements of the Fock matrix ' + do i = 1, mo_num + write(*,*)i,Fock_matrix_tc_mo_tot(i,i) + enddo + + N_iter = 1 + threshold_generators = 1.d0 + SOFT_TOUCH threshold_generators + + rss = memory_of_double(N_states)*4.d0 + call check_mem(rss,irp_here) + + allocate (zeros(N_states)) + call pt2_alloc(pt2_data, N_states) + call pt2_alloc(pt2_data_err, N_states) + + double precision :: hf_energy_ref + logical :: has, print_pt2 + double precision :: relative_error + + relative_error=PT2_relative_error + + zeros = 0.d0 + pt2_data % pt2 = -huge(1.e0) + pt2_data % rpt2 = -huge(1.e0) + pt2_data % overlap(:,:) = 0.d0 + pt2_data % variance = huge(1.e0) + + if (s2_eig) then + call make_s2_eigenfunction + endif + print_pt2 = .False. + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + + call ezfio_has_hartree_fock_energy(has) + if (has) then + call ezfio_get_hartree_fock_energy(hf_energy_ref) + else + hf_energy_ref = ref_bitmask_energy + endif + + if (N_det > N_det_max) then + psi_det(1:N_int,1:2,1:N_det) = psi_det_sorted_tc_gen(1:N_int,1:2,1:N_det) + psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states) + N_det = N_det_max + soft_touch N_det psi_det psi_coef + if (s2_eig) then + call make_s2_eigenfunction + endif + print_pt2 = .False. + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) +! call routine_save_right + endif + + correlation_energy_ratio = 0.d0 + + print_pt2 = .True. + do while ( & + (N_det < N_det_max) .and. & + (maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) & + ) + write(*,'(A)') '--------------------------------------------------------------------------------' + + + to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor) + to_select = max(N_states_diag, to_select) + + E_denom = E_tc ! TC Energy of the current wave function + if (do_pt2) then + call pt2_dealloc(pt2_data) + call pt2_dealloc(pt2_data_err) + call pt2_alloc(pt2_data, N_states) + call pt2_alloc(pt2_data_err, N_states) + threshold_generators_save = threshold_generators + threshold_generators = 1.d0 + SOFT_TOUCH threshold_generators + call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection + threshold_generators = threshold_generators_save + SOFT_TOUCH threshold_generators + else + call pt2_dealloc(pt2_data) + call pt2_alloc(pt2_data, N_states) + call ZMQ_selection(to_select, pt2_data) + endif + + N_iter += 1 + + if (qp_stop()) exit + + ! Add selected determinants + call copy_H_apply_buffer_to_wf() + + if (save_wf_after_selection) then + call save_wavefunction + endif + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted_tc + + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + if (qp_stop()) exit + enddo + + call pt2_dealloc(pt2_data) + call pt2_dealloc(pt2_data_err) + call pt2_alloc(pt2_data, N_states) + call pt2_alloc(pt2_data_err, N_states) + call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + +end diff --git a/src/cipsi_tc_bi_ortho/energy.irp.f b/src/cipsi_tc_bi_ortho/energy.irp.f new file mode 100644 index 00000000..16f4528e --- /dev/null +++ b/src/cipsi_tc_bi_ortho/energy.irp.f @@ -0,0 +1,51 @@ +BEGIN_PROVIDER [ logical, initialize_pt2_E0_denominator ] + implicit none + BEGIN_DOC + ! If true, initialize pt2_E0_denominator + END_DOC + initialize_pt2_E0_denominator = .True. +END_PROVIDER + +BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] + implicit none + BEGIN_DOC + ! E0 in the denominator of the PT2 + END_DOC + integer :: i,j + + pt2_E0_denominator = eigval_right_tc_bi_orth + +! if (initialize_pt2_E0_denominator) then +! if (h0_type == "EN") then +! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states) +! else if (h0_type == "HF") then +! do i=1,N_states +! j = maxloc(abs(psi_coef(:,i)),1) +! pt2_E0_denominator(i) = psi_det_hii(j) +! enddo +! else if (h0_type == "Barycentric") then +! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) +! else if (h0_type == "CFG") then +! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states) +! else +! print *, h0_type, ' not implemented' +! stop +! endif +! do i=1,N_states +! call write_double(6,pt2_E0_denominator(i)+nuclear_repulsion, 'PT2 Energy denominator') +! enddo +! else +! pt2_E0_denominator = -huge(1.d0) +! endif + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ] + implicit none + BEGIN_DOC + ! Overlap between the perturbed wave functions + END_DOC + pt2_overlap(1:N_states,1:N_states) = 0.d0 +END_PROVIDER + diff --git a/src/cipsi_tc_bi_ortho/environment.irp.f b/src/cipsi_tc_bi_ortho/environment.irp.f new file mode 100644 index 00000000..5c0e0820 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/environment.irp.f @@ -0,0 +1,14 @@ +BEGIN_PROVIDER [ integer, nthreads_pt2 ] + implicit none + BEGIN_DOC + ! Number of threads for Davidson + END_DOC + nthreads_pt2 = nproc + character*(32) :: env + call getenv('QP_NTHREADS_PT2',env) + if (trim(env) /= '') then + read(env,*) nthreads_pt2 + call write_int(6,nthreads_pt2,'Target number of threads for PT2') + endif +END_PROVIDER + diff --git a/src/cipsi_tc_bi_ortho/fock_diag.irp.f b/src/cipsi_tc_bi_ortho/fock_diag.irp.f new file mode 100644 index 00000000..af6849ab --- /dev/null +++ b/src/cipsi_tc_bi_ortho/fock_diag.irp.f @@ -0,0 +1,95 @@ +subroutine build_fock_tmp_tc(fock_diag_tmp,det_ref,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Build the diagonal of the Fock matrix corresponding to a generator +! determinant. $F_{00}$ is $\langle i|H|i \rangle = E_0$. + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det_ref(Nint,2) + double precision, intent(out) :: fock_diag_tmp(2,mo_num+1) + + integer :: occ(Nint*bit_kind_size,2) + integer :: ne(2), i, j, ii, jj + double precision :: E0 + + ! Compute Fock matrix diagonal elements + call bitstring_to_list_ab(det_ref,occ,Ne,Nint) + + fock_diag_tmp = 0.d0 + E0 = 0.d0 + + if (Ne(1) /= elec_alpha_num) then + print *, 'Error in build_fock_tmp_tc (alpha)', Ne(1), Ne(2) + call debug_det(det_ref,N_int) + stop -1 + endif + if (Ne(2) /= elec_beta_num) then + print *, 'Error in build_fock_tmp_tc (beta)', Ne(1), Ne(2) + call debug_det(det_ref,N_int) + stop -1 + endif + + ! Occupied MOs + do ii=1,elec_alpha_num + i = occ(ii,1) + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i) + E0 = E0 + mo_one_e_integrals(i,i) + do jj=1,elec_alpha_num + j = occ(jj,1) + if (i==j) cycle + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j) + E0 = E0 + 0.5d0*mo_two_e_integrals_jj_anti(i,j) + enddo + do jj=1,elec_beta_num + j = occ(jj,2) + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj(i,j) + E0 = E0 + mo_two_e_integrals_jj(i,j) + enddo + enddo + do ii=1,elec_beta_num + i = occ(ii,2) + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i) + E0 = E0 + mo_one_e_integrals(i,i) + do jj=1,elec_beta_num + j = occ(jj,2) + if (i==j) cycle + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j) + E0 = E0 + 0.5d0*mo_two_e_integrals_jj_anti(i,j) + enddo + do jj=1,elec_alpha_num + j = occ(jj,1) + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj(i,j) + enddo + enddo + + ! Virtual MOs + do i=1,mo_num + if (fock_diag_tmp(1,i) /= 0.d0) cycle + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i) + do jj=1,elec_alpha_num + j = occ(jj,1) + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j) + enddo + do jj=1,elec_beta_num + j = occ(jj,2) + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj(i,j) + enddo + enddo + do i=1,mo_num + if (fock_diag_tmp(2,i) /= 0.d0) cycle + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i) + do jj=1,elec_beta_num + j = occ(jj,2) + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j) + enddo + do jj=1,elec_alpha_num + j = occ(jj,1) + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj(i,j) + enddo + enddo + + fock_diag_tmp(1,mo_num+1) = E0 + fock_diag_tmp(2,mo_num+1) = E0 + +end diff --git a/src/cipsi_tc_bi_ortho/get_d.irp.f b/src/cipsi_tc_bi_ortho/get_d.irp.f new file mode 100644 index 00000000..9421787e --- /dev/null +++ b/src/cipsi_tc_bi_ortho/get_d.irp.f @@ -0,0 +1,1902 @@ + +! --- + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint) + + use bitmasks + implicit none + + integer, intent(in) :: Nint + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + integer(bit_kind), intent(in) :: phasemask(Nint,2) + + double precision, save :: res(0:1) = (/1d0, -1d0/) + + integer :: np + integer :: h1_int, h2_int + integer :: p1_int, p2_int + integer :: h1_bit, h2_bit + integer :: p1_bit, p2_bit + logical :: change + + h1_int = shiftr(h1-1,bit_kind_shift)+1 + h1_bit = h1 - shiftl(h1_int-1,bit_kind_shift)-1 + + h2_int = shiftr(h2-1,bit_kind_shift)+1 + h2_bit = h2 - shiftl(h2_int-1,bit_kind_shift)-1 + + p1_int = shiftr(p1-1,bit_kind_shift)+1 + p1_bit = p1 - shiftl(p1_int-1,bit_kind_shift)-1 + + p2_int = shiftr(p2-1,bit_kind_shift)+1 + p2_bit = p2 - shiftl(p2_int-1,bit_kind_shift)-1 + + ! Put the phasemask bits at position 0, and add them all + h1_bit = int( shiftr( phasemask(h1_int,s1), h1_bit ) ) + p1_bit = int( shiftr( phasemask(p1_int,s1), p1_bit ) ) + h2_bit = int( shiftr( phasemask(h2_int,s2), h2_bit ) ) + p2_bit = int( shiftr( phasemask(p2_int,s2), p2_bit ) ) + + np = h1_bit + p1_bit + h2_bit + p2_bit + + if(p1 < h1) np = np + 1 + if(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 function get_phase_bi + +! --- + +subroutine get_d3_htc(gen, bannedOrb, banned, mat_m, mat_p, mask, p, sp, rcoefs, lcoefs) + + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer, intent(in) :: p(0:4,2), sp + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + double precision, intent(in) :: rcoefs(N_states), lcoefs(N_states) + double precision, intent(inout) :: mat_m(N_states, mo_num, mo_num), mat_p(N_states, mo_num, mo_num) + + integer(bit_kind) :: det(N_int, 2) + integer :: k, h1, h2, p1, p2, puti, putj + double precision :: i_h_alpha, alpha_h_i + logical :: ok + + if(sp == 3) then ! AB + + h1 = p(1,1) + h2 = p(1,2) + do p1 = 1, mo_num + if(bannedOrb(p1, 1)) cycle + do p2 = 1, mo_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, 1)) cycle ! rentable? + + call apply_particles(mask, 1, p1, 2, p2, det, ok, N_int) + call htilde_mu_mat_bi_ortho_tot(gen, det, N_int, i_h_alpha) + call htilde_mu_mat_bi_ortho_tot(det,gen, N_int, alpha_h_i) +! call hji_hij_mu_mat_tot(gen, det, N_int,i_h_alpha , alpha_h_i) + if( dabs(alpha_h_i) .gt. 0.d0) then + !DIR$ LOOP COUNT AVG(4) + do k = 1, N_states + mat_p(k, p1, p2) = mat_p(k, p1, p2) + rcoefs(k) * alpha_h_i + enddo + endif + if( dabs(i_h_alpha) .gt. 0.d0) then + !DIR$ LOOP COUNT AVG(4) + do k = 1, N_states + mat_m(k, p1, p2) = mat_m(k, p1, p2) + lcoefs(k) * i_h_alpha + enddo + endif + + enddo + enddo + + else ! AA BB + + p1 = p(1,sp) + p2 = p(2,sp) + do puti = 1, mo_num + if(bannedOrb(puti, sp)) cycle + do putj = puti+1, mo_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, 1)) cycle ! rentable? + + call apply_particles(mask, sp, puti, sp, putj, det, ok, N_int) +! call hji_hij_mu_mat_tot(gen, det, N_int, i_h_alpha, alpha_h_i) + call htilde_mu_mat_bi_ortho_tot(gen, det, N_int, i_h_alpha) + call htilde_mu_mat_bi_ortho_tot( det,gen, N_int, alpha_h_i) + if( dabs(alpha_h_i) .gt. 0.d0) then + !DIR$ LOOP COUNT AVG(4) + do k = 1, N_states + mat_p(k, puti, putj) = mat_p(k, puti, putj) + rcoefs(k) * alpha_h_i + enddo + endif + if( dabs(i_h_alpha) .gt. 0.d0) then + !DIR$ LOOP COUNT AVG(4) + do k = 1, N_states + mat_m(k, puti, putj) = mat_m(k, puti, putj) + lcoefs(k) * i_h_alpha + enddo + endif + + enddo + enddo + + endif + +end subroutine get_d3_htc + +! --- + +subroutine get_d3_h(gen, bannedOrb, banned, mat, mask, p, sp, coefs) + + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer, intent(in) :: p(0:4,2), sp + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_num, mo_num) + + integer(bit_kind) :: det(N_int, 2) + integer :: k, h1, h2, p1, p2, puti, putj + double precision :: hij + logical :: ok + + if(sp == 3) then ! AB + + h1 = p(1,1) + h2 = p(1,2) + do p1 = 1, mo_num + if(bannedOrb(p1, 1)) cycle + do p2 = 1, mo_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, 1)) cycle ! rentable? + + call apply_particles(mask, 1, p1, 2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + if (hij == 0.d0) cycle + !DIR$ LOOP COUNT AVG(4) + do k = 1, N_states + mat(k, p1, p2) = mat(k, p1, p2) + coefs(k) * hij + enddo + + enddo + enddo + + else ! AA BB + + p1 = p(1,sp) + p2 = p(2,sp) + do puti = 1, mo_num + if(bannedOrb(puti, sp)) cycle + do putj = puti+1, mo_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, 1)) cycle ! rentable? + + call apply_particles(mask, sp, puti, sp, putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + !DIR$ LOOP COUNT AVG(4) + do k = 1, N_states + mat(k, puti, putj) = mat(k, puti, putj) + coefs(k) * hij + enddo + + enddo + enddo + + endif + +end subroutine get_d3_h + +! --- + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs) + + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num), mat_r(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi + + integer :: i, j, k, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, hji, 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/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + print*,'in get_d2' + stop + 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 + print*,'in sp == 3' + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + if(bannedOrb(puti, mi)) return + h1 = h(1, ma) + h2 = h(2, ma) + + 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) + + ! --> --> < p2 p1 | H^tilde| h1 h2 > + ! + ! - + ! < p2 p1 | H^tilde^dag| h1 h2 > = < h1 h2 | w_ee^h + t^nh | p1 p2 > + hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2, p1, h1, h2) + hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h2, h1, p1, p2) + if (hij == 0.d0) cycle + + hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + + if(ma == 1) then + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hij + mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hji + enddo + else + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hij + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hji + enddo + end if + end do + else + h1 = h(1,1) + h2 = h(1,2) + do j = 1,2 + putj = p(j, 2) + if(bannedOrb(putj, 2)) cycle + p2 = p(turn2(j), 2) + do i = 1,2 + puti = p(i, 1) + + if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle + p1 = p(turn2(i), 1) + + hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) + hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hji = hji * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hij + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hji + enddo + endif + end do + end do + end if + + else + print*,'NOT in sp == 3' + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + if(bannedOrb(puti,ma)) cycle + do j=i+1,4 + putj = p(j, ma) + if(bannedOrb(putj,ma)) cycle + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2) + hji = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h2,h1, p1, p2) + if (hij == 0.d0) cycle + + hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) +coefs(k,1) * hij + mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,2) * hji + enddo + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + if(bannedOrb(puti,ma)) cycle + putj = p(turn3(2,i), ma) + if(bannedOrb(putj,ma)) cycle + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) + hji = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) + if (hij == 0.d0) cycle + + hij = hij * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) + hji = hji * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) + if (puti < putj) then + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hij + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hji + enddo + else + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hij + mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hji + enddo + endif + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)) + hji = (mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h2,h1, p1, p2)) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) + hji = hji * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hij + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hji + enddo + end if + end if + end if + end if + +end subroutine get_d2 + +! --- + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs) + + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_p(N_states, mo_num, mo_num), mat_m(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + double precision, external :: get_phase_bi + logical :: ok + + logical, allocatable :: lbanned(:,:) + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j + integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l + integer :: mm + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + double precision, allocatable :: hij_cache(:,:) + double precision :: hij, tmp_row_ij(N_states, mo_num), tmp_row_ij2(N_states, mo_num) + double precision, allocatable :: hji_cache(:,:) + double precision :: hji, tmp_row_ji(N_states, mo_num), tmp_row_ji2(N_states, mo_num) + + PROVIDE mo_integrals_map N_int + + allocate (lbanned(mo_num, 2)) + allocate (hij_cache(mo_num,2)) + allocate (hji_cache(mo_num,2)) + lbanned = bannedOrb + print*,'in get d1' + call debug_det(gen, N_int) + + 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) + + bant = 1 + + if(sp == 3) then + print*,'in sp == 3' + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + print*,puti, hfix,p1,p2 + if(.not. bannedOrb(puti, mi)) then +! print*,'not banned' + do mm = 1, mo_num + hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,p2,mm,hfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,p1,mm,hfix) + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1) + enddo +! call get_mo_bi_ortho_tc_two_es(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map) +! call get_mo_bi_ortho_tc_two_es(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map) + tmp_row_ij = 0d0 + tmp_row_ji = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma)) cycle + if(banned(putj, puti,bant)) cycle + hij = hij_cache(putj,1) - hij_cache(putj,2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_row_ij(k,putj) = tmp_row_ij(k,putj) + hij * coefs(k,2) + enddo + endif + hji = hji_cache(putj,1) - hji_cache(putj,2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_row_ji(k,putj) = tmp_row_ji(k,putj) + hji * coefs(k,1) + enddo + endif + end do + do putj=hfix+1, mo_num + if(lbanned(putj, ma)) cycle + if(banned(putj, puti,bant)) cycle + hij = hij_cache(putj,2) - hij_cache(putj,1) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_row_ij(k,putj) = tmp_row_ij(k,putj) + hij * coefs(k,2) + enddo + endif + hji = hji_cache(putj,2) - hji_cache(putj,1) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_row_ji(k,putj) = tmp_row_ji(k,putj) + hji * coefs(k,1) + enddo + endif + end do + + if(ma == 1) then + mat_p(1:N_states,1:mo_num,puti) = mat_p(1:N_states,1:mo_num,puti) + tmp_row_ij(1:N_states,1:mo_num) + mat_m(1:N_states,1:mo_num,puti) = mat_m(1:N_states,1:mo_num,puti) + tmp_row_ji(1:N_states,1:mo_num) + else + do l=1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_p(k,puti,l) = mat_p(k,puti,l) + tmp_row_ij(k,l) + mat_m(k,puti,l) = mat_m(k,puti,l) + tmp_row_ji(k,l) + enddo + enddo + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row_ij = 0d0 + tmp_row_ij2 = 0d0 + tmp_row_ji = 0d0 + tmp_row_ji2 = 0d0 +! call get_mo_bi_ortho_tc_two_es(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map) +! call get_mo_bi_ortho_tc_two_es(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e(pfix,p1,mm,hfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e(pfix,p2,mm,hfix) + enddo + putj = p1 + do puti = 1, mo_num !HOT + + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = hij_cache(puti,2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_row_ij(k,puti) = tmp_row_ij(k,puti) + hij * coefs(k,2) + enddo + endif + hji = hji_cache(puti,2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_row_ji(k,puti) = tmp_row_ji(k,puti) + hji * coefs(k,1) + enddo + endif + endif + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = hij_cache(puti,1) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int) + do k=1,N_states + tmp_row_ij2(k,puti) = tmp_row_ij2(k,puti) + hij * coefs(k,2) + enddo + endif + hji = hji_cache(puti,1) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int) + do k=1,N_states + tmp_row_ji2(k,puti) = tmp_row_ji2(k,puti) + hji * coefs(k,1) + enddo + endif + endif + + enddo + + if(mi == 1) then + mat_p(:,:,p1) = mat_p(:,:,p1) + tmp_row_ij(:,:) + mat_p(:,:,p2) = mat_p(:,:,p2) + tmp_row_ij2(:,:) + mat_m(:,:,p1) = mat_m(:,:,p1) + tmp_row_ji(:,:) + mat_m(:,:,p2) = mat_m(:,:,p2) + tmp_row_ji2(:,:) + else + do l=1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_p(k,p1,l) = mat_p(k,p1,l) + tmp_row_ij(k,l) + mat_p(k,p2,l) = mat_p(k,p2,l) + tmp_row_ij2(k,l) + mat_m(k,p1,l) = mat_m(k,p1,l) + tmp_row_ji(k,l) + mat_m(k,p2,l) = mat_m(k,p2,l) + tmp_row_ji2(k,l) + enddo + enddo + end if + + else ! sp /= 3 + print*,'not in sp == 3' + + 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) +! call get_mo_bi_ortho_tc_two_es(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map) +! call get_mo_bi_ortho_tc_two_es(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map) + do mm = 1, mo_num + hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,p2,mm,hfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,p1,mm,hfix) + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1) + enddo + tmp_row_ij = 0d0 + tmp_row_ji = 0d0 + do putj=1,hfix-1 + if(banned(putj,puti,1)) cycle + if(lbanned(putj,ma)) cycle + hij = hij_cache(putj,1) - hij_cache(putj,2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + tmp_row_ij(:,putj) = tmp_row_ij(:,putj) + hij * coefs(:,1) + endif + hji = hji_cache(putj,1) - hji_cache(putj,2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + tmp_row_ji(:,putj) = tmp_row_ji(:,putj) + hji * coefs(:,2) + endif + end do + do putj=hfix+1,mo_num + if(banned(putj,puti,1)) cycle + if(lbanned(putj,ma)) cycle + hij = hij_cache(putj,2) - hij_cache(putj,1) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + tmp_row_ij(:,putj) = tmp_row_ij(:,putj) + hij * coefs(:,1) + endif + hji = hji_cache(putj,2) - hji_cache(putj,1) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + tmp_row_ji(:,putj) = tmp_row_ji(:,putj) + hji * coefs(:,2) + endif + end do + + mat_p(:, :puti-1, puti) = mat_p(:, :puti-1, puti) + tmp_row_ij(:,:puti-1) + mat_m(:, :puti-1, puti) = mat_m(:, :puti-1, puti) + tmp_row_ji(:,:puti-1) + do l=puti,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_p(k, puti, l) = mat_p(k, puti,l) + tmp_row_ij(k,l) + mat_m(k, puti, l) = mat_m(k, puti,l) + tmp_row_ji(k,l) + enddo + enddo + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row_ij = 0d0 + tmp_row_ij2 = 0d0 + tmp_row_ji = 0d0 + tmp_row_ji2 = 0d0 +! call get_mo_bi_ortho_tc_two_es(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map) +! call get_mo_bi_ortho_tc_two_es(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map) + do mm = 1, mo_num + hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,pfix,mm,hfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,pfix,mm,hfix) + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,pfix) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix) + enddo + putj = p2 + do puti=1,mo_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = hij_cache(puti,1) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_row_ij(k,puti) = tmp_row_ij(k,puti) + hij * coefs(k,1) + enddo + endif + hji = hji_cache(puti,1) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_row_ji(k,puti) = tmp_row_ji(k,puti) + hji * coefs(k,2) + enddo + endif + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = hij_cache(puti,2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int) + do k=1,N_states + tmp_row_ij2(k,puti) = tmp_row_ij2(k,puti) + hij * coefs(k,1) + enddo + endif + hji = hji_cache(puti,2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int) + do k=1,N_states + tmp_row_ji2(k,puti) = tmp_row_ji2(k,puti) + hji * coefs(k,2) + enddo + endif + end if + end do + mat_p(:,:p2-1,p2) = mat_p(:,:p2-1,p2) + tmp_row_ij(:,:p2-1) + mat_m(:,:p2-1,p2) = mat_m(:,:p2-1,p2) + tmp_row_ji(:,:p2-1) + do l=p2,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_p(k,p2,l) = mat_p(k,p2,l) + tmp_row_ij(k,l) + mat_m(k,p2,l) = mat_m(k,p2,l) + tmp_row_ji(k,l) + enddo + enddo + mat_p(:,:p1-1,p1) = mat_p(:,:p1-1,p1) + tmp_row_ij2(:,:p1-1) + mat_m(:,:p1-1,p1) = mat_m(:,:p1-1,p1) + tmp_row_ji2(:,:p1-1) + do l=p1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_p(k,p1,l) = mat_p(k,p1,l) + tmp_row_ij2(k,l) + mat_m(k,p1,l) = mat_m(k,p1,l) + tmp_row_ji2(k,l) + enddo + enddo + end if + end if + deallocate(lbanned,hij_cache) + + !! 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) .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) + !!!! GUESS ON THE ORDER OF DETS + print*,'compute hij' +! hij = 0.d0 +! hji = 0.d0 + call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji) + call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij) + !DIR$ LOOP COUNT AVG(4) + do k = 1, N_states + mat_p(k, p1, p2) = mat_p(k, p1, p2) + coefs(k,1) * hij + mat_m(k, p1, p2) = mat_m(k, p1, p2) + coefs(k,2) * hji + enddo + enddo + enddo + +end subroutine get_d1 + +! --- + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs) + + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_m(N_states, mo_num, mo_num) + double precision, intent(inout) :: mat_p(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, k, s, h1, h2, p1, p2, puti, putj, mm + double precision :: hij, phase, hji + double precision, external :: get_phase_bi + logical :: ok + + integer, parameter :: bant=1 + double precision, allocatable :: hij_cache1(:), hij_cache2(:) + allocate (hij_cache1(mo_num),hij_cache2(mo_num)) + double precision, allocatable :: hji_cache1(:), hji_cache2(:) + allocate (hji_cache1(mo_num),hji_cache2(mo_num)) + + print*,'in get d0' +! call debug_det(gen, N_int) + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) +! print*,'in AB' + do p1=1, mo_num + if(bannedOrb(p1, 1)) cycle +! call get_mo_bi_ortho_tc_two_es(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map) + do mm =1, mo_num + hji_cache1(mm) = mo_bi_ortho_tc_two_e(mm,p1,h2,h1) + hji_cache1(mm) = mo_bi_ortho_tc_two_e(h2,h1,mm,p1) + enddo + do p2=1, mo_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then +! print*,'in p1 == h1 or p2 == h2' + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) +! call i_h_j(gen, det, N_int, hij) + !!! GUESS ON THE ORDER + call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hji) + call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hij) + else +! print*,'ELSE ' + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hij = hij_cache1(p2) * phase + hji = hji_cache1(p2) * phase + end if + if (hij == 0.d0) cycle + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_p(k, p1, p2) = mat_p(k, p1, p2) + coefs(k,1) * hij ! HOTSPOT + mat_m(k, p1, p2) = mat_m(k, p1, p2) + coefs(k,2) * hji ! HOTSPOT + enddo + end do + end do + + else ! AA BB +! print*, 'in AA BB' + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_num + if(bannedOrb(puti, sp)) cycle + do mm = 1, mo_num + hij_cache1(mm) = mo_bi_ortho_tc_two_e(p2,p1,mm,puti) + hij_cache2(mm) = mo_bi_ortho_tc_two_e(p1,p2,mm,puti) + hji_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1) + hji_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2) + enddo +! call get_mo_bi_ortho_tc_two_es(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map) +! call get_mo_bi_ortho_tc_two_es(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map) + do putj=puti+1, mo_num + if(bannedOrb(putj, sp)) cycle + 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 i_h_j(gen, det, N_int, hij) + !!! GUESS + call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hji) + if (hij == 0.d0.or.hji == 0.d0) cycle + else + hji = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj)) + hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1)) + if (hij == 0.d0.or.hji==0.d0) cycle + hij = hij * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + hji = hji * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + end if + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k,1) * hij + mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k,2) * hji + enddo + end do + end do + end if + +! deallocate(hij_cache1,hij_cache2) +! deallocate(hji_cache1,hji_cache2) + +end subroutine get_d0 + +! --- + +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ + +!subroutine get_pm2(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs) +! +! use bitmasks +! +! implicit none +! +! integer, intent(in) :: h(0:2,2), p(0:4,2), sp +! integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int,2) +! logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) +! double precision, intent(in) :: coefs(N_states) +! double precision, intent(inout) :: mat_p(N_states, mo_num, mo_num), mat_m(N_states, mo_num, mo_num) +! +! 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 :: i, j, k, tip, ma, mi, puti, putj +! integer :: h1, h2, p1, p2, i1, i2 +! integer :: bant +! double precision :: hij_p, hij_m, phase +! +! double precision, external :: get_phase_bi +! double precision, external :: get_mo_bi_ortho_tc_two_e_tc_int, get_mo_bi_ortho_tc_two_e_tcdag_int +! +! PROVIDE mo_integrals_tc_int_map mo_integrals_tcdag_int_map +! +! bant = 1 +! +! 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(ma == 2) bant = 2 +! if(tip == 3) then +! puti = p(1, mi) +! if(bannedOrb(puti, mi)) return +! h1 = h(1, ma) +! h2 = h(2, ma) +! +! 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) +! +! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map ) & +! - get_mo_bi_ortho_tc_two_e_tc_int (p2, p1, h1, h2, mo_integrals_tc_int_map ) +! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map) & +! - get_mo_bi_ortho_tc_two_e_tcdag_int(p2, p1, h1, h2, mo_integrals_tcdag_int_map) +! +! if( (hij_p.eq.0.d0) .and. (hij_m.eq.0.d0) ) cycle +! +! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) +! +! if(ma == 1) then +! !DIR$ LOOP COUNT AVG(4) +! do k = 1, N_states +! mat_p(k, putj, puti) = mat_p(k, putj, puti) + coefs(k) * hij_p +! mat_m(k, putj, puti) = mat_m(k, putj, puti) + coefs(k) * hij_m +! enddo +! else +! !DIR$ LOOP COUNT AVG(4) +! do k = 1, N_states +! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p +! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m +! enddo +! end if +! end do +! +! else +! +! h1 = h(1,1) +! h2 = h(1,2) +! do j = 1,2 +! putj = p(j, 2) +! if(bannedOrb(putj, 2)) cycle +! p2 = p(turn2(j), 2) +! do i = 1,2 +! puti = p(i, 1) +! +! if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle +! p1 = p(turn2(i), 1) +! +! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map ) +! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) +! !DIR$ LOOP COUNT AVG(4) +! do k = 1, N_states +! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p +! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m +! enddo +! endif +! end do +! end do +! end if +! +! else +! if(tip == 0) then +! h1 = h(1, ma) +! h2 = h(2, ma) +! do i=1,3 +! puti = p(i, ma) +! if(bannedOrb(puti,ma)) cycle +! do j=i+1,4 +! putj = p(j, ma) +! if(bannedOrb(putj,ma)) cycle +! if(banned(puti,putj,1)) cycle +! +! i1 = turn2d(1, i, j) +! i2 = turn2d(2, i, j) +! p1 = p(i1, ma) +! p2 = p(i2, ma) +! +! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map ) & +! - get_mo_bi_ortho_tc_two_e_tc_int (p2, p1, h1, h2, mo_integrals_tc_int_map ) +! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map) & +! - get_mo_bi_ortho_tc_two_e_tcdag_int(p2, p1, h1, h2, mo_integrals_tcdag_int_map) +! +! if( (hij_p.eq.0.d0) .and. (hij_m.eq.0.d0) ) cycle +! +! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) +! +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p +! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m +! enddo +! end do +! end do +! +! else if(tip == 3) then +! h1 = h(1, mi) +! h2 = h(1, ma) +! p1 = p(1, mi) +! do i=1,3 +! puti = p(turn3(1,i), ma) +! if(bannedOrb(puti,ma)) cycle +! putj = p(turn3(2,i), ma) +! if(bannedOrb(putj,ma)) cycle +! if(banned(puti,putj,1)) cycle +! p2 = p(i, ma) +! +! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map ) +! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map) +! +! if( (hij_p.eq.0.d0) .and. (hij_m.eq.0.d0) ) cycle +! +! hij_p = hij_p * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) +! if (puti < putj) then +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p +! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m +! enddo +! else +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k, putj, puti) = mat_p(k, putj, puti) + coefs(k) * hij_p +! mat_m(k, putj, puti) = mat_m(k, putj, puti) + coefs(k) * hij_m +! enddo +! endif +! end do +! else ! tip == 4 +! puti = p(1, sp) +! putj = p(2, sp) +! if(.not. banned(puti,putj,1)) then +! p1 = p(1, mi) +! p2 = p(2, mi) +! h1 = h(1, mi) +! h2 = h(2, mi) +! +! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map ) & +! - get_mo_bi_ortho_tc_two_e_tc_int (p2, p1, h1, h2, mo_integrals_tc_int_map ) +! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map) & +! - get_mo_bi_ortho_tc_two_e_tcdag_int(p2, p1, h1, h2, mo_integrals_tcdag_int_map) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p +! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m +! enddo +! end if +! end if +! end if +! end if +! +!end subroutine get_pm2 +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ + + +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ + +!subroutine get_pm1(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs) +! +! use bitmasks +! +! implicit none +! +! integer(bit_kind) :: det(N_int, 2) +! integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) +! integer(bit_kind), intent(in) :: phasemask(N_int,2) +! logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) +! double precision, intent(in) :: coefs(N_states) +! integer, intent(in) :: h(0:2,2), p(0:4,2), sp +! double precision, intent(inout) :: mat_p(N_states, mo_num, mo_num), mat_m(N_states, mo_num, mo_num) +! +! double precision, external :: get_phase_bi +! double precision, external :: get_mo_bi_ortho_tc_two_e_tc_int, get_mo_bi_ortho_tc_two_e_tcdag_int +! +! logical :: ok +! logical, allocatable :: lbanned(:,:) +! integer :: bant +! integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j +! integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l +! double precision :: tmp_row_ij_p (N_states, mo_num), tmp_row_ij_m (N_states, mo_num) +! double precision :: hij_p, hij_m, tmp_row_ij2_p(N_states, mo_num), tmp_row_ij2_m(N_states, mo_num) +! double precision, allocatable :: hijp_cache(:,:), hijm_cache(:,:) +! +! integer, parameter :: turn2(2) = (/2,1/) +! integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) +! +! PROVIDE mo_integrals_tc_int_map mo_integrals_tcdag_int_map +! +! allocate( lbanned(mo_num, 2) ) +! allocate( hijp_cache(mo_num,2), hijm_cache(mo_num,2) ) +! lbanned = bannedOrb +! +! 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) +! +! bant = 1 +! +! if(sp == 3) then +! !move MA +! if(ma == 2) bant = 2 +! puti = p(1,mi) +! hfix = h(1,ma) +! p1 = p(1,ma) +! p2 = p(2,ma) +! if(.not. bannedOrb(puti, mi)) then +! +! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p1, p2, mo_num, hijp_cache(1,1), mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p2, p1, mo_num, hijp_cache(1,2), mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p1, p2, mo_num, hijm_cache(1,1), mo_integrals_tcdag_int_map) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p2, p1, mo_num, hijm_cache(1,2), mo_integrals_tcdag_int_map) +! +! tmp_row_ij_p = 0d0 +! tmp_row_ij_m = 0d0 +! do putj=1, hfix-1 +! if(lbanned(putj, ma)) cycle +! if(banned(putj, puti,bant)) cycle +! +! hij_p = hijp_cache(putj,1) - hijp_cache(putj,2) +! hij_m = hijm_cache(putj,1) - hijm_cache(putj,2) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! tmp_row_ij_p(k,putj) = tmp_row_ij_p(k,putj) + hij_p * coefs(k) +! tmp_row_ij_m(k,putj) = tmp_row_ij_m(k,putj) + hij_m * coefs(k) +! enddo +! endif +! end do +! do putj=hfix+1, mo_num +! if(lbanned(putj, ma)) cycle +! if(banned(putj, puti,bant)) cycle +! +! hij_p = hijp_cache(putj,2) - hijp_cache(putj,1) +! hij_m = hijm_cache(putj,2) - hijm_cache(putj,1) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! tmp_row_ij_p(k,putj) = tmp_row_ij_p(k,putj) + hij_p * coefs(k) +! tmp_row_ij_m(k,putj) = tmp_row_ij_m(k,putj) + hij_m * coefs(k) +! enddo +! endif +! end do +! +! if(ma == 1) then +! mat_p(1:N_states,1:mo_num,puti) = mat_p(1:N_states,1:mo_num,puti) + tmp_row_ij_p(1:N_states,1:mo_num) +! mat_m(1:N_states,1:mo_num,puti) = mat_m(1:N_states,1:mo_num,puti) + tmp_row_ij_m(1:N_states,1:mo_num) +! else +! do l=1,mo_num +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k,puti,l) = mat_p(k,puti,l) + tmp_row_ij_p(k,l) +! mat_m(k,puti,l) = mat_m(k,puti,l) + tmp_row_ij_m(k,l) +! enddo +! enddo +! end if +! end if +! +! !MOVE MI +! pfix = p(1,mi) +! tmp_row_ij_p = 0d0 +! tmp_row_ij_m = 0d0 +! tmp_row_ij2_p = 0d0 +! tmp_row_ij2_m = 0d0 +! +! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, pfix, p1, mo_num, hijp_cache(1,1), mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, pfix, p2, mo_num, hijp_cache(1,2), mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, pfix, p1, mo_num, hijm_cache(1,1), mo_integrals_tcdag_int_map) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, pfix, p2, mo_num, hijm_cache(1,2), mo_integrals_tcdag_int_map) +! +! putj = p1 +! do puti=1,mo_num !HOT +! if(lbanned(puti,mi)) cycle +! !p1 fixed +! putj = p1 +! if(.not. banned(putj,puti,bant)) then +! +! hij_p = hijp_cache(puti,2) +! hij_m = hijm_cache(puti,2) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int) +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! tmp_row_ij_p(k,puti) = tmp_row_ij_p(k,puti) + hij_p * coefs(k) +! tmp_row_ij_m(k,puti) = tmp_row_ij_m(k,puti) + hij_m * coefs(k) +! enddo +! endif +! end if +! +! putj = p2 +! if(.not. banned(putj,puti,bant)) then +! +! hij_p = hijp_cache(puti,1) +! hij_m = hijm_cache(puti,1) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int) +! do k=1,N_states +! tmp_row_ij2_p(k,puti) = tmp_row_ij2_p(k,puti) + hij_p * coefs(k) +! tmp_row_ij2_m(k,puti) = tmp_row_ij2_m(k,puti) + hij_m * coefs(k) +! enddo +! endif +! end if +! end do +! +! if(mi == 1) then +! mat_p(:,:,p1) = mat_p(:,:,p1) + tmp_row_ij_p (:,:) +! mat_p(:,:,p2) = mat_p(:,:,p2) + tmp_row_ij2_p(:,:) +! mat_m(:,:,p1) = mat_m(:,:,p1) + tmp_row_ij_m (:,:) +! mat_m(:,:,p2) = mat_m(:,:,p2) + tmp_row_ij2_m(:,:) +! else +! do l=1,mo_num +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k,p1,l) = mat_p(k,p1,l) + tmp_row_ij_p (k,l) +! mat_p(k,p2,l) = mat_p(k,p2,l) + tmp_row_ij2_p(k,l) +! mat_m(k,p1,l) = mat_m(k,p1,l) + tmp_row_ij_m (k,l) +! mat_m(k,p2,l) = mat_m(k,p2,l) + tmp_row_ij2_m(k,l) +! enddo +! enddo +! end if +! +! else ! sp /= 3 +! +! 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) +! +! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p1, p2, mo_num, hijp_cache(1,1), mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p2, p1, mo_num, hijp_cache(1,2), mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p1, p2, mo_num, hijm_cache(1,1), mo_integrals_tcdag_int_map) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p2, p1, mo_num, hijm_cache(1,2), mo_integrals_tcdag_int_map) +! +! tmp_row_ij_p = 0d0 +! tmp_row_ij_m = 0d0 +! do putj=1,hfix-1 +! if(banned(putj,puti,1)) cycle +! if(lbanned(putj,ma)) cycle +! +! hij_p = hijp_cache(putj,1) - hijp_cache(putj,2) +! hij_m = hijm_cache(putj,1) - hijm_cache(putj,2) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) +! tmp_row_ij_p(:,putj) = tmp_row_ij_p(:,putj) + hij_p * coefs(:) +! tmp_row_ij_m(:,putj) = tmp_row_ij_m(:,putj) + hij_m * coefs(:) +! endif +! end do +! do putj=hfix+1,mo_num +! if(banned(putj,puti,1)) cycle +! if(lbanned(putj,ma)) cycle +! +! hij_p = hijp_cache(putj,2) - hijp_cache(putj,1) +! hij_m = hijm_cache(putj,2) - hijm_cache(putj,1) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) +! tmp_row_ij_p(:,putj) = tmp_row_ij_p(:,putj) + hij_p * coefs(:) +! tmp_row_ij_m(:,putj) = tmp_row_ij_m(:,putj) + hij_m * coefs(:) +! endif +! end do +! +! mat_p(:, :puti-1, puti) = mat_p(:, :puti-1, puti) + tmp_row_ij_p(:,:puti-1) +! mat_m(:, :puti-1, puti) = mat_m(:, :puti-1, puti) + tmp_row_ij_m(:,:puti-1) +! do l=puti,mo_num +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k, puti, l) = mat_p(k, puti,l) + tmp_row_ij_p(k,l) +! mat_m(k, puti, l) = mat_m(k, puti,l) + tmp_row_ij_m(k,l) +! enddo +! enddo +! end do +! else +! hfix = h(1,mi) +! pfix = p(1,mi) +! p1 = p(1,ma) +! p2 = p(2,ma) +! tmp_row_ij_p = 0d0 +! tmp_row_ij_m = 0d0 +! tmp_row_ij2_p = 0d0 +! tmp_row_ij2_m = 0d0 +! +! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p1, pfix, mo_num, hijp_cache(1,1), mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p2, pfix, mo_num, hijp_cache(1,2), mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p1, pfix, mo_num, hijp_cache(1,1), mo_integrals_tcdag_int_map) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p2, pfix, mo_num, hijp_cache(1,2), mo_integrals_tcdag_int_map) +! +! putj = p2 +! do puti=1,mo_num +! if(lbanned(puti,ma)) cycle +! putj = p2 +! if(.not. banned(puti,putj,1)) then +! +! hij_p = hijp_cache(puti,1) +! hij_m = hijm_cache(puti,1) +! +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int) +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! tmp_row_ij_p(k,puti) = tmp_row_ij_p(k,puti) + hij_p * coefs(k) +! tmp_row_ij_m(k,puti) = tmp_row_ij_m(k,puti) + hij_m * coefs(k) +! enddo +! endif +! end if +! +! putj = p1 +! if(.not. banned(puti,putj,1)) then +! hij_p = hijp_cache(puti,2) +! hij_m = hijm_cache(puti,2) +! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then +! hij_p = hij_p * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int) +! do k=1,N_states +! tmp_row_ij2_p(k,puti) = tmp_row_ij2_p(k,puti) + hij_p * coefs(k) +! tmp_row_ij2_m(k,puti) = tmp_row_ij2_m(k,puti) + hij_m * coefs(k) +! enddo +! endif +! end if +! end do +! mat_p(:,:p2-1,p2) = mat_p(:,:p2-1,p2) + tmp_row_ij_p(:,:p2-1) +! mat_m(:,:p2-1,p2) = mat_m(:,:p2-1,p2) + tmp_row_ij_m(:,:p2-1) +! do l=p2,mo_num +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k,p2,l) = mat_p(k,p2,l) + tmp_row_ij_p(k,l) +! mat_m(k,p2,l) = mat_m(k,p2,l) + tmp_row_ij_m(k,l) +! enddo +! enddo +! mat_p(:,:p1-1,p1) = mat_p(:,:p1-1,p1) + tmp_row_ij2_p(:,:p1-1) +! mat_m(:,:p1-1,p1) = mat_m(:,:p1-1,p1) + tmp_row_ij2_m(:,:p1-1) +! do l=p1,mo_num +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k,p1,l) = mat_p(k,p1,l) + tmp_row_ij2_p(k,l) +! mat_m(k,p1,l) = mat_m(k,p1,l) + tmp_row_ij2_m(k,l) +! enddo +! enddo +! end if +! end if +! deallocate(lbanned,hijp_cache, hijm_cache) +! +! !! 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) .or. banned(p1, p2, 1)) cycle +! call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) +! +! call htilde_mu_mat_tot (gen, det, N_int, hij_p) +! call htildedag_mu_mat_tot(gen, det, N_int, hij_m) +! +! !DIR$ LOOP COUNT AVG(4) +! do k = 1, N_states +! mat_p(k, p1, p2) = mat_p(k, p1, p2) + coefs(k) * hij_p +! mat_m(k, p1, p2) = mat_m(k, p1, p2) + coefs(k) * hij_m +! enddo +! enddo +! enddo +! +!end subroutine get_pm1 +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ + + + +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ + +!subroutine get_pm0(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs) +! +! use bitmasks +! implicit none +! +! integer(bit_kind) :: det(N_int, 2) +! integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) +! integer(bit_kind), intent(in) :: phasemask(N_int,2) +! integer, intent(in) :: h(0:2,2), p(0:4,2), sp +! logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) +! double precision, intent(in) :: coefs(N_states) +! double precision, intent(inout) :: mat_p(N_states, mo_num, mo_num), mat_m(N_states, mo_num, mo_num) +! +! double precision, external :: get_phase_bi +! double precision, external :: get_mo_bi_ortho_tc_two_e_tc_int, get_mo_bi_ortho_tc_two_e_tcdag_int +! integer, parameter :: bant=1 +! integer :: i, j, k, s, h1, h2, p1, p2, puti, putj +! logical :: ok +! double precision :: hij_p, hij_m, phase +! double precision, allocatable :: hijp_cache1(:), hijp_cache2(:), hijm_cache1(:), hijm_cache2(:) +! +! PROVIDE mo_integrals_tc_int_map mo_integrals_tcdag_int_map +! +! allocate( hijp_cache1(mo_num) , hijp_cache2(mo_num) ) +! allocate( hijm_cache1(mo_num) , hijm_cache2(mo_num) ) +! +! if(sp == 3) then ! AB +! h1 = p(1,1) +! h2 = p(1,2) +! do p1=1, mo_num +! if(bannedOrb(p1, 1)) cycle +! +! call get_mo_bi_ortho_tc_two_es_tc_int (p1, h2, h1, mo_num, hijp_cache1, mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(p1, h2, h1, mo_num, hijm_cache1, mo_integrals_tcdag_int_map) +! +! do p2 = 1, mo_num +! if(bannedOrb(p2,2)) cycle +! 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 htilde_mu_mat_tot (gen, det, N_int, hij_p) +! call htildedag_mu_mat_tot(gen, det, N_int, hij_m) +! else +! phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) +! hij_p = hijp_cache1(p2) * phase +! hij_m = hijm_cache1(p2) * phase +! end if +! if( (hij_p.eq.0.d0).and.(hij_m.eq.0.d0) ) cycle +! !DIR$ LOOP COUNT AVG(4) +! do k = 1, N_states +! mat_p(k, p1, p2) = mat_p(k, p1, p2) + coefs(k) * hij_p ! HOTSPOT +! mat_m(k, p1, p2) = mat_m(k, p1, p2) + coefs(k) * hij_m ! HOTSPOT +! enddo +! end do +! end do +! +! else ! AA BB +! p1 = p(1,sp) +! p2 = p(2,sp) +! do puti=1, mo_num +! if(bannedOrb(puti, sp)) cycle +! +! call get_mo_bi_ortho_tc_two_es_tc_int (puti, p2, p1, mo_num, hijp_cache1, mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tc_int (puti, p1, p2, mo_num, hijp_cache2, mo_integrals_tc_int_map ) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(puti, p2, p1, mo_num, hijm_cache1, mo_integrals_tcdag_int_map) +! call get_mo_bi_ortho_tc_two_es_tcdag_int(puti, p1, p2, mo_num, hijm_cache2, mo_integrals_tcdag_int_map) +! +! do putj=puti+1, mo_num +! if(bannedOrb(putj, sp)) cycle +! 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 htilde_mu_mat_tot (gen, det, N_int, hij_p) +! call htildedag_mu_mat_tot(gen, det, N_int, hij_m) +! if( (hij_p.eq.0.d0).and.(hij_m.eq.0.d0) ) cycle +! else +! +! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, puti, putj, mo_integrals_tc_int_map ) & +! - get_mo_bi_ortho_tc_two_e_tc_int (p2, p1, puti, putj, mo_integrals_tc_int_map ) +! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, puti, putj, mo_integrals_tcdag_int_map) & +! - get_mo_bi_ortho_tc_two_e_tcdag_int(p2, p1, puti, putj, mo_integrals_tcdag_int_map) +! +! if( (hij_p.eq.0.d0).and.(hij_m.eq.0.d0) ) cycle +! +! hij_p = hij_p * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) +! hij_m = hij_m * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) +! +! end if +! !DIR$ LOOP COUNT AVG(4) +! do k=1,N_states +! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p +! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m +! enddo +! end do +! end do +! end if +! +! deallocate( hijp_cache1 , hijp_cache2 ) +! deallocate( hijm_cache1 , hijm_cache2 ) +! +!end subroutine get_pm0 +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ +! ___________________________________________________________________________________________________________________________________________________ + + +! OLD unoptimized routines for debugging +! ====================================== + +subroutine get_d0_reference(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) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_num + if(bannedOrb(p2,2)) cycle + 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 i_h_j(gen, det, N_int, hij) + else + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) * phase + end if + mat(:, p1, p2) = mat(:, p1, p2) + coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_num + if(bannedOrb(putj, sp)) cycle + 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 i_h_j(gen, det, N_int, hij) + else + hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + end if + mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij + end do + end do + end if + +end subroutine get_d0_reference + +! --- + +subroutine get_d1_reference(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) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + double precision :: hij, tmp_row_ij(N_states, mo_num), tmp_row_ij2(N_states, mo_num), hji + double precision, external :: get_phase_bi + logical :: ok + + logical, allocatable :: lbanned(:,:) + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j + integer :: hfix, pfix, h1, h2, p1, p2, ib + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + allocate (lbanned(mo_num, 2)) + lbanned = bannedOrb + + 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) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row_ij = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (mo_bi_ortho_tc_two_e(p1, p2, putj, hfix)-mo_bi_ortho_tc_two_e(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + tmp_row_ij(1:N_states,putj) = tmp_row_ij(1:N_states,putj) + hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (mo_bi_ortho_tc_two_e(p1, p2, hfix, putj)-mo_bi_ortho_tc_two_e(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + tmp_row_ij(1:N_states,putj) = tmp_row_ij(1:N_states,putj) + hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_num,puti) = mat(1:N_states,1:mo_num,puti) + tmp_row_ij(1:N_states,1:mo_num) + else + mat(1:N_states,puti,1:mo_num) = mat(1:N_states,puti,1:mo_num) + tmp_row_ij(1:N_states,1:mo_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row_ij = 0d0 + tmp_row_ij2 = 0d0 + do puti=1,mo_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = mo_bi_ortho_tc_two_e(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int) + tmp_row_ij(:,puti) = tmp_row_ij(:,puti) + hij * coefs(:) + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = mo_bi_ortho_tc_two_e(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int) + tmp_row_ij2(:,puti) = tmp_row_ij2(:,puti) + hij * coefs(:) + end if + end do + + if(mi == 1) then + mat(:,:,p1) = mat(:,:,p1) + tmp_row_ij(:,:) + mat(:,:,p2) = mat(:,:,p2) + tmp_row_ij2(:,:) + else + mat(:,p1,:) = mat(:,p1,:) + tmp_row_ij(:,:) + mat(:,p2,:) = mat(:,p2,:) + tmp_row_ij2(:,:) + 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_ij = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (mo_bi_ortho_tc_two_e(p1, p2, putj, hfix)-mo_bi_ortho_tc_two_e(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + tmp_row_ij(:,putj) = tmp_row_ij(:,putj) + hij * coefs(:) + end do + do putj=hfix+1,mo_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (mo_bi_ortho_tc_two_e(p1, p2, hfix, putj)-mo_bi_ortho_tc_two_e(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + tmp_row_ij(:,putj) = tmp_row_ij(:,putj) + hij * coefs(:) + end do + + mat(:, :puti-1, puti) = mat(:, :puti-1, puti) + tmp_row_ij(:,:puti-1) + mat(:, puti, puti:) = mat(:, puti, puti:) + tmp_row_ij(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row_ij = 0d0 + tmp_row_ij2 = 0d0 + do puti=1,mo_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = mo_bi_ortho_tc_two_e(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int) + tmp_row_ij(:,puti) = tmp_row_ij(:,puti) + hij * coefs(:) + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = mo_bi_ortho_tc_two_e(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int) + tmp_row_ij2(:,puti) = tmp_row_ij2(:,puti) + hij * coefs(:) + end if + end do + mat(:,:p2-1,p2) = mat(:,:p2-1,p2) + tmp_row_ij(:,:p2-1) + mat(:,p2,p2:) = mat(:,p2,p2:) + tmp_row_ij(:,p2:) + mat(:,:p1-1,p1) = mat(:,:p1-1,p1) + tmp_row_ij2(:,:p1-1) + mat(:,p1,p1:) = mat(:,p1,p1:) + tmp_row_ij2(:,p1:) + end if + end if + deallocate(lbanned) + + !! 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) .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) = mat(:, p1, p2) + coefs(:) * hij + end do + end do + +end subroutine get_d1_reference + +! --- + +subroutine get_d2_reference(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) + integer(bit_kind), intent(in) :: phasemask(2,N_int) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_num, mo_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, i1, i2, mm + double precision :: hij, phase, hji + + 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) + + 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(ma == 2) bant = 2 + + if(tip == 3) then + 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) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + if(ma == 1) then + mat(:, putj, puti) = mat(:, putj, puti) + coefs(:) * hij + else + mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij + end if + end do + else + h1 = h(1,1) + h2 = h(1,2) + do j = 1,2 + putj = p(j, 2) + p2 = p(turn2(j), 2) + do i = 1,2 + puti = p(i, 1) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + + hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2,N_int) + mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij + end do + end do + end if + + 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(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2,N_int) + mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2,N_int) + mat(:, min(puti, putj), max(puti, putj)) = mat(:, min(puti, putj), max(puti, putj)) + coefs(:) * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2,N_int) + mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij + end if + end if + end if + +end subroutine get_d2_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + +! --- + diff --git a/src/cipsi_tc_bi_ortho/get_d0_good.irp.f b/src/cipsi_tc_bi_ortho/get_d0_good.irp.f new file mode 100644 index 00000000..4270e7b8 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/get_d0_good.irp.f @@ -0,0 +1,139 @@ +subroutine get_d0_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs) + !todo: indices/conjg should be okay for complex + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num) + double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, k, s, h1, h2, p1, p2, puti, putj, mm + double precision :: phase + double precision :: hij,hji + double precision, external :: get_phase_bi + logical :: ok + + integer, parameter :: bant=1 + double precision, allocatable :: hij_cache1(:), hij_cache2(:) + allocate (hij_cache1(mo_num),hij_cache2(mo_num)) + double precision, allocatable :: hji_cache1(:), hji_cache2(:) + allocate (hji_cache1(mo_num),hji_cache2(mo_num)) +! print*,'in get_d0_new' +! call debug_det(gen,N_int) +! print*,'coefs',coefs(1,:) + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_num + if(bannedOrb(p1, 1)) cycle +! call get_mo_two_e_integrals_complex(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map) + do mm = 1, mo_num + hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,p1,h2,h1) + hji_cache1(mm) = mo_bi_ortho_tc_two_e(h2,h1,mm,p1) + enddo + !!!!!!!!!! + do p2=1, mo_num + if(bannedOrb(p2,2)) cycle + 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 i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this +! call i_h_j_complex(det, gen, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij) + else + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hij = hij_cache1(p2) * phase + end if + if (hij == (0.d0,0.d0)) cycle + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * hij ! HOTSPOT + enddo + end do + !!!!!!!!!! + do p2=1, mo_num + if(bannedOrb(p2,2)) cycle + 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 i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this +! call i_h_j_complex(det, gen, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji) + else + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hji = hji_cache1(p2) * phase + end if + if (hji == (0.d0,0.d0)) cycle + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,2) * hji ! HOTSPOT + enddo + end do + end do + + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_num + if(bannedOrb(puti, sp)) cycle +! call get_mo_two_e_integrals_complex(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1) + hij_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2) + hji_cache1(mm) = mo_bi_ortho_tc_two_e(p2,p1,mm,puti) + hji_cache2(mm) = mo_bi_ortho_tc_two_e(p1,p2,mm,puti) + enddo + !!!!!!!!!! + do putj=puti+1, mo_num + if(bannedOrb(putj, sp)) cycle + 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 i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this +! call i_h_j_complex(det, gen, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij) + if (hij == 0.d0) cycle + else +! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj)) +! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj)) + hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1)) + if (hij == 0.d0) cycle + hij = (hij) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + end if + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij + enddo + end do + + !!!!!!!!!! + do putj=puti+1, mo_num + if(bannedOrb(putj, sp)) cycle + 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 htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji) + if (hji == 0.d0) cycle + else + hji = (mo_bi_ortho_tc_two_e( p1, p2, puti, putj) - mo_bi_ortho_tc_two_e( p2, p1, puti, putj)) + if (hji == 0.d0) cycle + hji = (hji) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + end if + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji + enddo + end do + end do + end if + + deallocate(hij_cache1,hij_cache2) +end + diff --git a/src/cipsi_tc_bi_ortho/get_d1_good.irp.f b/src/cipsi_tc_bi_ortho/get_d1_good.irp.f new file mode 100644 index 00000000..bc19e7e4 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/get_d1_good.irp.f @@ -0,0 +1,454 @@ +subroutine get_d1_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs) + !todo: indices should be okay for complex? + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num) + double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + double precision, external :: get_phase_bi + double precision, external :: mo_two_e_integral_complex + logical :: ok + + logical, allocatable :: lbanned(:,:) + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j + integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l, mm + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + double precision, allocatable :: hij_cache(:,:) + double precision :: hij, tmp_rowij(N_states, mo_num), tmp_rowij2(N_states, mo_num) + double precision, allocatable :: hji_cache(:,:) + double precision :: hji, tmp_rowji(N_states, mo_num), tmp_rowji2(N_states, mo_num) +! PROVIDE mo_integrals_map N_int +! print*,'in get_d1_new' +! call debug_det(gen,N_int) +! print*,'coefs',coefs(1,:) + + allocate (lbanned(mo_num, 2)) + allocate (hij_cache(mo_num,2)) + allocate (hji_cache(mo_num,2)) + lbanned = bannedOrb + + 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) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then +! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,p2,mm,hfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,p1,mm,hfix) + enddo + !! + tmp_rowij = 0.d0 + do putj=1, hfix-1 + if(lbanned(putj, ma)) cycle + if(banned(putj, puti,bant)) cycle + hij = hij_cache(putj,1) - hij_cache(putj,2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,1) + enddo + endif + end do + do putj=hfix+1, mo_num + if(lbanned(putj, ma)) cycle + if(banned(putj, puti,bant)) cycle + hij = hij_cache(putj,2) - hij_cache(putj,1) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,1) + enddo + endif + end do + + if(ma == 1) then + mat_r(1:N_states,1:mo_num,puti) = mat_r(1:N_states,1:mo_num,puti) + tmp_rowij(1:N_states,1:mo_num) + else + do l=1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k,puti,l) = mat_r(k,puti,l) + tmp_rowij(k,l) + enddo + enddo + end if + + !! + tmp_rowji = 0.d0 + do putj=1, hfix-1 + if(lbanned(putj, ma)) cycle + if(banned(putj, puti,bant)) cycle + hji = hji_cache(putj,1) - hji_cache(putj,2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,2) + enddo + endif + end do + do putj=hfix+1, mo_num + if(lbanned(putj, ma)) cycle + if(banned(putj, puti,bant)) cycle + hji = hji_cache(putj,2) - hji_cache(putj,1) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,2) + enddo + endif + end do + + if(ma == 1) then + mat_l(1:N_states,1:mo_num,puti) = mat_l(1:N_states,1:mo_num,puti) + tmp_rowji(1:N_states,1:mo_num) + else + do l=1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k,puti,l) = mat_l(k,puti,l) + tmp_rowji(k,l) + enddo + enddo + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_rowij = 0.d0 + tmp_rowij2 = 0.d0 + tmp_rowji = 0.d0 + tmp_rowji2 = 0.d0 +! call get_mo_two_e_integrals_complex(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e(pfix,p1,mm,hfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e(pfix,p2,mm,hfix) + enddo + putj = p1 + !! + do puti=1,mo_num !HOT + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = hij_cache(puti,2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,1) + enddo + endif + end if +! + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = hij_cache(puti,1) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int) + do k=1,N_states + tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,1) + enddo + endif + end if + end do + + if(mi == 1) then + mat_r(:,:,p1) = mat_r(:,:,p1) + tmp_rowij(:,:) + mat_r(:,:,p2) = mat_r(:,:,p2) + tmp_rowij2(:,:) + else + do l=1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij(k,l) + mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij2(k,l) + enddo + enddo + end if + + putj = p1 + !! + do puti=1,mo_num !HOT + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hji = hji_cache(puti,2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,2) + enddo + endif + end if +! + putj = p2 + if(.not. banned(putj,puti,bant)) then + hji = hji_cache(puti,1) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int) + do k=1,N_states + tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,2) + enddo + endif + end if + end do + + if(mi == 1) then + mat_l(:,:,p1) = mat_l(:,:,p1) + tmp_rowji(:,:) + mat_l(:,:,p2) = mat_l(:,:,p2) + tmp_rowji2(:,:) + else + do l=1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji(k,l) + mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji2(k,l) + enddo + enddo + end if + + else ! sp /= 3 + + 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) +! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,p2,mm,hfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,p1,mm,hfix) + enddo + !! + tmp_rowij = 0.d0 + do putj=1,hfix-1 + if(banned(putj,puti,1)) cycle + if(lbanned(putj,ma)) cycle + hij = hij_cache(putj,1) - hij_cache(putj,2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,1) + endif + end do + do putj=hfix+1,mo_num + if(banned(putj,puti,1)) cycle + if(lbanned(putj,ma)) cycle + hij = hij_cache(putj,2) - hij_cache(putj,1) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,1) + endif + end do + + mat_r(:, :puti-1, puti) = mat_r(:, :puti-1, puti) + tmp_rowij(:,:puti-1) + do l=puti,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, l) = mat_r(k, puti,l) + tmp_rowij(k,l) + enddo + enddo + !! + tmp_rowji = 0.d0 + do putj=1,hfix-1 + if(banned(putj,puti,1)) cycle + if(lbanned(putj,ma)) cycle + hji = hji_cache(putj,1) - hji_cache(putj,2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,2) + endif + end do + do putj=hfix+1,mo_num + if(banned(putj,puti,1)) cycle + if(lbanned(putj,ma)) cycle + hji = hji_cache(putj,2) - hji_cache(putj,1) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,2) + endif + end do + + mat_l(:, :puti-1, puti) = mat_l(:, :puti-1, puti) + tmp_rowji(:,:puti-1) + do l=puti,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, l) = mat_l(k, puti,l) + tmp_rowji(k,l) + enddo + enddo + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_rowij = 0.d0 + tmp_rowij2 = 0.d0 + tmp_rowji = 0.d0 + tmp_rowji2 = 0.d0 +! call get_mo_two_e_integrals_complex(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,pfix) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,pfix,mm,hfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,pfix,mm,hfix) + enddo + putj = p2 + !! + do puti=1,mo_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = hij_cache(puti,1) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,1) + enddo + endif + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = hij_cache(puti,2) + if (hij /= 0.d0) then + hij = hij * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int) + do k=1,N_states + tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,1) + enddo + endif + end if + end do + mat_r(:,:p2-1,p2) = mat_r(:,:p2-1,p2) + tmp_rowij(:,:p2-1) + do l=p2,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij(k,l) + enddo + enddo + mat_r(:,:p1-1,p1) = mat_r(:,:p1-1,p1) + tmp_rowij2(:,:p1-1) + do l=p1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij2(k,l) + enddo + enddo + + + !! + putj = p2 + do puti=1,mo_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hji = hji_cache(puti,1) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,2) + enddo + endif + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hji = hji_cache(puti,2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int) + do k=1,N_states + tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,2) + enddo + endif + end if + end do + mat_l(:,:p2-1,p2) = mat_l(:,:p2-1,p2) + tmp_rowji(:,:p2-1) + do l=p2,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji(k,l) + enddo + enddo + mat_l(:,:p1-1,p1) = mat_l(:,:p1-1,p1) + tmp_rowji2(:,:p1-1) + do l=p1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji2(k,l) + enddo + enddo + end if + end if + deallocate(lbanned,hij_cache, hji_cache) + + !! 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) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + ! gen is a selector; mask is ionized generator; det is alpha + ! hij is contribution to +! call i_h_j_complex(gen, det, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(det, gen, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + ! take conjugate to get contribution to instead of +! mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * dconjg(hij) + mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * hij + mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,2) * hji + enddo + end do + end do +end + diff --git a/src/cipsi_tc_bi_ortho/get_d2_good.irp.f b/src/cipsi_tc_bi_ortho/get_d2_good.irp.f new file mode 100644 index 00000000..0a08c808 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/get_d2_good.irp.f @@ -0,0 +1,308 @@ + +subroutine get_d2_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs) + !todo: indices/conjg should be correct for complex + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num) + double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi + + integer :: i, j, k, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: phase + double precision :: hij,hji + + 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 +! print*, 'in get_d2_new' +! call debug_det(gen,N_int) +! print*,'coefs',coefs(1,:) + + tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles + + ma = sp !1:(alpha,alpha); 2:(b,b); 3:(a,b) + if(p(0,1) > p(0,2)) ma = 1 ! more alpha particles than beta particles + if(p(0,1) < p(0,2)) ma = 2 ! fewer alpha particles than beta particles + mi = mod(ma, 2) + 1 + + if(sp == 3) then ! if one alpha and one beta xhole + !(where xholes refer to the ionizations from the generator, not the holes occupied in the ionized generator) + if(ma == 2) bant = 2 ! if more beta particles than alpha particles + + if(tip == 3) then ! if 3 of one particle spin and 1 of the other particle spin + puti = p(1, mi) + if(bannedOrb(puti, mi)) return + h1 = h(1, ma) + h2 = h(2, ma) + + !! + do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma + 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) + + ! |G> = |psi_{gen,i}> + ! |G'> = a_{x1} a_{x2} |G> + ! |alpha> = a_{puti}^{\dagger} a_{putj}^{\dagger} |G'> + ! |alpha> = t_{x1,x2}^{puti,putj} |G> + ! hij = + ! |alpha> = t_{p1,p2}^{h1,h2}|psi_{selectors,i}> + !todo: = ( - ) * phase + ! += dconjg(c_i) * + ! = ( - ) * phase + ! += * c_i +! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2, p1, h1, h2) + +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e( h1, h2, p2, p1) + if (hij == 0.d0) cycle + + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + + if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,1) * hij + enddo + else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij + enddo + end if + end do + !! + do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma + 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) + hji = mo_bi_ortho_tc_two_e(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e( p2, p1, h1, h2) + if (hji == 0.d0) cycle + hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + + if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,2) * hji + enddo + else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji + enddo + end if + end do + else ! if 2 alpha and 2 beta particles + h1 = h(1,1) + h2 = h(1,2) + !! + do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle + putj = p(j, 2) + if(bannedOrb(putj, 2)) cycle + p2 = p(turn2(j), 2) + do i = 1,2 + puti = p(i, 1) + if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle + p1 = p(turn2(i), 1) + ! hij = +! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2 ) + if (hij /= 0.d0) then + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hij = hij * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij + enddo + endif + end do + end do + !! + do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle + putj = p(j, 2) + if(bannedOrb(putj, 2)) cycle + p2 = p(turn2(j), 2) + do i = 1,2 + puti = p(i, 1) + if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle + p1 = p(turn2(i), 1) + hji = mo_bi_ortho_tc_two_e( p1, p2, h1, h2) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji + enddo + endif + end do + end do + end if + + else ! if holes are (a,a) or (b,b) + if(tip == 0) then ! if particles are (a,a,a,a) or (b,b,b,b) + h1 = h(1, ma) + h2 = h(2, ma) + !! + do i=1,3 + puti = p(i, ma) + if(bannedOrb(puti,ma)) cycle + do j=i+1,4 + putj = p(j, ma) + if(bannedOrb(putj,ma)) cycle + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) +! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2) +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h1, h2, p2,p1 ) + if (hij == 0.d0) cycle + + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,1) * hij + enddo + end do + end do + !! + do i=1,3 + puti = p(i, ma) + if(bannedOrb(puti,ma)) cycle + do j=i+1,4 + putj = p(j, ma) + if(bannedOrb(putj,ma)) cycle + if(banned(puti,putj,1)) cycle + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1,h1, h2 ) + if (hji == 0.d0) cycle + hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) +coefs(k,2) * hji + enddo + end do + end do + else if(tip == 3) then ! if particles are (a,a,a,b) (ma=1,mi=2) or (a,b,b,b) (ma=2,mi=1) + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + !! + do i=1,3 + puti = p(turn3(1,i), ma) + if(bannedOrb(puti,ma)) cycle + putj = p(turn3(2,i), ma) + if(bannedOrb(putj,ma)) cycle + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + +! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + hij = mo_bi_ortho_tc_two_e(h1, h2,p1, p2 ) + if (hij == 0.d0) cycle + + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) + hij = hij * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) + if (puti < putj) then + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij + enddo + else + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,1) * hij + enddo + endif + end do + !! + do i=1,3 + puti = p(turn3(1,i), ma) + if(bannedOrb(puti,ma)) cycle + putj = p(turn3(2,i), ma) + if(bannedOrb(putj,ma)) cycle + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + hji = mo_bi_ortho_tc_two_e(p1, p2,h1, h2) + if (hji == 0.d0) cycle + hji = hji * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) + if (puti < putj) then + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji + enddo + else + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,2) * hji + enddo + endif + end do + else ! tip == 4 (a,a,b,b) + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + !! +! hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)) +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + hij = (mo_bi_ortho_tc_two_e(h1, h2,p1, p2) - mo_bi_ortho_tc_two_e(h1, h2, p2,p1)) + if (hij /= 0.d0) then + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) + hij = hij * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij + enddo + end if + !! + hji = (mo_bi_ortho_tc_two_e(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e( p2,p1, h1, h2)) + if (hji /= 0.d0) then + hji = hji * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji + enddo + end if + end if + end if + end if +end diff --git a/src/cipsi_tc_bi_ortho/lock_2rdm.irp.f b/src/cipsi_tc_bi_ortho/lock_2rdm.irp.f new file mode 100644 index 00000000..e69de29b diff --git a/src/cipsi_tc_bi_ortho/pouet b/src/cipsi_tc_bi_ortho/pouet new file mode 100644 index 00000000..a7a41454 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/pouet @@ -0,0 +1,33 @@ + + if(dabs(psi_h_alpha*alpha_h_psi - psi_h_alpha_tmp*alpha_h_psi_tmp).gt.1.d-10)then +!!! print*,'---' +!!! print*,psi_h_alpha *alpha_h_psi, psi_h_alpha, alpha_h_psi +!!! print*,psi_h_alpha_tmp*alpha_h_psi_tmp,psi_h_alpha_tmp,alpha_h_psi_tmp + call debug_det(det,N_int) + print*,dabs(psi_h_alpha*alpha_h_psi - psi_h_alpha_tmp*alpha_h_psi_tmp),psi_h_alpha *alpha_h_psi,psi_h_alpha_tmp*alpha_h_psi_tmp + print*,'-- Good ' + print*, psi_h_alpha, alpha_h_psi + print*,'-- bad ' + print*,psi_h_alpha_tmp,alpha_h_psi_tmp + print*,'-- details good' + double precision :: accu_1, accu_2 + accu_1 = 0.d0 + accu_2 = 0.d0 + do iii = 1, N_det + call get_excitation_degree( psi_det(1,1,iii), det, degree, N_int) + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,iii), det, N_int, i_h_alpha) + call htilde_mu_mat_bi_ortho_tot(det, psi_det(1,1,iii), N_int, alpha_h_i) + print*,iii,degree,i_h_alpha,alpha_h_i + accu_1 += i_h_alpha + accu_2 += alpha_h_i + print*,accu_1,accu_2 + + enddo +!!! if(dabs(psi_h_alpha*alpha_h_psi).gt.1.d-10)then +!!! print*,p1,p2 +!!! print*,det(1,1), det(1,2) +!!! call debug_det(det,N_int) +!!! print*,psi_h_alpha *alpha_h_psi, psi_h_alpha, alpha_h_psi +!!! print*,psi_h_alpha_tmp*alpha_h_psi_tmp,psi_h_alpha_tmp,alpha_h_psi_tmp +!!! print*, dabs(psi_h_alpha*alpha_h_psi - psi_h_alpha_tmp*alpha_h_psi_tmp),& +!!! psi_h_alpha *alpha_h_psi,psi_h_alpha_tmp*alpha_h_psi_tmp diff --git a/src/cipsi_tc_bi_ortho/pt2.irp.f b/src/cipsi_tc_bi_ortho/pt2.irp.f new file mode 100644 index 00000000..e7dca456 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/pt2.irp.f @@ -0,0 +1,89 @@ +subroutine pt2_tc_bi_ortho + use selection_types + implicit none + BEGIN_DOC +! Selected Full Configuration Interaction with Stochastic selection and PT2. + END_DOC + integer :: i,j,k,ndet + double precision, allocatable :: zeros(:) + integer :: to_select + type(pt2_type) :: pt2_data, pt2_data_err + logical, external :: qp_stop + logical :: print_pt2 + + double precision :: rss + double precision, external :: memory_of_double + double precision :: correlation_energy_ratio,E_denom,E_tc,norm + double precision, allocatable :: ept2(:), pt1(:),extrap_energy(:) + PROVIDE H_apply_buffer_allocated distributed_davidson mo_two_e_integrals_in_map + + print*,'Diagonal elements of the Fock matrix ' + do i = 1, mo_num + write(*,*)i,Fock_matrix_tc_mo_tot(i,i) + enddo + N_iter = 1 + threshold_generators = 1.d0 + SOFT_TOUCH threshold_generators + + rss = memory_of_double(N_states)*4.d0 + call check_mem(rss,irp_here) + + allocate (zeros(N_states)) + call pt2_alloc(pt2_data, N_states) + call pt2_alloc(pt2_data_err, N_states) + + double precision :: hf_energy_ref + logical :: has + double precision :: relative_error + + relative_error=PT2_relative_error + + zeros = 0.d0 + pt2_data % pt2 = -huge(1.e0) + pt2_data % rpt2 = -huge(1.e0) + pt2_data % overlap= 0.d0 + pt2_data % variance = huge(1.e0) + + if (s2_eig) then + call make_s2_eigenfunction + endif + print_pt2 = .False. + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) +! call routine_save_right + + if (N_det > N_det_max) then + psi_det(1:N_int,1:2,1:N_det) = psi_det_sorted_tc_gen(1:N_int,1:2,1:N_det) + psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states) + N_det = N_det_max + soft_touch N_det psi_det psi_coef + if (s2_eig) then + call make_s2_eigenfunction + endif + print_pt2 = .False. + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + endif + + allocate(ept2(1000),pt1(1000),extrap_energy(100)) + + correlation_energy_ratio = 0.d0 + +! thresh_it_dav = 5.d-5 +! soft_touch thresh_it_dav + + print_pt2 = .True. + to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor) + to_select = max(N_states_diag, to_select) + + E_denom = E_tc ! TC Energy of the current wave function + call pt2_dealloc(pt2_data) + call pt2_dealloc(pt2_data_err) + call pt2_alloc(pt2_data, N_states) + call pt2_alloc(pt2_data_err, N_states) + call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection + + N_iter += 1 + + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + +end + diff --git a/src/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f b/src/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f new file mode 100644 index 00000000..027b74c5 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f @@ -0,0 +1,869 @@ +BEGIN_PROVIDER [ integer, pt2_stoch_istate ] + implicit none + BEGIN_DOC + ! State for stochatsic PT2 + END_DOC + pt2_stoch_istate = 1 +END_PROVIDER + + BEGIN_PROVIDER [ integer, pt2_F, (N_det_generators) ] +&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ] + implicit none + logical, external :: testTeethBuilding + integer :: i,j + pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num - n_core_orb*2 + pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000) + call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max') + + pt2_F(:) = max(int(sqrt(float(pt2_n_tasks_max))),1) + do i=1,pt2_n_0(1+pt2_N_teeth/4) + pt2_F(i) = pt2_n_tasks_max*pt2_min_parallel_tasks + enddo + do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/4), pt2_n_0(pt2_N_teeth-pt2_N_teeth/10) + pt2_F(i) = pt2_min_parallel_tasks + enddo + do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/10), N_det_generators + pt2_F(i) = 1 + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ integer, pt2_N_teeth ] +&BEGIN_PROVIDER [ integer, pt2_minDetInFirstTeeth ] + implicit none + logical, external :: testTeethBuilding + + if(N_det_generators < 500) then + pt2_minDetInFirstTeeth = 1 + pt2_N_teeth = 1 + else + pt2_minDetInFirstTeeth = min(5, N_det_generators) + do pt2_N_teeth=100,2,-1 + if(testTeethBuilding(pt2_minDetInFirstTeeth, pt2_N_teeth)) exit + end do + end if + call write_int(6,pt2_N_teeth,'Number of comb teeth') +END_PROVIDER + + +logical function testTeethBuilding(minF, N) + implicit none + integer, intent(in) :: minF, N + integer :: n0, i + double precision :: u0, Wt, r + + double precision, allocatable :: tilde_w(:), tilde_cW(:) + integer, external :: dress_find_sample + + double precision :: rss + double precision, external :: memory_of_double, memory_of_int + + rss = memory_of_double(2*N_det_generators+1) + call check_mem(rss,irp_here) + + allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators)) + + double precision :: norm2 + norm2 = 0.d0 + do i=N_det_generators,1,-1 + tilde_w(i) = psi_coef_sorted_tc_gen(i,pt2_stoch_istate) * & + psi_coef_sorted_tc_gen(i,pt2_stoch_istate) + norm2 = norm2 + tilde_w(i) + enddo + + f = 1.d0/norm2 + tilde_w(:) = tilde_w(:) * f + + tilde_cW(0) = -1.d0 + do i=1,N_det_generators + tilde_cW(i) = tilde_cW(i-1) + tilde_w(i) + enddo + tilde_cW(:) = tilde_cW(:) + 1.d0 + deallocate(tilde_w) + + n0 = 0 + testTeethBuilding = .false. + double precision :: f + integer :: minFN + minFN = N_det_generators - minF * N + f = 1.d0/dble(N) + do + u0 = tilde_cW(n0) + r = tilde_cW(n0 + minF) + Wt = (1d0 - u0) * f + if (dabs(Wt) <= 1.d-3) then + exit + endif + if(Wt >= r - u0) then + testTeethBuilding = .true. + exit + end if + n0 += 1 + if(n0 > minFN) then + exit + end if + end do + deallocate(tilde_cW) + +end function + + + +subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) + use f77_zmq + use selection_types + + implicit none + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull + integer, intent(in) :: N_in +! integer, intent(inout) :: N_in + double precision, intent(in) :: relative_error, E(N_states) + type(pt2_type), intent(inout) :: pt2_data, pt2_data_err +! + integer :: i, N + + double precision :: state_average_weight_save(N_states), w(N_states,4) + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + type(selection_buffer) :: b + + PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique + PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order + PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns + PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_tc psi_det_sorted_tc + PROVIDE psi_det_hii selection_weight pseudo_sym + PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max + PROVIDE excitation_beta_max excitation_alpha_max excitation_max + PROVIDE psi_selectors_rcoef_bi_orth_transp psi_selectors_lcoef_bi_orth_transp + + if (h0_type == 'CFG') then + PROVIDE psi_configuration_hii det_to_configuration + endif + + if (N_det <= max(4,N_states) .or. pt2_N_teeth < 2) then + print*,'ZMQ_selection' + call ZMQ_selection(N_in, pt2_data) + else + print*,'else ZMQ_selection' + + N = max(N_in,1) * N_states + state_average_weight_save(:) = state_average_weight(:) + if (int(N,8)*2_8 > huge(1)) then + print *, irp_here, ': integer too large' + stop -1 + endif + call create_selection_buffer(N, N*2, b) + ASSERT (associated(b%det)) + ASSERT (associated(b%val)) + + do pt2_stoch_istate=1,N_states + state_average_weight(:) = 0.d0 + state_average_weight(pt2_stoch_istate) = 1.d0 + TOUCH state_average_weight pt2_stoch_istate selection_weight + + PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w + PROVIDE pt2_u pt2_J pt2_R + call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2') + + integer, external :: zmq_put_psi + integer, external :: zmq_put_N_det_generators + integer, external :: zmq_put_N_det_selectors + integer, external :: zmq_put_dvector + integer, external :: zmq_put_ivector + if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then + stop 'Unable to put psi on ZMQ server' + endif + if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then + stop 'Unable to put N_det_generators on ZMQ server' + endif + if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then + stop 'Unable to put N_det_selectors on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then + stop 'Unable to put energy on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then + stop 'Unable to put state_average_weight on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then + stop 'Unable to put selection_weight on ZMQ server' + endif + if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then + stop 'Unable to put pt2_stoch_istate on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then + stop 'Unable to put threshold_generators on ZMQ server' + endif + + + integer, external :: add_task_to_taskserver + character(300000) :: task + + integer :: j,k,ipos,ifirst + ifirst=0 + + ipos=0 + do i=1,N_det_generators + if (pt2_F(i) > 1) then + ipos += 1 + endif + enddo + call write_int(6,sum(pt2_F),'Number of tasks') + call write_int(6,ipos,'Number of fragmented tasks') + + ipos=1 + do i= 1, N_det_generators + do j=1,pt2_F(pt2_J(i)) + write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in + ipos += 30 + if (ipos > 300000-30) then + if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then + stop 'Unable to add task to task server' + endif + ipos=1 + if (ifirst == 0) then + ifirst=1 + if (zmq_set_running(zmq_to_qp_run_socket) == -1) then + print *, irp_here, ': Failed in zmq_set_running' + endif + endif + endif + end do + enddo + if (ipos > 1) then + if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then + stop 'Unable to add task to task server' + endif + endif + + integer, external :: zmq_set_running + if (zmq_set_running(zmq_to_qp_run_socket) == -1) then + print *, irp_here, ': Failed in zmq_set_running' + endif + + + double precision :: mem_collector, mem, rss + + call resident_memory(rss) + + mem_collector = 8.d0 * & ! bytes + ( 1.d0*pt2_n_tasks_max & ! task_id, index + + 0.635d0*N_det_generators & ! f,d + + pt2_n_tasks_max*pt2_type_size(N_states) & ! pt2_data_task + + N_det_generators*pt2_type_size(N_states) & ! pt2_data_I + + 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3 + + 1.d0*(N_int*2.d0*N + N) & ! selection buffer + + 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer + ) / 1024.d0**3 + + integer :: nproc_target, ii + nproc_target = nthreads_pt2 + ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2) + + do + mem = mem_collector + & ! + nproc_target * 8.d0 * & ! bytes + ( 0.5d0*pt2_n_tasks_max & ! task_id + + 64.d0*pt2_n_tasks_max & ! task + + pt2_type_size(N_states)*pt2_n_tasks_max*N_states & ! pt2, variance, overlap + + 1.d0*pt2_n_tasks_max & ! i_generator, subset + + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer + + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer + + 2.0d0*(ii) & ! preinteresting, interesting, + ! prefullinteresting, fullinteresting + + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist + + 1.0d0*(N_states*mo_num*mo_num) & ! mat + ) / 1024.d0**3 + + if (nproc_target == 0) then + call check_mem(mem,irp_here) + nproc_target = 1 + exit + endif + + if (mem+rss < qp_max_mem) then + exit + endif + + nproc_target = nproc_target - 1 + + enddo + call write_int(6,nproc_target,'Number of threads for PT2') + call write_double(6,mem,'Memory (Gb)') + + call omp_set_max_active_levels(1) + + + print '(A)', '========== ======================= ===================== ===================== ===========' + print '(A)', ' Samples Energy Variance Norm^2 Seconds' + print '(A)', '========== ======================= ===================== ===================== ===========' + + PROVIDE global_selection_buffer + + !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) & + !$OMP PRIVATE(i) + i = omp_get_thread_num() + if (i==0) then + + call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, pt2_data, pt2_data_err, b, N) + pt2_data % rpt2(pt2_stoch_istate) = & + pt2_data % pt2(pt2_stoch_istate)/(1.d0+pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate)) + + !TODO : We should use here the correct formula for the error of X/Y + pt2_data_err % rpt2(pt2_stoch_istate) = & + pt2_data_err % pt2(pt2_stoch_istate)/(1.d0 + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate)) + + else + call pt2_slave_inproc(i) + endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2') + call omp_set_max_active_levels(8) + + print '(A)', '========== ======================= ===================== ===================== ===========' + + do k=1,N_states + pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate) + enddo + SOFT_TOUCH pt2_overlap + + enddo + FREE pt2_stoch_istate + + ! Symmetrize overlap + do j=2,N_states + do i=1,j-1 + pt2_overlap(i,j) = 0.5d0 * (pt2_overlap(i,j) + pt2_overlap(j,i)) + pt2_overlap(j,i) = pt2_overlap(i,j) + enddo + enddo + + print *, 'Overlap of perturbed states:' + do k=1,N_states + print *, pt2_overlap(k,:) + enddo + print *, '-------' + + if (N_in > 0) then + b%cur = min(N_in,b%cur) + if (s2_eig) then + call make_selection_buffer_s2(b) + else + call remove_duplicates_in_selection_buffer(b) + endif + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) + endif + call delete_selection_buffer(b) + + state_average_weight(:) = state_average_weight_save(:) + TOUCH state_average_weight + call update_pt2_and_variance_weights(pt2_data, N_states) + endif + + +end subroutine + + +subroutine pt2_slave_inproc(i) + implicit none + integer, intent(in) :: i + + PROVIDE global_selection_buffer + call run_pt2_slave(1,i,pt2_e0_denominator) +end + + +subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_err, b, N_) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + double precision, intent(in) :: relative_error, E + type(pt2_type), intent(inout) :: pt2_data, pt2_data_err + type(selection_buffer), intent(inout) :: b + integer, intent(in) :: N_ + + type(pt2_type), allocatable :: pt2_data_task(:) + type(pt2_type), allocatable :: pt2_data_I(:) + type(pt2_type), allocatable :: pt2_data_S(:) + type(pt2_type), allocatable :: pt2_data_S2(:) + type(pt2_type) :: pt2_data_teeth + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer, external :: zmq_delete_tasks_async_send + integer, external :: zmq_delete_tasks_async_recv + integer, external :: zmq_abort + integer, external :: pt2_find_sample_lr + + PROVIDE pt2_stoch_istate + + integer :: more, n, i, p, c, t, n_tasks, U + integer, allocatable :: task_id(:) + integer, allocatable :: index(:) + + double precision :: v, x, x2, x3, avg, avg2, avg3(N_states), eqt, E0, v0, n0(N_states) + double precision :: eqta(N_states) + double precision :: time, time1, time0 + + integer, allocatable :: f(:) + logical, allocatable :: d(:) + logical :: do_exit, stop_now, sending + logical, external :: qp_stop + type(selection_buffer) :: b2 + + + double precision :: rss + double precision, external :: memory_of_double, memory_of_int + + sending =.False. + + rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2) + rss += memory_of_double(N_states*N_det_generators)*3.d0 + rss += memory_of_double(N_states*pt2_n_tasks_max)*3.d0 + rss += memory_of_double(pt2_N_teeth+1)*4.d0 + call check_mem(rss,irp_here) + + ! If an allocation is added here, the estimate of the memory should also be + ! updated in ZMQ_pt2 + allocate(task_id(pt2_n_tasks_max), index(pt2_n_tasks_max), f(N_det_generators)) + allocate(d(N_det_generators+1)) + allocate(pt2_data_task(pt2_n_tasks_max)) + allocate(pt2_data_I(N_det_generators)) + allocate(pt2_data_S(pt2_N_teeth+1)) + allocate(pt2_data_S2(pt2_N_teeth+1)) + + + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + call create_selection_buffer(N_, N_*2, b2) + + + pt2_data % pt2(pt2_stoch_istate) = -huge(1.) + pt2_data_err % pt2(pt2_stoch_istate) = huge(1.) + pt2_data % variance(pt2_stoch_istate) = huge(1.) + pt2_data_err % variance(pt2_stoch_istate) = huge(1.) + pt2_data % overlap(:,pt2_stoch_istate) = 0.d0 + pt2_data_err % overlap(:,pt2_stoch_istate) = huge(1.) + n = 1 + t = 0 + U = 0 + do i=1,pt2_n_tasks_max + call pt2_alloc(pt2_data_task(i),N_states) + enddo + do i=1,pt2_N_teeth+1 + call pt2_alloc(pt2_data_S(i),N_states) + call pt2_alloc(pt2_data_S2(i),N_states) + enddo + do i=1,N_det_generators + call pt2_alloc(pt2_data_I(i),N_states) + enddo + f(:) = pt2_F(:) + d(:) = .false. + n_tasks = 0 + E0 = E + v0 = 0.d0 + n0(:) = 0.d0 + more = 1 + call wall_time(time0) + time1 = time0 + + do_exit = .false. + stop_now = .false. + do while (n <= N_det_generators) + if(f(pt2_J(n)) == 0) then + d(pt2_J(n)) = .true. + do while(d(U+1)) + U += 1 + end do + + ! Deterministic part + do while(t <= pt2_N_teeth) + if(U >= pt2_n_0(t+1)) then + t=t+1 + E0 = 0.d0 + v0 = 0.d0 + n0(:) = 0.d0 + do i=pt2_n_0(t),1,-1 + E0 += pt2_data_I(i) % pt2(pt2_stoch_istate) + v0 += pt2_data_I(i) % variance(pt2_stoch_istate) + n0(:) += pt2_data_I(i) % overlap(:,pt2_stoch_istate) + end do + else + exit + end if + end do + + ! Add Stochastic part + c = pt2_R(n) + if(c > 0) then + + call pt2_alloc(pt2_data_teeth,N_states) + do p=pt2_N_teeth, 1, -1 + v = pt2_u_0 + pt2_W_T * (pt2_u(c) + dble(p-1)) + i = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(p),pt2_n_0(p+1)) + v = pt2_W_T / pt2_w(i) + call pt2_add ( pt2_data_teeth, v, pt2_data_I(i) ) + call pt2_add ( pt2_data_S(p), 1.d0, pt2_data_teeth ) + call pt2_add2( pt2_data_S2(p), 1.d0, pt2_data_teeth ) + enddo + call pt2_dealloc(pt2_data_teeth) + + avg = E0 + pt2_data_S(t) % pt2(pt2_stoch_istate) / dble(c) + avg2 = v0 + pt2_data_S(t) % variance(pt2_stoch_istate) / dble(c) + avg3(:) = n0(:) + pt2_data_S(t) % overlap(:,pt2_stoch_istate) / dble(c) + if ((avg /= 0.d0) .or. (n == N_det_generators) ) then + do_exit = .true. + endif + if (qp_stop()) then + stop_now = .True. + endif + pt2_data % pt2(pt2_stoch_istate) = avg + pt2_data % variance(pt2_stoch_istate) = avg2 + pt2_data % overlap(:,pt2_stoch_istate) = avg3(:) + call wall_time(time) + ! 1/(N-1.5) : see Brugger, The American Statistician (23) 4 p. 32 (1969) + if(c > 2) then + eqt = dabs((pt2_data_S2(t) % pt2(pt2_stoch_istate) / c) - (pt2_data_S(t) % pt2(pt2_stoch_istate)/c)**2) ! dabs for numerical stability + eqt = sqrt(eqt / (dble(c) - 1.5d0)) + pt2_data_err % pt2(pt2_stoch_istate) = eqt + + eqt = dabs((pt2_data_S2(t) % variance(pt2_stoch_istate) / c) - (pt2_data_S(t) % variance(pt2_stoch_istate)/c)**2) ! dabs for numerical stability + eqt = sqrt(eqt / (dble(c) - 1.5d0)) + pt2_data_err % variance(pt2_stoch_istate) = eqt + + eqta(:) = dabs((pt2_data_S2(t) % overlap(:,pt2_stoch_istate) / c) - (pt2_data_S(t) % overlap(:,pt2_stoch_istate)/c)**2) ! dabs for numerical stability + eqta(:) = sqrt(eqta(:) / (dble(c) - 1.5d0)) + pt2_data_err % overlap(:,pt2_stoch_istate) = eqta(:) + + + if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then + time1 = time + print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.4)', c, & + pt2_data % pt2(pt2_stoch_istate) +E, & + pt2_data_err % pt2(pt2_stoch_istate), & + pt2_data % variance(pt2_stoch_istate), & + pt2_data_err % variance(pt2_stoch_istate), & + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), & + pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), & + time-time0 + if (stop_now .or. ( & + (do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & + (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then + if (zmq_abort(zmq_to_qp_run_socket) == -1) then + call sleep(10) + if (zmq_abort(zmq_to_qp_run_socket) == -1) then + print *, irp_here, ': Error in sending abort signal (2)' + endif + endif + endif + endif + endif + end if + n += 1 + else if(more == 0) then + exit + else + call pull_pt2_results(zmq_socket_pull, index, pt2_data_task, task_id, n_tasks, b2) + if(n_tasks > pt2_n_tasks_max)then + print*,'PB !!!' + print*,'If you see this, send a bug report with the following content' + print*,irp_here + print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max + stop -1 + endif + if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then + stop 'PT2: Unable to delete tasks (send)' + endif + do i=1,n_tasks + if(index(i).gt.size(pt2_data_I,1).or.index(i).lt.1)then + print*,'PB !!!' + print*,'If you see this, send a bug report with the following content' + print*,irp_here + print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1) + stop -1 + endif + call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i)) + f(index(i)) -= 1 + end do + do i=1, b2%cur + ! We assume the pulled buffer is sorted + if (b2%val(i) > b%mini) exit + call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i)) + end do + if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then + stop 'PT2: Unable to delete tasks (recv)' + endif + end if + end do + do i=1,N_det_generators + call pt2_dealloc(pt2_data_I(i)) + enddo + do i=1,pt2_N_teeth+1 + call pt2_dealloc(pt2_data_S(i)) + call pt2_dealloc(pt2_data_S2(i)) + enddo + do i=1,pt2_n_tasks_max + call pt2_dealloc(pt2_data_task(i)) + enddo +!print *, 'deleting b2' + call delete_selection_buffer(b2) +!print *, 'sorting b' + call sort_selection_buffer(b) +!print *, 'done' + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + +end subroutine + + +integer function pt2_find_sample(v, w) + implicit none + double precision, intent(in) :: v, w(0:N_det_generators) + integer, external :: pt2_find_sample_lr + + pt2_find_sample = pt2_find_sample_lr(v, w, 0, N_det_generators) +end function + + +integer function pt2_find_sample_lr(v, w, l_in, r_in) + implicit none + double precision, intent(in) :: v, w(0:N_det_generators) + integer, intent(in) :: l_in,r_in + integer :: i,l,r + + l=l_in + r=r_in + + do while(r-l > 1) + i = shiftr(r+l,1) + if(w(i) < v) then + l = i + else + r = i + end if + end do + i = r + do r=i+1,N_det_generators + if (w(r) /= w(i)) then + exit + endif + enddo + pt2_find_sample_lr = r-1 +end function + + +BEGIN_PROVIDER [ integer, pt2_n_tasks ] + implicit none + BEGIN_DOC + ! Number of parallel tasks for the Monte Carlo + END_DOC + pt2_n_tasks = N_det_generators +END_PROVIDER + +BEGIN_PROVIDER[ double precision, pt2_u, (N_det_generators)] + implicit none + integer, allocatable :: seed(:) + integer :: m,i + call random_seed(size=m) + allocate(seed(m)) + do i=1,m + seed(i) = i + enddo + call random_seed(put=seed) + deallocate(seed) + + call RANDOM_NUMBER(pt2_u) + END_PROVIDER + + BEGIN_PROVIDER[ integer, pt2_J, (N_det_generators)] +&BEGIN_PROVIDER[ integer, pt2_R, (N_det_generators)] + implicit none + BEGIN_DOC +! pt2_J contains the list of generators after ordering them according to the +! Monte Carlo sampling. +! +! pt2_R(i) is the number of combs drawn when determinant i is computed. + END_DOC + integer :: N_c, N_j + integer :: U, t, i + double precision :: v + integer, external :: pt2_find_sample_lr + + logical, allocatable :: pt2_d(:) + integer :: m,l,r,k + integer :: ncache + integer, allocatable :: ii(:,:) + double precision :: dt + + ncache = min(N_det_generators,10000) + + double precision :: rss + double precision, external :: memory_of_double, memory_of_int + rss = memory_of_int(ncache)*dble(pt2_N_teeth) + memory_of_int(N_det_generators) + call check_mem(rss,irp_here) + + allocate(ii(pt2_N_teeth,ncache),pt2_d(N_det_generators)) + + pt2_R(:) = 0 + pt2_d(:) = .false. + N_c = 0 + N_j = pt2_n_0(1) + do i=1,N_j + pt2_d(i) = .true. + pt2_J(i) = i + end do + + U = 0 + do while(N_j < pt2_n_tasks) + + if (N_c+ncache > N_det_generators) then + ncache = N_det_generators - N_c + endif + + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(dt,v,t,k) + do k=1, ncache + dt = pt2_u_0 + do t=1, pt2_N_teeth + v = dt + pt2_W_T *pt2_u(N_c+k) + dt = dt + pt2_W_T + ii(t,k) = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(t),pt2_n_0(t+1)) + end do + enddo + !$OMP END PARALLEL DO + + do k=1,ncache + !ADD_COMB + N_c = N_c+1 + do t=1, pt2_N_teeth + i = ii(t,k) + if(.not. pt2_d(i)) then + N_j += 1 + pt2_J(N_j) = i + pt2_d(i) = .true. + end if + end do + + pt2_R(N_j) = N_c + + !FILL_TOOTH + do while(U < N_det_generators) + U += 1 + if(.not. pt2_d(U)) then + N_j += 1 + pt2_J(N_j) = U + pt2_d(U) = .true. + exit + end if + end do + if (N_j >= pt2_n_tasks) exit + end do + enddo + + if(N_det_generators > 1) then + pt2_R(N_det_generators-1) = 0 + pt2_R(N_det_generators) = N_c + end if + + deallocate(ii,pt2_d) + +END_PROVIDER + + + + BEGIN_PROVIDER [ double precision, pt2_w, (N_det_generators) ] +&BEGIN_PROVIDER [ double precision, pt2_cW, (0:N_det_generators) ] +&BEGIN_PROVIDER [ double precision, pt2_W_T ] +&BEGIN_PROVIDER [ double precision, pt2_u_0 ] +&BEGIN_PROVIDER [ integer, pt2_n_0, (pt2_N_teeth+1) ] + implicit none + integer :: i, t + double precision, allocatable :: tilde_w(:), tilde_cW(:) + double precision :: r, tooth_width + integer, external :: pt2_find_sample + + double precision :: rss + double precision, external :: memory_of_double, memory_of_int + rss = memory_of_double(2*N_det_generators+1) + call check_mem(rss,irp_here) + + if (N_det_generators == 1) then + + pt2_w(1) = 1.d0 + pt2_cw(1) = 1.d0 + pt2_u_0 = 1.d0 + pt2_W_T = 0.d0 + pt2_n_0(1) = 0 + pt2_n_0(2) = 1 + + else + + allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators)) + + tilde_cW(0) = 0d0 + + do i=1,N_det_generators + tilde_w(i) = psi_coef_sorted_tc_gen(i,pt2_stoch_istate)**2 !+ 1.d-20 + enddo + + double precision :: norm2 + norm2 = 0.d0 + do i=N_det_generators,1,-1 + norm2 += tilde_w(i) + enddo + + tilde_w(:) = tilde_w(:) / norm2 + + tilde_cW(0) = -1.d0 + do i=1,N_det_generators + tilde_cW(i) = tilde_cW(i-1) + tilde_w(i) + enddo + tilde_cW(:) = tilde_cW(:) + 1.d0 + + pt2_n_0(1) = 0 + do + pt2_u_0 = tilde_cW(pt2_n_0(1)) + r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth) + pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth) + if(pt2_W_T >= r - pt2_u_0) then + exit + end if + pt2_n_0(1) += 1 + if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then + print *, "teeth building failed" + stop -1 + end if + end do + + do t=2, pt2_N_teeth + r = pt2_u_0 + pt2_W_T * dble(t-1) + pt2_n_0(t) = pt2_find_sample(r, tilde_cW) + end do + pt2_n_0(pt2_N_teeth+1) = N_det_generators + + pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1)) + do t=1, pt2_N_teeth + tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t)) + if (tooth_width == 0.d0) then + tooth_width = sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1))) + endif + ASSERT(tooth_width > 0.d0) + do i=pt2_n_0(t)+1, pt2_n_0(t+1) + pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width + end do + end do + + pt2_cW(0) = 0d0 + do i=1,N_det_generators + pt2_cW(i) = pt2_cW(i-1) + pt2_w(i) + end do + pt2_n_0(pt2_N_teeth+1) = N_det_generators + + endif +END_PROVIDER + + + + + diff --git a/src/cipsi_tc_bi_ortho/pt2_type.irp.f b/src/cipsi_tc_bi_ortho/pt2_type.irp.f new file mode 100644 index 00000000..ee90d421 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/pt2_type.irp.f @@ -0,0 +1,128 @@ +subroutine pt2_alloc(pt2_data,N) + implicit none + use selection_types + type(pt2_type), intent(inout) :: pt2_data + integer, intent(in) :: N + integer :: k + + allocate(pt2_data % pt2(N) & + ,pt2_data % variance(N) & + ,pt2_data % rpt2(N) & + ,pt2_data % overlap(N,N) & + ) + + pt2_data % pt2(:) = 0.d0 + pt2_data % variance(:) = 0.d0 + pt2_data % rpt2(:) = 0.d0 + pt2_data % overlap(:,:) = 0.d0 + +end subroutine + +subroutine pt2_dealloc(pt2_data) + implicit none + use selection_types + type(pt2_type), intent(inout) :: pt2_data + deallocate(pt2_data % pt2 & + ,pt2_data % variance & + ,pt2_data % rpt2 & + ,pt2_data % overlap & + ) +end subroutine + +subroutine pt2_add(p1, w, p2) + implicit none + use selection_types + BEGIN_DOC +! p1 += w * p2 + END_DOC + type(pt2_type), intent(inout) :: p1 + double precision, intent(in) :: w + type(pt2_type), intent(in) :: p2 + + if (w == 1.d0) then + + p1 % pt2(:) = p1 % pt2(:) + p2 % pt2(:) + p1 % rpt2(:) = p1 % rpt2(:) + p2 % rpt2(:) + p1 % variance(:) = p1 % variance(:) + p2 % variance(:) + p1 % overlap(:,:) = p1 % overlap(:,:) + p2 % overlap(:,:) + + else + + p1 % pt2(:) = p1 % pt2(:) + w * p2 % pt2(:) + p1 % rpt2(:) = p1 % rpt2(:) + w * p2 % rpt2(:) + p1 % variance(:) = p1 % variance(:) + w * p2 % variance(:) + p1 % overlap(:,:) = p1 % overlap(:,:) + w * p2 % overlap(:,:) + + endif + +end subroutine + + +subroutine pt2_add2(p1, w, p2) + implicit none + use selection_types + BEGIN_DOC +! p1 += w * p2**2 + END_DOC + type(pt2_type), intent(inout) :: p1 + double precision, intent(in) :: w + type(pt2_type), intent(in) :: p2 + + if (w == 1.d0) then + + p1 % pt2(:) = p1 % pt2(:) + p2 % pt2(:) * p2 % pt2(:) + p1 % rpt2(:) = p1 % rpt2(:) + p2 % rpt2(:) * p2 % rpt2(:) + p1 % variance(:) = p1 % variance(:) + p2 % variance(:) * p2 % variance(:) + p1 % overlap(:,:) = p1 % overlap(:,:) + p2 % overlap(:,:) * p2 % overlap(:,:) + + else + + p1 % pt2(:) = p1 % pt2(:) + w * p2 % pt2(:) * p2 % pt2(:) + p1 % rpt2(:) = p1 % rpt2(:) + w * p2 % rpt2(:) * p2 % rpt2(:) + p1 % variance(:) = p1 % variance(:) + w * p2 % variance(:) * p2 % variance(:) + p1 % overlap(:,:) = p1 % overlap(:,:) + w * p2 % overlap(:,:) * p2 % overlap(:,:) + + endif + +end subroutine + + +subroutine pt2_serialize(pt2_data, n, x) + implicit none + use selection_types + type(pt2_type), intent(in) :: pt2_data + integer, intent(in) :: n + double precision, intent(out) :: x(*) + + integer :: i,k,n2 + + n2 = n*n + x(1:n) = pt2_data % pt2(1:n) + k=n + x(k+1:k+n) = pt2_data % rpt2(1:n) + k=k+n + x(k+1:k+n) = pt2_data % variance(1:n) + k=k+n + x(k+1:k+n2) = reshape(pt2_data % overlap(1:n,1:n), (/ n2 /)) + +end + +subroutine pt2_deserialize(pt2_data, n, x) + implicit none + use selection_types + type(pt2_type), intent(inout) :: pt2_data + integer, intent(in) :: n + double precision, intent(in) :: x(*) + + integer :: i,k,n2 + + n2 = n*n + pt2_data % pt2(1:n) = x(1:n) + k=n + pt2_data % rpt2(1:n) = x(k+1:k+n) + k=k+n + pt2_data % variance(1:n) = x(k+1:k+n) + k=k+n + pt2_data % overlap(1:n,1:n) = reshape(x(k+1:k+n2), (/ n, n /)) + +end diff --git a/src/cipsi_tc_bi_ortho/run_pt2_slave.irp.f b/src/cipsi_tc_bi_ortho/run_pt2_slave.irp.f new file mode 100644 index 00000000..aa6546e7 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/run_pt2_slave.irp.f @@ -0,0 +1,549 @@ + use omp_lib + use selection_types + use f77_zmq +BEGIN_PROVIDER [ integer(omp_lock_kind), global_selection_buffer_lock ] + use omp_lib + implicit none + BEGIN_DOC + ! Global buffer for the OpenMP selection + END_DOC + call omp_init_lock(global_selection_buffer_lock) +END_PROVIDER + +BEGIN_PROVIDER [ type(selection_buffer), global_selection_buffer ] + use omp_lib + implicit none + BEGIN_DOC + ! Global buffer for the OpenMP selection + END_DOC + call omp_set_lock(global_selection_buffer_lock) + call delete_selection_buffer(global_selection_buffer) + call create_selection_buffer(N_det_generators, 2*N_det_generators, & + global_selection_buffer) + call omp_unset_lock(global_selection_buffer_lock) +END_PROVIDER + + +subroutine run_pt2_slave(thread,iproc,energy) + use selection_types + use f77_zmq + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + if (N_det > 100000 ) then + call run_pt2_slave_large(thread,iproc,energy) + else + call run_pt2_slave_small(thread,iproc,energy) + endif +end + +subroutine run_pt2_slave_small(thread,iproc,energy) + use selection_types + use f77_zmq + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, ctask, ltask + character*(512), allocatable :: task(:) + integer, allocatable :: task_id(:) + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + type(selection_buffer) :: b + logical :: done, buffer_ready + + type(pt2_type), allocatable :: pt2_data(:) + integer :: n_tasks, k, N + integer, allocatable :: i_generator(:), subset(:) + + double precision, external :: memory_of_double, memory_of_int + integer :: bsize ! Size of selection buffers + + allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max)) + allocate(pt2_data(pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max)) + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + integer, external :: connect_to_taskserver + if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + return + endif + + zmq_socket_push = new_zmq_push_socket(thread) + + b%N = 0 + buffer_ready = .False. + n_tasks = 1 + + done = .False. + do while (.not.done) + + n_tasks = max(1,n_tasks) + n_tasks = min(pt2_n_tasks_max,n_tasks) + + integer, external :: get_tasks_from_taskserver + if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then + exit + endif + done = task_id(n_tasks) == 0 + if (done) then + n_tasks = n_tasks-1 + endif + if (n_tasks == 0) exit + + do k=1,n_tasks + call sscanf_ddd(task(k), subset(k), i_generator(k), N) + enddo + if (b%N == 0) then + ! Only first time + bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2) + call create_selection_buffer(bsize, bsize*2, b) + buffer_ready = .True. + else + ASSERT (b%N == bsize) + endif + + double precision :: time0, time1 + call wall_time(time0) + do k=1,n_tasks + call pt2_alloc(pt2_data(k),N_states) + b%cur = 0 + call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k))) + enddo + call wall_time(time1) + + integer, external :: tasks_done_to_taskserver + if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then + done = .true. + endif + call sort_selection_buffer(b) + call push_pt2_results(zmq_socket_push, i_generator, pt2_data, b, task_id, n_tasks) + do k=1,n_tasks + call pt2_dealloc(pt2_data(k)) + enddo + b%cur=0 + +! ! Try to adjust n_tasks around nproc/2 seconds per job + n_tasks = min(2*n_tasks,int( dble(n_tasks * nproc/2) / (time1 - time0 + 1.d0))) + n_tasks = min(n_tasks, pt2_n_tasks_max) +! n_tasks = 1 + end do + + integer, external :: disconnect_from_taskserver + do i=1,300 + if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) /= -2) exit + call usleep(500) + print *, 'Retry disconnect...' + end do + + call end_zmq_push_socket(zmq_socket_push,thread) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + if (buffer_ready) then + call delete_selection_buffer(b) + endif + deallocate(pt2_data) +end subroutine + + +subroutine run_pt2_slave_large(thread,iproc,energy) + use selection_types + use f77_zmq + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, ctask, ltask + character*(512) :: task + integer :: task_id(1) + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + type(selection_buffer) :: b + logical :: done, buffer_ready + + type(pt2_type) :: pt2_data + integer :: n_tasks, k, N + integer :: i_generator, subset + + integer :: bsize ! Size of selection buffers + logical :: sending + double precision :: time_shift + + PROVIDE global_selection_buffer global_selection_buffer_lock + + call random_number(time_shift) + time_shift = time_shift*15.d0 + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + integer, external :: connect_to_taskserver + if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + return + endif + + zmq_socket_push = new_zmq_push_socket(thread) + + b%N = 0 + buffer_ready = .False. + n_tasks = 1 + + sending = .False. + done = .False. + double precision :: time0, time1 + call wall_time(time0) + time0 = time0+time_shift + do while (.not.done) + + integer, external :: get_tasks_from_taskserver + if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then + exit + endif + done = task_id(1) == 0 + if (done) then + n_tasks = n_tasks-1 + endif + if (n_tasks == 0) exit + + call sscanf_ddd(task, subset, i_generator, N) + if( pt2_F(i_generator) <= 0 .or. pt2_F(i_generator) > N_det ) then + print *, irp_here + stop 'bug in selection' + endif + if (b%N == 0) then + ! Only first time + bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2) + call create_selection_buffer(bsize, bsize*2, b) + buffer_ready = .True. + else + ASSERT (b%N == bsize) + endif + + call pt2_alloc(pt2_data,N_states) + b%cur = 0 + call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator)) + + integer, external :: tasks_done_to_taskserver + if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then + done = .true. + endif + call sort_selection_buffer(b) + + call wall_time(time1) +! if (time1-time0 > 15.d0) then + call omp_set_lock(global_selection_buffer_lock) + global_selection_buffer%mini = b%mini + call merge_selection_buffers(b,global_selection_buffer) + b%cur=0 + call omp_unset_lock(global_selection_buffer_lock) + call wall_time(time0) +! endif + + call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending) + if ( iproc == 1 .or. i_generator < 100 .or. done) then + call omp_set_lock(global_selection_buffer_lock) + call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), global_selection_buffer, (/task_id/), 1,sending) + global_selection_buffer%cur = 0 + call omp_unset_lock(global_selection_buffer_lock) + else + call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), b, (/task_id/), 1,sending) + endif + + call pt2_dealloc(pt2_data) + end do + call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending) + + integer, external :: disconnect_from_taskserver + do i=1,300 + if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) /= -2) exit + call sleep(1) + print *, 'Retry disconnect...' + end do + + call end_zmq_push_socket(zmq_socket_push,thread) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + if (buffer_ready) then + call delete_selection_buffer(b) + endif + FREE global_selection_buffer +end subroutine + + +subroutine push_pt2_results(zmq_socket_push, index, pt2_data, b, task_id, n_tasks) + use selection_types + use f77_zmq + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + type(pt2_type), intent(in) :: pt2_data(n_tasks) + integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks) + type(selection_buffer), intent(inout) :: b + + logical :: sending + sending = .False. + call push_pt2_results_async_send(zmq_socket_push, index, pt2_data, b, task_id, n_tasks, sending) + call push_pt2_results_async_recv(zmq_socket_push, b%mini, sending) +end subroutine + + +subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2_data, b, task_id, n_tasks, sending) + use selection_types + use f77_zmq + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + type(pt2_type), intent(in) :: pt2_data(n_tasks) + integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks) + type(selection_buffer), intent(inout) :: b + logical, intent(inout) :: sending + integer :: rc, i + integer*8 :: rc8 + double precision, allocatable :: pt2_serialized(:,:) + + if (sending) then + print *, irp_here, ': sending is true' + stop -1 + endif + sending = .True. + + rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 1 + return + else if(rc /= 4) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, index, 4*n_tasks, ZMQ_SNDMORE) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 2 + return + else if(rc /= 4*n_tasks) then + stop 'push' + endif + + + allocate(pt2_serialized (pt2_type_size(N_states),n_tasks) ) + do i=1,n_tasks + call pt2_serialize(pt2_data(i),N_states,pt2_serialized(1,i)) + enddo + + rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE) + deallocate(pt2_serialized) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 3 + return + else if(rc /= size(pt2_serialized)*8) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, task_id, n_tasks*4, ZMQ_SNDMORE) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 6 + return + else if(rc /= 4*n_tasks) then + stop 'push' + endif + + + if (b%cur == 0) then + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, 0) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 7 + return + else if(rc /= 4) then + stop 'push' + endif + + else + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 7 + return + else if(rc /= 4) then + stop 'push' + endif + + + rc8 = f77_zmq_send8( zmq_socket_push, b%val, 8_8*int(b%cur,8), ZMQ_SNDMORE) + if (rc8 == -1_8) then + print *, irp_here, ': error sending result' + stop 8 + return + else if(rc8 /= 8_8*int(b%cur,8)) then + stop 'push' + endif + + + rc8 = f77_zmq_send8( zmq_socket_push, b%det, int(bit_kind*N_int*2,8)*int(b%cur,8), 0) + if (rc8 == -1_8) then + print *, irp_here, ': error sending result' + stop 9 + return + else if(rc8 /= int(N_int*2*8,8)*int(b%cur,8)) then + stop 'push' + endif + + endif + +end subroutine + +subroutine push_pt2_results_async_recv(zmq_socket_push,mini,sending) + use selection_types + use f77_zmq + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(out) :: mini + logical, intent(inout) :: sending + integer :: rc + + if (.not.sending) return + +! Activate is zmq_socket_push is a REQ +IRP_IF ZMQ_PUSH +IRP_ELSE + character*(2) :: ok + rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 10 + return + else if ((rc /= 2).and.(ok(1:2) /= 'ok')) then + print *, irp_here//': error in receiving ok' + stop -1 + endif + rc = f77_zmq_recv( zmq_socket_push, mini, 8, 0) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 11 + return + else if (rc /= 8) then + print *, irp_here//': error in receiving mini' + stop 12 + endif +IRP_ENDIF + sending = .False. +end subroutine + + + +subroutine pull_pt2_results(zmq_socket_pull, index, pt2_data, task_id, n_tasks, b) + use selection_types + use f77_zmq + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + type(pt2_type), intent(inout) :: pt2_data(*) + type(selection_buffer), intent(inout) :: b + integer, intent(out) :: index(*) + integer, intent(out) :: n_tasks, task_id(*) + integer :: rc, rn, i + integer*8 :: rc8 + double precision, allocatable :: pt2_serialized(:,:) + + rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0) + if (rc == -1) then + n_tasks = 1 + task_id(1) = 0 + else if(rc /= 4) then + stop 'pull' + endif + + rc = f77_zmq_recv( zmq_socket_pull, index, 4*n_tasks, 0) + if (rc == -1) then + n_tasks = 1 + task_id(1) = 0 + else if(rc /= 4*n_tasks) then + stop 'pull' + endif + + allocate(pt2_serialized (pt2_type_size(N_states),n_tasks) ) + rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized)*n_tasks, 0) + if (rc == -1) then + n_tasks = 1 + task_id(1) = 0 + else if(rc /= 8*size(pt2_serialized)) then + stop 'pull' + endif + + do i=1,n_tasks + call pt2_deserialize(pt2_data(i),N_states,pt2_serialized(1,i)) + enddo + deallocate(pt2_serialized) + + rc = f77_zmq_recv( zmq_socket_pull, task_id, n_tasks*4, 0) + if (rc == -1) then + n_tasks = 1 + task_id(1) = 0 + else if(rc /= 4*n_tasks) then + stop 'pull' + endif + + rc = f77_zmq_recv( zmq_socket_pull, b%cur, 4, 0) + if (rc == -1) then + n_tasks = 1 + task_id(1) = 0 + else if(rc /= 4) then + stop 'pull' + endif + + if (b%cur > 0) then + + rc8 = f77_zmq_recv8( zmq_socket_pull, b%val, 8_8*int(b%cur,8), 0) + if (rc8 == -1_8) then + n_tasks = 1 + task_id(1) = 0 + else if(rc8 /= 8_8*int(b%cur,8)) then + stop 'pull' + endif + + rc8 = f77_zmq_recv8( zmq_socket_pull, b%det, int(bit_kind*N_int*2,8)*int(b%cur,8), 0) + if (rc8 == -1_8) then + n_tasks = 1 + task_id(1) = 0 + else if(rc8 /= int(N_int*2*8,8)*int(b%cur,8)) then + stop 'pull' + endif + + endif + +! Activate is zmq_socket_pull is a REP +IRP_IF ZMQ_PUSH +IRP_ELSE + rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, ZMQ_SNDMORE) + if (rc == -1) then + n_tasks = 1 + task_id(1) = 0 + else if (rc /= 2) then + print *, irp_here//': error in sending ok' + stop -1 + endif + rc = f77_zmq_send( zmq_socket_pull, b%mini, 8, 0) +IRP_ENDIF + +end subroutine + diff --git a/src/cipsi_tc_bi_ortho/run_selection_slave.irp.f b/src/cipsi_tc_bi_ortho/run_selection_slave.irp.f new file mode 100644 index 00000000..d351cc79 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/run_selection_slave.irp.f @@ -0,0 +1,255 @@ +subroutine run_selection_slave(thread, iproc, energy) + + use f77_zmq + use selection_types + + implicit none + + double precision, intent(in) :: energy(N_states) + integer, intent(in) :: thread, iproc + + integer :: rc, i + integer :: worker_id, task_id(1), ctask, ltask + character*(512) :: task + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_socket_push + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR), external :: new_zmq_push_socket + type(selection_buffer) :: buf, buf2 + type(pt2_type) :: pt2_data + logical :: done, buffer_ready + + PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique + PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order + PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns + PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym + PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc weight_selection + + call pt2_alloc(pt2_data,N_states) + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + integer, external :: connect_to_taskserver + if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + return + endif + + zmq_socket_push = new_zmq_push_socket(thread) + + buf%N = 0 + buffer_ready = .False. + ctask = 1 + + do + integer, external :: get_task_from_taskserver + if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then + exit + endif + done = task_id(ctask) == 0 + if (done) then + ctask = ctask - 1 + else + integer :: i_generator, N, subset, bsize + call sscanf_ddd(task, subset, i_generator, N) + if(buf%N == 0) then + ! Only first time + call create_selection_buffer(N, N*2, buf) + buffer_ready = .True. + else + if (N /= buf%N) then + print *, 'N=', N + print *, 'buf%N=', buf%N + print *, 'bug in ', irp_here + stop '-1' + end if + end if + call select_connected(i_generator, energy, pt2_data, buf,subset, pt2_F(i_generator)) + endif + + integer, external :: task_done_to_taskserver + + if(done .or. ctask == size(task_id)) then + do i=1, ctask + if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then + call usleep(100) + if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then + ctask = 0 + done = .true. + exit + endif + endif + end do + if(ctask > 0) then + call sort_selection_buffer(buf) +! call merge_selection_buffers(buf,buf2) + call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask) + call pt2_dealloc(pt2_data) + call pt2_alloc(pt2_data,N_states) +! buf%mini = buf2%mini + buf%cur = 0 + end if + ctask = 0 + end if + + if(done) exit + ctask = ctask + 1 + end do + + if(ctask > 0) then + call sort_selection_buffer(buf) +! call merge_selection_buffers(buf,buf2) + call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask) +! buf%mini = buf2%mini + buf%cur = 0 + end if + ctask = 0 + call pt2_dealloc(pt2_data) + + integer, external :: disconnect_from_taskserver + if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then + continue + endif + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + if (buffer_ready) then + call delete_selection_buffer(buf) +! call delete_selection_buffer(buf2) + endif +end subroutine + + +subroutine push_selection_results(zmq_socket_push, pt2_data, b, task_id, ntasks) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + type(pt2_type), intent(in) :: pt2_data + type(selection_buffer), intent(inout) :: b + integer, intent(in) :: ntasks, task_id(*) + integer :: rc + double precision, allocatable :: pt2_serialized(:) + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) + if(rc /= 4) then + print *, 'f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)' + endif + + + allocate(pt2_serialized (pt2_type_size(N_states)) ) + call pt2_serialize(pt2_data,N_states,pt2_serialized) + + rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE) + if (rc == -1) then + print *, irp_here, ': error sending result' + stop 3 + return + else if(rc /= size(pt2_serialized)*8) then + stop 'push' + endif + deallocate(pt2_serialized) + + if (b%cur > 0) then + + rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE) + if(rc /= 8*b%cur) then + print *, 'f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)' + endif + + 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) then + print *, 'f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)' + endif + + endif + + rc = f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE) + if(rc /= 4) then + print *, 'f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)' + endif + + rc = f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0) + if(rc /= 4*ntasks) then + print *, 'f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)' + endif + +! Activate is zmq_socket_push is a REQ +IRP_IF ZMQ_PUSH +IRP_ELSE + character*(2) :: ok + rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) + if ((rc /= 2).and.(ok(1:2) /= 'ok')) then + print *, irp_here//': error in receiving ok' + stop -1 + endif +IRP_ENDIF + +end subroutine + + +subroutine pull_selection_results(zmq_socket_pull, pt2_data, val, det, N, task_id, ntasks) + use f77_zmq + use selection_types + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + type(pt2_type), intent(inout) :: pt2_data + double precision, intent(out) :: val(*) + integer(bit_kind), intent(out) :: det(N_int, 2, *) + integer, intent(out) :: N, ntasks, task_id(*) + integer :: rc, rn, i + double precision, allocatable :: pt2_serialized(:) + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) + if(rc /= 4) then + print *, 'f77_zmq_recv( zmq_socket_pull, N, 4, 0)' + endif + + allocate(pt2_serialized (pt2_type_size(N_states)) ) + rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized), 0) + if (rc == -1) then + ntasks = 1 + task_id(1) = 0 + else if(rc /= 8*size(pt2_serialized)) then + stop 'pull' + endif + + call pt2_deserialize(pt2_data,N_states,pt2_serialized) + deallocate(pt2_serialized) + + if (N>0) then + rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0) + if(rc /= 8*N) then + print *, 'f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)' + endif + + 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) then + print *, 'f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)' + endif + endif + + rc = f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0) + if(rc /= 4) then + print *, 'f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)' + endif + + rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0) + if(rc /= 4*ntasks) then + print *, 'f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)' + endif + +! Activate is zmq_socket_pull is a REP +IRP_IF ZMQ_PUSH +IRP_ELSE + rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) + if (rc /= 2) then + print *, irp_here//': error in sending ok' + stop -1 + endif +IRP_ENDIF +end subroutine + + + diff --git a/src/cipsi_tc_bi_ortho/selection.irp.f b/src/cipsi_tc_bi_ortho/selection.irp.f new file mode 100644 index 00000000..13e6c510 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/selection.irp.f @@ -0,0 +1,1073 @@ +use bitmasks + +subroutine get_mask_phase(det1, pm, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(out) :: pm(Nint,2) + integer(bit_kind) :: tmp1, tmp2 + integer :: i + tmp1 = 0_8 + tmp2 = 0_8 + select case (Nint) + +BEGIN_TEMPLATE + case ($Nint) + do i=1,$Nint + pm(i,1) = ieor(det1(i,1), shiftl(det1(i,1), 1)) + pm(i,2) = ieor(det1(i,2), shiftl(det1(i,2), 1)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 2)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 2)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 4)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 4)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 8)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 8)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 16)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 16)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 32)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 32)) + pm(i,1) = ieor(pm(i,1), tmp1) + pm(i,2) = ieor(pm(i,2), tmp2) + if(iand(popcnt(det1(i,1)), 1) == 1) tmp1 = not(tmp1) + if(iand(popcnt(det1(i,2)), 1) == 1) tmp2 = not(tmp2) + end do +SUBST [ Nint ] +1;; +2;; +3;; +4;; +END_TEMPLATE + case default + do i=1,Nint + pm(i,1) = ieor(det1(i,1), shiftl(det1(i,1), 1)) + pm(i,2) = ieor(det1(i,2), shiftl(det1(i,2), 1)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 2)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 2)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 4)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 4)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 8)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 8)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 16)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 16)) + pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 32)) + pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 32)) + pm(i,1) = ieor(pm(i,1), tmp1) + pm(i,2) = ieor(pm(i,2), tmp2) + if(iand(popcnt(det1(i,1)), 1) == 1) tmp1 = not(tmp1) + if(iand(popcnt(det1(i,2)), 1) == 1) tmp2 = not(tmp2) + end do + end select + +end subroutine + + +subroutine select_connected(i_generator,E0,pt2_data,b,subset,csubset) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator, subset, csubset + type(selection_buffer), intent(inout) :: b + type(pt2_type), intent(inout) :: pt2_data + 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, allocatable :: fock_diag_tmp(:,:) + + allocate(fock_diag_tmp(2,mo_num+1)) + + call build_fock_tmp_tc(fock_diag_tmp, psi_det_generators(1,1,i_generator), N_int) + + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part), not(psi_det_generators(k,2,i_generator)) ) + enddo + call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b,subset,csubset) + deallocate(fock_diag_tmp) +end subroutine select_connected + + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint) + use bitmasks + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: phasemask(Nint,2) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer :: np + double precision, save :: res(0:1) = (/1d0, -1d0/) + + integer :: h1_int, h2_int + integer :: p1_int, p2_int + integer :: h1_bit, h2_bit + integer :: p1_bit, p2_bit + h1_int = shiftr(h1-1,bit_kind_shift)+1 + h1_bit = h1 - shiftl(h1_int-1,bit_kind_shift)-1 + + h2_int = shiftr(h2-1,bit_kind_shift)+1 + h2_bit = h2 - shiftl(h2_int-1,bit_kind_shift)-1 + + p1_int = shiftr(p1-1,bit_kind_shift)+1 + p1_bit = p1 - shiftl(p1_int-1,bit_kind_shift)-1 + + p2_int = shiftr(p2-1,bit_kind_shift)+1 + p2_bit = p2 - shiftl(p2_int-1,bit_kind_shift)-1 + + + ! Put the phasemask bits at position 0, and add them all + h1_bit = int(shiftr(phasemask(h1_int,s1),h1_bit)) + p1_bit = int(shiftr(phasemask(p1_int,s1),p1_bit)) + h2_bit = int(shiftr(phasemask(h2_int,s2),h2_bit)) + p2_bit = int(shiftr(phasemask(p2_int,s2),p2_bit)) + + np = h1_bit + p1_bit + h2_bit + p2_bit + + if(p1 < h1) np = np + 1 + if(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 select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock_diag_tmp, E0, pt2_data, buf, subset, csubset) + use bitmasks + use selection_types + implicit none + BEGIN_DOC + ! WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted_tc + END_DOC + + integer, intent(in) :: i_generator, subset, csubset + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_num) + double precision, intent(in) :: E0(N_states) + type(pt2_type), intent(inout) :: pt2_data + type(selection_buffer), intent(inout) :: buf + + double precision, parameter :: norm_thr = 1.d-16 + + integer :: h1, h2, s1, s2, s3, i1, i2, ib, sp, k, i, j, nt, ii, sze + integer :: maskInd + 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) + integer :: l_a, nmax, idx + integer :: nb_count, maskInd_save + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + logical :: fullMatch, ok + logical :: monoAdo, monoBdo + logical :: monoBdo_save + logical :: found + + integer, allocatable :: preinteresting(:), prefullinteresting(:) + integer, allocatable :: interesting(:), fullinteresting(:) + integer, allocatable :: tmp_array(:) + integer, allocatable :: indices(:), exc_degree(:), iorder(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + logical, allocatable :: banned(:,:,:), bannedOrb(:,:) + double precision, allocatable :: coef_fullminilist_rev(:,:) + double precision, allocatable :: mat(:,:,:), mat_l(:,:,:), mat_r(:,:,:) + + + PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique + PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order + PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns + PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_tc + PROVIDE psi_selectors_rcoef_bi_orth_transp psi_selectors_lcoef_bi_orth_transp + + PROVIDE banned_excitation + + monoAdo = .true. + monoBdo = .true. + + + 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 + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + allocate( indices(N_det), exc_degree( max(N_det_alpha_unique, N_det_beta_unique) ) ) + + ! Pre-compute excitation degrees wrt alpha determinants + k=1 + do i=1,N_det_alpha_unique + call get_excitation_degree_spin(psi_det_alpha_unique(1,i), & + psi_det_generators(1,1,i_generator), exc_degree(i), N_int) + enddo + + ! Iterate on 0SD beta, and find alphas 0SDTQ such that exc_degree <= 4 + do j=1,N_det_beta_unique + call get_excitation_degree_spin(psi_det_beta_unique(1,j), & + psi_det_generators(1,2,i_generator), nt, N_int) + if (nt > 2) cycle + do l_a=psi_bilinear_matrix_columns_loc(j), psi_bilinear_matrix_columns_loc(j+1)-1 + i = psi_bilinear_matrix_rows(l_a) + if(nt + exc_degree(i) <= 4) then + idx = psi_det_sorted_tc_order(psi_bilinear_matrix_order(l_a)) +! if (psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then + indices(k) = idx + k = k + 1 +! endif + endif + enddo + enddo + + ! Pre-compute excitation degrees wrt beta determinants + do i=1,N_det_beta_unique + call get_excitation_degree_spin(psi_det_beta_unique(1,i), psi_det_generators(1,2,i_generator), exc_degree(i), N_int) + enddo + + ! Iterate on 0S alpha, and find betas TQ such that exc_degree <= 4 + ! Remove also contributions < 1.d-20) + do j=1,N_det_alpha_unique + call get_excitation_degree_spin(psi_det_alpha_unique(1,j), psi_det_generators(1,1,i_generator), nt, N_int) + if (nt > 1) cycle + do l_a = psi_bilinear_matrix_transp_rows_loc(j), psi_bilinear_matrix_transp_rows_loc(j+1)-1 + i = psi_bilinear_matrix_transp_columns(l_a) + if(exc_degree(i) < 3) cycle + if(nt + exc_degree(i) <= 4) then + idx = psi_det_sorted_tc_order( & + psi_bilinear_matrix_order( & + psi_bilinear_matrix_transp_order(l_a))) +! if(psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then + indices(k) = idx + k = k + 1 +! endif + endif + enddo + enddo + + deallocate(exc_degree) + nmax = k - 1 + + call isort_noidx(indices,nmax) + + ! Start with 32 elements. Size will double along with the filtering. + allocate(preinteresting(0:32), prefullinteresting(0:32), interesting(0:32), fullinteresting(0:32)) + preinteresting(:) = 0 + prefullinteresting(:) = 0 + + do i = 1, N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + enddo + + do k = 1, nmax + + i = indices(k) + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted_tc(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted_tc(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j = 2, N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted_tc(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted_tc(j,2,i)) + nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + enddo + + if(nt <= 4) then + if(i <= N_det_selectors) then + sze = preinteresting(0) + if(sze+1 == size(preinteresting)) then + allocate(tmp_array(0:sze)) + tmp_array(0:sze) = preinteresting(0:sze) + deallocate(preinteresting) + allocate(preinteresting(0:2*sze)) + preinteresting(0:sze) = tmp_array(0:sze) + deallocate(tmp_array) + endif + preinteresting(0) = sze+1 + preinteresting(sze+1) = i + elseif(nt <= 2) then + sze = prefullinteresting(0) + if(sze+1 == size(prefullinteresting)) then + allocate (tmp_array(0:sze)) + tmp_array(0:sze) = prefullinteresting(0:sze) + deallocate(prefullinteresting) + allocate(prefullinteresting(0:2*sze)) + prefullinteresting(0:sze) = tmp_array(0:sze) + deallocate(tmp_array) + endif + prefullinteresting(0) = sze+1 + prefullinteresting(sze+1) = i + endif + endif + + enddo + deallocate(indices) + + allocate( banned(mo_num, mo_num,2), bannedOrb(mo_num, 2) ) + allocate( mat(N_states, mo_num, mo_num) ) + allocate( mat_l(N_states, mo_num, mo_num), mat_r(N_states, mo_num, mo_num) ) + maskInd = -1 + + + + + do s1 = 1, 2 + do i1 = N_holes(s1), 1, -1 ! Generate low excitations first + + found = .False. + monoBdo_save = monoBdo + maskInd_save = maskInd + do s2 = s1, 2 + ib = 1 + if(s1 == s2) ib = i1+1 + do i2 = N_holes(s2), ib, -1 + maskInd = maskInd + 1 + if(mod(maskInd, csubset) == (subset-1)) then + found = .True. + end if + enddo + if(s1 /= s2) monoBdo = .false. + enddo + + if (.not.found) cycle + monoBdo = monoBdo_save + maskInd = maskInd_save + + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1, h1, pmask, ok, N_int) + + negMask = not(pmask) + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii = 1, preinteresting(0) + i = preinteresting(ii) + select case(N_int) + case(1) + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted_tc(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted_tc(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + case(2) + mobMask(1:2,1) = iand(negMask(1:2,1), psi_det_sorted_tc(1:2,1,i)) + mobMask(1:2,2) = iand(negMask(1:2,2), psi_det_sorted_tc(1:2,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + & + popcnt(mobMask(2, 1)) + popcnt(mobMask(2, 2)) + case(3) + mobMask(1:3,1) = iand(negMask(1:3,1), psi_det_sorted_tc(1:3,1,i)) + mobMask(1:3,2) = iand(negMask(1:3,2), psi_det_sorted_tc(1:3,2,i)) + nt = 0 + do j = 3, 1, -1 + if (mobMask(j,1) /= 0_bit_kind) then + nt = nt+ popcnt(mobMask(j, 1)) + if (nt > 4) exit + endif + if (mobMask(j,2) /= 0_bit_kind) then + nt = nt+ popcnt(mobMask(j, 2)) + if (nt > 4) exit + endif + enddo + case(4) + mobMask(1:4,1) = iand(negMask(1:4,1), psi_det_sorted_tc(1:4,1,i)) + mobMask(1:4,2) = iand(negMask(1:4,2), psi_det_sorted_tc(1:4,2,i)) + nt = 0 + do j = 4, 1, -1 + if (mobMask(j,1) /= 0_bit_kind) then + nt = nt+ popcnt(mobMask(j, 1)) + if (nt > 4) exit + endif + if (mobMask(j,2) /= 0_bit_kind) then + nt = nt+ popcnt(mobMask(j, 2)) + if (nt > 4) exit + endif + enddo + case default + mobMask(1:N_int,1) = iand(negMask(1:N_int,1), psi_det_sorted_tc(1:N_int,1,i)) + mobMask(1:N_int,2) = iand(negMask(1:N_int,2), psi_det_sorted_tc(1:N_int,2,i)) + nt = 0 + do j = N_int, 1, -1 + if (mobMask(j,1) /= 0_bit_kind) then + nt = nt+ popcnt(mobMask(j, 1)) + if (nt > 4) exit + endif + if (mobMask(j,2) /= 0_bit_kind) then + nt = nt+ popcnt(mobMask(j, 2)) + if (nt > 4) exit + endif + enddo + end select + + if(nt <= 4) then + sze = interesting(0) + if(sze+1 == size(interesting)) then + allocate (tmp_array(0:sze)) + tmp_array(0:sze) = interesting(0:sze) + deallocate(interesting) + allocate(interesting(0:2*sze)) + interesting(0:sze) = tmp_array(0:sze) + deallocate(tmp_array) + endif + interesting(0) = sze+1 + interesting(sze+1) = i + if(nt <= 2) then + sze = fullinteresting(0) + if(sze+1 == size(fullinteresting)) then + allocate (tmp_array(0:sze)) + tmp_array(0:sze) = fullinteresting(0:sze) + deallocate(fullinteresting) + allocate(fullinteresting(0:2*sze)) + fullinteresting(0:sze) = tmp_array(0:sze) + deallocate(tmp_array) + endif + fullinteresting(0) = sze+1 + fullinteresting(sze+1) = i + endif + endif + + enddo + + do ii = 1, prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted_tc(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted_tc(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + if (nt > 2) cycle + do j=N_int,2,-1 + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted_tc(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted_tc(j,2,i)) + nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + if (nt > 2) exit + end do + + if(nt <= 2) then + sze = fullinteresting(0) + if (sze+1 == size(fullinteresting)) then + allocate (tmp_array(0:sze)) + tmp_array(0:sze) = fullinteresting(0:sze) + deallocate(fullinteresting) + allocate(fullinteresting(0:2*sze)) + fullinteresting(0:sze) = tmp_array(0:sze) + deallocate(tmp_array) + endif + fullinteresting(0) = sze+1 + fullinteresting(sze+1) = i + endif + enddo + allocate( fullminilist (N_int, 2, fullinteresting(0)), & + minilist (N_int, 2, interesting(0)) ) + + do i = 1, fullinteresting(0) + do k = 1, N_int + fullminilist(k,1,i) = psi_det_sorted_tc(k,1,fullinteresting(i)) + fullminilist(k,2,i) = psi_det_sorted_tc(k,2,fullinteresting(i)) + enddo + enddo + + do i = 1, interesting(0) + do k = 1, N_int + minilist(k,1,i) = psi_det_sorted_tc(k,1,interesting(i)) + minilist(k,2,i) = psi_det_sorted_tc(k,2,interesting(i)) + enddo + enddo + + do s2 = s1, 2 + sp = s1 + + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + monoAdo = .true. + do i2 = N_holes(s2), ib, -1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + banned(:,:,1) = banned_excitation(:,:) + banned(:,:,2) = banned_excitation(:,:) + do j = 1, mo_num + bannedOrb(j, 1) = .true. + bannedOrb(j, 2) = .true. + enddo + do s3 = 1, 2 + do i = 1, N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + if(s1 /= s2) then + if(monoBdo) then + bannedOrb(h1,s1) = .false. + endif + if(monoAdo) then + bannedOrb(h2,s2) = .false. + monoAdo = .false. + endif + endif + + maskInd = maskInd + 1 + if(mod(maskInd, csubset) == (subset-1)) then + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + if(fullMatch) cycle + + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting, mat_l, mat_r) + + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf, mat_l, mat_r) + endif + + enddo + + if(s1 /= s2) monoBdo = .false. + enddo + + deallocate(fullminilist, minilist) + + enddo + enddo + + deallocate(preinteresting, prefullinteresting, interesting, fullinteresting) + deallocate(banned, bannedOrb,mat) + deallocate(mat_l, mat_r) + +end subroutine select_singles_and_doubles + +! --- + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + + use bitmasks + implicit none + + BEGIN_DOC + ! Identify the determinants in det which are in the internal space. These are + ! the determinants that can be produced by creating two particles on the mask. + END_DOC + + integer, intent(in) :: i_gen, N + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + logical, intent(inout) :: banned(mo_num, mo_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 + ! If det(i) can't be generated by the mask, cycle + 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, 2)) cycle genl + end do + + ! If det(i) < det(i_gen), it hs already been considered + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + ! Identify the particles + 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_in_selection(myMask(1,1), list(1), na, N_int) + call bitstring_to_list_in_selection(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl + +end subroutine spot_isinwf + +! --- + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting, mat_l, mat_r) + + BEGIN_DOC + ! Computes the contributions A(r,s) by + ! comparing the external determinant to all the internal determinants det(i). + ! an applying two particles (r,s) to the mask. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: sp, i_gen, N_sel + integer, intent(in) :: interesting(0:N_sel) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + logical, intent(inout) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num, 2) + double precision, intent(inout) :: mat(N_states, mo_num, mo_num) + double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num), mat_r(N_states, mo_num, mo_num) + + integer :: i, ii, 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) + integer(bit_kind) :: phasemask(N_int,2) + + + PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc + PROVIDE psi_selectors_rcoef_bi_orth_transp psi_selectors_lcoef_bi_orth_transp + + + mat = 0d0 + mat_l = 0d0 + mat_r = 0d0 + + 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 + if(interesting(i) < 0) then + stop 'prefetch interesting(i) and det(i)' + endif + + mobMask(1,1) = iand(negMask(1,1), det(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), det(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + + if(nt > 4) cycle + + do j = 2, 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 = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + enddo + + if(nt > 4) cycle + + if (interesting(i) == i_gen) then + if(sp == 3) then + do k = 1, mo_num + do j = 1, mo_num + banned(j,k,2) = banned(k,j,1) + enddo + enddo + else + do k = 1, mo_num + do l = k+1, mo_num + banned(l,k,1) = banned(k,l,1) + enddo + enddo + endif + endif + + if (interesting(i) >= i_gen) then + + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + + perMask(1,1) = iand(mask(1,1), not(det(1,1,i))) + perMask(1,2) = iand(mask(1,2), not(det(1,2,i))) + do j=2,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 get_d3_h ( det(1,1,i), bannedOrb, banned, mat , mask, p, sp, psi_selectors_coef_transp_tc (1, interesting(i)) ) +! call get_d3_htc( det(1,1,i), bannedOrb, banned, mat_r, mat_l, mask, p, sp, psi_selectors_rcoef_bi_orth_transp(1, interesting(i)) & +! , psi_selectors_lcoef_bi_orth_transp(1, interesting(i)) ) + + call bitstring_to_list_in_selection(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int) + + call get_mask_phase(psi_det_sorted_tc(1,1,interesting(i)), phasemask,N_int) + if(nt == 4) then + call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + elseif(nt == 3) then + call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + else + call get_d0_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + endif + elseif(nt == 4) then + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + call past_d2(banned, p, sp) + elseif(nt == 3) then + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + call past_d1(bannedOrb, p) + endif + enddo + +end subroutine splash_pq + +! --- + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf, mat_l, mat_r) + + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_num, mo_num) + double precision, intent(in) :: mat_l(N_states, mo_num, mo_num), mat_r(N_states, mo_num, mo_num) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num) + double precision, intent(in) :: fock_diag_tmp(mo_num) + double precision, intent(in) :: E0(N_states) + type(pt2_type), intent(inout) :: pt2_data + type(selection_buffer), intent(inout) :: buf + + integer :: iii, s, degree + integer :: s1, s2, p1, p2, ib, j, istate, jstate + integer :: info, k , iwork(N_states+1) + integer(bit_kind) :: occ(N_int,2), n + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + logical :: do_cycle, ok, do_diag + double precision :: delta_E, val, Hii, w, tmp, alpha_h_psi + double precision :: E_shift + double precision :: i_h_alpha, alpha_h_i, psi_h_alpha + double precision :: e_pert(N_states), coef(N_states) + double precision :: s_weight(N_states,N_states) + double precision :: eigvalues(N_states+1) + double precision :: work(1+6*(N_states+1)+2*(N_states+1)**2) + + integer, external :: number_of_holes, number_of_particles + logical, external :: is_a_two_holes_two_particles + logical, external :: is_a_1h1p + double precision, external :: diag_H_mat_elem_fock + + + PROVIDE dominant_dets_of_cfgs N_dominant_dets_of_cfgs + + do jstate = 1, N_states + do istate = 1, N_states + s_weight(istate,jstate) = dsqrt(selection_weight(istate)*selection_weight(jstate)) + enddo + enddo + + 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) + E_shift = 0.d0 + + if (h0_type == 'CFG') then + j = det_to_configuration(i_generator) + E_shift = psi_det_Hii(i_generator) - psi_configuration_Hii(j) + endif + + do p1 = 1, mo_num + + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + + do p2 = ib, mo_num + + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + + ! TODO ?? + !if(pseudo_sym)then + ! if(dabs(mat(1, p1, p2)).lt.thresh_sym)then + ! w = 0.d0 + ! endif + !endif + + ! MANU: ERREUR dans les calculs puisque < I | H | J > = 0 + ! n'implique pas < I | H_TC | J > = 0 ?? + !val = maxval(abs(mat(1:N_states, p1, p2))) + !if( val == 0d0) cycle + + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + if(do_only_cas) then + if( number_of_particles(det) > 0 ) cycle + if( number_of_holes(det) > 0 ) cycle + endif + + if(do_ddci) then + if(is_a_two_holes_two_particles(det)) cycle + endif + + if(do_only_1h1p) then + if(.not.is_a_1h1p(det)) cycle + endif + + if(seniority_max >= 0) then + s = 0 + do k = 1, N_int + s = s + popcnt(ieor(det(k,1),det(k,2))) + enddo + if (s > seniority_max) cycle + endif + + if(excitation_max >= 0) then + do_cycle = .True. + if(excitation_ref == 1) then + call get_excitation_degree(HF_bitmask, det(1,1), degree, N_int) + do_cycle = do_cycle .and. (degree > excitation_max) + elseif(excitation_ref == 2) then + do k = 1, N_dominant_dets_of_cfgs + call get_excitation_degree(dominant_dets_of_cfgs(1,1,k), det(1,1), degree, N_int) + do_cycle = do_cycle .and. (degree > excitation_max) + enddo + endif + if(do_cycle) cycle + endif + + if(excitation_alpha_max >= 0) then + do_cycle = .True. + if(excitation_ref == 1) then + call get_excitation_degree_spin(HF_bitmask, det(1,1), degree, N_int) + do_cycle = do_cycle .and. (degree > excitation_max) + elseif (excitation_ref == 2) then + do k = 1, N_dominant_dets_of_cfgs + call get_excitation_degree_spin(dominant_dets_of_cfgs(1,1,k), det(1,1), degree, N_int) + do_cycle = do_cycle .and. (degree > excitation_alpha_max) + enddo + endif + if(do_cycle) cycle + endif + + if(excitation_beta_max >= 0) then + do_cycle = .True. + if(excitation_ref == 1) then + call get_excitation_degree_spin(HF_bitmask, det(1,2), degree, N_int) + do_cycle = do_cycle .and. (degree > excitation_max) + elseif(excitation_ref == 2) then + do k = 1, N_dominant_dets_of_cfgs + call get_excitation_degree(dominant_dets_of_cfgs(1,2,k), det(1,2), degree, N_int) + do_cycle = do_cycle .and. (degree > excitation_beta_max) + enddo + endif + if(do_cycle) cycle + endif + + + w = 0.d0 + + e_pert = 0.d0 + coef = 0.d0 + do_diag = .False. + + ! psi_det_generators --> |i> of psi_0 + ! psi_coef_generators --> c_i of psi_0 + ! + ! = \sum_i c_i + + ! ------------------------------------------- + ! Non hermitian + ! c_alpha = /delta_E(alpha) + ! e_alpha = c_alpha * + ! and + ! and transpose + ! ------------------------------------------- + +! call htilde_mu_mat_bi_ortho_tot(det, det, N_int, Hii) + double precision :: hmono, htwoe, hthree + call diag_htilde_mu_mat_fock_bi_ortho(N_int, det, hmono, htwoe, hthree, hii) + do istate = 1,N_states + delta_E = E0(istate) - Hii + E_shift + double precision :: alpha_h_psi_tmp, psi_h_alpha_tmp, error + if(debug_tc_pt2 == 1)then !! Using the old version + psi_h_alpha = 0.d0 + alpha_h_psi = 0.d0 + do iii = 1, N_det_selectors + call htilde_mu_mat_bi_ortho_tot(psi_selectors(1,1,iii), det, N_int, i_h_alpha) + call htilde_mu_mat_bi_ortho_tot(det, psi_selectors(1,1,iii), N_int, alpha_h_i) + call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int) + if(degree == 0)then + print*,'problem !!!' + print*,'a determinant is already in the wave function !!' + print*,'it corresponds to the selector number ',iii + call debug_det(det,N_int) + stop + endif +! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha) +! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i) + psi_h_alpha += i_h_alpha * psi_selectors_coef_tc(iii,2,1) ! left function + alpha_h_psi += alpha_h_i * psi_selectors_coef_tc(iii,1,1) ! right function + enddo + else if(debug_tc_pt2 == 2)then !! debugging the new version + psi_h_alpha_tmp = mat_l(istate, p1, p2) ! new version + alpha_h_psi_tmp = mat_r(istate, p1, p2) ! new version + psi_h_alpha = 0.d0 + alpha_h_psi = 0.d0 + do iii = 1, N_det_selectors ! old version + call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha) + call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i) + psi_h_alpha += i_h_alpha * psi_selectors_coef_tc(iii,2,1) ! left function + alpha_h_psi += alpha_h_i * psi_selectors_coef_tc(iii,1,1) ! right function + enddo + if(dabs(psi_h_alpha*alpha_h_psi/delta_E).gt.1.d-10)then + error = dabs(psi_h_alpha * alpha_h_psi - psi_h_alpha_tmp * alpha_h_psi_tmp)/dabs(psi_h_alpha * alpha_h_psi) + if(error.gt.1.d-2)then + print*,'error =',error,psi_h_alpha * alpha_h_psi/delta_E,psi_h_alpha_tmp * alpha_h_psi_tmp/delta_E + endif + endif + else + psi_h_alpha = mat_l(istate, p1, p2) + alpha_h_psi = mat_r(istate, p1, p2) + endif + coef(istate) = alpha_h_psi / delta_E + e_pert(istate) = coef(istate) * psi_h_alpha +! if(selection_tc == 1 )then +! if(e_pert(istate).lt.0.d0)then +! e_pert(istate) = 0.d0 +! endif +! else if(selection_tc == -1)then +! if(e_pert(istate).gt.0.d0)then +! e_pert(istate) = 0.d0 +! endif +! endif + enddo + + + do_diag = sum(dabs(coef)) > 0.001d0 .and. N_states > 1 + + do istate = 1, N_states + + alpha_h_psi = mat_r(istate, p1, p2) + psi_h_alpha = mat_l(istate, p1, p2) + + pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate) + pt2_data % variance(istate) = pt2_data % variance(istate) + dabs(e_pert(istate)) + pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate) + + select case (weight_selection) + case(5) + ! Variance selection + if (h0_type == 'CFG') then + w = min(w, - psi_h_alpha * alpha_h_psi * s_weight(istate,istate)) & + / c0_weight(istate) + else + w = min(w, - psi_h_alpha * alpha_h_psi * s_weight(istate,istate)) + endif + case(6) + if (h0_type == 'CFG') then + w = min(w,- coef(istate) * coef(istate) * s_weight(istate,istate)) & + / c0_weight(istate) + else + w = min(w,- coef(istate) * coef(istate) * s_weight(istate,istate)) + endif + case default + ! Energy selection + if (h0_type == 'CFG') then + !w = min(w, e_pert(istate) * s_weight(istate,istate)) / c0_weight(istate) + w = min(w, -dabs(e_pert(istate)) * s_weight(istate,istate)) / c0_weight(istate) + else + !w = min(w, e_pert(istate) * s_weight(istate,istate)) + w = min(w, -dabs( e_pert(istate) ) * s_weight(istate,istate)) + endif + endselect + enddo + + if(h0_type == 'CFG') then + do k = 1, N_int + occ(k,1) = ieor(det(k,1), det(k,2)) + occ(k,2) = iand(det(k,1), det(k,2)) + enddo + call configuration_to_dets_size(occ, n, elec_alpha_num, N_int) + n = max(n,1) + w *= dsqrt(dble(n)) + endif + + if(w <= buf%mini) then + call add_to_selection_buffer(buf, det, w) + endif + + enddo ! end do p2 + enddo ! end do p1 + +end subroutine fill_buffer_double + +! --- + + +subroutine past_d1(bannedOrb, p) + + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_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 past_d1 + +! --- + +subroutine past_d2(banned, p, sp) + + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_num, mo_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do j=1,p(0,2) + do i=1,p(0,1) + 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 past_d2 + +! --- + +subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) + + BEGIN_DOC + ! Gives the inidices(+1) of the bits set to 1 in the bit string + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: string(Nint) + integer, intent(out) :: list(Nint*bit_kind_size) + integer, intent(out) :: n_elements + + integer :: i, ishift + integer(bit_kind) :: l + + n_elements = 0 + ishift = 2 + do i=1,Nint + l = string(i) + do while (l /= 0_bit_kind) + n_elements = n_elements+1 + list(n_elements) = ishift+popcnt(l-1_bit_kind) - popcnt(l) + l = iand(l,l-1_bit_kind) + enddo + ishift = ishift + bit_kind_size + enddo + +end subroutine bitstring_to_list_in_selection + +! --- + diff --git a/src/cipsi_tc_bi_ortho/selection_buffer.irp.f b/src/cipsi_tc_bi_ortho/selection_buffer.irp.f new file mode 100644 index 00000000..10132086 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/selection_buffer.irp.f @@ -0,0 +1,416 @@ + +subroutine create_selection_buffer(N, size_in, res) + use selection_types + implicit none + BEGIN_DOC +! Allocates the memory for a selection buffer. +! The arrays have dimension size_in and the maximum number of elements is N + END_DOC + + integer, intent(in) :: N, size_in + type(selection_buffer), intent(out) :: res + + integer :: siz + siz = max(size_in,1) + + double precision :: rss + double precision, external :: memory_of_double + rss = memory_of_double(siz)*(N_int*2+1) + call check_mem(rss,irp_here) + + 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 delete_selection_buffer(b) + use selection_types + implicit none + type(selection_buffer), intent(inout) :: b + if (associated(b%det)) then + deallocate(b%det) + endif + if (associated(b%val)) then + deallocate(b%val) + endif + NULLIFY(b%det) + NULLIFY(b%val) + b%cur = 0 + b%mini = 0.d0 + b%N = 0 +end + + +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(b%N > 0 .and. val <= b%mini) then + b%cur += 1 + b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2) + b%val(b%cur) = val + if(b%cur == size(b%val)) then + call sort_selection_buffer(b) + end if + end if +end subroutine + +subroutine merge_selection_buffers(b1, b2) + use selection_types + implicit none + BEGIN_DOC +! Merges the selection buffers b1 and b2 into b2 + END_DOC + type(selection_buffer), intent(inout) :: b1 + type(selection_buffer), intent(inout) :: b2 + integer(bit_kind), pointer :: detmp(:,:,:) + double precision, pointer :: val(:) + integer :: i, i1, i2, k, nmwen, sze + if (b1%cur == 0) return + do while (b1%val(b1%cur) > b2%mini) + b1%cur = b1%cur-1 + if (b1%cur == 0) then + return + endif + enddo + nmwen = min(b1%N, b1%cur+b2%cur) + double precision :: rss + double precision, external :: memory_of_double + sze = max(size(b1%val), size(b2%val)) + rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze) + call check_mem(rss,irp_here) + allocate(val(sze), detmp(N_int, 2, sze)) + i1=1 + i2=1 + do i=1,nmwen + if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then + exit + else if (i1 > b1%cur) then + val(i) = b2%val(i2) + detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2) + detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2) + i2=i2+1 + else if (i2 > b2%cur) then + val(i) = b1%val(i1) + detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1) + detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1) + i1=i1+1 + else + if (b1%val(i1) <= b2%val(i2)) then + val(i) = b1%val(i1) + detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1) + detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1) + i1=i1+1 + else + val(i) = b2%val(i2) + detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2) + detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2) + i2=i2+1 + endif + endif + enddo + deallocate(b2%det, b2%val) + do i=nmwen+1,b2%N + val(i) = 0.d0 + detmp(1:N_int,1:2,i) = 0_bit_kind + enddo + b2%det => detmp + b2%val => val + b2%mini = min(b2%mini,b2%val(b2%N)) + b2%cur = nmwen +end + + +subroutine sort_selection_buffer(b) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + integer, allocatable :: iorder(:) + integer(bit_kind), pointer :: detmp(:,:,:) + integer :: i, nmwen + logical, external :: detEq + if (b%N == 0 .or. b%cur == 0) return + nmwen = min(b%N, b%cur) + + double precision :: rss + double precision, external :: memory_of_double, memory_of_int + rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3)) + call check_mem(rss,irp_here) + allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3))) + do i=1,b%cur + iorder(i) = i + end do + call dsort(b%val, iorder, b%cur) + do i=1, nmwen + detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i)) + detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i)) + end do + deallocate(b%det,iorder) + b%det => detmp + b%mini = min(b%mini,b%val(b%N)) + b%cur = nmwen +end subroutine + +subroutine make_selection_buffer_s2(b) + use selection_types + type(selection_buffer), intent(inout) :: b + + integer(bit_kind), allocatable :: o(:,:,:) + double precision, allocatable :: val(:) + + integer :: n_d + integer :: i,k,sze,n_alpha,j,n + logical :: dup + + ! Sort + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8, external :: configuration_search_key + integer(bit_kind), allocatable :: tmp_array(:,:,:) + logical, allocatable :: duplicate(:) + + n_d = b%cur + double precision :: rss + double precision, external :: memory_of_double + rss = (4*N_int+4)*memory_of_double(n_d) + call check_mem(rss,irp_here) + allocate(o(N_int,2,n_d), iorder(n_d), duplicate(n_d), bit_tmp(n_d), & + tmp_array(N_int,2,n_d), val(n_d) ) + + do i=1,n_d + do k=1,N_int + o(k,1,i) = ieor(b%det(k,1,i), b%det(k,2,i)) + o(k,2,i) = iand(b%det(k,1,i), b%det(k,2,i)) + enddo + iorder(i) = i + bit_tmp(i) = configuration_search_key(o(1,1,i),N_int) + enddo + + deallocate(b%det) + + call i8sort(bit_tmp,iorder,n_d) + + do i=1,n_d + do k=1,N_int + tmp_array(k,1,i) = o(k,1,iorder(i)) + tmp_array(k,2,i) = o(k,2,iorder(i)) + enddo + val(i) = b%val(iorder(i)) + duplicate(i) = .False. + enddo + + ! Find duplicates + do i=1,n_d-1 + if (duplicate(i)) then + cycle + endif + j = i+1 + do while (bit_tmp(j)==bit_tmp(i)) + if (duplicate(j)) then + j+=1 + if (j>n_d) then + exit + endif + cycle + endif + dup = .True. + do k=1,N_int + if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) & + .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then + dup = .False. + exit + endif + enddo + if (dup) then + val(i) = max(val(i), val(j)) + duplicate(j) = .True. + endif + j+=1 + if (j>n_d) then + exit + endif + enddo + enddo + + deallocate (b%val) + ! Copy filtered result + integer :: n_p + n_p=0 + do i=1,n_d + if (duplicate(i)) then + cycle + endif + n_p = n_p + 1 + do k=1,N_int + o(k,1,n_p) = tmp_array(k,1,i) + o(k,2,n_p) = tmp_array(k,2,i) + enddo + val(n_p) = val(i) + enddo + + ! Sort by importance + do i=1,n_p + iorder(i) = i + end do + call dsort(val,iorder,n_p) + do i=1,n_p + do k=1,N_int + tmp_array(k,1,i) = o(k,1,iorder(i)) + tmp_array(k,2,i) = o(k,2,iorder(i)) + enddo + enddo + do i=1,n_p + do k=1,N_int + o(k,1,i) = tmp_array(k,1,i) + o(k,2,i) = tmp_array(k,2,i) + enddo + enddo + + ! Create determinants + n_d = 0 + do i=1,n_p + call configuration_to_dets_size(o(1,1,i),sze,elec_alpha_num,N_int) + n_d = n_d + sze + if (n_d > b%cur) then +! if (n_d - b%cur > b%cur - n_d + sze) then +! n_d = n_d - sze +! endif + exit + endif + enddo + + rss = (4*N_int+2)*memory_of_double(n_d) + call check_mem(rss,irp_here) + allocate(b%det(N_int,2,2*n_d), b%val(2*n_d)) + k=1 + do i=1,n_p + n=n_d + call configuration_to_dets_size(o(1,1,i),n,elec_alpha_num,N_int) + call configuration_to_dets(o(1,1,i),b%det(1,1,k),n,elec_alpha_num,N_int) + do j=k,k+n-1 + b%val(j) = val(i) + enddo + k = k+n + if (k > n_d) exit + enddo + deallocate(o) + b%cur = n_d + b%N = n_d +end + + + + +subroutine remove_duplicates_in_selection_buffer(b) + use selection_types + type(selection_buffer), intent(inout) :: b + + integer(bit_kind), allocatable :: o(:,:,:) + double precision, allocatable :: val(:) + + integer :: n_d + integer :: i,k,sze,n_alpha,j,n + logical :: dup + + ! Sort + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8, external :: det_search_key + integer(bit_kind), allocatable :: tmp_array(:,:,:) + logical, allocatable :: duplicate(:) + + n_d = b%cur + logical :: found_duplicates + double precision :: rss + double precision, external :: memory_of_double + rss = (4*N_int+4)*memory_of_double(n_d) + call check_mem(rss,irp_here) + + found_duplicates = .False. + allocate(iorder(n_d), duplicate(n_d), bit_tmp(n_d), & + tmp_array(N_int,2,n_d), val(n_d) ) + + do i=1,n_d + iorder(i) = i + bit_tmp(i) = det_search_key(b%det(1,1,i),N_int) + enddo + + call i8sort(bit_tmp,iorder,n_d) + + do i=1,n_d + do k=1,N_int + tmp_array(k,1,i) = b%det(k,1,iorder(i)) + tmp_array(k,2,i) = b%det(k,2,iorder(i)) + enddo + val(i) = b%val(iorder(i)) + duplicate(i) = .False. + enddo + + ! Find duplicates + do i=1,n_d-1 + if (duplicate(i)) then + cycle + endif + j = i+1 + do while (bit_tmp(j)==bit_tmp(i)) + if (duplicate(j)) then + j+=1 + if (j>n_d) then + exit + endif + cycle + endif + dup = .True. + do k=1,N_int + if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) & + .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then + dup = .False. + exit + endif + enddo + if (dup) then + duplicate(j) = .True. + found_duplicates = .True. + endif + j+=1 + if (j>n_d) then + exit + endif + enddo + enddo + + if (found_duplicates) then + + ! Copy filtered result + integer :: n_p + n_p=0 + do i=1,n_d + if (duplicate(i)) then + cycle + endif + n_p = n_p + 1 + do k=1,N_int + b%det(k,1,n_p) = tmp_array(k,1,i) + b%det(k,2,n_p) = tmp_array(k,2,i) + enddo + val(n_p) = val(i) + enddo + b%cur=n_p + b%N=n_p + + endif + +end + + + diff --git a/src/cipsi_tc_bi_ortho/selection_types.f90 b/src/cipsi_tc_bi_ortho/selection_types.f90 new file mode 100644 index 00000000..58ce0e03 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/selection_types.f90 @@ -0,0 +1,25 @@ +module selection_types + type selection_buffer + integer :: N, cur + integer(8) , pointer :: det(:,:,:) + double precision, pointer :: val(:) + double precision :: mini + endtype + + type pt2_type + double precision, allocatable :: pt2(:) + double precision, allocatable :: rpt2(:) + double precision, allocatable :: variance(:) + double precision, allocatable :: overlap(:,:) + endtype + + contains + + integer function pt2_type_size(N) + implicit none + integer, intent(in) :: N + pt2_type_size = (3*n + n*n) + end function + +end module + diff --git a/src/cipsi_tc_bi_ortho/selection_weight.irp.f b/src/cipsi_tc_bi_ortho/selection_weight.irp.f new file mode 100644 index 00000000..3c09e59a --- /dev/null +++ b/src/cipsi_tc_bi_ortho/selection_weight.irp.f @@ -0,0 +1,134 @@ +BEGIN_PROVIDER [ double precision, pt2_match_weight, (N_states) ] + implicit none + BEGIN_DOC + ! Weights adjusted along the selection to make the PT2 contributions + ! of each state coincide. + END_DOC + pt2_match_weight(:) = 1.d0 +END_PROVIDER + + + +BEGIN_PROVIDER [ double precision, variance_match_weight, (N_states) ] + implicit none + BEGIN_DOC + ! Weights adjusted along the selection to make the variances + ! of each state coincide. + END_DOC + variance_match_weight(:) = 1.d0 +END_PROVIDER + + + +subroutine update_pt2_and_variance_weights(pt2_data, N_st) + implicit none + use selection_types + BEGIN_DOC +! Updates the PT2- and Variance- matching weights. + END_DOC + integer, intent(in) :: N_st + type(pt2_type), intent(in) :: pt2_data + double precision :: pt2(N_st) + double precision :: variance(N_st) + + double precision :: avg, element, dt, x + integer :: k + pt2(:) = pt2_data % pt2(:) + variance(:) = pt2_data % variance(:) + + avg = sum(pt2(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero + + dt = 8.d0 !* selection_factor + do k=1,N_st + element = exp(dt*(pt2(k)/avg - 1.d0)) + element = min(2.0d0 , element) + element = max(0.5d0 , element) + pt2_match_weight(k) *= element + enddo + + + avg = sum(variance(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero + + do k=1,N_st + element = exp(dt*(variance(k)/avg -1.d0)) + element = min(2.0d0 , element) + element = max(0.5d0 , element) + variance_match_weight(k) *= element + enddo + + if (N_det < 100) then + ! For tiny wave functions, weights are 1.d0 + pt2_match_weight(:) = 1.d0 + variance_match_weight(:) = 1.d0 + endif + + threshold_davidson_pt2 = min(1.d-6, & + max(threshold_davidson, 1.e-1 * PT2_relative_error * minval(abs(pt2(1:N_states)))) ) + + SOFT_TOUCH pt2_match_weight variance_match_weight threshold_davidson_pt2 +end + + + + +BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] + implicit none + BEGIN_DOC + ! Weights used in the selection criterion + END_DOC + select case (weight_selection) + + case (0) + print *, 'Using input weights in selection' + selection_weight(1:N_states) = c0_weight(1:N_states) * state_average_weight(1:N_states) + + case (1) + print *, 'Using 1/c_max^2 weight in selection' + selection_weight(1:N_states) = c0_weight(1:N_states) + + case (2) + print *, 'Using pt2-matching weight in selection' + selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states) + print *, '# PT2 weight ', real(pt2_match_weight(:),4) + + case (3) + print *, 'Using variance-matching weight in selection' + selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states) + print *, '# var weight ', real(variance_match_weight(:),4) + + case (4) + print *, 'Using variance- and pt2-matching weights in selection' + selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states)) + print *, '# PT2 weight ', real(pt2_match_weight(:),4) + print *, '# var weight ', real(variance_match_weight(:),4) + + case (5) + print *, 'Using variance-matching weight in selection' + selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states) + print *, '# var weight ', real(variance_match_weight(:),4) + + case (6) + print *, 'Using CI coefficient-based selection' + selection_weight(1:N_states) = c0_weight(1:N_states) + + case (7) + print *, 'Input weights multiplied by variance- and pt2-matching' + selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states)) * state_average_weight(1:N_states) + print *, '# PT2 weight ', real(pt2_match_weight(:),4) + print *, '# var weight ', real(variance_match_weight(:),4) + + case (8) + print *, 'Input weights multiplied by pt2-matching' + selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states) * state_average_weight(1:N_states) + print *, '# PT2 weight ', real(pt2_match_weight(:),4) + + case (9) + print *, 'Input weights multiplied by variance-matching' + selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states) * state_average_weight(1:N_states) + print *, '# var weight ', real(variance_match_weight(:),4) + + end select + print *, '# Total weight ', real(selection_weight(:),4) + +END_PROVIDER + diff --git a/src/cipsi_tc_bi_ortho/slave_cipsi.irp.f b/src/cipsi_tc_bi_ortho/slave_cipsi.irp.f new file mode 100644 index 00000000..c3a49280 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/slave_cipsi.irp.f @@ -0,0 +1,350 @@ +subroutine run_slave_cipsi + + BEGIN_DOC + ! Helper program for distributed parallelism + END_DOC + + implicit none + + call omp_set_max_active_levels(1) + distributed_davidson = .False. + read_wf = .False. + SOFT_TOUCH read_wf distributed_davidson + call provide_everything + call switch_qp_run_to_master + call run_slave_main +end + +subroutine provide_everything + PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag + PROVIDE psi_selectors_rcoef_bi_orth_transp psi_selectors_lcoef_bi_orth_transp + + PROVIDE pt2_e0_denominator mo_num N_int ci_energy mpi_master zmq_state zmq_context + PROVIDE psi_det psi_coef threshold_generators state_average_weight + PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym +end + + +subroutine run_slave_main + + use f77_zmq + + implicit none + IRP_IF MPI + include 'mpif.h' + IRP_ENDIF + + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + double precision :: energy(N_states) + character*(64) :: states(10) + character*(64) :: old_state + integer :: rc, i, ierr + double precision :: t0, t1 + + integer, external :: zmq_get_dvector, zmq_get_N_det_generators + integer, external :: zmq_get8_dvector + integer, external :: zmq_get_ivector + integer, external :: zmq_get_psi, zmq_get_N_det_selectors, zmq_get_psi_bilinear + integer, external :: zmq_get_psi_notouch + integer, external :: zmq_get_N_states_diag + + zmq_context = f77_zmq_ctx_new () + states(1) = 'selection' + states(2) = 'davidson' + states(3) = 'pt2' + old_state = 'Waiting' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + PROVIDE psi_det psi_coef threshold_generators state_average_weight mpi_master + PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator + PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank + + IRP_IF MPI + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + do + + if (mpi_master) then + call wait_for_states(states,zmq_state,size(states)) + if (zmq_state(1:64) == old_state(1:64)) then + call usleep(200) + cycle + else + old_state(1:64) = zmq_state(1:64) + endif + print *, trim(zmq_state) + endif + + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + call MPI_BCAST (zmq_state, 128, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here, 'error in broadcast of zmq_state' + endif + IRP_ENDIF + + if(zmq_state(1:7) == 'Stopped') then + exit + endif + + + if (zmq_state(1:9) == 'selection') then + + ! Selection + ! --------- + + call wall_time(t0) + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_psi') + IRP_ENDIF + if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_dvector threshold_generators') + IRP_ENDIF + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_dvector energy') + IRP_ENDIF + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_N_det_generators') + IRP_ENDIF + if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_N_det_selectors') + IRP_ENDIF + if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_dvector state_average_weight') + IRP_ENDIF + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_dvector selection_weight') + IRP_ENDIF + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) cycle + pt2_e0_denominator(1:N_states) = energy(1:N_states) + TOUCH pt2_e0_denominator state_average_weight threshold_generators selection_weight psi_det psi_coef + + if (mpi_master) then + print *, 'N_det', N_det + print *, 'N_det_generators', N_det_generators + print *, 'N_det_selectors', N_det_selectors + print *, 'pt2_e0_denominator', pt2_e0_denominator + print *, 'pt2_stoch_istate', pt2_stoch_istate + print *, 'state_average_weight', state_average_weight + print *, 'selection_weight', selection_weight + endif + call wall_time(t1) + call write_double(6,(t1-t0),'Broadcast time') + + IRP_IF MPI_DEBUG + call mpi_print('Entering OpenMP section') + IRP_ENDIF + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call run_selection_slave(0,i,energy) + !$OMP END PARALLEL + print *, mpi_rank, ': Selection done' + IRP_IF MPI + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here, 'error in barrier' + endif + IRP_ENDIF + call mpi_print('----------') + + else if (zmq_state(1:8) == 'davidson') then + + ! Davidson + ! -------- + + call wall_time(t0) + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_N_states_diag') + IRP_ENDIF + if (zmq_get_N_states_diag(zmq_to_qp_run_socket,1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_psi') + IRP_ENDIF + if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle + + call wall_time(t1) + call write_double(6,(t1-t0),'Broadcast time') + + !--- + call omp_set_max_active_levels(8) + call davidson_slave_tcp(0) + call omp_set_max_active_levels(1) + print *, mpi_rank, ': Davidson done' + !--- + + IRP_IF MPI + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here, 'error in barrier' + endif + IRP_ENDIF + call mpi_print('----------') + + else if (zmq_state(1:3) == 'pt2') then + + ! PT2 + ! --- + + IRP_IF MPI + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here, 'error in barrier' + endif + IRP_ENDIF + call wall_time(t0) + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_psi') + IRP_ENDIF + if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_N_det_generators') + IRP_ENDIF + if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_N_det_selectors') + IRP_ENDIF + if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_dvector threshold_generators') + IRP_ENDIF + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_dvector energy') + IRP_ENDIF + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_ivector pt2_stoch_istate') + IRP_ENDIF + if (zmq_get_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_dvector state_average_weight') + IRP_ENDIF + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) cycle + IRP_IF MPI_DEBUG + call mpi_print('zmq_get_dvector selection_weight') + IRP_ENDIF + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) cycle + pt2_e0_denominator(1:N_states) = energy(1:N_states) + SOFT_TOUCH pt2_e0_denominator state_average_weight pt2_stoch_istate threshold_generators selection_weight psi_det psi_coef N_det_generators N_det_selectors + + + call wall_time(t1) + call write_double(6,(t1-t0),'Broadcast time') + IRP_IF MPI + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here, 'error in barrier' + endif + IRP_ENDIF + + + IRP_IF MPI_DEBUG + call mpi_print('Entering OpenMP section') + IRP_ENDIF + if (.true.) then + integer :: nproc_target, ii + double precision :: mem_collector, mem, rss + + call resident_memory(rss) + + nproc_target = nthreads_pt2 + ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2) + + do + mem = rss + & ! + nproc_target * 8.d0 * & ! bytes + ( 0.5d0*pt2_n_tasks_max & ! task_id + + 64.d0*pt2_n_tasks_max & ! task + + 3.d0*pt2_n_tasks_max*N_states & ! pt2, variance, norm + + 1.d0*pt2_n_tasks_max & ! i_generator, subset + + 3.d0*(N_int*2.d0*ii+ ii) & ! selection buffer + + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer + + 2.0d0*(ii) & ! preinteresting, interesting, + ! prefullinteresting, fullinteresting + + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist + + 1.0d0*(N_states*mo_num*mo_num) & ! mat + ) / 1024.d0**3 + + if (nproc_target == 0) then + call check_mem(mem,irp_here) + nproc_target = 1 + exit + endif + + if (mem+rss < qp_max_mem) then + exit + endif + + nproc_target = nproc_target - 1 + + enddo + + if (N_det > 100000) then + + if (mpi_master) then + print *, 'N_det', N_det + print *, 'N_det_generators', N_det_generators + print *, 'N_det_selectors', N_det_selectors + print *, 'pt2_e0_denominator', pt2_e0_denominator + print *, 'pt2_stoch_istate', pt2_stoch_istate + print *, 'state_average_weight', state_average_weight + print *, 'selection_weight', selection_weight + print *, 'Number of threads', nproc_target + endif + + if (h0_type == 'CFG') then + PROVIDE det_to_configuration + endif + + PROVIDE global_selection_buffer pt2_N_teeth pt2_F N_det_generators + PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique + PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order + PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns + PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted_tc + PROVIDE psi_selectors_rcoef_bi_orth_transp psi_selectors_lcoef_bi_orth_transp + + PROVIDE psi_det_hii selection_weight pseudo_sym pt2_min_parallel_tasks + + if (mpi_master) then + print *, 'Running PT2' + endif + !$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target+1) + i = omp_get_thread_num() + call run_pt2_slave(0,i,pt2_e0_denominator) + !$OMP END PARALLEL + FREE state_average_weight + print *, mpi_rank, ': PT2 done' + print *, '-------' + + endif + endif + + IRP_IF MPI + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here, 'error in barrier' + endif + IRP_ENDIF + call mpi_print('----------') + + endif + + end do + IRP_IF MPI + call MPI_finalize(ierr) + IRP_ENDIF +end + + + diff --git a/src/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/src/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f new file mode 100644 index 00000000..c1e4af0c --- /dev/null +++ b/src/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f @@ -0,0 +1,149 @@ +subroutine run_stochastic_cipsi + use selection_types + implicit none + BEGIN_DOC +! Selected Full Configuration Interaction with Stochastic selection and PT2. + END_DOC + integer :: i,j,k,ndet + double precision, allocatable :: zeros(:) + integer :: to_select + type(pt2_type) :: pt2_data, pt2_data_err + logical, external :: qp_stop + logical :: print_pt2 + + double precision :: rss + double precision, external :: memory_of_double + double precision :: correlation_energy_ratio,E_denom,E_tc,norm + double precision, allocatable :: ept2(:), pt1(:),extrap_energy(:) + PROVIDE H_apply_buffer_allocated distributed_davidson + + print*,'Diagonal elements of the Fock matrix ' + do i = 1, mo_num + write(*,*)i,Fock_matrix_tc_mo_tot(i,i) + enddo + N_iter = 1 + threshold_generators = 1.d0 + SOFT_TOUCH threshold_generators + + rss = memory_of_double(N_states)*4.d0 + call check_mem(rss,irp_here) + + allocate (zeros(N_states)) + call pt2_alloc(pt2_data, N_states) + call pt2_alloc(pt2_data_err, N_states) + + double precision :: hf_energy_ref + logical :: has + double precision :: relative_error + + relative_error=PT2_relative_error + + zeros = 0.d0 + pt2_data % pt2 = -huge(1.e0) + pt2_data % rpt2 = -huge(1.e0) + pt2_data % overlap= 0.d0 + pt2_data % variance = huge(1.e0) + + !!!! WARNING !!!! SEEMS TO BE PROBLEM WTH make_s2_eigenfunction !!!! THE DETERMINANTS CAN APPEAR TWICE IN THE WFT DURING SELECTION +! if (s2_eig) then +! call make_s2_eigenfunction +! endif + print_pt2 = .False. + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) +! call routine_save_right + + +! if (N_det > N_det_max) then +! psi_det(1:N_int,1:2,1:N_det) = psi_det_sorted_tc_gen(1:N_int,1:2,1:N_det) +! psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states) +! N_det = N_det_max +! soft_touch N_det psi_det psi_coef +! if (s2_eig) then +! call make_s2_eigenfunction +! endif +! print_pt2 = .False. +! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) +! call routine_save_right +! endif + + allocate(ept2(1000),pt1(1000),extrap_energy(100)) + + correlation_energy_ratio = 0.d0 + +! thresh_it_dav = 5.d-5 +! soft_touch thresh_it_dav + + print_pt2 = .True. + do while ( & + (N_det < N_det_max) .and. & + (maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) & + ) + write(*,'(A)') '--------------------------------------------------------------------------------' + + + to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor) + to_select = max(N_states_diag, to_select) + + E_denom = E_tc ! TC Energy of the current wave function + call pt2_dealloc(pt2_data) + call pt2_dealloc(pt2_data_err) + call pt2_alloc(pt2_data, N_states) + call pt2_alloc(pt2_data_err, N_states) + call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection +! stop + + N_iter += 1 + + if (qp_stop()) exit + + ! Add selected determinants + call copy_H_apply_buffer_to_wf_tc() + + PROVIDE psi_l_coef_bi_ortho psi_r_coef_bi_ortho + PROVIDE psi_det + PROVIDE psi_det_sorted_tc + + ept2(N_iter-1) = E_tc + nuclear_repulsion + (pt2_data % pt2(1))/norm + pt1(N_iter-1) = dsqrt(pt2_data % overlap(1,1)) + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + if (qp_stop()) exit + enddo +! print*,'data to extrapolate ' +! do i = 2, N_iter +! print*,'iteration ',i +! print*,'pt1,Ept2',pt1(i),ept2(i) +! call get_extrapolated_energy(i-1,ept2(i),pt1(i),extrap_energy(i)) +! do j = 2, i +! print*,'j,e,energy',j,extrap_energy(j) +! enddo +! enddo + +! thresh_it_dav = 5.d-6 +! soft_touch thresh_it_dav + + call pt2_dealloc(pt2_data) + call pt2_dealloc(pt2_data_err) + call pt2_alloc(pt2_data, N_states) + call pt2_alloc(pt2_data_err, N_states) + call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection + call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) +! if (.not.qp_stop()) then +! if (N_det < N_det_max) then +! thresh_it_dav = 5.d-7 +! soft_touch thresh_it_dav +! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) +! endif +! +! call pt2_dealloc(pt2_data) +! call pt2_dealloc(pt2_data_err) +! call pt2_alloc(pt2_data, N_states) +! call pt2_alloc(pt2_data_err, N_states) +! call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error, 0) ! Stochastic PT2 +! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) +! endif +! call pt2_dealloc(pt2_data) +! call pt2_dealloc(pt2_data_err) +! call routine_save_right + +end + diff --git a/src/cipsi_tc_bi_ortho/zmq_selection.irp.f b/src/cipsi_tc_bi_ortho/zmq_selection.irp.f new file mode 100644 index 00000000..dc3e0f27 --- /dev/null +++ b/src/cipsi_tc_bi_ortho/zmq_selection.irp.f @@ -0,0 +1,235 @@ +subroutine ZMQ_selection(N_in, pt2_data) + use f77_zmq + use selection_types + + implicit none + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket , zmq_socket_pull + integer, intent(in) :: N_in + type(selection_buffer) :: b + integer :: i, l, N + integer, external :: omp_get_thread_num + type(pt2_type), intent(inout) :: pt2_data + + PROVIDE psi_det psi_coef N_det qp_max_mem N_states pt2_F s2_eig N_det_generators + + N = max(N_in,1) + N = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2) + if (.True.) then + PROVIDE pt2_e0_denominator nproc + PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique + PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order + PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns + PROVIDE psi_bilinear_matrix_transp_order selection_weight pseudo_sym + PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max + PROVIDE excitation_beta_max excitation_alpha_max excitation_max + + call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection') + + integer, external :: zmq_put_psi + integer, external :: zmq_put_N_det_generators + integer, external :: zmq_put_N_det_selectors + integer, external :: zmq_put_dvector + + if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then + stop 'Unable to put psi on ZMQ server' + endif + if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then + stop 'Unable to put N_det_generators on ZMQ server' + endif + if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then + stop 'Unable to put N_det_selectors on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then + stop 'Unable to put energy on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then + stop 'Unable to put state_average_weight on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then + stop 'Unable to put selection_weight on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then + stop 'Unable to put threshold_generators on ZMQ server' + endif + call create_selection_buffer(N, N*2, b) + endif + + integer, external :: add_task_to_taskserver + character(len=100000) :: task + integer :: j,k,ipos + ipos=1 + task = ' ' + + + do i= 1, N_det_generators + do j=1,pt2_F(i) + write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, i, N + ipos += 30 + if (ipos > 100000-30) then + if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then + stop 'Unable to add task to task server' + endif + ipos=1 + endif + end do + enddo + if (ipos > 1) then + if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then + stop 'Unable to add task to task server' + endif + endif + N = max(N_in,1) + + + ASSERT (associated(b%det)) + ASSERT (associated(b%val)) + + integer, external :: zmq_set_running + if (zmq_set_running(zmq_to_qp_run_socket) == -1) then + print *, irp_here, ': Failed in zmq_set_running' + endif + + integer :: nproc_target + if (N_det < 3*nproc) then + nproc_target = N_det/4 + else + nproc_target = nproc + endif + double precision :: mem + mem = 8.d0 * N_det * (N_int * 2.d0 * 3.d0 + 3.d0 + 5.d0) / (1024.d0**3) + call write_double(6,mem,'Estimated memory/thread (Gb)') + if (qp_max_mem > 0) then + nproc_target = max(1,int(dble(qp_max_mem)/(0.1d0 + mem))) + nproc_target = min(nproc_target,nproc) + endif + + f(:) = 1.d0 + if (.not.do_pt2) then + double precision :: f(N_states), u_dot_u + do k=1,min(N_det,N_states) + f(k) = 1.d0 / u_dot_u(psi_selectors_coef(1,k), N_det_selectors) + enddo + endif + + !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2_data) PRIVATE(i) NUM_THREADS(nproc_target+1) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(zmq_socket_pull, b, N, pt2_data) + else + call selection_slave_inproc(i) + endif + !$OMP END PARALLEL + + call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'selection') + if (N_in > 0) then + if (s2_eig) then + call make_selection_buffer_s2(b) + endif + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) + endif + call delete_selection_buffer(b) + + do k=1,N_states + pt2_data % pt2(k) = pt2_data % pt2(k) * f(k) + pt2_data % variance(k) = pt2_data % variance(k) * f(k) + do l=1,N_states + pt2_data % overlap(k,l) = pt2_data % overlap(k,l) * dsqrt(f(k)*f(l)) + pt2_data % overlap(l,k) = pt2_data % overlap(l,k) * dsqrt(f(k)*f(l)) + enddo + + pt2_data % rpt2(k) = & + pt2_data % pt2(k)/(1.d0 + pt2_data % overlap(k,k)) + enddo + + pt2_overlap(:,:) = pt2_data % overlap(:,:) + + print *, 'Overlap of perturbed states:' + do l=1,N_states + print *, pt2_overlap(l,:) + enddo + print *, '-------' + SOFT_TOUCH pt2_overlap + call update_pt2_and_variance_weights(pt2_data, N_states) + +end subroutine + + +subroutine selection_slave_inproc(i) + implicit none + integer, intent(in) :: i + + call run_selection_slave(1,i,pt2_e0_denominator) +end + +subroutine selection_collector(zmq_socket_pull, b, N, pt2_data) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + type(selection_buffer), intent(inout) :: b + integer, intent(in) :: N + type(pt2_type), intent(inout) :: pt2_data + type(pt2_type) :: pt2_data_tmp + + double precision :: pt2_mwen(N_states) + double precision :: variance_mwen(N_states) + double precision :: norm2_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 :: msg_size, rc, more + integer :: acc, i, j, robin, ntask + double precision, pointer :: val(:) + integer(bit_kind), pointer :: det(:,:,:) + integer, allocatable :: task_id(:) + type(selection_buffer) :: b2 + + + + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + call create_selection_buffer(N, N*2, b2) + integer :: k + double precision :: rss + double precision, external :: memory_of_int + rss = memory_of_int(N_det_generators) + call check_mem(rss,irp_here) + allocate(task_id(N_det_generators)) + more = 1 + pt2_data % pt2(:) = 0d0 + pt2_data % variance(:) = 0.d0 + pt2_data % overlap(:,:) = 0.d0 + call pt2_alloc(pt2_data_tmp,N_states) + do while (more == 1) + call pull_selection_results(zmq_socket_pull, pt2_data_tmp, b2%val(1), b2%det(1,1,1), b2%cur, task_id, ntask) + + call pt2_add(pt2_data, 1.d0, pt2_data_tmp) + do i=1, b2%cur + call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i)) + if (b2%val(i) > b%mini) exit + end do + + do i=1, ntask + if(task_id(i) == 0) then + print *, "Error in collector" + endif + integer, external :: zmq_delete_task + if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) == -1) then + stop 'Unable to delete task' + endif + end do + end do + call pt2_dealloc(pt2_data_tmp) + + + call delete_selection_buffer(b2) + call sort_selection_buffer(b) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) +end subroutine + diff --git a/src/dav_general_mat/dav_diag_dressed_ext_rout_nonsym_B1space.irp.f b/src/dav_general_mat/dav_diag_dressed_ext_rout_nonsym_B1space.irp.f new file mode 100644 index 00000000..670b2395 --- /dev/null +++ b/src/dav_general_mat/dav_diag_dressed_ext_rout_nonsym_B1space.irp.f @@ -0,0 +1,500 @@ + +! --- + +subroutine davidson_general_diag_dressed_ext_rout_nonsym_b1space(u_in, H_jj, Dress_jj,energies, sze, N_st, N_st_diag_in, converged, hcalc) + + use mmap_module + + BEGIN_DOC + ! Generic modified-Davidson diagonalization + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st + ! + ! Initial guess vectors are not necessarily orthonormal + ! + ! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output) + END_DOC + + implicit none + + integer, intent(in) :: sze, N_st, N_st_diag_in + double precision, intent(in) :: H_jj(sze),Dress_jj(sze) + logical, intent(inout) :: converged + double precision, intent(inout) :: u_in(sze,N_st_diag_in) + double precision, intent(out) :: energies(N_st) + external hcalc + + character*(16384) :: write_buffer + integer :: iter, N_st_diag + integer :: i, j, k, l, m + integer :: iter2, itertot + logical :: disk_based + integer :: shift, shift2, itermax + integer :: nproc_target + integer :: order(N_st_diag_in) + double precision :: to_print(2,N_st) + double precision :: r1, r2, alpha + double precision :: cpu, wall + double precision :: cmax + double precision :: energy_shift(N_st_diag_in*davidson_sze_max) + double precision, allocatable :: U(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:) + double precision, allocatable :: residual_norm(:) + + double precision :: lambda_tmp + integer, allocatable :: i_omax(:) + double precision, allocatable :: U_tmp(:), overlap(:) + + double precision, allocatable :: W(:,:) + !double precision, pointer :: W(:,:) + double precision, external :: u_dot_v, u_dot_u + + + include 'constants.include.F' + + N_st_diag = N_st_diag_in +! print*,'trial vector' + do i = 1, sze + if(isnan(u_in(i,1)))then + print*,'pb in input vector of davidson_general_ext_rout_nonsym_b1space' + print*,i,u_in(i,1) + stop + else if (dabs(u_in(i,1)).lt.1.d-16)then + u_in(i,1) = 0.d0 + endif + enddo + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda + if(N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_full to ', N_st_diag*3 + stop -1 + endif + + itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1 + + provide threshold_nonsym_davidson + call write_time(6) + write(6,'(A)') '' + write(6,'(A)') 'Davidson Diagonalization' + write(6,'(A)') '------------------------' + write(6,'(A)') '' + + + ! Find max number of cores to fit in memory + ! ----------------------------------------- + + nproc_target = nproc + double precision :: rss + integer :: maxab + maxab = sze + + m=1 + disk_based = .False. + call resident_memory(rss) + do + r1 = 8.d0 * &! bytes + ( dble(sze)*(N_st_diag*itermax) &! U + + 1.d0*dble(sze*m)*(N_st_diag*itermax) &! W + + 2.d0*(N_st_diag*itermax)**2 &! h,y + + 2.d0*(N_st_diag*itermax) &! s2,lambda + + 1.d0*(N_st_diag) &! residual_norm + ! In H_S2_u_0_nstates_zmq + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave + + 0.5d0*maxab &! idx0 in H_S2_u_0_nstates_openmp_work_* + + nproc_target * &! In OMP section + ( 1.d0*(N_int*maxab) &! buffer + + 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx + ) / 1024.d0**3 + + if(nproc_target == 0) then + call check_mem(r1, irp_here) + nproc_target = 1 + exit + endif + + if(r1+rss < qp_max_mem) then + exit + endif + + if(itermax > 4) then + itermax = itermax - 1 + else if (m==1.and.disk_based_davidson) then + m = 0 + disk_based = .True. + itermax = 6 + else + nproc_target = nproc_target - 1 + endif + + enddo + + nthreads_davidson = nproc_target + TOUCH nthreads_davidson + + call write_int(6, N_st, 'Number of states') + call write_int(6, N_st_diag, 'Number of states in diagonalization') + call write_int(6, sze, 'Number of basis functions') + call write_int(6, nproc_target, 'Number of threads for diagonalization') + call write_double(6, r1, 'Memory(Gb)') + if(disk_based) then + print *, 'Using swap space to reduce RAM' + endif + + !--------------- + + write(6,'(A)') '' + write_buffer = '=====' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = 'Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy Residual ' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = '=====' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + + ! --- + + + allocate( W(sze,N_st_diag*itermax) ) + + allocate( & + ! Large + U(sze,N_st_diag*itermax), & + ! Small + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + lambda(N_st_diag*itermax), & + residual_norm(N_st_diag), & + i_omax(N_st) & + ) + + U = 0.d0 + h = 0.d0 + y = 0.d0 + lambda = 0.d0 + residual_norm = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + + ! Davidson iterations + ! =================== + + converged = .False. + + ! Initialize from N_st to N_st_diag with gaussian random numbers + ! to be sure to have overlap with any eigenvectors + do k = N_st+1, N_st_diag + u_in(k,k) = 10.d0 + do i = 1, sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + ! Normalize all states + do k = 1, N_st_diag + call normalize(u_in(1,k), sze) + enddo + + ! Copy from the guess input "u_in" to the working vectors "U" + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + ! --- + + itertot = 0 + + do while (.not.converged) + + itertot = itertot + 1 + if(itertot == 8) then + exit + endif + + do iter = 1, itermax-1 + + shift = N_st_diag * (iter-1) + shift2 = N_st_diag * iter + + if( (iter > 1) .or. (itertot == 1) ) then + + ! Gram-Schmidt to orthogonalize all new guess with the previous vectors + call ortho_qr(U, size(U, 1), sze, shift2) + call ortho_qr(U, size(U, 1), sze, shift2) + + ! W = H U + call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze) + call dress_calc(W(1,shift+1), Dress_jj, U(1,shift+1), N_st_diag, sze) + + else + + ! Already computed in update below + continue + endif + + ! Compute h_kl = = + ! ------------------------------------------- + call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 & + , U, size(U, 1), W, size(W, 1) & + , 0.d0, h, size(h, 1) ) + + + ! Diagonalize h y = lambda y + ! --------------------------- + call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1)) + + + ! Express eigenvectors of h in the determinant basis: + ! --------------------------------------------------- + + ! y(:,k) = rk + ! U(:,k) = Bk + ! U(:,shift2+k) = Rk = Bk x rk + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, U(1,shift2+1), size(U, 1) ) + + do k = 1, N_st_diag + call normalize(U(1,shift2+k), sze) + enddo + + ! --- + ! select the max overlap + + ! + ! start test ------------------------------------------------------------------------ + ! + !double precision, allocatable :: Utest(:,:), Otest(:) + !allocate( Utest(sze,shift2), Otest(shift2) ) + + !call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 & + ! , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) ) + !do k = 1, shift2 + ! call normalize(Utest(1,k), sze) + !enddo + !do j = 1, sze + ! write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2) + !enddo + + !do k = 1, shift2 + ! Otest(k) = 0.d0 + ! do i = 1, sze + ! Otest(k) += Utest(i,k) * u_in(i,1) + ! enddo + ! Otest(k) = dabs(Otest(k)) + ! print *, ' Otest =', k, Otest(k), lambda(k) + !enddo + + !deallocate(Utest, Otest) + ! + ! end test ------------------------------------------------------------------------ + ! + + ! TODO + ! state_following is more efficient + do l = 1, N_st + + allocate( overlap(N_st_diag) ) + + do k = 1, N_st_diag + overlap(k) = 0.d0 + do i = 1, sze + overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l) + enddo + overlap(k) = dabs(overlap(k)) + !print *, ' overlap =', k, overlap(k) + enddo + + lambda_tmp = 0.d0 + do k = 1, N_st_diag + if(overlap(k) .gt. lambda_tmp) then + i_omax(l) = k + lambda_tmp = overlap(k) + endif + enddo + + deallocate(overlap) + + if(lambda_tmp .lt. 0.7d0) then + print *, ' very small overlap ...', l, i_omax(l) + print *, ' max overlap = ', lambda_tmp + stop + endif + + if(i_omax(l) .ne. l) then + print *, ' !!! WARNONG !!!' + print *, ' index of state', l, i_omax(l) + endif + enddo + + ! y(:,k) = rk + ! W(:,k) = H x Bk + ! W(:,shift2+k) = H x Bk x rk + ! = Wk + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, W(1,shift2+1), size(W, 1) ) + + ! --- + + ! Compute residual vector and davidson step + ! ----------------------------------------- + + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k) + do k = 1, N_st_diag + do i = 1, sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2) + enddo + if(k <= N_st) then + l = k + residual_norm(k) = u_dot_u(U(1,shift2+l), sze) + to_print(1,k) = lambda(l) + to_print(2,k) = residual_norm(l) + endif + enddo + !$OMP END PARALLEL DO + !residual_norm(1) = u_dot_u(U(1,shift2+1), sze) + !to_print(1,1) = lambda(1) + !to_print(2,1) = residual_norm(1) + + + if( (itertot > 1) .and. (iter == 1) ) then + !don't print + continue + else + write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st) + endif + + ! Check convergence + if(iter > 1) then + converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson + endif + + do k = 1, N_st + if(residual_norm(k) > 1.e8) then + print *, 'Davidson failed' + stop -1 + endif + enddo + if(converged) then + exit + endif + + logical, external :: qp_stop + if(qp_stop()) then + converged = .True. + exit + endif + + enddo ! loop over iter + + + ! Re-contract U and update W + ! -------------------------------- + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1) ) + do k = 1, N_st_diag + do i = 1, sze + W(i,k) = u_in(i,k) + enddo + enddo + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1) ) + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + call ortho_qr(U, size(U, 1), sze, N_st_diag) + call ortho_qr(U, size(U, 1), sze, N_st_diag) + do j = 1, N_st_diag + k = 1 + do while( (k < sze) .and. (U(k,j) == 0.d0) ) + k = k+1 + enddo + if(U(k,j) * u_in(k,j) < 0.d0) then + do i = 1, sze + W(i,j) = -W(i,j) + enddo + endif + enddo + + enddo ! loop over while + + ! --- + + do k = 1, N_st + energies(k) = lambda(k) + enddo + write_buffer = '=====' + do i = 1, N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') trim(write_buffer) + write(6,'(A)') '' + call write_time(6) + + deallocate(W) + deallocate(U, h, y, lambda, residual_norm, i_omax) + + FREE nthreads_davidson + +end subroutine davidson_general_ext_rout_nonsym_b1space + +! --- + +subroutine dress_calc(v,dress,u,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Routine that computed the action of the diagonal dressing dress + ! + ! WARNING :: v is not initialiazed !!! + END_DOC + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u(sze,N_st),dress(sze) + double precision, intent(inout) :: v(sze,N_st) + integer :: i,istate + + do istate = 1, N_st + do i = 1, sze + v(i,istate) += dress(i) * u(i,istate) + enddo + enddo +end + + + + + + diff --git a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f new file mode 100644 index 00000000..1bed60fe --- /dev/null +++ b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f @@ -0,0 +1,473 @@ + +! --- + +subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N_st, N_st_diag_in, converged, hcalc) + + use mmap_module + + BEGIN_DOC + ! Generic modified-Davidson diagonalization + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st + ! + ! Initial guess vectors are not necessarily orthonormal + ! + ! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output) + END_DOC + + implicit none + + integer, intent(in) :: sze, N_st, N_st_diag_in + double precision, intent(in) :: H_jj(sze) + logical, intent(inout) :: converged + double precision, intent(inout) :: u_in(sze,N_st_diag_in) + double precision, intent(out) :: energies(N_st) + external hcalc + + character*(16384) :: write_buffer + integer :: iter, N_st_diag + integer :: i, j, k, l, m + integer :: iter2, itertot + logical :: disk_based + integer :: shift, shift2, itermax + integer :: nproc_target + integer :: order(N_st_diag_in) + double precision :: to_print(2,N_st) + double precision :: r1, r2, alpha + double precision :: cpu, wall + double precision :: cmax + double precision :: energy_shift(N_st_diag_in*davidson_sze_max) + double precision, allocatable :: U(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:) + double precision, allocatable :: residual_norm(:) + + double precision :: lambda_tmp + integer, allocatable :: i_omax(:) + double precision, allocatable :: U_tmp(:), overlap(:) + + double precision, allocatable :: W(:,:) + !double precision, pointer :: W(:,:) + double precision, external :: u_dot_v, u_dot_u + + + include 'constants.include.F' + + N_st_diag = N_st_diag_in +! print*,'trial vector' + do i = 1, sze + if(isnan(u_in(i,1)))then + print*,'pb in input vector of davidson_general_ext_rout_nonsym_b1space' + print*,i,u_in(i,1) + stop + else if (dabs(u_in(i,1)).lt.1.d-16)then + u_in(i,1) = 0.d0 + endif + enddo + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda + if(N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_full to ', N_st_diag*3 + stop -1 + endif + + itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1 + + provide threshold_nonsym_davidson + call write_time(6) + write(6,'(A)') '' + write(6,'(A)') 'Davidson Diagonalization' + write(6,'(A)') '------------------------' + write(6,'(A)') '' + + + ! Find max number of cores to fit in memory + ! ----------------------------------------- + + nproc_target = nproc + double precision :: rss + integer :: maxab + maxab = sze + + m=1 + disk_based = .False. + call resident_memory(rss) + do + r1 = 8.d0 * &! bytes + ( dble(sze)*(N_st_diag*itermax) &! U + + 1.d0*dble(sze*m)*(N_st_diag*itermax) &! W + + 2.d0*(N_st_diag*itermax)**2 &! h,y + + 2.d0*(N_st_diag*itermax) &! s2,lambda + + 1.d0*(N_st_diag) &! residual_norm + ! In H_S2_u_0_nstates_zmq + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave + + 0.5d0*maxab &! idx0 in H_S2_u_0_nstates_openmp_work_* + + nproc_target * &! In OMP section + ( 1.d0*(N_int*maxab) &! buffer + + 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx + ) / 1024.d0**3 + + if(nproc_target == 0) then + call check_mem(r1, irp_here) + nproc_target = 1 + exit + endif + + if(r1+rss < qp_max_mem) then + exit + endif + + if(itermax > 4) then + itermax = itermax - 1 +! else if (m==1.and.disk_based_davidson) then +! m = 0 +! disk_based = .True. +! itermax = 6 + else + nproc_target = nproc_target - 1 + endif + + enddo + + nthreads_davidson = nproc_target + TOUCH nthreads_davidson + + call write_int(6, N_st, 'Number of states') + call write_int(6, N_st_diag, 'Number of states in diagonalization') + call write_int(6, sze, 'Number of basis functions') + call write_int(6, nproc_target, 'Number of threads for diagonalization') + call write_double(6, r1, 'Memory(Gb)') + if(disk_based) then + print *, 'Using swap space to reduce RAM' + endif + + !--------------- + + write(6,'(A)') '' + write_buffer = '=====' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = 'Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy Residual ' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = '=====' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + + ! --- + + + allocate( W(sze,N_st_diag*itermax) ) + + allocate( & + ! Large + U(sze,N_st_diag*itermax), & + ! Small + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + lambda(N_st_diag*itermax), & + residual_norm(N_st_diag), & + i_omax(N_st) & + ) + + U = 0.d0 + h = 0.d0 + y = 0.d0 + lambda = 0.d0 + residual_norm = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + + ! Davidson iterations + ! =================== + + converged = .False. + + ! Initialize from N_st to N_st_diag with gaussian random numbers + ! to be sure to have overlap with any eigenvectors + do k = N_st+1, N_st_diag + u_in(k,k) = 10.d0 + do i = 1, sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + ! Normalize all states + do k = 1, N_st_diag + call normalize(u_in(1,k), sze) + enddo + + ! Copy from the guess input "u_in" to the working vectors "U" + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + ! --- + + itertot = 0 + + do while (.not.converged) + + itertot = itertot + 1 + if(itertot == 8) then + exit + endif + + do iter = 1, itermax-1 + + shift = N_st_diag * (iter-1) + shift2 = N_st_diag * iter + + if( (iter > 1) .or. (itertot == 1) ) then + + ! Gram-Schmidt to orthogonalize all new guess with the previous vectors + call ortho_qr(U, size(U, 1), sze, shift2) + call ortho_qr(U, size(U, 1), sze, shift2) + + ! W = H U + call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze) + + else + + ! Already computed in update below + continue + endif + + ! Compute h_kl = = + ! ------------------------------------------- + call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 & + , U, size(U, 1), W, size(W, 1) & + , 0.d0, h, size(h, 1) ) + + + ! Diagonalize h y = lambda y + ! --------------------------- + call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1)) + + + ! Express eigenvectors of h in the determinant basis: + ! --------------------------------------------------- + + ! y(:,k) = rk + ! U(:,k) = Bk + ! U(:,shift2+k) = Rk = Bk x rk + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, U(1,shift2+1), size(U, 1) ) + + do k = 1, N_st_diag + call normalize(U(1,shift2+k), sze) + enddo + + ! --- + ! select the max overlap + + ! + ! start test ------------------------------------------------------------------------ + ! + !double precision, allocatable :: Utest(:,:), Otest(:) + !allocate( Utest(sze,shift2), Otest(shift2) ) + + !call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 & + ! , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) ) + !do k = 1, shift2 + ! call normalize(Utest(1,k), sze) + !enddo + !do j = 1, sze + ! write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2) + !enddo + + !do k = 1, shift2 + ! Otest(k) = 0.d0 + ! do i = 1, sze + ! Otest(k) += Utest(i,k) * u_in(i,1) + ! enddo + ! Otest(k) = dabs(Otest(k)) + ! print *, ' Otest =', k, Otest(k), lambda(k) + !enddo + + !deallocate(Utest, Otest) + ! + ! end test ------------------------------------------------------------------------ + ! + + ! TODO + ! state_following is more efficient + do l = 1, N_st + + allocate( overlap(N_st_diag) ) + + do k = 1, N_st_diag + overlap(k) = 0.d0 + do i = 1, sze + overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l) + enddo + overlap(k) = dabs(overlap(k)) + !print *, ' overlap =', k, overlap(k) + enddo + + lambda_tmp = 0.d0 + do k = 1, N_st_diag + if(overlap(k) .gt. lambda_tmp) then + i_omax(l) = k + lambda_tmp = overlap(k) + endif + enddo + + deallocate(overlap) + + if(lambda_tmp .lt. 0.7d0) then + print *, ' very small overlap ...', l, i_omax(l) + print *, ' max overlap = ', lambda_tmp + stop + endif + + if(i_omax(l) .ne. l) then + print *, ' !!! WARNONG !!!' + print *, ' index of state', l, i_omax(l) + endif + enddo + + ! y(:,k) = rk + ! W(:,k) = H x Bk + ! W(:,shift2+k) = H x Bk x rk + ! = Wk + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, W(1,shift2+1), size(W, 1) ) + + ! --- + + ! Compute residual vector and davidson step + ! ----------------------------------------- + + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k) + do k = 1, N_st_diag + do i = 1, sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2) + enddo + if(k <= N_st) then + l = k + residual_norm(k) = u_dot_u(U(1,shift2+l), sze) + to_print(1,k) = lambda(l) + to_print(2,k) = residual_norm(l) + endif + enddo + !$OMP END PARALLEL DO + !residual_norm(1) = u_dot_u(U(1,shift2+1), sze) + !to_print(1,1) = lambda(1) + !to_print(2,1) = residual_norm(1) + + + if( (itertot > 1) .and. (iter == 1) ) then + !don't print + continue + else + write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st) + endif + + ! Check convergence + if(iter > 1) then + converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson + endif + + do k = 1, N_st + if(residual_norm(k) > 1.e8) then + print *, 'Davidson failed' + stop -1 + endif + enddo + if(converged) then + exit + endif + + logical, external :: qp_stop + if(qp_stop()) then + converged = .True. + exit + endif + + enddo ! loop over iter + + + ! Re-contract U and update W + ! -------------------------------- + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1) ) + do k = 1, N_st_diag + do i = 1, sze + W(i,k) = u_in(i,k) + enddo + enddo + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1) ) + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + call ortho_qr(U, size(U, 1), sze, N_st_diag) + call ortho_qr(U, size(U, 1), sze, N_st_diag) + do j = 1, N_st_diag + k = 1 + do while( (k < sze) .and. (U(k,j) == 0.d0) ) + k = k+1 + enddo + if(U(k,j) * u_in(k,j) < 0.d0) then + do i = 1, sze + W(i,j) = -W(i,j) + enddo + endif + enddo + + enddo ! loop over while + + ! --- + + do k = 1, N_st + energies(k) = lambda(k) + enddo + write_buffer = '=====' + do i = 1, N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') trim(write_buffer) + write(6,'(A)') '' + call write_time(6) + + deallocate(W) + deallocate(U, h, y, lambda, residual_norm, i_omax) + + FREE nthreads_davidson + +end subroutine davidson_general_ext_rout_nonsym_b1space + +! --- diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index 92c41b4c..bfa55526 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -4,6 +4,12 @@ doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false. interface: ezfio,provider,ocaml default: 1.e-10 +[threshold_nonsym_davidson] +type: Threshold +doc: Thresholds of non-symetric Davidson's algorithm +interface: ezfio,provider,ocaml +default: 1.e-10 + [threshold_davidson_from_pt2] type: logical doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2 diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index b6b11485..6960a4d4 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -589,6 +589,67 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) endif end +subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef,psicoef) + implicit none + BEGIN_DOC + ! Save the wave function into the |EZFIO| file + END_DOC + use bitmasks + include 'constants.include.F' + integer, intent(in) :: ndet,nstates,dim_psicoef + integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) + double precision, intent(in) :: psicoef(dim_psicoef,nstates) + integer*8, allocatable :: psi_det_save(:,:,:) + double precision, allocatable :: psi_coef_save(:,:) + + double precision :: accu_norm + integer :: i,j,k, ndet_qp_edit + + if (mpi_master) then + ndet_qp_edit = min(ndet,N_det_qp_edit) + + call ezfio_set_determinants_N_int(N_int) + call ezfio_set_determinants_bit_kind(bit_kind) + call ezfio_set_determinants_N_det(ndet) + call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) + call ezfio_set_determinants_n_states(nstates) + call ezfio_set_determinants_mo_label(mo_label) + + allocate (psi_det_save(N_int,2,ndet)) + do i=1,ndet + do j=1,2 + do k=1,N_int + psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8) + enddo + enddo + enddo + call ezfio_set_determinants_psi_det(psi_det_save) + call ezfio_set_determinants_psi_det_qp_edit(psi_det_save) + deallocate (psi_det_save) + + allocate (psi_coef_save(ndet,nstates)) + do k=1,nstates + do i=1,ndet + psi_coef_save(i,k) = psicoef(i,k) + enddo + enddo + + call ezfio_set_determinants_psi_coef(psi_coef_save) + deallocate (psi_coef_save) + + allocate (psi_coef_save(ndet_qp_edit,nstates)) + do k=1,nstates + do i=1,ndet_qp_edit + psi_coef_save(i,k) = psicoef(i,k) + enddo + enddo + + call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) + deallocate (psi_coef_save) + + call write_int(6,ndet,'Saved determinants') + endif +end subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save) diff --git a/src/fci_tc_bi/13.fci_tc_bi_ortho.bats b/src/fci_tc_bi/13.fci_tc_bi_ortho.bats new file mode 100644 index 00000000..7f5d0a9f --- /dev/null +++ b/src/fci_tc_bi/13.fci_tc_bi_ortho.bats @@ -0,0 +1,26 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh +source $QP_ROOT/quantum_package.rc + + +function run_O() { + qp set_file O_tc_scf + FILE=O_tc_scf/tc_bi_ortho/psi_l_coef_bi_ortho.gz + if test -f "$FILE"; then + rm O_tc_scf/tc_bi_ortho/psi* + fi + qp set determinants n_det_max 20000 + file=${EZFIO_FILE}.fci_tc_bi_ortho.out + qp run fci_tc_bi_ortho | tee $file + eref=-74.971188861115309 + energy="$(grep 'E(before) +rPT2 =' $file | tail -1 | cut -d '=' -f 2)" + eq $energy $eref 1e-4 +} + + +@test "O" { + run_O +} + + diff --git a/src/fci_tc_bi/EZFIO.cfg b/src/fci_tc_bi/EZFIO.cfg new file mode 100644 index 00000000..a2552c74 --- /dev/null +++ b/src/fci_tc_bi/EZFIO.cfg @@ -0,0 +1,17 @@ +[energy] +type: double precision +doc: Calculated Selected |FCI| energy +interface: ezfio +size: (determinants.n_states) + +[energy_pt2] +type: double precision +doc: Calculated |FCI| energy + |PT2| +interface: ezfio +size: (determinants.n_states) + +[cipsi_tc] +type: character*(32) +doc: TODO +interface: ezfio,provider,ocaml +default: h_tc diff --git a/src/fci_tc_bi/NEED b/src/fci_tc_bi/NEED new file mode 100644 index 00000000..000b0deb --- /dev/null +++ b/src/fci_tc_bi/NEED @@ -0,0 +1,3 @@ +tc_bi_ortho +davidson_undressed +cipsi_tc_bi_ortho diff --git a/src/fci_tc_bi/class.irp.f b/src/fci_tc_bi/class.irp.f new file mode 100644 index 00000000..b4a68ac2 --- /dev/null +++ b/src/fci_tc_bi/class.irp.f @@ -0,0 +1,12 @@ + BEGIN_PROVIDER [ logical, do_only_1h1p ] +&BEGIN_PROVIDER [ logical, do_only_cas ] +&BEGIN_PROVIDER [ logical, do_ddci ] + implicit none + BEGIN_DOC + ! In the FCI case, all those are always false + END_DOC + do_only_1h1p = .False. + do_only_cas = .False. + do_ddci = .False. +END_PROVIDER + diff --git a/src/fci_tc_bi/copy_wf.irp.f b/src/fci_tc_bi/copy_wf.irp.f new file mode 100644 index 00000000..c46f20d2 --- /dev/null +++ b/src/fci_tc_bi/copy_wf.irp.f @@ -0,0 +1,215 @@ + +use bitmasks + +subroutine copy_H_apply_buffer_to_wf_tc + use omp_lib + implicit none + BEGIN_DOC +! Copies the H_apply buffer to psi_coef. +! After calling this subroutine, N_det, psi_det and psi_coef need to be touched + END_DOC + integer(bit_kind), allocatable :: buffer_det(:,:,:) + double precision, allocatable :: buffer_r_coef(:,:), buffer_l_coef(:,:) + integer :: i,j,k + integer :: N_det_old + + PROVIDE H_apply_buffer_allocated + + + ASSERT (N_int > 0) + ASSERT (N_det > 0) + + allocate ( buffer_det(N_int,2,N_det), buffer_r_coef(N_det,N_states), buffer_l_coef(N_det,N_states) ) + + ! Backup determinants + j=0 + do i=1,N_det +! if (pruned(i)) cycle ! Pruned determinants + j+=1 + ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num) + buffer_det(:,:,j) = psi_det(:,:,i) + enddo + N_det_old = j + + ! Backup coefficients + do k=1,N_states + j=0 + do i=1,N_det +! if (pruned(i)) cycle ! Pruned determinants + j += 1 + buffer_r_coef(j,k) = psi_r_coef_bi_ortho(i,k) + buffer_l_coef(j,k) = psi_l_coef_bi_ortho(i,k) + enddo + ASSERT ( j == N_det_old ) + enddo + + ! Update N_det + N_det = N_det_old + do j=0,nproc-1 + N_det = N_det + H_apply_buffer(j)%N_det + enddo + + ! Update array sizes + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + + ! Restore backup in resized array + do i=1,N_det_old + psi_det(:,:,i) = buffer_det(:,:,i) + ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num ) + enddo + do k=1,N_states + do i=1,N_det_old + psi_r_coef_bi_ortho(i,k) = buffer_r_coef(i,k) + psi_l_coef_bi_ortho(i,k) = buffer_l_coef(i,k) + enddo + enddo + + ! Copy new buffers + + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) & + !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_r_coef_bi_ortho,psi_l_coef_bi_ortho,N_states,psi_det_size) + j=0 + !$ j=omp_get_thread_num() + do k=0,j-1 + N_det_old += H_apply_buffer(k)%N_det + enddo + do i=1,H_apply_buffer(j)%N_det + do k=1,N_int + psi_det(k,1,i+N_det_old) = H_apply_buffer(j)%det(k,1,i) + psi_det(k,2,i+N_det_old) = H_apply_buffer(j)%det(k,2,i) + enddo + ASSERT (sum(popcnt(psi_det(:,1,i+N_det_old))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num ) + enddo + do k=1,N_states + do i=1,H_apply_buffer(j)%N_det + psi_r_coef_bi_ortho(i+N_det_old,k) = H_apply_buffer(j)%coef(i,k) + psi_l_coef_bi_ortho(i+N_det_old,k) = 0.d0 + enddo + enddo + !$OMP BARRIER + H_apply_buffer(j)%N_det = 0 + !$OMP END PARALLEL + SOFT_TOUCH N_det psi_det psi_r_coef_bi_ortho psi_l_coef_bi_ortho + + logical :: found_duplicates + call remove_duplicates_in_psi_det_tc(found_duplicates) + call bi_normalize(psi_l_coef_bi_ortho,psi_r_coef_bi_ortho,N_det,size(psi_l_coef_bi_ortho,1),N_states) + SOFT_TOUCH N_det psi_det psi_r_coef_bi_ortho psi_l_coef_bi_ortho + +end + +subroutine remove_duplicates_in_psi_det_tc(found_duplicates) + implicit none + logical, intent(out) :: found_duplicates + BEGIN_DOC +! Removes duplicate determinants in the wave function. + END_DOC + integer :: i,j,k + integer(bit_kind), allocatable :: bit_tmp(:) + logical,allocatable :: duplicate(:) + logical :: dup + + allocate (duplicate(N_det), bit_tmp(N_det)) + + found_duplicates = .False. + + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,dup) + + !$OMP DO + do i=1,N_det + integer, external :: det_search_key + !$DIR FORCEINLINE + bit_tmp(i) = det_search_key(psi_det_sorted_bit_tc(1,1,i),N_int) + duplicate(i) = .False. + enddo + !$OMP END DO + + !$OMP DO schedule(dynamic,1024) + do i=1,N_det-1 + if (duplicate(i)) then + cycle + endif + j = i+1 + do while (bit_tmp(j)==bit_tmp(i)) + if (duplicate(j)) then + j = j+1 + if (j > N_det) then + exit + else + cycle + endif + endif + dup = .True. + do k=1,N_int + if ( (psi_det_sorted_bit_tc(k,1,i) /= psi_det_sorted_bit_tc(k,1,j) ) & + .or. (psi_det_sorted_bit_tc(k,2,i) /= psi_det_sorted_bit_tc(k,2,j) ) ) then + dup = .False. + exit + endif + enddo + if (dup) then + duplicate(j) = .True. + found_duplicates = .True. + endif + j += 1 + if (j > N_det) then + exit + endif + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + if (found_duplicates) then + k=0 + do i=1,N_det + if (.not.duplicate(i)) then + k += 1 + psi_det(:,:,k) = psi_det_sorted_bit_tc (:,:,i) + psi_r_coef_bi_ortho(k,:) = psi_r_coef_sorted_bit(i,:) + psi_l_coef_bi_ortho(k,:) = psi_l_coef_sorted_bit(i,:) + else + if (sum(abs(psi_r_coef_sorted_bit(i,:))) /= 0.d0 ) then + psi_r_coef_bi_ortho(k,:) = psi_r_coef_sorted_bit(i,:) + psi_l_coef_bi_ortho(k,:) = psi_l_coef_sorted_bit(i,:) + endif + endif + enddo + N_det = k + psi_det_sorted_bit_tc(:,:,1:N_det) = psi_det(:,:,1:N_det) + psi_r_coef_sorted_bit(1:N_det,:) = psi_r_coef_bi_ortho(1:N_det,:) + psi_l_coef_sorted_bit(1:N_det,:) = psi_l_coef_bi_ortho(1:N_det,:) + TOUCH N_det psi_det psi_det_sorted_bit_tc c0_weight psi_r_coef_sorted_bit psi_l_coef_sorted_bit + endif + psi_det = psi_det_sorted_tc + psi_r_coef_bi_ortho = psi_r_coef_sorted_bi_ortho + psi_l_coef_bi_ortho = psi_l_coef_sorted_bi_ortho + SOFT_TOUCH psi_det psi_r_coef_bi_ortho psi_l_coef_bi_ortho psi_det_sorted_bit_tc psi_r_coef_sorted_bit psi_l_coef_sorted_bit + deallocate (duplicate,bit_tmp) +end + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit_tc, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_r_coef_sorted_bit, (N_det,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_l_coef_sorted_bit, (N_det,N_states) ] + implicit none + BEGIN_DOC + ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation. + ! They are sorted by determinants interpreted as integers. Useful + ! to accelerate the search of a random determinant in the wave + ! function. + END_DOC + + call sort_dets_by_det_search_key(N_det, psi_det, psi_r_coef_bi_ortho, size(psi_r_coef_bi_ortho,1), & + psi_det_sorted_bit_tc, psi_r_coef_sorted_bit, N_states) + call sort_dets_by_det_search_key(N_det, psi_det, psi_l_coef_bi_ortho, size(psi_l_coef_bi_ortho,1), & + psi_det_sorted_bit_tc, psi_l_coef_sorted_bit, N_states) + +END_PROVIDER diff --git a/src/fci_tc_bi/diagonalize_ci.irp.f b/src/fci_tc_bi/diagonalize_ci.irp.f new file mode 100644 index 00000000..56c561ac --- /dev/null +++ b/src/fci_tc_bi/diagonalize_ci.irp.f @@ -0,0 +1,100 @@ + +subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + use selection_types + implicit none + integer, intent(inout) :: ndet ! number of determinants from before + double precision, intent(inout) :: E_tc,norm ! E and norm from previous wave function + type(pt2_type) , intent(in) :: pt2_data ! PT2 from previous wave function + logical, intent(in) :: print_pt2 + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + double precision :: pt2_tmp,pt1_norm,rpt2_tmp,abs_pt2 + pt2_tmp = pt2_data % pt2(1) + abs_pt2 = pt2_data % variance(1) + pt1_norm = pt2_data % overlap(1,1) + rpt2_tmp = pt2_tmp/(1.d0 + pt1_norm) + print*,'*****' + print*,'New wave function information' + print*,'N_det tc = ',N_det + print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth + print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(1) + print*,'Ndet, E_tc = ',N_det,eigval_right_tc_bi_orth(1) + print*,'*****' + if(print_pt2)then + print*,'*****' + print*,'previous wave function info' + print*,'norm(before) = ',norm + print*,'E(before) = ',E_tc + print*,'PT1 norm = ',dsqrt(pt1_norm) + print*,'PT2 = ',pt2_tmp + print*,'rPT2 = ',rpt2_tmp + print*,'|PT2| = ',abs_pt2 + print*,'Positive PT2 = ',(pt2_tmp + abs_pt2)*0.5d0 + print*,'Negative PT2 = ',(pt2_tmp - abs_pt2)*0.5d0 + print*,'E(before) + PT2 = ',E_tc + pt2_tmp/norm + print*,'E(before) +rPT2 = ',E_tc + rpt2_tmp/norm + write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tmp/norm,E_tc + rpt2_tmp/norm,abs_pt2 + print*,'*****' + endif + E_tc = eigval_right_tc_bi_orth(1) + norm = norm_ground_left_right_bi_orth + ndet = N_det + do j=1,N_states + do i=1,N_det + psi_l_coef_bi_ortho(i,j) = leigvec_tc_bi_orth(i,j) + psi_r_coef_bi_ortho(i,j) = reigvec_tc_bi_orth(i,j) + psi_coef(i,j) = dabs(psi_l_coef_bi_ortho(i,j) * psi_r_coef_bi_ortho(i,j)) + enddo + enddo + SOFT_TOUCH eigval_left_tc_bi_orth eigval_right_tc_bi_orth leigvec_tc_bi_orth reigvec_tc_bi_orth norm_ground_left_right_bi_orth psi_coef psi_l_coef_bi_ortho psi_r_coef_bi_ortho + + + + call save_tc_bi_ortho_wavefunction +end + +subroutine print_CI_dressed(ndet, E_tc,norm,pt2_data,print_pt2) + use selection_types + implicit none + integer, intent(inout) :: ndet ! number of determinants from before + double precision, intent(inout) :: E_tc,norm ! E and norm from previous wave function + type(pt2_type) , intent(in) :: pt2_data ! PT2 from previous wave function + logical, intent(in) :: print_pt2 + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + print*,'*****' + print*,'New wave function information' + print*,'N_det tc = ',N_det + print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth + print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(1) + print*,'Ndet, E_tc = ',N_det,eigval_right_tc_bi_orth(1) + print*,'*****' + if(print_pt2)then + print*,'*****' + print*,'previous wave function info' + print*,'norm(before) = ',norm + print*,'E(before) = ',E_tc + print*,'PT1 norm = ',dsqrt(pt2_data % overlap(1,1)) + print*,'E(before) + PT2 = ',E_tc + (pt2_data % pt2(1))/norm + print*,'PT2 = ',pt2_data % pt2(1) + print*,'Ndet, E_tc, E+PT2 = ',ndet,E_tc,E_tc + (pt2_data % pt2(1))/norm,dsqrt(pt2_data % overlap(1,1)) + print*,'*****' + endif + E_tc = eigval_right_tc_bi_orth(1) + norm = norm_ground_left_right_bi_orth + ndet = N_det + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = reigvec_tc_bi_orth(i,j) + enddo + enddo + SOFT_TOUCH eigval_left_tc_bi_orth eigval_right_tc_bi_orth leigvec_tc_bi_orth norm_ground_left_right_bi_orth psi_coef reigvec_tc_bi_orth + +end + diff --git a/src/fci_tc_bi/fci_tc_bi_ortho.irp.f b/src/fci_tc_bi/fci_tc_bi_ortho.irp.f new file mode 100644 index 00000000..84ac8166 --- /dev/null +++ b/src/fci_tc_bi/fci_tc_bi_ortho.irp.f @@ -0,0 +1,85 @@ +program fci + implicit none + BEGIN_DOC + ! Selected Full Configuration Interaction with stochastic selection + ! and PT2. + ! + ! This program performs a |CIPSI|-like selected |CI| using a + ! stochastic scheme for both the selection of the important Slater + ! determinants and the computation of the |PT2| correction. This + ! |CIPSI|-like algorithm will be performed for the lowest states of + ! the variational space (see :option:`determinants n_states`). The + ! |FCI| program will stop when reaching at least one the two following + ! conditions: + ! + ! * number of Slater determinants > :option:`determinants n_det_max` + ! * abs(|PT2|) less than :option:`perturbation pt2_max` + ! + ! The following other options can be of interest: + ! + ! :option:`determinants read_wf` + ! When set to |false|, the program starts with a ROHF-like Slater + ! determinant as a guess wave function. When set to |true|, the + ! program starts with the wave function(s) stored in the |EZFIO| + ! directory as guess wave function(s). + ! + ! :option:`determinants s2_eig` + ! When set to |true|, the selection will systematically add all the + ! necessary Slater determinants in order to have a pure spin wave + ! function with an |S^2| value corresponding to + ! :option:`determinants expected_s2`. + ! + ! For excited states calculations, it is recommended to start with + ! :ref:`cis` or :ref:`cisd` guess wave functions, eventually in + ! a restricted set of |MOs|, and to set :option:`determinants s2_eig` + ! to |true|. + ! + END_DOC + + + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + pruning = -1.d0 + touch pruning +! pt2_relative_error = 0.01d0 +! touch pt2_relative_error + call run_cipsi_tc + +end + + +subroutine run_cipsi_tc + + implicit none + + if (.not.is_zmq_slave) then + PROVIDE psi_det psi_coef mo_bi_ortho_tc_two_e mo_bi_ortho_tc_one_e + if(elec_alpha_num+elec_beta_num.ge.3)then + if(three_body_h_tc)then + call provide_all_three_ints_bi_ortho + endif + endif + ! --- + + if (do_pt2) then + call run_stochastic_cipsi + else + call run_cipsi + endif + + else + PROVIDE mo_bi_ortho_tc_one_e mo_bi_ortho_tc_two_e pt2_min_parallel_tasks + if(elec_alpha_num+elec_beta_num.ge.3)then + if(three_body_h_tc)then + call provide_all_three_ints_bi_ortho + endif + endif + ! --- + + call run_slave_cipsi + + endif + +end diff --git a/src/fci_tc_bi/generators.irp.f b/src/fci_tc_bi/generators.irp.f new file mode 100644 index 00000000..55c0cbb9 --- /dev/null +++ b/src/fci_tc_bi/generators.irp.f @@ -0,0 +1,51 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of generators is 1 : the + ! Hartree-Fock determinant + END_DOC + integer :: i + double precision :: norm + call write_time(6) + norm = 1.d0 + N_det_generators = N_det + do i=1,N_det + norm = norm - psi_average_norm_contrib_sorted_tc(i) + if (norm - 1.d-10 < 1.d0 - threshold_generators) then + N_det_generators = i + exit + endif + enddo + N_det_generators = max(N_det_generators,1) + call write_int(6,N_det_generators,'Number of generators') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + psi_det_generators(1:N_int,1:2,1:N_det) = psi_det_sorted_tc(1:N_int,1:2,1:N_det) + psi_coef_generators(1:N_det,1:N_states) = psi_coef_sorted_tc(1:N_det,1:N_states) + +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_gen, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc_gen, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_tc_gen_order, (psi_det_size) ] + + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + psi_det_sorted_tc_gen = psi_det_sorted_tc + psi_coef_sorted_tc_gen = psi_coef_sorted_tc + psi_det_sorted_tc_gen_order = psi_det_sorted_tc_order +END_PROVIDER + + diff --git a/src/fci_tc_bi/save_energy.irp.f b/src/fci_tc_bi/save_energy.irp.f new file mode 100644 index 00000000..7c41d00f --- /dev/null +++ b/src/fci_tc_bi/save_energy.irp.f @@ -0,0 +1,9 @@ +subroutine save_energy(E,pt2) + implicit none + BEGIN_DOC +! Saves the energy in |EZFIO|. + END_DOC + double precision, intent(in) :: E(N_states), pt2(N_states) + call ezfio_set_fci_tc_energy(E(1:N_states)) + call ezfio_set_fci_tc_energy_pt2(E(1:N_states)+pt2(1:N_states)) +end diff --git a/src/fci_tc_bi/scripts_fci_tc/CH2.xyz b/src/fci_tc_bi/scripts_fci_tc/CH2.xyz new file mode 100644 index 00000000..9fa57f4b --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/CH2.xyz @@ -0,0 +1,6 @@ +3 + +C 6.000000 0.000000 0.000000 0.173480 +H 1.000000 0.000000 -0.861500 -0.520430 +H 1.000000 0.000000 0.861500 -0.520430 + diff --git a/src/fci_tc_bi/scripts_fci_tc/FH.xyz b/src/fci_tc_bi/scripts_fci_tc/FH.xyz new file mode 100644 index 00000000..9a1563f4 --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/FH.xyz @@ -0,0 +1,5 @@ +2 + +H 0.000000 0.000000 -0.825120 +F 0.000000 0.000000 0.091680 + diff --git a/src/fci_tc_bi/scripts_fci_tc/extract_tables.sh b/src/fci_tc_bi/scripts_fci_tc/extract_tables.sh new file mode 100755 index 00000000..a585884e --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/extract_tables.sh @@ -0,0 +1,16 @@ + +input=h2o +basis=dz +EZFIO=${input}_${basis}_bi_ortho +file=${EZFIO}.tc_fci.out +grep "Ndet,E,E+PT2,E+RPT2,|PT2|=" ${file} | cut -d "=" -f 2 > data_${EZFIO} +file=${EZFIO}.tc_fci_normal_order.out +grep "Ndet,E,E+PT2,E+RPT2=" ${file} | cut -d "=" -f 2 > data_${EZFIO}_normal + +#EZFIO=${input}_${basis}_ortho +#file=${EZFIO}.tc_fci.out +#grep "Ndet, E_tc, E+PT2 =" ${file} | cut -d "=" -f 2 > data_${EZFIO} +#file=${EZFIO}.tc_fci_normal_order.out +#grep "Ndet, E_tc, E+PT2 =" ${file} | cut -d "=" -f 2 > data_${EZFIO}_normal + +#zip data_${input}_${basis}.zip data* diff --git a/src/fci_tc_bi/scripts_fci_tc/h2o.sh b/src/fci_tc_bi/scripts_fci_tc/h2o.sh new file mode 100644 index 00000000..d0afca30 --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/h2o.sh @@ -0,0 +1,41 @@ +#!/bin/bash +# This is a sample PBS script +# temps CPU a ajuster au calcul + #PBS -l cput=2000:00:00 + #PBS -l nodes=1:ppn=16 +# memoire a ajuster au calcul + #PBS -l vmem=100gb +# a changer +# Pour savoir sur quel noeud on est +#echo $HOSTNAME +# Startdir = ou sont les fichiers d'input, par defaut HOMEDIR +# +StartDir=$PBS_O_WORKDIR +echo $StartDir +# +# SCRATCHDIR = espace temporaire (local au noeud et a vider apres le calcul) +# NE PAS MODIFIER +ulimit -s unlimited +export SCRATCHDIR=/scratch/$USER/$PBS_JOBID +# +cd $StartDir + + +############################################################################ +#### EXAMPLE OF SCRIPT TO RUN A CIPSI CALCULATION ON 5 STATES ON THE Ne^+ CATION +#### USING NATURAL ORBITALS OF A SMALL CIPSI AS MOS +#### ALL STATES WILL HAVE THE SAME SPIN SIMETRY : A DOUBLET + +####### YOU PUT THE PATH TO YOUR +QP_ROOT=/home_lct/eginer/programs/qp2 +source ${QP_ROOT}/quantum_package.rc +####### YOU LOAD SOME LIBRARIES +alias python3='/programmes/installation/Python/3.7.1/bin/python3' +type -a python3 + +export OMP_NUM_THREADS=16 + +module load intel2016_OMPI-V2 + +source ~/programs/qp2/quantum_package.rc +./script.sh h2o dz O 1 diff --git a/src/fci_tc_bi/scripts_fci_tc/h2o.xyz b/src/fci_tc_bi/scripts_fci_tc/h2o.xyz new file mode 100644 index 00000000..dee51ffc --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/h2o.xyz @@ -0,0 +1,6 @@ +3 + +O 0.000000 0.000000 0.000000 +H 0.000000 0.000000 0.957200 +H -0.926627 0.000000 -0.239987 + diff --git a/src/fci_tc_bi/scripts_fci_tc/script.sh b/src/fci_tc_bi/scripts_fci_tc/script.sh new file mode 100755 index 00000000..58585658 --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/script.sh @@ -0,0 +1,31 @@ +source /home_lct/eginer/qp2/quantum_package.rc +input=$1 + basis=$2 + atom=$3 + mul=$4 + EXPORT_OMP_NUM_THREADS=16 + dir=${input}_${basis} + mkdir ${dir} + cp ${input}.xyz ${dir}/ + cd $dir + EZFIO=${input}_${basis}_bi_ortho + qp create_ezfio -b "${atom}:cc-pcv${basis}|H:cc-pv${basis}" ${input}.xyz -m $mul -o $EZFIO + qp run scf + # Getting THE GOOD VALUE OF MU + qp run print_mu_av_tc | tee ${EZFIO_FILE}.mu_av.out + mu=`grep "average_mu_rs_c_lda =" ${EZFIO_FILE}.mu_av.out | cut -d "=" -f 2` + qp set ao_two_e_erf_ints mu_erf $mu + # Carrying the BI-ORTHO TC-SCF + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + # Three body terms without normal order + ### THREE E TERMS FOR FCI + qp set tc_keywords three_body_h_tc True + qp set tc_keywords double_normal_ord False + qp set perturbation pt2_max 0.003 + qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.tc_fci.out + # Three body terms with normal order + qp set tc_keywords double_normal_ord True + qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.tc_fci_normal_order.out + +cd ../ + diff --git a/src/fci_tc_bi/selectors.irp.f b/src/fci_tc_bi/selectors.irp.f new file mode 100644 index 00000000..af1176d2 --- /dev/null +++ b/src/fci_tc_bi/selectors.irp.f @@ -0,0 +1,100 @@ +use bitmasks + +BEGIN_PROVIDER [ double precision, threshold_selectors ] + implicit none + BEGIN_DOC + ! Thresholds on selectors (fraction of the square of the norm) + END_DOC + threshold_selectors = dsqrt(threshold_generators) +END_PROVIDER + +BEGIN_PROVIDER [ integer, N_det_selectors] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of selectors is 1 : the + ! Hartree-Fock determinant + END_DOC + integer :: i + double precision :: norm, norm_max + call write_time(6) + N_det_selectors = N_det + norm = 1.d0 + do i=1,N_det + norm = norm - psi_average_norm_contrib_tc(i) + if (norm - 1.d-10 < 1.d0 - threshold_selectors) then + N_det_selectors = i + exit + endif + enddo + N_det_selectors = max(N_det_selectors,N_det_generators) + call write_int(6,N_det_selectors,'Number of selectors') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_selectors, (N_int,2,psi_selectors_size) ] +&BEGIN_PROVIDER [ double precision, psi_selectors_coef, (psi_selectors_size,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_selectors_coef_tc, (psi_selectors_size,2,N_states) ] + implicit none + BEGIN_DOC + ! Determinants on which we apply for perturbation. + END_DOC + integer :: i,k + + do i=1,N_det_selectors + do k=1,N_int + psi_selectors(k,1,i) = psi_det_sorted_tc(k,1,i) + psi_selectors(k,2,i) = psi_det_sorted_tc(k,2,i) + enddo + enddo + do k=1,N_states + do i=1,N_det_selectors + psi_selectors_coef(i,k) = psi_coef_sorted_tc_gen(i,k) + psi_selectors_coef_tc(i,1,k) = psi_l_coef_sorted_bi_ortho(i,k) + psi_selectors_coef_tc(i,2,k) = psi_r_coef_sorted_bi_ortho(i,k) +! psi_selectors_coef_tc(i,1,k) = 1.d0 +! psi_selectors_coef_tc(i,2,k) = 1.d0 + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ] +&BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp_tc, (N_states,2,psi_selectors_size) ] + implicit none + BEGIN_DOC + ! Transposed psi_selectors + END_DOC + integer :: i,k + + do i=1,N_det_selectors + do k=1,N_states + psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k) + psi_selectors_coef_transp_tc(k,1,i) = psi_selectors_coef_tc(i,1,k) + psi_selectors_coef_transp_tc(k,2,i) = psi_selectors_coef_tc(i,2,k) + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ double precision, psi_selectors_rcoef_bi_orth_transp, (N_states, psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_selectors_lcoef_bi_orth_transp, (N_states, psi_det_size) ] + + implicit none + integer :: i, k + + psi_selectors_rcoef_bi_orth_transp = 0.d0 + psi_selectors_lcoef_bi_orth_transp = 0.d0 + + print*,'N_det,N_det_selectors',N_det,N_det_selectors + do i = 1, N_det_selectors + do k = 1, N_states + psi_selectors_rcoef_bi_orth_transp(k,i) = psi_r_coef_sorted_bi_ortho(i,k) + psi_selectors_lcoef_bi_orth_transp(k,i) = psi_l_coef_sorted_bi_ortho(i,k) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ integer, psi_selectors_size ] + implicit none + psi_selectors_size = psi_det_size +END_PROVIDER + diff --git a/src/fci_tc_bi/zmq.irp.f b/src/fci_tc_bi/zmq.irp.f new file mode 100644 index 00000000..cb2df483 --- /dev/null +++ b/src/fci_tc_bi/zmq.irp.f @@ -0,0 +1,103 @@ +BEGIN_TEMPLATE + +integer function zmq_put_$X(zmq_to_qp_run_socket,worker_id) + use f77_zmq + implicit none + BEGIN_DOC +! Put $X on the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer :: rc + character*(256) :: msg + + zmq_put_$X = 0 + + write(msg,'(A,1X,I8,1X,A200)') 'put_data '//trim(zmq_state), worker_id, '$X' + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) + if (rc /= len(trim(msg))) then + zmq_put_$X = -1 + return + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,$X,4,0) + if (rc /= 4) then + zmq_put_$X = -1 + return + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:rc) /= 'put_data_reply ok') then + zmq_put_$X = -1 + return + endif + +end + +integer function zmq_get_$X(zmq_to_qp_run_socket, worker_id) + use f77_zmq + implicit none + BEGIN_DOC +! Get $X from the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer :: rc + character*(256) :: msg + + PROVIDE zmq_state + zmq_get_$X = 0 + if (mpi_master) then + + write(msg,'(A,1X,I8,1X,A200)') 'get_data '//trim(zmq_state), worker_id, '$X' + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) + if (rc /= len(trim(msg))) then + zmq_get_$X = -1 + go to 10 + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:14) /= 'get_data_reply') then + zmq_get_$X = -1 + go to 10 + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,$X,4,0) + if (rc /= 4) then + zmq_get_$X = -1 + go to 10 + endif + + endif + + 10 continue + + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + + call MPI_BCAST (zmq_get_$X, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here//': Unable to broadcast N_det_generators' + stop -1 + endif + call MPI_BCAST ($X, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here//': Unable to broadcast N_det_generators' + stop -1 + endif + IRP_ENDIF + +end + +SUBST [ X ] + +N_det_generators ;; +N_det_selectors ;; + +END_TEMPLATE + diff --git a/src/iterations_tc/EZFIO.cfg b/src/iterations_tc/EZFIO.cfg new file mode 100644 index 00000000..2a5e94a7 --- /dev/null +++ b/src/iterations_tc/EZFIO.cfg @@ -0,0 +1,24 @@ +[n_iter] +interface: ezfio +doc: Number of saved iterations +type:integer +default: 1 + +[n_det_iterations] +interface: ezfio, provider +doc: Number of determinants at each iteration +type: integer +size: (100) + +[energy_iterations] +interface: ezfio, provider +doc: The variational energy at each iteration +type: double precision +size: (determinants.n_states,100) + +[pt2_iterations] +interface: ezfio, provider +doc: The |PT2| correction at each iteration +type: double precision +size: (determinants.n_states,100) + diff --git a/src/iterations_tc/NEED b/src/iterations_tc/NEED new file mode 100644 index 00000000..e69de29b diff --git a/src/iterations_tc/io.irp.f b/src/iterations_tc/io.irp.f new file mode 100644 index 00000000..821f5e84 --- /dev/null +++ b/src/iterations_tc/io.irp.f @@ -0,0 +1,37 @@ +BEGIN_PROVIDER [ integer, n_iter ] + implicit none + BEGIN_DOC +! number of iterations + END_DOC + + logical :: has + PROVIDE ezfio_filename + if (mpi_master) then + + double precision :: zeros(N_states,100) + integer :: izeros(100) + zeros = 0.d0 + izeros = 0 + call ezfio_set_iterations_n_iter(0) + call ezfio_set_iterations_energy_iterations(zeros) + call ezfio_set_iterations_pt2_iterations(zeros) + call ezfio_set_iterations_n_det_iterations(izeros) + n_iter = 1 + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( n_iter, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read n_iter with MPI' + endif + IRP_ENDIF + + call write_time(6) + +END_PROVIDER + diff --git a/src/iterations_tc/iterations.irp.f b/src/iterations_tc/iterations.irp.f new file mode 100644 index 00000000..2f1cf0c1 --- /dev/null +++ b/src/iterations_tc/iterations.irp.f @@ -0,0 +1,43 @@ +BEGIN_PROVIDER [ double precision, extrapolated_energy, (N_iter,N_states) ] + implicit none + BEGIN_DOC + ! Extrapolated energy, using E_var = f(PT2) where PT2=0 + END_DOC +! integer :: i + extrapolated_energy = 0.D0 +END_PROVIDER + + subroutine get_extrapolated_energy(Niter,ept2,pt1,extrap_energy) + implicit none + integer, intent(in) :: Niter + double precision, intent(in) :: ept2(Niter),pt1(Niter),extrap_energy(Niter) + call extrapolate_data(Niter,ept2,pt1,extrap_energy) + end + +subroutine save_iterations(e_, pt2_,n_) + implicit none + BEGIN_DOC +! Update the energy in the EZFIO file. + END_DOC + integer, intent(in) :: n_ + double precision, intent(in) :: e_(N_states), pt2_(N_states) + integer :: i + + if (N_iter == 101) then + do i=2,N_iter-1 + energy_iterations(1:N_states,N_iter-1) = energy_iterations(1:N_states,N_iter) + pt2_iterations(1:N_states,N_iter-1) = pt2_iterations(1:N_states,N_iter) + enddo + N_iter = N_iter-1 + TOUCH N_iter + endif + + energy_iterations(1:N_states,N_iter) = e_(1:N_states) + pt2_iterations(1:N_states,N_iter) = pt2_(1:N_states) + n_det_iterations(N_iter) = n_ + call ezfio_set_iterations_N_iter(N_iter) + call ezfio_set_iterations_energy_iterations(energy_iterations) + call ezfio_set_iterations_pt2_iterations(pt2_iterations) + call ezfio_set_iterations_n_det_iterations(n_det_iterations) +end + diff --git a/src/iterations_tc/print_extrapolation.irp.f b/src/iterations_tc/print_extrapolation.irp.f new file mode 100644 index 00000000..cb46fb67 --- /dev/null +++ b/src/iterations_tc/print_extrapolation.irp.f @@ -0,0 +1,46 @@ +subroutine print_extrapolated_energy + implicit none + BEGIN_DOC +! Print the extrapolated energy in the output + END_DOC + + integer :: i,k + + if (N_iter< 2) then + return + endif + write(*,'(A)') '' + write(*,'(A)') 'Extrapolated energies' + write(*,'(A)') '------------------------' + write(*,'(A)') '' + + print *, '' + print *, 'State ', 1 + print *, '' + write(*,*) '=========== ', '===================' + write(*,*) 'minimum PT2 ', 'Extrapolated energy' + write(*,*) '=========== ', '===================' + do k=2,min(N_iter,8) + write(*,'(F11.4,2X,F18.8)') pt2_iterations(1,N_iter+1-k), extrapolated_energy(k,1) + enddo + write(*,*) '=========== ', '===================' + + do i=2, min(N_states,N_det) + print *, '' + print *, 'State ', i + print *, '' + write(*,*) '=========== ', '=================== ', '=================== ', '===================' + write(*,*) 'minimum PT2 ', 'Extrapolated energy ', ' Excitation (a.u) ', ' Excitation (eV) ' + write(*,*) '=========== ', '=================== ', '=================== ', '===================' + do k=2,min(N_iter,8) + write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,N_iter+1-k), extrapolated_energy(k,i), & + extrapolated_energy(k,i) - extrapolated_energy(k,1), & + (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * 27.211396641308d0 + enddo + write(*,*) '=========== ', '=================== ', '=================== ', '===================' + enddo + + print *, '' + +end subroutine + diff --git a/src/iterations_tc/print_summary.irp.f b/src/iterations_tc/print_summary.irp.f new file mode 100644 index 00000000..8e6285e2 --- /dev/null +++ b/src/iterations_tc/print_summary.irp.f @@ -0,0 +1,104 @@ +subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s2_) + use selection_types + implicit none + BEGIN_DOC +! Print the extrapolated energy in the output + END_DOC + + integer, intent(in) :: n_det_, n_configuration_, n_st + double precision, intent(in) :: e_(n_st), s2_(n_st) + type(pt2_type) , intent(in) :: pt2_data, pt2_data_err + integer :: i, k + integer :: N_states_p + character*(9) :: pt2_string + character*(512) :: fmt + + if (do_pt2) then + pt2_string = ' ' + else + pt2_string = '(approx)' + endif + + N_states_p = min(N_det_,n_st) + + print *, '' + print '(A,I12)', 'Summary at N_det = ', N_det_ + print '(A)', '-----------------------------------' + print *, '' + + write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))' + write(*,fmt) + write(fmt,*) '(13X,', N_states_p, '(6X,A7,1X,I6,10X))' + write(*,fmt) ('State',k, k=1,N_states_p) + write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))' + write(*,fmt) + write(fmt,*) '(A13,', N_states_p, '(1X,F14.8,15X))' + write(*,fmt) '# E ', e_(1:N_states_p) + if (N_states_p > 1) then + write(*,fmt) '# Excit. (au)', e_(1:N_states_p)-e_(1) + write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*27.211396641308d0 + endif + write(fmt,*) '(A13,', 2*N_states_p, '(1X,F14.8))' + write(*,fmt) '# PT2 '//pt2_string, (pt2_data % pt2(k), pt2_data_err % pt2(k), k=1,N_states_p) + write(*,fmt) '# rPT2'//pt2_string, (pt2_data % rpt2(k), pt2_data_err % rpt2(k), k=1,N_states_p) + write(*,'(A)') '#' + write(*,fmt) '# E+PT2 ', (e_(k)+pt2_data % pt2(k),pt2_data_err % pt2(k), k=1,N_states_p) + write(*,fmt) '# E+rPT2 ', (e_(k)+pt2_data % rpt2(k),pt2_data_err % rpt2(k), k=1,N_states_p) + if (N_states_p > 1) then + write(*,fmt) '# Excit. (au)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1)), & + dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1)), k=1,N_states_p) + write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*27.211396641308d0, & + dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*27.211396641308d0, k=1,N_states_p) + endif + write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))' + write(*,fmt) + print *, '' + + print *, 'N_det = ', N_det_ + print *, 'N_states = ', n_st + if (s2_eig) then + print *, 'N_cfg = ', N_configuration_ + if (only_expected_s2) then + print *, 'N_csf = ', N_csf + endif + endif + print *, '' + + do k=1, N_states_p + print*,'* State ',k + print *, '< S^2 > = ', s2_(k) + print *, 'E = ', e_(k) + print *, 'Variance = ', pt2_data % variance(k), ' +/- ', pt2_data_err % variance(k) + print *, 'PT norm = ', dsqrt(pt2_data % overlap(k,k)), ' +/- ', 0.5d0*dsqrt(pt2_data % overlap(k,k)) * pt2_data_err % overlap(k,k) / (pt2_data % overlap(k,k)) + print *, 'PT2 = ', pt2_data % pt2(k), ' +/- ', pt2_data_err % pt2(k) + print *, 'rPT2 = ', pt2_data % rpt2(k), ' +/- ', pt2_data_err % rpt2(k) + print *, 'E+PT2 '//pt2_string//' = ', e_(k)+pt2_data % pt2(k), ' +/- ', pt2_data_err % pt2(k) + print *, 'E+rPT2'//pt2_string//' = ', e_(k)+pt2_data % rpt2(k), ' +/- ', pt2_data_err % rpt2(k) + print *, '' + enddo + + print *, '-----' + if(n_st.gt.1)then + print *, 'Variational Energy difference (au | eV)' + do i=2, N_states_p + print*,'Delta E = ', (e_(i) - e_(1)), & + (e_(i) - e_(1)) * 27.211396641308d0 + enddo + print *, '-----' + print*, 'Variational + perturbative Energy difference (au | eV)' + do i=2, N_states_p + print*,'Delta E = ', (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))), & + (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * 27.211396641308d0 + enddo + print *, '-----' + print*, 'Variational + renormalized perturbative Energy difference (au | eV)' + do i=2, N_states_p + print*,'Delta E = ', (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))), & + (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * 27.211396641308d0 + enddo + endif + +! call print_energy_components() + +end subroutine + diff --git a/src/three_body_ints/NEED b/src/ortho_three_e_ints/NEED similarity index 100% rename from src/three_body_ints/NEED rename to src/ortho_three_e_ints/NEED diff --git a/src/three_body_ints/io_6_index_tensor.irp.f b/src/ortho_three_e_ints/io_6_index_tensor.irp.f similarity index 100% rename from src/three_body_ints/io_6_index_tensor.irp.f rename to src/ortho_three_e_ints/io_6_index_tensor.irp.f diff --git a/src/three_body_ints/semi_num_ints_mo.irp.f b/src/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f similarity index 79% rename from src/three_body_ints/semi_num_ints_mo.irp.f rename to src/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f index 831ceb9b..a3f1b6ef 100644 --- a/src/three_body_ints/semi_num_ints_mo.irp.f +++ b/src/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f @@ -1,8 +1,29 @@ +subroutine give_integrals_3_body(i,j,m,k,l,n,integral) + implicit none + double precision, intent(out) :: integral + integer, intent(in) :: i,j,m,k,l,n + double precision :: weight + BEGIN_DOC +! + END_DOC + integer :: ipoint,mm + integral = 0.d0 + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + integral += weight * mos_in_r_array_transp(ipoint,i) * mos_in_r_array_transp(ipoint,k) * x_W_ij_erf_rk(ipoint,mm,m,n) * x_W_ij_erf_rk(ipoint,mm,j,l) + integral += weight * mos_in_r_array_transp(ipoint,j) * mos_in_r_array_transp(ipoint,l) * x_W_ij_erf_rk(ipoint,mm,m,n) * x_W_ij_erf_rk(ipoint,mm,i,k) + integral += weight * mos_in_r_array_transp(ipoint,m) * mos_in_r_array_transp(ipoint,n) * x_W_ij_erf_rk(ipoint,mm,j,l) * x_W_ij_erf_rk(ipoint,mm,i,k) + enddo + enddo +end BEGIN_PROVIDER [ double precision, mo_v_ij_erf_rk_cst_mu_naive, ( mo_num, mo_num,n_points_final_grid)] implicit none BEGIN_DOC ! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1 )/(2|r - R|) on the MO basis +! +! WARNING: not on the BI-ORTHO MOs END_DOC integer :: i,j,k,l,ipoint do ipoint = 1, n_points_final_grid @@ -23,6 +44,8 @@ BEGIN_PROVIDER [ double precision, mo_v_ij_erf_rk_cst_mu, ( mo_num, mo_num,n_poi implicit none BEGIN_DOC ! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the MO basis +! +! WARNING: not on the BI-ORTHO MOs END_DOC integer :: ipoint !$OMP PARALLEL & @@ -42,6 +65,8 @@ BEGIN_PROVIDER [ double precision, mo_v_ij_erf_rk_cst_mu_transp, ( n_points_fina implicit none BEGIN_DOC ! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the MO basis +! +! WARNING: not on the BI-ORTHO MOs END_DOC integer :: ipoint,i,j do i = 1, mo_num @@ -59,6 +84,8 @@ BEGIN_PROVIDER [ double precision, mo_x_v_ij_erf_rk_cst_mu_naive, ( mo_num, mo_n implicit none BEGIN_DOC ! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1 )/|r - R| on the MO basis +! +! WARNING: not on the BI-ORTHO MOs END_DOC integer :: i,j,k,l,ipoint,m do ipoint = 1, n_points_final_grid @@ -81,6 +108,8 @@ BEGIN_PROVIDER [ double precision, mo_x_v_ij_erf_rk_cst_mu, ( mo_num, mo_num,3,n implicit none BEGIN_DOC ! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/2|r - R| on the MO basis +! +! WARNING: not on the BI-ORTHO MOs END_DOC integer :: ipoint,m !$OMP PARALLEL & @@ -119,6 +148,8 @@ BEGIN_PROVIDER [ double precision, x_W_ij_erf_rk, ( n_points_final_grid,3,mo_num implicit none BEGIN_DOC ! W_mn^X(R) = \int dr phi_m(r) phi_n(r) (1 - erf(mu |r-R|)) (x-X) +! +! WARNING: not on the BI-ORTHO MOs END_DOC include 'constants.include.F' integer :: ipoint,m,i,j @@ -160,48 +191,3 @@ BEGIN_PROVIDER [ double precision, sqrt_weight_at_r, (n_points_final_grid)] enddo END_PROVIDER -!BEGIN_PROVIDER [ double precision, mos_in_r_array_transp_sq_weight, (n_points_final_grid,mo_num)] - - -!BEGIN_PROVIDER [ double precision, gauss_ij_rk_transp, (ao_num, ao_num, n_points_final_grid) ] -! implicit none -! integer :: i,j,ipoint -! do ipoint = 1, n_points_final_grid -! do j = 1, ao_num -! do i = 1, ao_num -! gauss_ij_rk_transp(i,j,ipoint) = gauss_ij_rk(ipoint,i,j) -! enddo -! enddo -! enddo -!END_PROVIDER -! -! -!BEGIN_PROVIDER [ double precision, mo_gauss_ij_rk, ( mo_num, mo_num,n_points_final_grid)] -! implicit none -! integer :: ipoint -! !$OMP PARALLEL & -! !$OMP DEFAULT (NONE) & -! !$OMP PRIVATE (ipoint) & -! !$OMP SHARED (n_points_final_grid,gauss_ij_rk_transp,mo_gauss_ij_rk) -! !$OMP DO SCHEDULE (dynamic) -! do ipoint = 1, n_points_final_grid -! call ao_to_mo(gauss_ij_rk_transp(1,1,ipoint),size(gauss_ij_rk_transp,1),mo_gauss_ij_rk(1,1,ipoint),size(mo_gauss_ij_rk,1)) -! enddo -! !$OMP END DO -! !$OMP END PARALLEL -! -!END_PROVIDER -! -!BEGIN_PROVIDER [ double precision, mo_gauss_ij_rk_transp, (n_points_final_grid, mo_num, mo_num)] -! implicit none -! integer :: i,j,ipoint -! do ipoint = 1, n_points_final_grid -! do j = 1, mo_num -! do i = 1, mo_num -! mo_gauss_ij_rk_transp(ipoint,i,j) = mo_gauss_ij_rk(i,j,ipoint) -! enddo -! enddo -! enddo -! -!END_PROVIDER -! diff --git a/src/tc_bi_ortho/12.tc_bi_ortho.bats b/src/tc_bi_ortho/12.tc_bi_ortho.bats new file mode 100644 index 00000000..f5b9d8c0 --- /dev/null +++ b/src/tc_bi_ortho/12.tc_bi_ortho.bats @@ -0,0 +1,49 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh +source $QP_ROOT/quantum_package.rc + + +function run_Ne() { + qp set_file Ne_tc_scf + qp run cisd + qp run tc_bi_ortho | tee Ne_tc_scf.cisd_tc_bi_ortho.out + eref=-128.77020441279302 + energy="$(grep "eigval_right_tc_bi_orth =" Ne_tc_scf.cisd_tc_bi_ortho.out)" + eq $energy $eref 1e-6 +} + + +@test "Ne" { + run_Ne +} + + +function run_C() { + qp set_file C_tc_scf + qp run cisd + qp run tc_bi_ortho | tee C_tc_scf.cisd_tc_bi_ortho.out + eref=-37.757536149952514 + energy="$(grep "eigval_right_tc_bi_orth =" C_tc_scf.cisd_tc_bi_ortho.out)" + eq $energy $eref 1e-6 +} + + +@test "C" { + run_C +} + +function run_O() { + qp set_file C_tc_scf + qp run cisd + qp run tc_bi_ortho | tee O_tc_scf.cisd_tc_bi_ortho.out + eref=-74.908518517716161 + energy="$(grep "eigval_right_tc_bi_orth =" O_tc_scf.cisd_tc_bi_ortho.out)" + eq $energy $eref 1e-6 +} + + +@test "O" { + run_O +} + diff --git a/src/tc_bi_ortho/EZFIO.cfg b/src/tc_bi_ortho/EZFIO.cfg new file mode 100644 index 00000000..a34d2134 --- /dev/null +++ b/src/tc_bi_ortho/EZFIO.cfg @@ -0,0 +1,11 @@ +[psi_l_coef_bi_ortho] +interface: ezfio +doc: Coefficients for the left wave function +type: double precision +size: (determinants.n_det,determinants.n_states) + +[psi_r_coef_bi_ortho] +interface: ezfio +doc: Coefficients for the right wave function +type: double precision +size: (determinants.n_det,determinants.n_states) diff --git a/src/tc_bi_ortho/NEED b/src/tc_bi_ortho/NEED new file mode 100644 index 00000000..9a0c20ef --- /dev/null +++ b/src/tc_bi_ortho/NEED @@ -0,0 +1,6 @@ +bi_ort_ints +bi_ortho_mos +tc_keywords +non_hermit_dav +dav_general_mat +tc_scf diff --git a/src/tc_bi_ortho/compute_deltamu_right.irp.f b/src/tc_bi_ortho/compute_deltamu_right.irp.f new file mode 100644 index 00000000..7ca2c890 --- /dev/null +++ b/src/tc_bi_ortho/compute_deltamu_right.irp.f @@ -0,0 +1,53 @@ +program compute_deltamu_right + + implicit none + + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + read_wf = .True. + touch read_wf + + PROVIDE N_int + call delta_right() + +end + +! --- + +subroutine delta_right() + + implicit none + integer :: k + double precision, allocatable :: delta(:,:) + + print *, j1b_type + print *, j1b_pen + print *, mu_erf + + allocate( delta(N_det,N_states) ) + delta = 0.d0 + + do k = 1, N_states + !do k = 1, 1 + + ! get < I_left | H_mu - H | psi_right > + !call get_h_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k)) + call get_delta_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k)) + + ! order as QMCCHEM + call dset_order(delta(:,k), psi_bilinear_matrix_order, N_det) + + enddo + +! call ezfio_set_dmc_dress_dmc_delta_h(delta) + + deallocate(delta) + + return +end subroutine delta_right + +! --- + diff --git a/src/tc_bi_ortho/dressing_vectors_lr.irp.f b/src/tc_bi_ortho/dressing_vectors_lr.irp.f new file mode 100644 index 00000000..08913bab --- /dev/null +++ b/src/tc_bi_ortho/dressing_vectors_lr.irp.f @@ -0,0 +1,155 @@ + +! --- + +subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta) + + BEGIN_DOC + ! + ! delta(I) = < I_left | H_TC - H | Psi_right > + ! + END_DOC + + use bitmasks + + implicit none + + integer, intent(in) :: ndet, Nint + double precision, intent(in) :: psicoef(ndet) + integer(bit_kind), intent(in) :: psidet(Nint,2,ndet) + double precision, intent(out) :: delta(ndet) + + integer :: i, j + double precision :: h_mono, h_twoe, h_tot + double precision :: htc_mono, htc_twoe, htc_three, htc_tot + double precision :: delta_mat + + print *, ' get_delta_bitc_right ...' + + i = 1 + j = 1 + call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) + call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot) + + delta = 0.d0 + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(delta, ndet, psidet, psicoef, Nint) & + !$OMP PRIVATE(i, j, delta_mat, h_mono, h_twoe, h_tot, & + !$OMP htc_mono, htc_twoe, htc_three, htc_tot) + do i = 1, ndet + do j = 1, ndet + + ! < I | Htilde | J > + call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) + ! < I | H | J > + call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot) + + delta_mat = htc_tot - h_tot + + delta(i) = delta(i) + psicoef(j) * delta_mat + enddo + enddo + !$OMP END PARALLEL DO + +end subroutine get_delta_bitc_right + +! --- + +subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta) + + BEGIN_DOC + ! + ! delta(I) = < I_left | H_TC | Psi_right > + ! + END_DOC + + use bitmasks + + implicit none + + integer, intent(in) :: ndet, Nint + double precision, intent(in) :: psicoef(ndet) + integer(bit_kind), intent(in) :: psidet(Nint,2,ndet) + double precision, intent(out) :: delta(ndet) + + integer :: i, j + double precision :: htc_mono, htc_twoe, htc_three, htc_tot + + print *, ' get_htc_bitc_right ...' + + i = 1 + j = 1 + call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) + + delta = 0.d0 + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(delta, ndet, psidet, psicoef, Nint) & + !$OMP PRIVATE(i, j, htc_mono, htc_twoe, htc_three, htc_tot) + do i = 1, ndet + do j = 1, ndet + + ! < I | Htilde | J > + call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) + + delta(i) = delta(i) + psicoef(j) * htc_tot + enddo + enddo + !$OMP END PARALLEL DO + +end subroutine get_htc_bitc_right + +! --- + +subroutine get_h_bitc_right(psidet, psicoef, ndet, Nint, delta) + + BEGIN_DOC + ! + ! delta(I) = < I_left | H | Psi_right > + ! + END_DOC + + use bitmasks + + implicit none + + integer, intent(in) :: ndet, Nint + double precision, intent(in) :: psicoef(ndet) + integer(bit_kind), intent(in) :: psidet(Nint,2,ndet) + double precision, intent(out) :: delta(ndet) + + integer :: i, j + double precision :: h_mono, h_twoe, h_tot + + print *, ' get_h_bitc_right ...' + + i = 1 + j = 1 + call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot) + + !double precision :: norm + !norm = 0.d0 + !do i = 1, ndet + ! norm += psicoef(i) * psicoef(i) + !enddo + !print*, ' norm = ', norm + + call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot) + + delta = 0.d0 +! !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & +! !$OMP SHARED(delta, ndet, psidet, psicoef, Nint) & +! !$OMP PRIVATE(i, j, h_mono, h_twoe, h_tot) + do i = 1, ndet + do j = 1, ndet + + ! < I | H | J > + call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot) + + delta(i) = delta(i) + psicoef(j) * h_tot + enddo + enddo +! !$OMP END PARALLEL DO + +end subroutine get_h_bitc_right + +! --- + diff --git a/src/tc_bi_ortho/e_corr_bi_ortho.irp.f b/src/tc_bi_ortho/e_corr_bi_ortho.irp.f new file mode 100644 index 00000000..ec66a8b5 --- /dev/null +++ b/src/tc_bi_ortho/e_corr_bi_ortho.irp.f @@ -0,0 +1,104 @@ + use bitmasks ! you need to include the bitmasks_module.f90 features + BEGIN_PROVIDER [ double precision, e_tilde_00] + implicit none + double precision :: hmono,htwoe,hthree,htot + call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot) + e_tilde_00 = htot + END_PROVIDER + + BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth] +&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_single] +&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_double] + implicit none + integer :: i,degree + double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e + e_pt2_tc_bi_orth = 0.d0 + e_pt2_tc_bi_orth_single = 0.d0 + e_pt2_tc_bi_orth_double = 0.d0 + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree == 1 .or. degree == 2)then + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + delta_e = e_tilde_00 - e_i0 + coef_pt1 = htilde_ij / delta_e + call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + e_pt2_tc_bi_orth += coef_pt1 * htilde_ij + if(degree == 1)then + e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij + else +! print*,'coef_pt1, e_pt2',coef_pt1,coef_pt1 * htilde_ij + e_pt2_tc_bi_orth_double += coef_pt1 * htilde_ij + endif + endif + enddo + END_PROVIDER + + BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00] + implicit none + double precision :: hmono,htwoe,hthree,htilde_ij + call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00) + e_tilde_bi_orth_00 += nuclear_repulsion + END_PROVIDER + + BEGIN_PROVIDER [ double precision, e_corr_bi_orth ] +&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj ] +&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth ] +&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth ] + implicit none + integer :: i,degree + double precision :: hmono,htwoe,hthree,htilde_ij + + e_corr_bi_orth = 0.d0 + e_corr_single_bi_orth = 0.d0 + e_corr_double_bi_orth = 0.d0 + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + if(degree == 1)then + e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1) + else if(degree == 2)then + e_corr_double_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1) +! print*,'coef_wf , e_cor',reigvec_tc_bi_orth(i,1)/reigvec_tc_bi_orth(1,1), reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1) + endif + enddo + e_corr_bi_orth_proj = e_corr_single_bi_orth + e_corr_double_bi_orth + e_corr_bi_orth = eigval_right_tc_bi_orth(1) - e_tilde_bi_orth_00 + END_PROVIDER + + BEGIN_PROVIDER [ double precision, e_tc_left_right ] + implicit none + integer :: i,j + double precision :: hmono,htwoe,hthree,htilde_ij,accu + e_tc_left_right = 0.d0 + accu = 0.d0 + do i = 1, N_det + accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1) + do j = 1, N_det + call htilde_mu_mat_bi_ortho(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1) + enddo + enddo + e_tc_left_right *= 1.d0/accu + e_tc_left_right += nuclear_repulsion + + END_PROVIDER + + +BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)] + implicit none + integer :: i,degree + double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree==0)then + coef_pt1_bi_ortho(i) = 1.d0 + else + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + delta_e = e_tilde_00 - e_i0 + coef_pt1 = htilde_ij / delta_e + coef_pt1_bi_ortho(i)= coef_pt1 + endif + enddo +END_PROVIDER diff --git a/src/tc_bi_ortho/h_biortho.irp.f b/src/tc_bi_ortho/h_biortho.irp.f new file mode 100644 index 00000000..492e1282 --- /dev/null +++ b/src/tc_bi_ortho/h_biortho.irp.f @@ -0,0 +1,243 @@ + +! -- + +subroutine hmat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, htot) + + BEGIN_DOC + ! + ! < key_j | H | key_i > where | key_j > is developed on the LEFT basis and | key_i > is developed on the RIGHT basis + ! + END_DOC + + use bitmasks + + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hmono, htwoe, htot + + integer :: degree + + hmono = 0.d0 + htwoe = 0.d0 + htot = 0.d0 + + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree .gt. 2) return + + if(degree == 0) then + + call diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe) + htot = htot + nuclear_repulsion + + else if (degree == 1) then + + call single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe) + + else if(degree == 2) then + + call double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe) + + endif + + htot += hmono + htwoe + + return +end subroutine hmat_bi_ortho + +! --- + +subroutine diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe) + + use bitmasks + + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe + + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin + + hmono = 0.d0 + htwoe = 0.d0 + + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + + do ispin = 1, 2 + do i = 1, Ne(ispin) + ii = occ(i,ispin) + hmono += mo_bi_ortho_one_e(ii,ii) + enddo + enddo + + ! alpha/beta two-body + ispin = 1 + jspin = 2 + do i = 1, Ne(ispin) ! electron 1 + ii = occ(i,ispin) + do j = 1, Ne(jspin) ! electron 2 + jj = occ(j,jspin) + htwoe += mo_bi_ortho_coul_e(jj,ii,jj,ii) + enddo + enddo + + ! alpha/alpha two-body + do i = 1, Ne(ispin) + ii = occ(i,ispin) + do j = i+1, Ne(ispin) + jj = occ(j,ispin) + htwoe += mo_bi_ortho_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii) + enddo + enddo + + ! beta/beta two-body + do i = 1, Ne(jspin) + ii = occ(i,jspin) + do j = i+1, Ne(jspin) + jj = occ(j,jspin) + htwoe += mo_bi_ortho_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii) + enddo + enddo + + return +end subroutine diag_hmat_bi_ortho + +! --- + +subroutine single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe) + + BEGIN_DOC + ! + ! < key_j | H | key_i > for single excitation + ! + END_DOC + + use bitmasks + + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe + + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, ispin, jspin + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + integer :: other_spin(2) + double precision :: phase + + other_spin(1) = 2 + other_spin(2) = 1 + + hmono = 0.d0 + htwoe = 0.d0 + + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree .ne. 1) then + return + endif + + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + + call get_single_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2) + + hmono = mo_bi_ortho_one_e(p1,h1) * phase + + ! alpha/beta two-body + ispin = other_spin(s1) + if(s1 == 1) then + + ! single alpha + do i = 1, Ne(ispin) ! electron 2 + ii = occ(i,ispin) + htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1) + enddo + + else + + ! single beta + do i = 1, Ne(ispin) ! electron 1 + ii = occ(i,ispin) + htwoe += mo_bi_ortho_coul_e(p1,ii,h1,ii) + enddo + + endif + + ! same spin two-body + do i = 1, Ne(s1) + ii = occ(i,s1) + ! ( h1 p1 |ii ii ) - ( h1 ii | p1 ii ) + htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1) - mo_bi_ortho_coul_e(p1,ii,ii,h1) + enddo + + htwoe *= phase + +end subroutine single_hmat_bi_ortho + +! --- + +subroutine double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe) + + BEGIN_DOC + ! + ! < key_j | H | key_i> for double excitation + ! + END_DOC + + use bitmasks + + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe + + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, ispin, jspin + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + integer :: other_spin(2) + double precision :: phase + + other_spin(1) = 2 + other_spin(2) = 1 + + call get_excitation_degree(key_i, key_j, degree, Nint) + + hmono = 0.d0 + htwoe = 0.d0 + + if(degree .ne. 2) then + return + endif + + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + + call get_double_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + + if(s1 .ne. s2) then + + htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1) + + else + + ! same spin two-body + + ! direct terms exchange terms + htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1) - mo_bi_ortho_coul_e(p1,p2,h2,h1) + + endif + + htwoe *= phase + +end subroutine double_hmat_bi_ortho + +! --- + + diff --git a/src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f b/src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f new file mode 100644 index 00000000..b7129d36 --- /dev/null +++ b/src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f @@ -0,0 +1,92 @@ +subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze) + + use bitmasks + + BEGIN_DOC + ! Application of H_TC on a vector + ! + ! v(i,istate) = \sum_j u(j,istate) H_TC(i,j), with: + ! H_TC(i,j) = < Di | H_TC | Dj > + ! + END_DOC + + implicit none + + integer, intent(in) :: N_st, sze + double precision, intent(in) :: u(sze,N_st) + double precision, intent(inout) :: v(sze,N_st) + + integer :: i, j, istate + double precision :: htot + + PROVIDE N_int + PROVIDE psi_det + + + ! TODO : transform it with the bi-linear representation in terms of alpha-beta. + + i = 1 + j = 1 + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot) + + v = 0.d0 + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(N_st, sze, N_int, psi_det, u, v) & + !$OMP PRIVATE(istate, i, j, htot) + do istate = 1, N_st + do i = 1, sze + do j = 1, sze + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot) + v(i,istate) = v(i,istate) + htot * u(j,istate) + enddo + enddo + enddo + !$OMP END PARALLEL DO + +end + +subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze) + + use bitmasks + + BEGIN_DOC + ! Application of (H_TC)^dagger on a vector + ! + ! v(i,istate) = \sum_j u(j,istate) H_TC(j,i), with: + ! H_TC(i,j) = < Di | H_TC | Dj > + ! + END_DOC + + implicit none + + integer, intent(in) :: N_st, sze + double precision, intent(in) :: u(sze,N_st) + double precision, intent(inout) :: v(sze,N_st) + + integer :: i, j, istate + double precision :: htot + + PROVIDE N_int + PROVIDE psi_det + + i = 1 + j = 1 + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot) + + v = 0.d0 + + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(N_st, sze, N_int, psi_det, u, v) & + !$OMP PRIVATE(istate, i, j, htot) + do istate = 1, N_st + do i = 1, sze + do j = 1, sze + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot) + v(i,istate) = v(i,istate) + htot * u(j,istate) + enddo + enddo + enddo + !$OMP END PARALLEL DO + +end + diff --git a/src/tc_bi_ortho/normal_ordered.irp.f b/src/tc_bi_ortho/normal_ordered.irp.f new file mode 100644 index 00000000..81f5fb2c --- /dev/null +++ b/src/tc_bi_ortho/normal_ordered.irp.f @@ -0,0 +1,319 @@ +BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth, (mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! Normal ordering of the three body interaction on the HF density + END_DOC + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + + integer :: i,h1,p1,h2,p2 + integer :: hh1,hh2,pp1,pp2 + integer :: Ne(2) + integer, allocatable :: occ(:,:) + integer(bit_kind), allocatable :: key_i_core(:,:) + double precision :: hthree_aba,hthree_aaa,hthree_aab + double precision :: wall0,wall1 + + PROVIDE N_int + + allocate( occ(N_int*bit_kind_size,2) ) + allocate( key_i_core(N_int,2) ) + + if(core_tc_op) then + do i = 1, N_int + key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core,occ,Ne,N_int) + else + call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int) + endif + + normal_two_body_bi_orth = 0.d0 + print*,'Providing normal_two_body_bi_orth ...' + call wall_time(wall0) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, hthree_aba, hthree_aab, hthree_aaa) & + !$OMP SHARED (N_int, n_act_orb, list_act, Ne, occ, normal_two_body_bi_orth) + !$OMP DO SCHEDULE (static) + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do pp2 = 1, n_act_orb + p2 = list_act(pp2) + ! opposite spin double excitations + call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aba) + ! same spin double excitations with opposite spin contributions + if(h1h2 + ! same spin double excitations with same spin contributions + if(Ne(2).ge.3)then + call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2 + else + hthree_aaa = 0.d0 + endif + else + call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab) + if(Ne(2).ge.3)then + call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa) + else + hthree_aaa = 0.d0 + endif + endif + normal_two_body_bi_orth(p2,h2,p1,h1) = 0.5d0*(hthree_aba + hthree_aab + hthree_aaa) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,'Wall time for normal_two_body_bi_orth ',wall1-wall0 + + deallocate( occ ) + deallocate( key_i_core ) + +END_PROVIDER + + + +subroutine give_aba_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree) + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer, intent(in) :: Nint, h1, h2, p1, p2 + integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2) + double precision, intent(out) :: hthree + integer :: ii, i + double precision :: int_direct, int_exc_12, int_exc_13, integral + + !!!! double alpha/beta + hthree = 0.d0 + do ii = 1, Ne(2) ! purely closed shell part + i = occ(ii,2) + call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral) + int_exc_13 = -1.d0 * integral + call give_integrals_3_body_bi_ort(p2, i,p1,i,h2,h1,integral) + int_exc_12 = -1.d0 * integral + hthree += 2.d0 * int_direct - 1.d0 * ( int_exc_13 + int_exc_12) + enddo + do ii = Ne(2) + 1, Ne(1) ! purely open-shell part + i = occ(ii,1) + call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral) + int_exc_13 = -1.d0 * integral + call give_integrals_3_body_bi_ort(p2, i,p1,i,h2,h1,integral) + int_exc_12 = -1.d0 * integral + hthree += 1.d0 * int_direct - 0.5d0* ( int_exc_13 + int_exc_12) + enddo + +end subroutine give_aba_contraction + + + +BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_ab, (mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! Normal ordered two-body sector of the three-body terms for opposite spin double excitations + END_DOC + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer :: h1, p1, h2, p2, i + integer :: hh1, hh2, pp1, pp2 + integer :: Ne(2) + integer, allocatable :: occ(:,:) + integer(bit_kind), allocatable :: key_i_core(:,:) + double precision :: hthree + + PROVIDE N_int + + allocate( key_i_core(N_int,2) ) + allocate( occ(N_int*bit_kind_size,2) ) + + if(core_tc_op)then + do i = 1, N_int + key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core,occ,Ne,N_int) + else + call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int) + endif + normal_two_body_bi_orth_ab = 0.d0 + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do pp2 = 1, n_act_orb + p2 = list_act(pp2) + call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree) + normal_two_body_bi_orth_ab(p2,h2,p1,h1) = hthree + enddo + enddo + enddo + enddo + + deallocate( key_i_core ) + deallocate( occ ) + +END_PROVIDER + + + +BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_aa_bb, (n_act_orb, n_act_orb, n_act_orb, n_act_orb)] + + BEGIN_DOC + ! Normal ordered two-body sector of the three-body terms for same spin double excitations + END_DOC + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer :: i,ii,j,h1,p1,h2,p2 + integer :: hh1,hh2,pp1,pp2 + integer :: Ne(2) + integer, allocatable :: occ(:,:) + integer(bit_kind), allocatable :: key_i_core(:,:) + double precision :: hthree_aab, hthree_aaa + + PROVIDE N_int + + allocate( key_i_core(N_int,2) ) + allocate( occ(N_int*bit_kind_size,2) ) + + if(core_tc_op)then + do i = 1, N_int + key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, N_int) + else + call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) + endif + + normal_two_body_bi_orth_aa_bb = 0.d0 + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + do pp1 = 1 , n_act_orb + p1 = list_act(pp1) + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do pp2 = 1 , n_act_orb + p2 = list_act(pp2) + if(h1h2 + if(Ne(2).ge.3)then + call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2 + else + hthree_aaa = 0.d0 + endif + else + call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab) + if(Ne(2).ge.3)then + call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa) + else + hthree_aaa = 0.d0 + endif + endif + normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) = hthree_aab + hthree_aaa + enddo + enddo + enddo + enddo + + deallocate( key_i_core ) + deallocate( occ ) + +END_PROVIDER + + + +subroutine give_aaa_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree) + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer, intent(in) :: Nint, h1, h2, p1, p2 + integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2) + double precision, intent(out) :: hthree + integer :: ii,i + double precision :: int_direct,int_exc_12,int_exc_13,int_exc_23 + double precision :: integral,int_exc_l,int_exc_ll + + hthree = 0.d0 + do ii = 1, Ne(2) ! purely closed shell part + i = occ(ii,2) + call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p2,p1,i ,i,h2,h1,integral) + int_exc_l = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,i ,p2,i,h2,h1,integral) + int_exc_ll= -1.d0 * integral + call give_integrals_3_body_bi_ort(p2,i ,p1,i,h2,h1,integral) + int_exc_12= -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral) + int_exc_13= -1.d0 * integral + call give_integrals_3_body_bi_ort(i ,p1,p2,i,h2,h1,integral) + int_exc_23= -1.d0 * integral + + hthree += 1.d0 * int_direct + int_exc_l + int_exc_ll -( int_exc_12+ int_exc_13+ int_exc_23 ) + enddo + do ii = Ne(2)+1,Ne(1) ! purely open-shell part + i = occ(ii,1) + call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p2,p1,i ,i,h2,h1,integral) + int_exc_l = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,i ,p2,i,h2,h1,integral) + int_exc_ll= -1.d0 * integral + call give_integrals_3_body_bi_ort(p2,i ,p1,i,h2,h1,integral) + int_exc_12= -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral) + int_exc_13= -1.d0 * integral + call give_integrals_3_body_bi_ort(i ,p1,p2,i,h2,h1,integral) + int_exc_23= -1.d0 * integral + + hthree += 1.d0 * int_direct + 0.5d0 * (int_exc_l + int_exc_ll -( int_exc_12+ int_exc_13+ int_exc_23 )) + enddo + +end subroutine give_aaa_contraction + + + +subroutine give_aab_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree) + implicit none + use bitmasks ! you need to include the bitmasks_module.f90 features + integer, intent(in) :: Nint, h1, h2, p1, p2 + integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2) + double precision, intent(out) :: hthree + integer :: ii, i + double precision :: int_direct, int_exc_12, int_exc_13, int_exc_23 + double precision :: integral, int_exc_l, int_exc_ll + + hthree = 0.d0 + do ii = 1, Ne(2) ! purely closed shell part + i = occ(ii,2) + call give_integrals_3_body_bi_ort(p2,p1,i,h2,h1,i,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2,i,h2,h1,i,integral) + int_exc_23= -1.d0 * integral + hthree += 1.d0 * int_direct - int_exc_23 + enddo + +end subroutine give_aab_contraction diff --git a/src/tc_bi_ortho/print_he_tc_energy.irp.f b/src/tc_bi_ortho/print_he_tc_energy.irp.f new file mode 100644 index 00000000..84d34bcb --- /dev/null +++ b/src/tc_bi_ortho/print_he_tc_energy.irp.f @@ -0,0 +1,142 @@ + +! --- + +program print_he_tc_energy + + implicit none + + call print_overlap() + + call print_energy1() + +end + +! --- + +subroutine print_overlap() + + implicit none + integer :: i, j, k, l + double precision :: S_ij + + print *, ' ao_overlap:' + do i = 1, ao_num + do j = 1, ao_num + print *, j, i, ao_overlap(j,i) + enddo + enddo + + print *, ' mo_overlap:' + do i = 1, mo_num + do j = 1, mo_num + + S_ij = 0.d0 + do k = 1, ao_num + do l = 1, ao_num + S_ij += mo_l_coef(k,i) * ao_overlap(k,l) * mo_r_coef(l,j) + enddo + enddo + + print *, i, j, S_ij + enddo + enddo + +end subroutine print_overlap + +! --- + +subroutine print_energy1() + + implicit none + integer :: i, j, k, l + double precision :: e, n, e_tmp, n_tmp, e_ns + double precision, external :: ao_two_e_integral + + e = 0.d0 + n = 0.d0 + + ! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + ! < phi_1 phi_1 | h1 | phi_1 phi_1 > + + e_tmp = 0.d0 + n_tmp = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + e_tmp += mo_l_coef(i,1) * ao_one_e_integrals(i,j) * mo_r_coef(j,1) + n_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1) + enddo + enddo + + e += e_tmp * n_tmp + + ! --- + + ! < phi_1 phi_1 | h2 | phi_1 phi_1 > + + e_tmp = 0.d0 + n_tmp = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + n_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1) + e_tmp += mo_l_coef(i,1) * ao_one_e_integrals(i,j) * mo_r_coef(j,1) + enddo + enddo + + e += e_tmp * n_tmp + + ! --- + + ! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + ! --- + + e_ns = 0.d0 + + do i = 1, ao_num + do j = 1, ao_num + do k = 1, ao_num + do l = 1, ao_num + + ! ao_two_e_tc_tot(i,j,k,l) = + e += mo_l_coef(i,1) * mo_l_coef(k,1) * ao_two_e_tc_tot(i,j,k,l) * mo_r_coef(j,1) * mo_r_coef(l,1) + + e_ns += mo_l_coef(i,1) * mo_l_coef(k,1) * ao_non_hermit_term_chemist(i,j,k,l) * mo_r_coef(j,1) * mo_r_coef(l,1) + enddo + enddo + enddo + enddo + + ! --- + + ! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + ! --- + + ! < phi_1 phi_1 | phi_1 phi_1 > + e_tmp = 0.d0 + n_tmp = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + e_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1) + n_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1) + enddo + enddo + + n += e_tmp * n_tmp + + ! --- + + ! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + e = e / n + e_ns = e_ns / n + + print *, ' tc energy = ', e + print *, ' non-sym energy = ', e_ns + +end subroutine print_energy1 + +! --- + + diff --git a/src/tc_bi_ortho/print_tc_wf.irp.f b/src/tc_bi_ortho/print_tc_wf.irp.f new file mode 100644 index 00000000..58a733a7 --- /dev/null +++ b/src/tc_bi_ortho/print_tc_wf.irp.f @@ -0,0 +1,104 @@ +program print_tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid +! if(three_body_h_tc)then +! call provide_all_three_ints_bi_ortho +! endif +! call routine + call write_l_r_wf +end + +subroutine write_l_r_wf + implicit none + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + output=trim(ezfio_filename)//'.tc_wf' + i_unit_output = getUnitAndOpen(output,'w') + integer :: i + print*,'Writing the left-right wf' + do i = 1, N_det + write(i_unit_output,*)i,psi_l_coef_sorted_bi_ortho_left(i),psi_r_coef_sorted_bi_ortho_right(i) + enddo + + +end + +subroutine routine + implicit none + integer :: i,degree + integer :: exc(0:2,2,2),h1,p1,s1,h2,p2,s2 + double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e,e_pt2 + double precision :: contrib_pt,e_corr,coef,contrib,phase + double precision :: accu_positive,accu_positive_pt, accu_positive_core,accu_positive_core_pt + e_pt2 = 0.d0 + accu_positive = 0.D0 + accu_positive_pt = 0.D0 + accu_positive_core = 0.d0 + accu_positive_core_pt = 0.d0 + + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree == 1 .or. degree == 2)then + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + delta_e = e_tilde_00 - e_i0 + coef_pt1 = htilde_ij / delta_e + + call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + contrib_pt = coef_pt1 * htilde_ij + e_pt2 += contrib_pt + + coef = psi_r_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1) + contrib = coef * htilde_ij + e_corr += contrib + call get_excitation(HF_bitmask,psi_det(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + print*,'*********' + if(degree==1)then + print*,'s1',s1 + print*,'h1,p1 = ',h1,p1 + else if(degree ==2)then + print*,'s1',s1 + print*,'h1,p1 = ',h1,p1 + print*,'s2',s2 + print*,'h2,p2 = ',h2,p2 + endif + print*,'coef_pt1 = ',coef_pt1 + print*,'coef = ',coef + print*,'contrib_pt ',contrib_pt + print*,'contrib = ',contrib + if(contrib.gt.0.d0)then + accu_positive += contrib + if(h1==1.or.h2==1)then + accu_positive_core += contrib + endif + if(dabs(contrib).gt.1.d-5)then + print*,'Found a positive contribution to correlation energy !!' + endif + endif + if(contrib_pt.gt.0.d0)then + accu_positive_pt += contrib_pt + if(h2==1.or.h1==1)then + accu_positive_core_pt += contrib_pt + endif + endif + endif + enddo + print*,'' + print*,'' + print*,'Total correlation energy = ',e_corr + print*,'Total correlation energy PT = ',e_pt2 + print*,'Positive contribution to ecorr = ',accu_positive + print*,'Positive contribution to ecorr PT = ',accu_positive_pt + print*,'Pure core contribution = ',accu_positive_core + print*,'Pure core contribution PT = ',accu_positive_core_pt +end diff --git a/src/tc_bi_ortho/psi_det_tc_sorted.irp.f b/src/tc_bi_ortho/psi_det_tc_sorted.irp.f new file mode 100644 index 00000000..212c8588 --- /dev/null +++ b/src/tc_bi_ortho/psi_det_tc_sorted.irp.f @@ -0,0 +1,157 @@ +use bitmasks + +BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_tc, (psi_det_size) ] + implicit none + BEGIN_DOC + ! Contribution of determinants to the state-averaged density. + END_DOC + integer :: i,j,k + double precision :: f + + psi_average_norm_contrib_tc(:) = 0.d0 + do k=1,N_states + do i=1,N_det + psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i) + & + dabs(psi_l_coef_bi_ortho(i,k)*psi_r_coef_bi_ortho(i,k))*state_average_weight(k) + enddo + enddo + f = 1.d0/sum(psi_average_norm_contrib_tc(1:N_det)) + do i=1,N_det + psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i)*f + enddo +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted_tc, (psi_det_size) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_tc_order, (psi_det_size) ] + implicit none + BEGIN_DOC + ! Wave function sorted by determinants contribution to the norm (state-averaged) + ! + ! psi_det_sorted_tc_order(i) -> k : index in psi_det + END_DOC + integer :: i,j,k + integer, allocatable :: iorder(:) + allocate ( iorder(N_det) ) + do i=1,N_det + psi_average_norm_contrib_sorted_tc(i) = -psi_average_norm_contrib_tc(i) + iorder(i) = i + enddo + call dsort(psi_average_norm_contrib_sorted_tc,iorder,N_det) + do i=1,N_det + do j=1,N_int + psi_det_sorted_tc(j,1,i) = psi_det(j,1,iorder(i)) + psi_det_sorted_tc(j,2,i) = psi_det(j,2,iorder(i)) + enddo + psi_average_norm_contrib_sorted_tc(i) = -psi_average_norm_contrib_sorted_tc(i) + psi_det_sorted_tc_order(iorder(i)) = i + enddo + double precision :: accu + do k=1,N_states + accu = 0.d0 + do i=1,N_det + psi_coef_sorted_tc(i,k) = dsqrt(dabs(psi_l_coef_bi_ortho(iorder(i),k)*psi_r_coef_bi_ortho(iorder(i),k))) + accu += psi_coef_sorted_tc(i,k)**2 + enddo + accu = 1.d0/dsqrt(accu) + do i=1,N_det + psi_coef_sorted_tc(i,k) *= accu + enddo + enddo + + psi_det_sorted_tc(:,:,N_det+1:psi_det_size) = 0_bit_kind + psi_coef_sorted_tc(N_det+1:psi_det_size,:) = 0.d0 + psi_average_norm_contrib_sorted_tc(N_det+1:psi_det_size) = 0.d0 + psi_det_sorted_tc_order(N_det+1:psi_det_size) = 0 + + deallocate(iorder) + +END_PROVIDER + + BEGIN_PROVIDER [double precision, psi_r_coef_sorted_bi_ortho, (psi_det_size, N_states)] +&BEGIN_PROVIDER [double precision, psi_l_coef_sorted_bi_ortho, (psi_det_size, N_states)] + BEGIN_DOC + ! psi_r_coef_sorted_bi_ortho : right coefficients corresponding to psi_det_sorted_tc + ! psi_l_coef_sorted_bi_ortho : left coefficients corresponding to psi_det_sorted_tc + END_DOC + implicit none + integer :: i, j, k + psi_r_coef_sorted_bi_ortho = 0.d0 + psi_l_coef_sorted_bi_ortho = 0.d0 + do i = 1, N_det + psi_r_coef_sorted_bi_ortho(i,1) = psi_r_coef_bi_ortho(psi_det_sorted_tc_order(i),1) + psi_l_coef_sorted_bi_ortho(i,1) = psi_l_coef_bi_ortho(psi_det_sorted_tc_order(i),1) + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc_bit, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation. + ! They are sorted by determinants interpreted as integers. Useful + ! to accelerate the search of a random determinant in the wave + ! function. + END_DOC + + call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, size(psi_coef,1), & + psi_det_sorted_tc_bit, psi_coef_sorted_tc_bit, N_states) + +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_right, (N_int,2,N_det) ] +&BEGIN_PROVIDER [double precision, psi_r_coef_sorted_bi_ortho_right, (N_det)] + implicit none + BEGIN_DOC + ! psi_det_sorted_tc_right : Slater determinants sorted by decreasing value of |right- coefficients| + ! + ! psi_r_coef_sorted_bi_ortho_right : right wave function according to psi_det_sorted_tc_right + END_DOC + integer, allocatable :: iorder(:) + double precision, allocatable :: coef(:) + integer :: i,j + allocate ( iorder(N_det) , coef(N_det)) + do i=1,N_det + coef(i) = -dabs(psi_r_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1)) + iorder(i) = i + enddo + call dsort(coef,iorder,N_det) + do i=1,N_det + do j=1,N_int + psi_det_sorted_tc_right(j,1,i) = psi_det(j,1,iorder(i)) + psi_det_sorted_tc_right(j,2,i) = psi_det(j,2,iorder(i)) + enddo + psi_r_coef_sorted_bi_ortho_right(i) = psi_r_coef_bi_ortho(iorder(i),1)/psi_r_coef_bi_ortho(iorder(1),1) + enddo +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_left, (N_int,2,N_det) ] +&BEGIN_PROVIDER [double precision, psi_l_coef_sorted_bi_ortho_left, (N_det)] + implicit none + BEGIN_DOC + ! psi_det_sorted_tc_left : Slater determinants sorted by decreasing value of |LEFTt- coefficients| + ! + ! psi_r_coef_sorted_bi_ortho_left : LEFT wave function according to psi_det_sorted_tc_left + END_DOC + integer, allocatable :: iorder(:) + double precision, allocatable :: coef(:) + integer :: i,j + allocate ( iorder(N_det) , coef(N_det)) + do i=1,N_det + coef(i) = -dabs(psi_l_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1)) + iorder(i) = i + enddo + call dsort(coef,iorder,N_det) + do i=1,N_det + do j=1,N_int + psi_det_sorted_tc_left(j,1,i) = psi_det(j,1,iorder(i)) + psi_det_sorted_tc_left(j,2,i) = psi_det(j,2,iorder(i)) + enddo + psi_l_coef_sorted_bi_ortho_left(i) = psi_l_coef_bi_ortho(iorder(i),1)/psi_l_coef_bi_ortho(iorder(1),1) + enddo +END_PROVIDER diff --git a/src/tc_bi_ortho/psi_left_qmc.irp.f b/src/tc_bi_ortho/psi_left_qmc.irp.f new file mode 100644 index 00000000..25048f82 --- /dev/null +++ b/src/tc_bi_ortho/psi_left_qmc.irp.f @@ -0,0 +1,44 @@ + +! --- + +BEGIN_PROVIDER [ double precision, psi_bitcleft_bilinear_matrix_values, (N_det,N_states) ] + + BEGIN_DOC + ! Sparse coefficient matrix if the wave function is expressed in a bilinear form : + ! $D_\alpha^\dagger.C.D_\beta$ + ! + ! Rows are $\alpha$ determinants and columns are $\beta$. + ! + ! Order refers to psi_det + END_DOC + + use bitmasks + + implicit none + integer :: k, l + + if(N_det .eq. 1) then + + do l = 1, N_states + psi_bitcleft_bilinear_matrix_values(1,l) = 1.d0 + enddo + + else + + do l = 1, N_states + do k = 1, N_det + psi_bitcleft_bilinear_matrix_values(k,l) = psi_l_coef_bi_ortho(k,l) + enddo + enddo + + PROVIDE psi_bilinear_matrix_order + do l = 1, N_states + call dset_order(psi_bitcleft_bilinear_matrix_values(1,l), psi_bilinear_matrix_order, N_det) + enddo + + endif + +END_PROVIDER + +! --- + diff --git a/src/tc_bi_ortho/psi_r_l_prov.irp.f b/src/tc_bi_ortho/psi_r_l_prov.irp.f new file mode 100644 index 00000000..ac9b0e74 --- /dev/null +++ b/src/tc_bi_ortho/psi_r_l_prov.irp.f @@ -0,0 +1,234 @@ +use bitmasks + +BEGIN_PROVIDER [ double precision, psi_l_coef_bi_ortho, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file + ! is empty. + END_DOC + + integer :: i,k, N_int2 + logical :: exists + character*(64) :: label + + PROVIDE read_wf N_det mo_label ezfio_filename nproc + psi_l_coef_bi_ortho = 0.d0 + do i=1,min(N_states,N_det) + psi_l_coef_bi_ortho(i,i) = 1.d0 + enddo + + if (mpi_master) then + if (read_wf) then + call ezfio_has_tc_bi_ortho_psi_l_coef_bi_ortho(exists) +! if (exists) then +! call ezfio_has_tc_bi_ortho_mo_label(exists) +! if (exists) then +! call ezfio_get_tc_bi_ortho_mo_label(label) +! exists = (label == mo_label) +! endif +! endif + + if (exists) then + + double precision, allocatable :: psi_l_coef_bi_ortho_read(:,:) + allocate (psi_l_coef_bi_ortho_read(N_det,N_states)) + print *, 'Read psi_l_coef_bi_ortho', N_det, N_states + call ezfio_get_tc_bi_ortho_psi_l_coef_bi_ortho(psi_l_coef_bi_ortho_read) + do k=1,N_states + do i=1,N_det + psi_l_coef_bi_ortho(i,k) = psi_l_coef_bi_ortho_read(i,k) + enddo + enddo + deallocate(psi_l_coef_bi_ortho_read) + + else + + print*, 'psi_l_coef_bi_ortho are psi_coef' + do k=1,N_states + do i=1,N_det + psi_l_coef_bi_ortho(i,k) = psi_coef(i,k) + enddo + enddo + + endif + endif + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( psi_l_coef_bi_ortho, size(psi_l_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read psi_l_coef_bi_ortho with MPI' + endif + IRP_ENDIF +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, psi_r_coef_bi_ortho, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file + ! is empty. + END_DOC + + integer :: i,k, N_int2 + logical :: exists + character*(64) :: label + + PROVIDE read_wf N_det mo_label ezfio_filename nproc + psi_r_coef_bi_ortho = 0.d0 + do i=1,min(N_states,N_det) + psi_r_coef_bi_ortho(i,i) = 1.d0 + enddo + + if (mpi_master) then + if (read_wf) then + call ezfio_has_tc_bi_ortho_psi_r_coef_bi_ortho(exists) +! if (exists) then +! call ezfio_has_tc_bi_ortho_mo_label(exists) +! if (exists) then +! call ezfio_get_tc_bi_ortho_mo_label(label) +! exists = (label == mo_label) +! endif +! endif + + if (exists) then + + double precision, allocatable :: psi_r_coef_bi_ortho_read(:,:) + allocate (psi_r_coef_bi_ortho_read(N_det,N_states)) + print *, 'Read psi_r_coef_bi_ortho', N_det, N_states + call ezfio_get_tc_bi_ortho_psi_r_coef_bi_ortho(psi_r_coef_bi_ortho_read) + do k=1,N_states + do i=1,N_det + psi_r_coef_bi_ortho(i,k) = psi_r_coef_bi_ortho_read(i,k) + enddo + enddo + deallocate(psi_r_coef_bi_ortho_read) + + else + + print*, 'psi_r_coef_bi_ortho are psi_coef' + do k=1,N_states + do i=1,N_det + psi_r_coef_bi_ortho(i,k) = psi_coef(i,k) + enddo + enddo + + endif + endif + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( psi_r_coef_bi_ortho, size(psi_r_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read psi_r_coef_bi_ortho with MPI' + endif + IRP_ENDIF +END_PROVIDER + + +subroutine save_tc_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psilcoef,psircoef) + implicit none + BEGIN_DOC + ! Save the wave function into the |EZFIO| file + END_DOC + use bitmasks + include 'constants.include.F' + integer, intent(in) :: ndet,nstates,dim_psicoef + integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) + double precision, intent(in) :: psilcoef(dim_psicoef,nstates) + double precision, intent(in) :: psircoef(dim_psicoef,nstates) + integer*8, allocatable :: psi_det_save(:,:,:) + double precision, allocatable :: psil_coef_save(:,:) + double precision, allocatable :: psir_coef_save(:,:) + + double precision :: accu_norm + integer :: i,j,k, ndet_qp_edit + + if (mpi_master) then + ndet_qp_edit = min(ndet,N_det_qp_edit) + + call ezfio_set_determinants_N_int(N_int) + call ezfio_set_determinants_bit_kind(bit_kind) + call ezfio_set_determinants_N_det(ndet) + call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) + call ezfio_set_determinants_n_states(nstates) + call ezfio_set_determinants_mo_label(mo_label) + + allocate (psi_det_save(N_int,2,ndet)) + do i=1,ndet + do j=1,2 + do k=1,N_int + psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8) + enddo + enddo + enddo + call ezfio_set_determinants_psi_det(psi_det_save) + call ezfio_set_determinants_psi_det_qp_edit(psi_det_save) + deallocate (psi_det_save) + + allocate (psil_coef_save(ndet,nstates),psir_coef_save(ndet,nstates)) + do k=1,nstates + do i=1,ndet + psil_coef_save(i,k) = psilcoef(i,k) + psir_coef_save(i,k) = psircoef(i,k) + enddo + enddo + + call ezfio_set_tc_bi_ortho_psi_l_coef_bi_ortho(psil_coef_save) + call ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho(psir_coef_save) + deallocate (psil_coef_save,psir_coef_save) + +! allocate (psi_coef_save(ndet_qp_edit,nstates)) +! do k=1,nstates +! do i=1,ndet_qp_edit +! psi_coef_save(i,k) = psicoef(i,k) +! enddo +! enddo +! +! call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) +! deallocate (psi_coef_save) + + call write_int(6,ndet,'Saved determinantsi and psi_r/psi_l coef') + endif +end + +subroutine save_tc_bi_ortho_wavefunction + implicit none + call save_tc_wavefunction_general(N_det,N_states,psi_det,size(psi_l_coef_bi_ortho, 1),psi_l_coef_bi_ortho,psi_r_coef_bi_ortho) + call routine_save_right_bi_ortho +end + +subroutine routine_save_right_bi_ortho + implicit none + double precision, allocatable :: coef_tmp(:,:) + integer :: i + allocate(coef_tmp(N_det, N_states)) + do i = 1, N_det + coef_tmp(i,1:N_states) = psi_r_coef_bi_ortho(i,1:N_states) + enddo + call save_wavefunction_general_unormalized(N_det,N_states,psi_det,size(coef_tmp,1),coef_tmp(1,1)) +end + +subroutine routine_save_left_right_bi_ortho + implicit none + double precision, allocatable :: coef_tmp(:,:) + integer :: i,n_states_tmp + n_states_tmp = 2 + allocate(coef_tmp(N_det, n_states_tmp)) + do i = 1, N_det + coef_tmp(i,1) = psi_r_coef_bi_ortho(i,1) + coef_tmp(i,2) = psi_l_coef_bi_ortho(i,1) + enddo + call save_wavefunction_general_unormalized(N_det,n_states_tmp,psi_det,size(coef_tmp,1),coef_tmp(1,1)) +end + diff --git a/src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.pouet b/src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.pouet new file mode 100644 index 00000000..eb812401 --- /dev/null +++ b/src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.pouet @@ -0,0 +1,76 @@ +program save_bitcpsileft_for_qmcchem + + integer :: iunit + logical :: exists + double precision :: e_ref + + print *, ' ' + print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + print *, ' call save_for_qmcchem before ' + print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + print *, ' ' + + call write_lr_spindeterminants() + + e_ref = 0.d0 + iunit = 13 + open(unit=iunit, file=trim(ezfio_filename)//'/simulation/e_ref', action='write') + + call ezfio_has_fci_energy_pt2(exists) + if(.not.exists) then + + call ezfio_has_fci_energy(exists) + if(.not.exists) then + + call ezfio_has_cisd_energy(exists) + if(.not.exists) then + + call ezfio_has_tc_scf_bitc_energy(exists) + if(exists) then + call ezfio_get_tc_scf_bitc_energy(e_ref) + endif + + else + call ezfio_get_cisd_energy(e_ref) + endif + + else + call ezfio_get_fci_energy(e_ref) + endif + + else + call ezfio_get_fci_energy_pt2(e_ref) + endif + + write(iunit,*) e_ref + + close(iunit) + +end + +! -- + +subroutine write_lr_spindeterminants() + + use bitmasks + + implicit none + + integer :: k, l + double precision, allocatable :: buffer(:,:) + + PROVIDE psi_bitcleft_bilinear_matrix_values + + allocate(buffer(N_det,N_states)) + do l = 1, N_states + do k = 1, N_det + buffer(k,l) = psi_bitcleft_bilinear_matrix_values(k,l) + enddo + enddo + call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer) + deallocate(buffer) + +end subroutine write_lr_spindeterminants + +! --- + diff --git a/src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f b/src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f new file mode 100644 index 00000000..5eb3c069 --- /dev/null +++ b/src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f @@ -0,0 +1,15 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call routine_save_left_right_bi_ortho +! call test +end diff --git a/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f b/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f new file mode 100644 index 00000000..8b6eb1d1 --- /dev/null +++ b/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f @@ -0,0 +1,35 @@ + program tc_natorb_bi_ortho + implicit none + BEGIN_DOC + ! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call print_energy_and_mos + call save_tc_natorb +! call minimize_tc_orb_angles + end + + subroutine save_tc_natorb + implicit none + print*,'Saving the natorbs ' + provide natorb_tc_leigvec_ao natorb_tc_reigvec_ao + call ezfio_set_bi_ortho_mos_mo_l_coef(natorb_tc_leigvec_ao) + call ezfio_set_bi_ortho_mos_mo_r_coef(natorb_tc_reigvec_ao) + call save_ref_determinant_nstates_1 + call ezfio_set_determinants_read_wf(.False.) + end + + subroutine save_ref_determinant_nstates_1 + implicit none + use bitmasks + double precision :: buffer(1,N_states) + buffer = 0.d0 + buffer(1,1) = 1.d0 + call save_wavefunction_general(1,1,ref_bitmask,1,buffer) + end diff --git a/src/tc_bi_ortho/select_dets_bi_ortho.irp.f b/src/tc_bi_ortho/select_dets_bi_ortho.irp.f new file mode 100644 index 00000000..e6bf3d6e --- /dev/null +++ b/src/tc_bi_ortho/select_dets_bi_ortho.irp.f @@ -0,0 +1,61 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + !!!!!!!!!!!!!!! WARNING NO 3-BODY + !!!!!!!!!!!!!!! WARNING NO 3-BODY + three_body_h_tc = .False. + touch three_body_h_tc + !!!!!!!!!!!!!!! WARNING NO 3-BODY + !!!!!!!!!!!!!!! WARNING NO 3-BODY + + call routine_test +! call test +end + +subroutine routine_test + implicit none + use bitmasks ! you need to include the bitmasks_module.f90 features + integer :: i,n_good,degree + integer(bit_kind), allocatable :: dets(:,:,:) + integer, allocatable :: iorder(:) + double precision, allocatable :: coef(:),coef_new(:,:) + double precision :: thr + allocate(coef(N_det), iorder(N_det)) + do i = 1, N_det + iorder(i) = i + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree==1)then + coef(i) = -0.5d0 + else + coef(i) = -dabs(coef_pt1_bi_ortho(i)) + endif + enddo + call dsort(coef,iorder,N_det) + !thr = save_threshold + thr = 1d-15 + n_good = 0 + do i = 1, N_det + if(dabs(coef(i)).gt.thr)then + n_good += 1 + endif + enddo + print*,'n_good = ',n_good + allocate(dets(N_int,2,n_good),coef_new(n_good,n_states)) + do i = 1, n_good + dets(:,:,i) = psi_det(:,:,iorder(i)) + coef_new(i,:) = psi_coef(iorder(i),:) + enddo + call save_wavefunction_general(n_good,n_states,dets,n_good,coef_new) + + +end diff --git a/src/tc_bi_ortho/slater_tc.irp.f b/src/tc_bi_ortho/slater_tc.irp.f new file mode 100644 index 00000000..2c0ae2ca --- /dev/null +++ b/src/tc_bi_ortho/slater_tc.irp.f @@ -0,0 +1,376 @@ + +! --- + +subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot) + + BEGIN_DOC + ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + double precision, intent(out) :: htot + double precision :: hmono, htwoe, hthree + integer :: degree + + call get_excitation_degree(key_j, key_i, degree, Nint) + if(degree.gt.2)then + htot = 0.d0 + else + call htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot) + endif + +end subroutine htilde_mu_mat_bi_ortho_tot + +! -- + +subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot) + + BEGIN_DOC + ! + ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis + !! + ! Returns the detail of the matrix element in terms of single, two and three electron contribution. + !! WARNING !! + ! + ! Non hermitian !! + ! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hmono, htwoe, hthree, htot + integer :: degree + + hmono = 0.d0 + htwoe = 0.d0 + htot = 0.d0 + hthree = 0.D0 + + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.gt.2) return + + if(degree == 0)then + call diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot) + else if (degree == 1)then + call single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) + else if(degree == 2)then + call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) + endif + + if(three_body_h_tc) then + if(degree == 2) then + if(.not.double_normal_ord) then + call double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) + endif + else if(degree == 1) then + call single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) + else if(degree == 0) then + call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree) + endif + endif + + htot = hmono + htwoe + hthree + if(degree==0) then + htot += nuclear_repulsion + endif + +end + +! --- + +subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot) + + BEGIN_DOC + ! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + double precision, intent(out) :: hmono,htwoe,htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + double precision :: get_mo_two_e_integral_tc_int + integer(bit_kind) :: key_i_core(Nint,2) + +! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e +! +! PROVIDE mo_integrals_erf_map core_energy nuclear_repulsion core_bitmask +! PROVIDE core_fock_operator +! +! PROVIDE j1b_gauss + +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! do i = 1, Nint +! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) +! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) +! enddo +! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) +! hmono = core_energy - nuclear_repulsion +! else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + hmono = 0.d0 +! endif + htwoe= 0.d0 + htot = 0.d0 + + do ispin = 1, 2 + do i = 1, Ne(ispin) ! + ii = occ(i,ispin) + hmono += mo_bi_ortho_tc_one_e(ii,ii) + +! if(j1b_gauss .eq. 1) then +! print*,'j1b not implemented for bi ortho TC' +! print*,'stopping ....' +! stop +! !hmono += mo_j1b_gauss_hermI (ii,ii) & +! ! + mo_j1b_gauss_hermII (ii,ii) & +! ! + mo_j1b_gauss_nonherm(ii,ii) +! endif + +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! hmono += core_fock_operator(ii,ii) ! add the usual Coulomb - Exchange from the core +! endif + enddo + enddo + + + ! alpha/beta two-body + ispin = 1 + jspin = 2 + do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1)) + ii = occ(i,ispin) + do j = 1, Ne(jspin) ! electron 2 + jj = occ(j,jspin) + htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii) + enddo + enddo + + ! alpha/alpha two-body + do i = 1, Ne(ispin) + ii = occ(i,ispin) + do j = i+1, Ne(ispin) + jj = occ(j,ispin) + htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + enddo + enddo + + ! beta/beta two-body + do i = 1, Ne(jspin) + ii = occ(i,jspin) + do j = i+1, Ne(jspin) + jj = occ(j,jspin) + htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + enddo + enddo + htot = hmono + htwoe + +end + + + +subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) + + BEGIN_DOC + ! for double excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe, htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + integer :: other_spin(2) + integer(bit_kind) :: key_i_core(Nint,2) + double precision :: get_mo_two_e_integral_tc_int,phase + +! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e + + other_spin(1) = 2 + other_spin(2) = 1 + + call get_excitation_degree(key_i, key_j, degree, Nint) + + hmono = 0.d0 + htwoe= 0.d0 + htot = 0.d0 + + if(degree.ne.2)then + return + endif + +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! do i = 1, Nint +! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) +! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) +! enddo +! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) +! else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) +! endif + call get_double_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + + if(s1.ne.s2)then + ! opposite spin two-body +! key_j, key_i + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + if(double_normal_ord.and.+Ne(1).gt.2)then + htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ??? + endif + else + ! same spin two-body + ! direct terms + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + ! exchange terms + htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) + if(double_normal_ord.and.+Ne(1).gt.2)then + htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ??? + htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ??? + endif + endif + htwoe *= phase + htot = htwoe + +end + + +subroutine single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) + + BEGIN_DOC + ! for single excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe, htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: get_mo_two_e_integral_tc_int, phase + double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13 + integer :: other_spin(2) + integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2) + +! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e +! +! PROVIDE core_bitmask core_fock_operator mo_integrals_erf_map + +! PROVIDE j1b_gauss + + other_spin(1) = 2 + other_spin(2) = 1 + + hmono = 0.d0 + htwoe= 0.d0 + htot = 0.d0 + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.ne.1)then + return + endif +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! do i = 1, Nint +! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) +! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) +! key_j_core(i,1) = xor(key_j(i,1),core_bitmask(i,1)) +! key_j_core(i,2) = xor(key_j(i,2),core_bitmask(i,2)) +! enddo +! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) +! else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) +! endif + + call get_single_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc,1,h1,p1,h2,p2,s1,s2) +! if(h1==14.and.p1==2)then +! print*,'h1,p1 old = ',h1,p1 +! endif + + hmono = mo_bi_ortho_tc_one_e(p1,h1) * phase + +! if(j1b_gauss .eq. 1) then +! print*,'j1b not implemented for bi ortho TC' +! print*,'stopping ....' +! stop +! !hmono += ( mo_j1b_gauss_hermI (h1,p1) & +! ! + mo_j1b_gauss_hermII (h1,p1) & +! ! + mo_j1b_gauss_nonherm(h1,p1) ) * phase +! endif + +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! hmono += phase * core_fock_operator(h1,p1) +! endif + + ! alpha/beta two-body + ispin = other_spin(s1) + if(s1==1)then + ! single alpha + do i = 1, Ne(ispin) ! electron 2 + ii = occ(i,ispin) + htwoe += mo_bi_ortho_tc_two_e(ii,p1,ii,h1) + enddo + else + ! single beta + do i = 1, Ne(ispin) ! electron 1 + ii = occ(i,ispin) + htwoe += mo_bi_ortho_tc_two_e(p1,ii,h1,ii) + enddo + endif +! ! same spin two-body + do i = 1, Ne(s1) + ii = occ(i,s1) + ! (h1p1|ii ii) - (h1 ii| p1 ii) + htwoe += mo_bi_ortho_tc_two_e(ii,p1,ii,h1) - mo_bi_ortho_tc_two_e(p1,ii,ii,h1) + enddo + + htwoe *= phase + htot = hmono + htwoe + +end + + diff --git a/src/tc_bi_ortho/slater_tc_3e.irp.f b/src/tc_bi_ortho/slater_tc_3e.irp.f new file mode 100644 index 00000000..9740ee2f --- /dev/null +++ b/src/tc_bi_ortho/slater_tc_3e.irp.f @@ -0,0 +1,288 @@ +subroutine provide_all_three_ints_bi_ortho + implicit none + BEGIN_DOC +! routine that provides all necessary three-electron integrals + END_DOC + if(three_body_h_tc)then + PROVIDE three_e_3_idx_direct_bi_ort three_e_3_idx_cycle_1_bi_ort three_e_3_idx_cycle_2_bi_ort + PROVIDE three_e_3_idx_exch23_bi_ort three_e_3_idx_exch13_bi_ort three_e_3_idx_exch12_bi_ort + PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_cycle_2_bi_ort + PROVIDE three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort three_e_4_idx_exch12_bi_ort + endif +if(.not.double_normal_ord)then + PROVIDE three_e_5_idx_direct_bi_ort three_e_5_idx_cycle_1_bi_ort three_e_5_idx_cycle_2_bi_ort + PROVIDE three_e_5_idx_exch23_bi_ort three_e_5_idx_exch13_bi_ort three_e_5_idx_exch12_bi_ort +else + PROVIDE normal_two_body_bi_orth +endif +end + +subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree) + + BEGIN_DOC + ! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + double precision, intent(out) :: hthree + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm + integer(bit_kind) :: key_i_core(Nint,2) + double precision :: direct_int, exchange_int + double precision :: sym_3_e_int_from_6_idx_tensor + double precision :: three_e_diag_parrallel_spin + + if(core_tc_op)then + do i = 1, Nint + key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core,occ,Ne,Nint) + else + call bitstring_to_list_ab(key_i,occ,Ne,Nint) + endif + hthree = 0.d0 + + if(Ne(1)+Ne(2).ge.3)then +!! ! alpha/alpha/beta three-body + do i = 1, Ne(1) + ii = occ(i,1) + do j = i+1, Ne(1) + jj = occ(j,1) + do m = 1, Ne(2) + mm = occ(m,2) +! direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) USES THE 6-IDX TENSOR +! exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) USES THE 6-IDX TENSOR + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR + hthree += direct_int - exchange_int + enddo + enddo + enddo + + ! beta/beta/alpha three-body + do i = 1, Ne(2) + ii = occ(i,2) + do j = i+1, Ne(2) + jj = occ(j,2) + do m = 1, Ne(1) + mm = occ(m,1) + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) + hthree += direct_int - exchange_int + enddo + enddo + enddo + + ! alpha/alpha/alpha three-body + do i = 1, Ne(1) + ii = occ(i,1) ! 1 + do j = i+1, Ne(1) + jj = occ(j,1) ! 2 + do m = j+1, Ne(1) + mm = occ(m,1) ! 3 +! ref = sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR + hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS + enddo + enddo + enddo + + ! beta/beta/beta three-body + do i = 1, Ne(2) + ii = occ(i,2) ! 1 + do j = i+1, Ne(2) + jj = occ(j,2) ! 2 + do m = j+1, Ne(2) + mm = occ(m,2) ! 3 +! ref = sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR + hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS + enddo + enddo + enddo + endif + +end + + +subroutine single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) + + BEGIN_DOC + ! for single excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + double precision, intent(out) :: hthree + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2),i,j,ii,jj,ispin,jspin,k,kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: direct_int,phase,exchange_int,three_e_single_parrallel_spin + double precision :: sym_3_e_int_from_6_idx_tensor + integer :: other_spin(2) + integer(bit_kind) :: key_j_core(Nint,2),key_i_core(Nint,2) + + other_spin(1) = 2 + other_spin(2) = 1 + + + hthree = 0.d0 + call get_excitation_degree(key_i,key_j,degree,Nint) + if(degree.ne.1)then + return + endif + if(core_tc_op)then + do i = 1, Nint + key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) + key_j_core(i,1) = xor(key_j(i,1),core_bitmask(i,1)) + key_j_core(i,2) = xor(key_j(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) + else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + endif + + call get_single_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2) + + ! alpha/alpha/beta three-body +! print*,'IN SLAT RULES' + if(Ne(1)+Ne(2).ge.3)then + ! hole of spin s1 :: contribution from purely other spin + ispin = other_spin(s1) ! ispin is the other spin than s1 + do i = 1, Ne(ispin) ! i is the orbitals of the other spin than s1 + ii = occ(i,ispin) + do j = i+1, Ne(ispin) ! j has the same spin than s1 + jj = occ(j,ispin) + ! is == ispin in ::: s1 is is s1 is is s1 is is s1 is is + ! < h1 j i | p1 j i > - < h1 j i | p1 i j > + ! + direct_int = three_e_4_idx_direct_bi_ort(jj,ii,p1,h1) + exchange_int = three_e_4_idx_exch23_bi_ort(jj,ii,p1,h1) + hthree += direct_int - exchange_int + enddo + enddo + + ! hole of spin s1 :: contribution from mixed other spin / same spin + do i = 1, Ne(ispin) ! other spin + ii = occ(i,ispin) ! other spin + do j = 1, Ne(s1) ! same spin + jj = occ(j,s1) ! same spin + direct_int = three_e_4_idx_direct_bi_ort(jj,ii,p1,h1) + exchange_int = three_e_4_idx_exch13_bi_ort(jj,ii,p1,h1) + ! < h1 j i | p1 j i > - < h1 j i | j p1 i > + hthree += direct_int - exchange_int + enddo + enddo +! + ! hole of spin s1 :: PURE SAME SPIN CONTRIBUTIONS !!! + do i = 1, Ne(s1) + ii = occ(i,s1) + do j = i+1, Ne(s1) + jj = occ(j,s1) +! ref = sym_3_e_int_from_6_idx_tensor(jj,ii,p1,jj,ii,h1) + hthree += three_e_single_parrallel_spin(jj,ii,p1,h1) ! USES THE 4-IDX TENSOR + enddo + enddo + endif + hthree *= phase + +end + +! --- + +subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) + + BEGIN_DOC + ! for double excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + double precision, intent(out) :: hthree + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: phase + integer :: other_spin(2) + integer(bit_kind) :: key_i_core(Nint,2) + double precision :: direct_int,exchange_int,sym_3_e_int_from_6_idx_tensor + double precision :: three_e_double_parrallel_spin + + other_spin(1) = 2 + other_spin(2) = 1 + + call get_excitation_degree(key_i, key_j, degree, Nint) + + hthree = 0.d0 + + if(degree.ne.2)then + return + endif + + if(core_tc_op) then + do i = 1, Nint + key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) + else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + endif + call get_double_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + + + if(Ne(1)+Ne(2).ge.3)then + if(s1==s2)then ! same spin excitation + ispin = other_spin(s1) + do m = 1, Ne(ispin) ! direct(other_spin) - exchange(s1) + mm = occ(m,ispin) + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1) + hthree += direct_int - exchange_int + enddo + do m = 1, Ne(s1) ! pure contribution from s1 + mm = occ(m,s1) + hthree += three_e_double_parrallel_spin(mm,p2,h2,p1,h1) + enddo + else ! different spin excitation + do m = 1, Ne(s1) + mm = occ(m,s1) ! + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch13_bi_ort(mm,p2,h2,p1,h1) + hthree += direct_int - exchange_int + enddo + do m = 1, Ne(s2) + mm = occ(m,s2) ! + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch23_bi_ort(mm,p2,h2,p1,h1) + hthree += direct_int - exchange_int + enddo + endif + endif + hthree *= phase + end + +! --- + diff --git a/src/tc_bi_ortho/slater_tc_opt.irp.f b/src/tc_bi_ortho/slater_tc_opt.irp.f new file mode 100644 index 00000000..a19d4688 --- /dev/null +++ b/src/tc_bi_ortho/slater_tc_opt.irp.f @@ -0,0 +1,105 @@ +subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot) + implicit none + BEGIN_DOC + ! + ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis + !! + ! Returns the total matrix element + !! WARNING !! + ! + ! Non hermitian !! + ! + END_DOC + + use bitmasks + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: htot + double precision :: hmono, htwoe, hthree + call htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot) +end +subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot) + BEGIN_DOC + ! + ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis + !! + ! Returns the detail of the matrix element in terms of single, two and three electron contribution. + !! WARNING !! + ! + ! Non hermitian !! + ! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hmono, htwoe, hthree, htot + integer :: degree + + hmono = 0.d0 + htwoe = 0.d0 + htot = 0.d0 + hthree = 0.D0 + + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.gt.2) return + + if(degree == 0)then + call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot) + else if (degree == 1)then + call single_htilde_mu_mat_fock_bi_ortho(Nint,key_j, key_i , hmono, htwoe, hthree, htot) + else if(degree == 2)then + call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) + endif + + if(degree==0) then + htot += nuclear_repulsion + endif + +end + +! --- + +subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot) + + BEGIN_DOC + ! + ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis + !! + ! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS + !! WARNING !! + ! + ! Non hermitian !! + ! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: htot + integer :: degree + + htot = 0.d0 + + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.gt.2) return + + if(degree == 0)then + call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,htot) + else if (degree == 1)then + call single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint,key_j, key_i , htot) + else if(degree == 2)then + call double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot) + endif + + if(degree==0) then + htot += nuclear_repulsion + endif + +end + +! --- diff --git a/src/tc_bi_ortho/slater_tc_opt_diag.irp.f b/src/tc_bi_ortho/slater_tc_opt_diag.irp.f new file mode 100644 index 00000000..68f647dd --- /dev/null +++ b/src/tc_bi_ortho/slater_tc_opt_diag.irp.f @@ -0,0 +1,473 @@ + BEGIN_PROVIDER [ double precision, ref_tc_energy_tot] +&BEGIN_PROVIDER [ double precision, ref_tc_energy_1e] +&BEGIN_PROVIDER [ double precision, ref_tc_energy_2e] +&BEGIN_PROVIDER [ double precision, ref_tc_energy_3e] + implicit none + BEGIN_DOC +! Various component of the TC energy for the reference "HF" Slater determinant + END_DOC + double precision :: hmono, htwoe, htot, hthree + call diag_htilde_mu_mat_bi_ortho(N_int,HF_bitmask , hmono, htwoe, htot) + ref_tc_energy_1e = hmono + ref_tc_energy_2e = htwoe + if(three_body_h_tc)then + call diag_htilde_three_body_ints_bi_ort(N_int, HF_bitmask, hthree) + ref_tc_energy_3e = hthree + else + ref_tc_energy_3e = 0.d0 + endif + ref_tc_energy_tot = ref_tc_energy_1e + ref_tc_energy_2e + ref_tc_energy_3e + END_PROVIDER + +subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree, htot) + implicit none + BEGIN_DOC + ! Computes $\langle i|H|i \rangle$. + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + double precision, intent(out) :: hmono,htwoe,htot,hthree + + integer(bit_kind) :: hole(Nint,2) + integer(bit_kind) :: particle(Nint,2) + integer :: i, nexc(2), ispin + integer :: occ_particle(Nint*bit_kind_size,2) + integer :: occ_hole(Nint*bit_kind_size,2) + integer(bit_kind) :: det_tmp(Nint,2) + integer :: na, nb + + ASSERT (Nint > 0) + ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num) + + + nexc(1) = 0 + nexc(2) = 0 + do i=1,Nint + hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1)) + hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2)) + particle(i,1) = iand(hole(i,1),det_in(i,1)) + particle(i,2) = iand(hole(i,2),det_in(i,2)) + hole(i,1) = iand(hole(i,1),ref_bitmask(i,1)) + hole(i,2) = iand(hole(i,2),ref_bitmask(i,2)) + nexc(1) = nexc(1) + popcnt(hole(i,1)) + nexc(2) = nexc(2) + popcnt(hole(i,2)) + enddo + + if (nexc(1)+nexc(2) == 0) then + hmono = ref_tc_energy_1e + htwoe = ref_tc_energy_2e + hthree= ref_tc_energy_3e + htot = ref_tc_energy_tot + return + endif + + !call debug_det(det_in,Nint) + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(particle, occ_particle, tmp, Nint) + ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha + ASSERT (tmp(2) == nexc(2)) ! Number of particle beta + !DIR$ FORCEINLINE + call bitstring_to_list_ab(hole, occ_hole, tmp, Nint) + ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha + ASSERT (tmp(2) == nexc(2)) ! Number of holes beta + + + det_tmp = ref_bitmask + hmono = ref_tc_energy_1e + htwoe = ref_tc_energy_2e + hthree= ref_tc_energy_3e + do ispin=1,2 + na = elec_num_tab(ispin) + nb = elec_num_tab(iand(ispin,1)+1) + do i=1,nexc(ispin) + !DIR$ FORCEINLINE + call ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, hmono,htwoe,hthree, Nint,na,nb) + !DIR$ FORCEINLINE + call a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, hmono,htwoe,hthree, Nint,na,nb) + enddo + enddo + htot = hmono+htwoe+hthree +end + +subroutine ac_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Routine that computes one- and two-body energy corresponding + ! + ! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin' + ! + ! onto a determinant 'key'. + ! + ! in output, the determinant key is changed by the ADDITION of that electron + ! + ! and the quantities hmono,htwoe,hthree are INCREMENTED + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hmono,htwoe,hthree + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i,jj,mm,j,m + double precision :: direct_int, exchange_int + + + if (iorb < 1) then + print *, irp_here, ': iorb < 1' + print *, iorb, mo_num + stop -1 + endif + if (iorb > mo_num) then + print *, irp_here, ': iorb > mo_num' + print *, iorb, mo_num + stop -1 + endif + + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) + ASSERT (tmp(1) == elec_alpha_num) + ASSERT (tmp(2) == elec_beta_num) + + k = shiftr(iorb-1,bit_kind_shift)+1 + ASSERT (k >0) + l = iorb - shiftl(k-1,bit_kind_shift)-1 + ASSERT (l >= 0) + key(k,ispin) = ibset(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + hmono = hmono + mo_bi_ortho_tc_one_e(iorb,iorb) + + ! Same spin + do i=1,na + htwoe = htwoe + mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb) + enddo + + if(three_body_h_tc)then + !!!!! 3-e part + !! same-spin/same-spin + do j = 1, na + jj = occ(j,ispin) + do m = j+1, na + mm = occ(m,ispin) + hthree += three_e_diag_parrallel_spin_prov(mm,jj,iorb) + enddo + enddo + !! same-spin/oposite-spin + do j = 1, na + jj = occ(j,ispin) + do m = 1, nb + mm = occ(m,other_spin) + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + hthree += direct_int - exchange_int + enddo + enddo + !! oposite-spin/opposite-spin + do j = 1, nb + jj = occ(j,other_spin) + do m = j+1, nb + mm = occ(m,other_spin) + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + hthree += direct_int - exchange_int + enddo + enddo + endif + + na = na+1 +end + +subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Routine that computes one- and two-body energy corresponding + ! + ! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin' + ! + ! onto a determinant 'key'. + ! + ! in output, the determinant key is changed by the REMOVAL of that electron + ! + ! and the quantities hmono,htwoe,hthree are INCREMENTED + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hmono,htwoe,hthree + + double precision :: direct_int, exchange_int + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i,jj,mm,j,m + integer :: tmp(2) + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + k = shiftr(iorb-1,bit_kind_shift)+1 + ASSERT (k>0) + l = iorb - shiftl(k-1,bit_kind_shift)-1 + key(k,ispin) = ibclr(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) + na = na-1 + + hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb) + + ! Same spin + do i=1,na + htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb) + enddo + + if(three_body_h_tc)then + !!!!! 3-e part + !! same-spin/same-spin + do j = 1, na + jj = occ(j,ispin) + do m = j+1, na + mm = occ(m,ispin) + hthree -= three_e_diag_parrallel_spin_prov(mm,jj,iorb) + enddo + enddo + !! same-spin/oposite-spin + do j = 1, na + jj = occ(j,ispin) + do m = 1, nb + mm = occ(m,other_spin) + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + hthree -= (direct_int - exchange_int) + enddo + enddo + !! oposite-spin/opposite-spin + do j = 1, nb + jj = occ(j,other_spin) + do m = j+1, nb + mm = occ(m,other_spin) + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + hthree -= (direct_int - exchange_int) + enddo + enddo + endif + +end + + +subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot) + implicit none + BEGIN_DOC + ! Computes $\langle i|H|i \rangle$. WITHOUT ANY CONTRIBUTIONS FROM 3E TERMS + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + double precision, intent(out) :: htot + double precision :: hmono,htwoe + + integer(bit_kind) :: hole(Nint,2) + integer(bit_kind) :: particle(Nint,2) + integer :: i, nexc(2), ispin + integer :: occ_particle(Nint*bit_kind_size,2) + integer :: occ_hole(Nint*bit_kind_size,2) + integer(bit_kind) :: det_tmp(Nint,2) + integer :: na, nb + + ASSERT (Nint > 0) + ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num) + + + nexc(1) = 0 + nexc(2) = 0 + do i=1,Nint + hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1)) + hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2)) + particle(i,1) = iand(hole(i,1),det_in(i,1)) + particle(i,2) = iand(hole(i,2),det_in(i,2)) + hole(i,1) = iand(hole(i,1),ref_bitmask(i,1)) + hole(i,2) = iand(hole(i,2),ref_bitmask(i,2)) + nexc(1) = nexc(1) + popcnt(hole(i,1)) + nexc(2) = nexc(2) + popcnt(hole(i,2)) + enddo + + if (nexc(1)+nexc(2) == 0) then + hmono = ref_tc_energy_1e + htwoe = ref_tc_energy_2e + htot = ref_tc_energy_tot + return + endif + + !call debug_det(det_in,Nint) + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(particle, occ_particle, tmp, Nint) + ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha + ASSERT (tmp(2) == nexc(2)) ! Number of particle beta + !DIR$ FORCEINLINE + call bitstring_to_list_ab(hole, occ_hole, tmp, Nint) + ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha + ASSERT (tmp(2) == nexc(2)) ! Number of holes beta + + + det_tmp = ref_bitmask + hmono = ref_tc_energy_1e + htwoe = ref_tc_energy_2e + do ispin=1,2 + na = elec_num_tab(ispin) + nb = elec_num_tab(iand(ispin,1)+1) + do i=1,nexc(ispin) + !DIR$ FORCEINLINE + call ac_tc_operator_no_3e( occ_particle(i,ispin), ispin, det_tmp, hmono,htwoe, Nint,na,nb) + !DIR$ FORCEINLINE + call a_tc_operator_no_3e ( occ_hole (i,ispin), ispin, det_tmp, hmono,htwoe, Nint,na,nb) + enddo + enddo + htot = hmono+htwoe +end + +subroutine ac_tc_operator_no_3e(iorb,ispin,key,hmono,htwoe,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Routine that computes one- and two-body energy corresponding + ! + ! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin' + ! + ! onto a determinant 'key'. + ! + ! in output, the determinant key is changed by the ADDITION of that electron + ! + ! and the quantities hmono,htwoe are INCREMENTED + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hmono,htwoe + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i,jj,mm,j,m + double precision :: direct_int, exchange_int + + + if (iorb < 1) then + print *, irp_here, ': iorb < 1' + print *, iorb, mo_num + stop -1 + endif + if (iorb > mo_num) then + print *, irp_here, ': iorb > mo_num' + print *, iorb, mo_num + stop -1 + endif + + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) + ASSERT (tmp(1) == elec_alpha_num) + ASSERT (tmp(2) == elec_beta_num) + + k = shiftr(iorb-1,bit_kind_shift)+1 + ASSERT (k >0) + l = iorb - shiftl(k-1,bit_kind_shift)-1 + ASSERT (l >= 0) + key(k,ispin) = ibset(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + hmono = hmono + mo_bi_ortho_tc_one_e(iorb,iorb) + + ! Same spin + do i=1,na + htwoe = htwoe + mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb) + enddo + + na = na+1 +end + +subroutine a_tc_operator_no_3e(iorb,ispin,key,hmono,htwoe,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Routine that computes one- and two-body energy corresponding + ! + ! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin' + ! + ! onto a determinant 'key'. + ! + ! in output, the determinant key is changed by the REMOVAL of that electron + ! + ! and the quantities hmono,htwoe are INCREMENTED + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hmono,htwoe + + double precision :: direct_int, exchange_int + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i,jj,mm,j,m + integer :: tmp(2) + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + k = shiftr(iorb-1,bit_kind_shift)+1 + ASSERT (k>0) + l = iorb - shiftl(k-1,bit_kind_shift)-1 + key(k,ispin) = ibclr(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) + na = na-1 + + hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb) + + ! Same spin + do i=1,na + htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb) + enddo + +end + diff --git a/src/tc_bi_ortho/slater_tc_opt_double.irp.f b/src/tc_bi_ortho/slater_tc_opt_double.irp.f new file mode 100644 index 00000000..d094d76e --- /dev/null +++ b/src/tc_bi_ortho/slater_tc_opt_double.irp.f @@ -0,0 +1,476 @@ + +subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) + + BEGIN_DOC + ! for double excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe, hthree, htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: get_mo_two_e_integral_tc_int,phase + + + call get_excitation_degree(key_i, key_j, degree, Nint) + + hmono = 0.d0 + htwoe = 0.d0 + hthree = 0.d0 + htot = 0.d0 + + if(degree.ne.2)then + return + endif + integer :: degree_i,degree_j + call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int) + call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int) + call get_double_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + + if(s1.ne.s2)then + ! opposite spin two-body + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + if(three_body_h_tc)then + if(.not.double_normal_ord)then + if(degree_i>degree_j)then + call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree) + else + call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree) + endif + elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then + htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ??? + endif + endif + else + ! same spin two-body + ! direct terms + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + ! exchange terms + htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) + if(three_body_h_tc)then + if(.not.double_normal_ord)then + if(degree_i>degree_j)then + call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree) + else + call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree) + endif + elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then + htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ??? + htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ??? + endif + endif + endif + hthree *= phase + htwoe *= phase + htot = htwoe + hthree + +end + + + +subroutine three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree) + implicit none + integer(bit_kind), intent(in) :: key_i(N_int,2) + integer, intent(in) :: h1,h2,p1,p2,s1,s2 + double precision, intent(out) :: hthree + integer :: nexc(2),i,ispin,na,nb + integer(bit_kind) :: hole(N_int,2) + integer(bit_kind) :: particle(N_int,2) + integer :: occ_hole(N_int*bit_kind_size,2) + integer :: occ_particle(N_int*bit_kind_size,2) + integer :: n_occ_ab_hole(2),n_occ_ab_particle(2) + integer(bit_kind) :: det_tmp(N_int,2) + integer :: ipart, ihole + double precision :: direct_int, exchange_int + + nexc(1) = 0 + nexc(2) = 0 + !! Get all the holes and particles of key_i with respect to the ROHF determinant + do i=1,N_int + hole(i,1) = xor(key_i(i,1),ref_bitmask(i,1)) + hole(i,2) = xor(key_i(i,2),ref_bitmask(i,2)) + particle(i,1) = iand(hole(i,1),key_i(i,1)) + particle(i,2) = iand(hole(i,2),key_i(i,2)) + hole(i,1) = iand(hole(i,1),ref_bitmask(i,1)) + hole(i,2) = iand(hole(i,2),ref_bitmask(i,2)) + nexc(1) = nexc(1) + popcnt(hole(i,1)) + nexc(2) = nexc(2) + popcnt(hole(i,2)) + enddo + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(particle, occ_particle, tmp, N_int) + ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha + ASSERT (tmp(2) == nexc(2)) ! Number of particle beta + !DIR$ FORCEINLINE + call bitstring_to_list_ab(hole, occ_hole, tmp, N_int) + ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha + ASSERT (tmp(2) == nexc(2)) ! Number of holes beta + if(s1==s2.and.s1==1)then + !!!!!!!!!!!!!!!!!!!!!!!!!! alpha/alpha double exc + hthree = eff_2_e_from_3_e_aa(p2,p1,h2,h1) + if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant + !!!!!!!! the matrix element is already exact + !!!!!!!! else you need to take care of holes and particles + !!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!! + ispin = 1 ! i==alpha ==> pure same spin terms + do i = 1, nexc(ispin) ! number of couple of holes/particles + ipart=occ_particle(i,ispin) + hthree += three_e_double_parrallel_spin_prov(ipart,p2,h2,p1,h1) + ihole=occ_hole(i,ispin) + hthree -= three_e_double_parrallel_spin_prov(ihole,p2,h2,p1,h1) + enddo + ispin = 2 ! i==beta ==> alpha/alpha/beta terms + do i = 1, nexc(ispin) ! number of couple of holes/particles + ! exchange between (h1,p1) and (h2,p2) + ipart=occ_particle(i,ispin) + direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch12_bi_ort(ipart,p2,h2,p1,h1) + hthree += direct_int - exchange_int + ihole=occ_hole(i,ispin) + direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch12_bi_ort(ihole,p2,h2,p1,h1) + hthree -= direct_int - exchange_int + enddo + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + elseif(s1==s2.and.s1==2)then + !!!!!!!!!!!!!!!!!!!!!!!!!! beta/beta double exc + hthree = eff_2_e_from_3_e_bb(p2,p1,h2,h1) + if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant + !!!!!!!! the matrix element is already exact + !!!!!!!! else you need to take care of holes and particles + !!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!! + ispin = 2 ! i==beta ==> pure same spin terms + do i = 1, nexc(ispin) ! number of couple of holes/particles + ipart=occ_particle(i,ispin) + hthree += three_e_double_parrallel_spin_prov(ipart,p2,h2,p1,h1) + ihole=occ_hole(i,ispin) + hthree -= three_e_double_parrallel_spin_prov(ihole,p2,h2,p1,h1) + enddo + ispin = 1 ! i==alpha==> beta/beta/alpha terms + do i = 1, nexc(ispin) ! number of couple of holes/particles + ! exchange between (h1,p1) and (h2,p2) + ipart=occ_particle(i,ispin) + direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch12_bi_ort(ipart,p2,h2,p1,h1) + hthree += direct_int - exchange_int + ihole=occ_hole(i,ispin) + direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch12_bi_ort(ihole,p2,h2,p1,h1) + hthree -= direct_int - exchange_int + enddo + else ! (h1,p1) == alpha/(h2,p2) == beta + hthree = eff_2_e_from_3_e_ab(p2,p1,h2,h1) + if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant + !!!!!!!! the matrix element is already exact + !!!!!!!! else you need to take care of holes and particles + !!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!! + ispin = 1 ! i==alpha ==> alpha/beta/alpha terms + do i = 1, nexc(ispin) ! number of couple of holes/particles + ! exchange between (h1,p1) and i + ipart=occ_particle(i,ispin) + direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch13_bi_ort(ipart,p2,h2,p1,h1) + hthree += direct_int - exchange_int + ihole=occ_hole(i,ispin) + direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch13_bi_ort(ihole,p2,h2,p1,h1) + hthree -= direct_int - exchange_int + enddo + ispin = 2 ! i==beta ==> alpha/beta/beta terms + do i = 1, nexc(ispin) ! number of couple of holes/particles + ! exchange between (h2,p2) and i + ipart=occ_particle(i,ispin) + direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch23_bi_ort(ipart,p2,h2,p1,h1) + hthree += direct_int - exchange_int + ihole=occ_hole(i,ispin) + direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch23_bi_ort(ihole,p2,h2,p1,h1) + hthree -= direct_int - exchange_int + enddo + endif +end + + +BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_ab, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for alpha/beta double excitations +! +! from contraction with HF density = a^{dagger}_p1_alpha a^{dagger}_p2_beta a_h2_beta a_h1_alpha + END_DOC + integer :: i,h1,p1,h2,p2 + integer :: hh1,hh2,pp1,pp2,m,mm + integer :: Ne(2) + integer, allocatable :: occ(:,:) + double precision :: contrib + allocate( occ(N_int*bit_kind_size,2) ) + call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int) + call give_contrib_for_abab(1,1,1,1,occ,Ne,contrib) + eff_2_e_from_3_e_ab = 0.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) & + !$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_ab) + !$OMP DO SCHEDULE (static) + do hh1 = 1, n_act_orb !! alpha + h1 = list_act(hh1) + do hh2 = 1, n_act_orb !! beta + h2 = list_act(hh2) + do pp1 = 1, n_act_orb !! alpha + p1 = list_act(pp1) + do pp2 = 1, n_act_orb !! beta + p2 = list_act(pp2) + call give_contrib_for_abab(h1,h2,p1,p2,occ,Ne,contrib) + eff_2_e_from_3_e_ab(p2,p1,h2,h1) = contrib + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + +END_PROVIDER + +subroutine give_contrib_for_abab(h1,h2,p1,p2,occ,Ne,contrib) + implicit none + BEGIN_DOC +! gives the contribution for a double excitation (h1,p1)_alpha (h2,p2)_beta +! +! on top of a determinant whose occupied orbitals is in (occ, Ne) + END_DOC + integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2) + double precision, intent(out) :: contrib + integer :: mm,m + double precision :: direct_int, exchange_int + !! h1,p1 == alpha + !! h2,p2 == beta + contrib = 0.d0 + do mm = 1, Ne(1) !! alpha + m = occ(mm,1) + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + ! exchange between (h1,p1) and m + exchange_int = three_e_5_idx_exch13_bi_ort(mm,p2,h2,p1,h1) + contrib += direct_int - exchange_int + enddo + + do mm = 1, Ne(2) !! beta + m = occ(mm,2) + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + ! exchange between (h2,p2) and m + exchange_int = three_e_5_idx_exch23_bi_ort(mm,p2,h2,p1,h1) + contrib += direct_int - exchange_int + enddo +end + +BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_aa, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for alpha/alpha double excitations +! +! from contractionelec_alpha_num with HF density = a^{dagger}_p1_alpha a^{dagger}_p2_alpha a_h2_alpha a_h1_alpha +! +! WARNING :: to be coherent with the phase convention used in the Hamiltonian matrix elements, you must fulfill +! +! |||| h2>h1, p2>p1 |||| + END_DOC + integer :: i,h1,p1,h2,p2 + integer :: hh1,hh2,pp1,pp2,m,mm + integer :: Ne(2) + integer, allocatable :: occ(:,:) + double precision :: contrib + allocate( occ(N_int*bit_kind_size,2) ) + call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int) + call give_contrib_for_aaaa(1 ,1 ,1 ,1 ,occ,Ne,contrib) + eff_2_e_from_3_e_aa = 100000000.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) & + !$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_aa) + !$OMP DO SCHEDULE (static) + do hh1 = 1, n_act_orb !! alpha + h1 = list_act(hh1) + do hh2 = hh1+1, n_act_orb !! alpha + h2 = list_act(hh2) + do pp1 = 1, n_act_orb !! alpha + p1 = list_act(pp1) + do pp2 = pp1+1, n_act_orb !! alpha + p2 = list_act(pp2) + call give_contrib_for_aaaa(h1,h2,p1,p2,occ,Ne,contrib) + eff_2_e_from_3_e_aa(p2,p1,h2,h1) = contrib + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + +END_PROVIDER + +subroutine give_contrib_for_aaaa(h1,h2,p1,p2,occ,Ne,contrib) + implicit none + BEGIN_DOC +! gives the contribution for a double excitation (h1,p1)_alpha (h2,p2)_alpha +! +! on top of a determinant whose occupied orbitals is in (occ, Ne) + END_DOC + integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2) + double precision, intent(out) :: contrib + integer :: mm,m + double precision :: direct_int, exchange_int + !! h1,p1 == alpha + !! h2,p2 == alpha + contrib = 0.d0 + do mm = 1, Ne(1) !! alpha ==> pure parallele spin contribution + m = occ(mm,1) + contrib += three_e_double_parrallel_spin_prov(m,p2,h2,p1,h1) + enddo + + do mm = 1, Ne(2) !! beta + m = occ(mm,2) + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + ! exchange between (h1,p1) and (h2,p2) + exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1) + contrib += direct_int - exchange_int + enddo +end + + +BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_bb, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for beta/beta double excitations +! +! from contractionelec_beta_num with HF density = a^{dagger}_p1_beta a^{dagger}_p2_beta a_h2_beta a_h1_beta +! +! WARNING :: to be coherent with the phase convention used in the Hamiltonian matrix elements, you must fulfill +! +! |||| h2>h1, p2>p1 |||| + END_DOC + integer :: i,h1,p1,h2,p2 + integer :: hh1,hh2,pp1,pp2,m,mm + integer :: Ne(2) + integer, allocatable :: occ(:,:) + double precision :: contrib + allocate( occ(N_int*bit_kind_size,2) ) + call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int) + call give_contrib_for_bbbb(1,1 ,1 ,1 ,occ,Ne,contrib) + eff_2_e_from_3_e_bb = 100000000.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) & + !$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_bb) + !$OMP DO SCHEDULE (static) + do hh1 = 1, n_act_orb !! beta + h1 = list_act(hh1) + do hh2 = hh1+1, n_act_orb !! beta + h2 = list_act(hh2) + do pp1 = 1, n_act_orb !! beta + p1 = list_act(pp1) + do pp2 = pp1+1, n_act_orb !! beta + p2 = list_act(pp2) + call give_contrib_for_bbbb(h1,h2,p1,p2,occ,Ne,contrib) + eff_2_e_from_3_e_bb(p2,p1,h2,h1) = contrib + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + +END_PROVIDER + +subroutine give_contrib_for_bbbb(h1,h2,p1,p2,occ,Ne,contrib) + implicit none + BEGIN_DOC +! gives the contribution for a double excitation (h1,p1)_beta (h2,p2)_beta +! +! on top of a determinant whose occupied orbitals is in (occ, Ne) + END_DOC + integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2) + double precision, intent(out) :: contrib + integer :: mm,m + double precision :: direct_int, exchange_int + !! h1,p1 == beta + !! h2,p2 == beta + contrib = 0.d0 + do mm = 1, Ne(2) !! beta ==> pure parallele spin contribution + m = occ(mm,1) + contrib += three_e_double_parrallel_spin_prov(m,p2,h2,p1,h1) + enddo + + do mm = 1, Ne(1) !! alpha + m = occ(mm,1) + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + ! exchange between (h1,p1) and (h2,p2) + exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1) + contrib += direct_int - exchange_int + enddo +end + + +subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot) + + BEGIN_DOC + ! for double excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: htot + double precision :: hmono, htwoe + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: get_mo_two_e_integral_tc_int,phase + + + call get_excitation_degree(key_i, key_j, degree, Nint) + + hmono = 0.d0 + htwoe = 0.d0 + htot = 0.d0 + + if(degree.ne.2)then + return + endif + integer :: degree_i,degree_j + call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int) + call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int) + call get_double_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + + if(s1.ne.s2)then + ! opposite spin two-body + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + else + ! same spin two-body + ! direct terms + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + ! exchange terms + htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) + endif + htwoe *= phase + htot = htwoe + +end + diff --git a/src/tc_bi_ortho/slater_tc_opt_single.irp.f b/src/tc_bi_ortho/slater_tc_opt_single.irp.f new file mode 100644 index 00000000..7cff3c73 --- /dev/null +++ b/src/tc_bi_ortho/slater_tc_opt_single.irp.f @@ -0,0 +1,572 @@ + + +subroutine single_htilde_mu_mat_fock_bi_ortho (Nint, key_j, key_i, hmono, htwoe, hthree, htot) + BEGIN_DOC + ! for single excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe, hthree, htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: get_mo_two_e_integral_tc_int, phase + double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13 + integer :: other_spin(2) + integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2) + + other_spin(1) = 2 + other_spin(2) = 1 + + hmono = 0.d0 + htwoe = 0.d0 + hthree = 0.d0 + htot = 0.d0 + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.ne.1)then + return + endif + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + + call get_single_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc,1,h1,p1,h2,p2,s1,s2) + call get_single_excitation_from_fock_tc(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,hthree,htot) +end + + +subroutine get_single_excitation_from_fock_tc(key_i,key_j,h,p,spin,phase,hmono,htwoe,hthree,htot) + use bitmasks + implicit none + integer,intent(in) :: h,p,spin + double precision, intent(in) :: phase + integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2) + double precision, intent(out) :: hmono,htwoe,hthree,htot + integer(bit_kind) :: differences(N_int,2) + integer(bit_kind) :: hole(N_int,2) + integer(bit_kind) :: partcl(N_int,2) + integer :: occ_hole(N_int*bit_kind_size,2) + integer :: occ_partcl(N_int*bit_kind_size,2) + integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2) + integer :: i0,i + double precision :: buffer_c(mo_num),buffer_x(mo_num) + do i=1, mo_num + buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h) + buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h) + enddo + do i = 1, N_int + differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1)) + differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2)) + hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1)) + hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2)) + partcl(i,1) = iand(differences(i,1),key_i(i,1)) + partcl(i,2) = iand(differences(i,2),key_i(i,2)) + enddo + call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int) + call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int) + hmono = mo_bi_ortho_tc_one_e(p,h) + htwoe = fock_op_2_e_tc_closed_shell(p,h) + ! holes :: direct terms + do i0 = 1, n_occ_ab_hole(1) + i = occ_hole(i0,1) + htwoe -= buffer_c(i) + enddo + do i0 = 1, n_occ_ab_hole(2) + i = occ_hole(i0,2) + htwoe -= buffer_c(i) + enddo + + ! holes :: exchange terms + do i0 = 1, n_occ_ab_hole(spin) + i = occ_hole(i0,spin) + htwoe += buffer_x(i) + enddo + + ! particles :: direct terms + do i0 = 1, n_occ_ab_partcl(1) + i = occ_partcl(i0,1) + htwoe += buffer_c(i) + enddo + do i0 = 1, n_occ_ab_partcl(2) + i = occ_partcl(i0,2) + htwoe += buffer_c(i) + enddo + + ! particles :: exchange terms + do i0 = 1, n_occ_ab_partcl(spin) + i = occ_partcl(i0,spin) + htwoe -= buffer_x(i) + enddo + hthree = 0.d0 + if (three_body_h_tc)then + call three_comp_fock_elem(key_i,h,p,spin,hthree) + endif + + + htwoe = htwoe * phase + hmono = hmono * phase + hthree = hthree * phase + htot = htwoe + hmono + hthree + +end + +subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree) + implicit none + integer,intent(in) :: h_fock,p_fock,ispin_fock + integer(bit_kind), intent(in) :: key_i(N_int,2) + double precision, intent(out) :: hthree + integer :: nexc(2),i,ispin,na,nb + integer(bit_kind) :: hole(N_int,2) + integer(bit_kind) :: particle(N_int,2) + integer :: occ_hole(N_int*bit_kind_size,2) + integer :: occ_particle(N_int*bit_kind_size,2) + integer :: n_occ_ab_hole(2),n_occ_ab_particle(2) + integer(bit_kind) :: det_tmp(N_int,2) + + + nexc(1) = 0 + nexc(2) = 0 + !! Get all the holes and particles of key_i with respect to the ROHF determinant + do i=1,N_int + hole(i,1) = xor(key_i(i,1),ref_bitmask(i,1)) + hole(i,2) = xor(key_i(i,2),ref_bitmask(i,2)) + particle(i,1) = iand(hole(i,1),key_i(i,1)) + particle(i,2) = iand(hole(i,2),key_i(i,2)) + hole(i,1) = iand(hole(i,1),ref_bitmask(i,1)) + hole(i,2) = iand(hole(i,2),ref_bitmask(i,2)) + nexc(1) = nexc(1) + popcnt(hole(i,1)) + nexc(2) = nexc(2) + popcnt(hole(i,2)) + enddo + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(particle, occ_particle, tmp, N_int) + ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha + ASSERT (tmp(2) == nexc(2)) ! Number of particle beta + !DIR$ FORCEINLINE + call bitstring_to_list_ab(hole, occ_hole, tmp, N_int) + ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha + ASSERT (tmp(2) == nexc(2)) ! Number of holes beta + + !! Initialize the matrix element with the reference ROHF Slater determinant Fock element + if(ispin_fock==1)then + hthree = fock_a_tot_3e_bi_orth(p_fock,h_fock) + else + hthree = fock_b_tot_3e_bi_orth(p_fock,h_fock) + endif + det_tmp = ref_bitmask + do ispin=1,2 + na = elec_num_tab(ispin) + nb = elec_num_tab(iand(ispin,1)+1) + do i=1,nexc(ispin) + !DIR$ FORCEINLINE + call fock_ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb) + !DIR$ FORCEINLINE + call fock_a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb) + enddo + enddo +end + +subroutine fock_ac_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Routine that computes the contribution to the three-electron part of the Fock operator + ! + ! a^dagger_{p_fock} a_{h_fock} of spin ispin_fock + ! + ! on top of a determinant 'key' on which you ADD an electron of spin ispin in orbital iorb + ! + ! in output, the determinant key is changed by the ADDITION of that electron + ! + ! the output hthree is INCREMENTED + END_DOC + integer, intent(in) :: iorb, ispin, Nint, h_fock,p_fock, ispin_fock + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hthree + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i,jj,j + double precision :: direct_int, exchange_int + + + if (iorb < 1) then + print *, irp_here, ': iorb < 1' + print *, iorb, mo_num + stop -1 + endif + if (iorb > mo_num) then + print *, irp_here, ': iorb > mo_num' + print *, iorb, mo_num + stop -1 + endif + + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) + ASSERT (tmp(1) == elec_alpha_num) + ASSERT (tmp(2) == elec_beta_num) + + k = shiftr(iorb-1,bit_kind_shift)+1 + ASSERT (k >0) + l = iorb - shiftl(k-1,bit_kind_shift)-1 + ASSERT (l >= 0) + key(k,ispin) = ibset(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + + !! spin of other electrons == ispin + if(ispin == ispin_fock)then + !! in what follows :: jj == other electrons in the determinant + !! :: iorb == electron that has been added of spin ispin + !! :: p_fock, h_fock == hole particle of spin ispin_fock + !! jj = ispin = ispin_fock >> pure parallel spin + do j = 1, na + jj = occ(j,ispin) + hthree += three_e_single_parrallel_spin_prov(jj,iorb,p_fock,h_fock) + enddo + !! spin of jj == other spin than ispin AND ispin_fock + !! exchange between the iorb and (h_fock, p_fock) + do j = 1, nb + jj = occ(j,other_spin) + direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + hthree += direct_int - exchange_int + enddo + else !! ispin NE to ispin_fock + !! jj = ispin BUT NON EQUAL TO ispin_fock + !! exchange between the jj and iorb + do j = 1, na + jj = occ(j,ispin) + direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + exchange_int = three_e_4_idx_exch23_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + hthree += direct_int - exchange_int + enddo + !! jj = other_spin than ispin BUT jj == ispin_fock + !! exchange between jj and (h_fock,p_fock) + do j = 1, nb + jj = occ(j,other_spin) + direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + exchange_int = three_e_4_idx_exch13_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + hthree += direct_int - exchange_int + enddo + endif + + na = na+1 +end + +subroutine fock_a_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Routine that computes the contribution to the three-electron part of the Fock operator + ! + ! a^dagger_{p_fock} a_{h_fock} of spin ispin_fock + ! + ! on top of a determinant 'key' on which you REMOVE an electron of spin ispin in orbital iorb + ! + ! in output, the determinant key is changed by the REMOVAL of that electron + ! + ! the output hthree is INCREMENTED + END_DOC + integer, intent(in) :: iorb, ispin, Nint, h_fock,p_fock, ispin_fock + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hthree + + double precision :: direct_int, exchange_int + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i,jj,mm,j,m + integer :: tmp(2) + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + k = shiftr(iorb-1,bit_kind_shift)+1 + ASSERT (k>0) + l = iorb - shiftl(k-1,bit_kind_shift)-1 + key(k,ispin) = ibclr(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) + na = na-1 + !! spin of other electrons == ispin + if(ispin == ispin_fock)then + !! in what follows :: jj == other electrons in the determinant + !! :: iorb == electron that has been added of spin ispin + !! :: p_fock, h_fock == hole particle of spin ispin_fock + !! jj = ispin = ispin_fock >> pure parallel spin + do j = 1, na + jj = occ(j,ispin) + hthree -= three_e_single_parrallel_spin_prov(jj,iorb,p_fock,h_fock) + enddo + !! spin of jj == other spin than ispin AND ispin_fock + !! exchange between the iorb and (h_fock, p_fock) + do j = 1, nb + jj = occ(j,other_spin) + direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + hthree -= direct_int - exchange_int + enddo + else !! ispin NE to ispin_fock + !! jj = ispin BUT NON EQUAL TO ispin_fock + !! exchange between the jj and iorb + do j = 1, na + jj = occ(j,ispin) + direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + exchange_int = three_e_4_idx_exch23_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + hthree -= direct_int - exchange_int + enddo + !! jj = other_spin than ispin BUT jj == ispin_fock + !! exchange between jj and (h_fock,p_fock) + do j = 1, nb + jj = occ(j,other_spin) + direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + exchange_int = three_e_4_idx_exch13_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR + hthree -= direct_int - exchange_int + enddo + endif + +end + + +BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num) ] + implicit none + BEGIN_DOC +! Closed-shell part of the Fock operator for the TC operator + END_DOC + integer :: h0,p0,h,p,k0,k,i + integer :: n_occ_ab(2) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab_virt(2) + integer :: occ_virt(N_int*bit_kind_size,2) + integer(bit_kind) :: key_test(N_int) + integer(bit_kind) :: key_virt(N_int,2) + double precision :: accu + + fock_op_2_e_tc_closed_shell = -1000.d0 + call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int) + do i = 1, N_int + key_virt(i,1) = full_ijkl_bitmask(i) + key_virt(i,2) = full_ijkl_bitmask(i) + key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1)) + key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int) + ! docc ---> virt single excitations + do h0 = 1, n_occ_ab(1) + h=occ(h0,1) + do p0 = 1, n_occ_ab_virt(1) + p = occ_virt(p0,1) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h) + enddo + fock_op_2_e_tc_closed_shell(p,h) = accu + enddo + enddo + + do h0 = 1, n_occ_ab_virt(1) + h = occ_virt(h0,1) + do p0 = 1, n_occ_ab(1) + p=occ(p0,1) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h) + enddo + fock_op_2_e_tc_closed_shell(p,h) = accu + enddo + enddo + + ! virt ---> virt single excitations + do h0 = 1, n_occ_ab_virt(1) + h=occ_virt(h0,1) + do p0 = 1, n_occ_ab_virt(1) + p = occ_virt(p0,1) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h) + enddo + fock_op_2_e_tc_closed_shell(p,h) = accu + enddo + enddo + + do h0 = 1, n_occ_ab_virt(1) + h = occ_virt(h0,1) + do p0 = 1, n_occ_ab_virt(1) + p=occ_virt(p0,1) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h) + enddo + fock_op_2_e_tc_closed_shell(p,h) = accu + enddo + enddo + + + ! docc ---> docc single excitations + do h0 = 1, n_occ_ab(1) + h=occ(h0,1) + do p0 = 1, n_occ_ab(1) + p = occ(p0,1) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h) + enddo + fock_op_2_e_tc_closed_shell(p,h) = accu + enddo + enddo + + do h0 = 1, n_occ_ab(1) + h = occ(h0,1) + do p0 = 1, n_occ_ab(1) + p=occ(p0,1) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h) + enddo + fock_op_2_e_tc_closed_shell(p,h) = accu + enddo + enddo + +! do i = 1, mo_num +! write(*,'(100(F10.5,X))')fock_op_2_e_tc_closed_shell(:,i) +! enddo + +END_PROVIDER + + +subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot) + BEGIN_DOC + ! for single excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: htot + double precision :: hmono, htwoe + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: get_mo_two_e_integral_tc_int, phase + double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13 + integer :: other_spin(2) + integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2) + + other_spin(1) = 2 + other_spin(2) = 1 + + hmono = 0.d0 + htwoe = 0.d0 + htot = 0.d0 + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.ne.1)then + return + endif + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + + call get_single_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc,1,h1,p1,h2,p2,s1,s2) + call get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,htot) +end + + +subroutine get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h,p,spin,phase,hmono,htwoe,htot) + use bitmasks + implicit none + integer,intent(in) :: h,p,spin + double precision, intent(in) :: phase + integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2) + double precision, intent(out) :: hmono,htwoe,htot + integer(bit_kind) :: differences(N_int,2) + integer(bit_kind) :: hole(N_int,2) + integer(bit_kind) :: partcl(N_int,2) + integer :: occ_hole(N_int*bit_kind_size,2) + integer :: occ_partcl(N_int*bit_kind_size,2) + integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2) + integer :: i0,i + double precision :: buffer_c(mo_num),buffer_x(mo_num) + do i=1, mo_num + buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h) + buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h) + enddo + do i = 1, N_int + differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1)) + differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2)) + hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1)) + hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2)) + partcl(i,1) = iand(differences(i,1),key_i(i,1)) + partcl(i,2) = iand(differences(i,2),key_i(i,2)) + enddo + call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int) + call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int) + hmono = mo_bi_ortho_tc_one_e(p,h) + htwoe = fock_op_2_e_tc_closed_shell(p,h) + ! holes :: direct terms + do i0 = 1, n_occ_ab_hole(1) + i = occ_hole(i0,1) + htwoe -= buffer_c(i) + enddo + do i0 = 1, n_occ_ab_hole(2) + i = occ_hole(i0,2) + htwoe -= buffer_c(i) + enddo + + ! holes :: exchange terms + do i0 = 1, n_occ_ab_hole(spin) + i = occ_hole(i0,spin) + htwoe += buffer_x(i) + enddo + + ! particles :: direct terms + do i0 = 1, n_occ_ab_partcl(1) + i = occ_partcl(i0,1) + htwoe += buffer_c(i) + enddo + do i0 = 1, n_occ_ab_partcl(2) + i = occ_partcl(i0,2) + htwoe += buffer_c(i) + enddo + + ! particles :: exchange terms + do i0 = 1, n_occ_ab_partcl(spin) + i = occ_partcl(i0,spin) + htwoe -= buffer_x(i) + enddo + htwoe = htwoe * phase + hmono = hmono * phase + htot = htwoe + hmono + +end + diff --git a/src/tc_bi_ortho/symmetrized_3_e_int.irp.f b/src/tc_bi_ortho/symmetrized_3_e_int.irp.f new file mode 100644 index 00000000..e4f7ca93 --- /dev/null +++ b/src/tc_bi_ortho/symmetrized_3_e_int.irp.f @@ -0,0 +1,111 @@ +subroutine give_all_perm_for_three_e(n,l,k,m,j,i,idx_list,phase) + implicit none + BEGIN_DOC + ! returns all the list of permutting indices for the antimmetrization of + ! + ! (k^dagger l^dagger n^dagger m j i) when all indices have the same spins + ! + ! idx_list(:,i) == list of the 6 indices corresponding the permutation "i" + ! + ! phase(i) == phase of the permutation "i" + ! + ! there are in total 6 permutations with different indices + END_DOC + integer, intent(in) :: n,l,k,m,j,i + integer, intent(out) :: idx_list(6,6) + double precision :: phase(6) + integer :: list(6) + !!! CYCLIC PERMUTATIONS + phase(1:3) = 1.d0 + !!! IDENTITY PERMUTATION + list = (/n,l,k,m,j,i/) + idx_list(:,1) = list(:) + !!! FIRST CYCLIC PERMUTATION + list = (/n,l,k,j,i,m/) + idx_list(:,2) = list(:) + !!! FIRST CYCLIC PERMUTATION + list = (/n,l,k,i,m,j/) + idx_list(:,3) = list(:) + + !!! NON CYCLIC PERMUTATIONS + phase(1:3) = -1.d0 + !!! PARTICLE 1 is FIXED + list = (/n,l,k,j,m,i/) + idx_list(:,4) = list(:) + !!! PARTICLE 2 is FIXED + list = (/n,l,k,i,j,m/) + idx_list(:,5) = list(:) + !!! PARTICLE 3 is FIXED + list = (/n,l,k,m,i,j/) + idx_list(:,6) = list(:) + +end + +double precision function sym_3_e_int_from_6_idx_tensor(n,l,k,m,j,i) + implicit none + BEGIN_DOC + ! returns all good combinations of permutations of integrals with the good signs + ! + ! for a given (k^dagger l^dagger n^dagger m j i) when all indices have the same spins + END_DOC + integer, intent(in) :: n,l,k,m,j,i + sym_3_e_int_from_6_idx_tensor = three_body_ints_bi_ort(n,l,k,m,j,i) & ! direct + + three_body_ints_bi_ort(n,l,k,j,i,m) & ! 1st cyclic permutation + + three_body_ints_bi_ort(n,l,k,i,m,j) & ! 2nd cyclic permutation + - three_body_ints_bi_ort(n,l,k,j,m,i) & ! elec 1 is kept fixed + - three_body_ints_bi_ort(n,l,k,i,j,m) & ! elec 2 is kept fixed + - three_body_ints_bi_ort(n,l,k,m,i,j) ! elec 3 is kept fixed + +end + +double precision function direct_sym_3_e_int(n,l,k,m,j,i) + implicit none + BEGIN_DOC + ! returns all good combinations of permutations of integrals with the good signs + ! + ! for a given (k^dagger l^dagger n^dagger m j i) when all indices have the same spins + END_DOC + integer, intent(in) :: n,l,k,m,j,i + double precision :: integral + direct_sym_3_e_int = 0.d0 + call give_integrals_3_body_bi_ort(n,l,k,m,j,i,integral) ! direct + direct_sym_3_e_int += integral + call give_integrals_3_body_bi_ort(n,l,k,j,i,m,integral) ! 1st cyclic permutation + direct_sym_3_e_int += integral + call give_integrals_3_body_bi_ort(n,l,k,i,m,j,integral) ! 2nd cyclic permutation + direct_sym_3_e_int += integral + call give_integrals_3_body_bi_ort(n,l,k,j,m,i,integral) ! elec 1 is kept fixed + direct_sym_3_e_int += -integral + call give_integrals_3_body_bi_ort(n,l,k,i,j,m,integral) ! elec 2 is kept fixed + direct_sym_3_e_int += -integral + call give_integrals_3_body_bi_ort(n,l,k,m,i,j,integral) ! elec 3 is kept fixed + direct_sym_3_e_int += -integral + +end + +double precision function three_e_diag_parrallel_spin(m,j,i) + implicit none + integer, intent(in) :: i,j,m + three_e_diag_parrallel_spin = three_e_3_idx_direct_bi_ort(m,j,i) ! direct + three_e_diag_parrallel_spin += three_e_3_idx_cycle_1_bi_ort(m,j,i) + three_e_3_idx_cycle_2_bi_ort(m,j,i) & ! two cyclic permutations + - three_e_3_idx_exch23_bi_ort(m,j,i) - three_e_3_idx_exch13_bi_ort(m,j,i) & ! two first exchange + - three_e_3_idx_exch12_bi_ort(m,j,i) ! last exchange +end + +double precision function three_e_single_parrallel_spin(m,j,k,i) + implicit none + integer, intent(in) :: i,k,j,m + three_e_single_parrallel_spin = three_e_4_idx_direct_bi_ort(m,j,k,i) ! direct + three_e_single_parrallel_spin += three_e_4_idx_cycle_1_bi_ort(m,j,k,i) + three_e_4_idx_cycle_2_bi_ort(m,j,k,i) & ! two cyclic permutations + - three_e_4_idx_exch23_bi_ort(m,j,k,i) - three_e_4_idx_exch13_bi_ort(m,j,k,i) & ! two first exchange + - three_e_4_idx_exch12_bi_ort(m,j,k,i) ! last exchange +end + +double precision function three_e_double_parrallel_spin(m,l,j,k,i) + implicit none + integer, intent(in) :: i,k,j,m,l + three_e_double_parrallel_spin = three_e_5_idx_direct_bi_ort(m,l,j,k,i) ! direct + three_e_double_parrallel_spin += three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) + three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) & ! two cyclic permutations + - three_e_5_idx_exch23_bi_ort(m,l,j,k,i) - three_e_5_idx_exch13_bi_ort(m,l,j,k,i) & ! two first exchange + - three_e_5_idx_exch12_bi_ort(m,l,j,k,i) ! last exchange +end diff --git a/src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f b/src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f new file mode 100644 index 00000000..e8277a74 --- /dev/null +++ b/src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f @@ -0,0 +1,140 @@ + +BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! + ! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS + ! + ! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form for same spin matrix elements + ! + ! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign + ! + END_DOC + + implicit none + integer :: i, j, m + double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin + + three_e_diag_parrallel_spin_prov = 0.d0 + print *, ' Providing the three_e_diag_parrallel_spin_prov ...' + + integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = j, mo_num + three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do i = 1, mo_num + do j = 1, mo_num + do m = 1, j + three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i) + enddo + enddo + enddo + + call wall_time(wall1) + print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! + ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs + ! + ! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of for same spin matrix elements + ! + ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + ! + END_DOC + + implicit none + integer :: i, j, k, m + double precision :: integral, wall1, wall0, three_e_single_parrallel_spin + + three_e_single_parrallel_spin_prov = 0.d0 + print *, ' Providing the three_e_single_parrallel_spin_prov ...' + + integral = three_e_single_parrallel_spin(1,1,1,1) + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,integral) & + !$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0 + +END_PROVIDER + + +! --- + +BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! + ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs + ! + ! three_e_double_parrallel_spin_prov(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO + ! + ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + + implicit none + integer :: i, j, k, m, l + double precision :: integral, wall1, wall0, three_e_double_parrallel_spin + + three_e_double_parrallel_spin_prov = 0.d0 + print *, ' Providing the three_e_double_parrallel_spin_prov ...' + call wall_time(wall0) + + integral = three_e_double_parrallel_spin(1,1,1,1,1) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,l,integral) & + !$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do l = 1, mo_num + do m = 1, mo_num + three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i) + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0 + +END_PROVIDER + diff --git a/src/tc_bi_ortho/tc_bi_ortho.irp.f b/src/tc_bi_ortho/tc_bi_ortho.irp.f new file mode 100644 index 00000000..cfa24f3b --- /dev/null +++ b/src/tc_bi_ortho/tc_bi_ortho.irp.f @@ -0,0 +1,61 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end. + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call routine_diag +! call test +end + +subroutine test + implicit none + integer :: i,j + double precision :: hmono,htwoe,hthree,htot + use bitmasks + + print*,'test' +! call htilde_mu_mat_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot) + call double_htilde_mu_mat_bi_ortho(N_int,psi_det(1,1,1), psi_det(1,1,2), hmono, htwoe, htot) + print*,hmono, htwoe, htot + +end + +subroutine routine_diag + implicit none +! provide eigval_right_tc_bi_orth + provide overlap_bi_ortho +! provide htilde_matrix_elmt_bi_ortho + integer ::i,j + print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1) + print*,'e_tc_left_right = ',e_tc_left_right + print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00 + print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth + print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single + print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double + print*,'***' + print*,'e_corr_bi_orth = ',e_corr_bi_orth + print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj + print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth + print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth + print*,'Left/right eigenvectors' + do i = 1,N_det + write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1) + enddo + do j=1,N_states + do i=1,N_det + psi_l_coef_bi_ortho(i,j) = leigvec_tc_bi_orth(i,j) + psi_r_coef_bi_ortho(i,j) = reigvec_tc_bi_orth(i,j) + enddo + enddo + SOFT_TOUCH psi_l_coef_bi_ortho psi_r_coef_bi_ortho + call save_tc_bi_ortho_wavefunction +! call routine_save_left_right_bi_ortho +end + diff --git a/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f b/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f new file mode 100644 index 00000000..28f122ee --- /dev/null +++ b/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f @@ -0,0 +1,24 @@ +program tc_bi_ortho_prop + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid +! call routine_diag + call test +end + +subroutine test + implicit none + integer :: i + print*,'TC Dipole components' + do i= 1, 3 + print*,tc_bi_ortho_dipole(i,1) + enddo +end diff --git a/src/tc_bi_ortho/tc_cisd_sc2.irp.f b/src/tc_bi_ortho/tc_cisd_sc2.irp.f new file mode 100644 index 00000000..0fb9f524 --- /dev/null +++ b/src/tc_bi_ortho/tc_cisd_sc2.irp.f @@ -0,0 +1,24 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + call test +end + +subroutine test + implicit none +! double precision, allocatable :: dressing_dets(:),e_corr_dets(:) +! allocate(dressing_dets(N_det),e_corr_dets(N_det)) +! e_corr_dets = 0.d0 +! call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets) + provide eigval_tc_cisd_sc2_bi_ortho +end diff --git a/src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f new file mode 100644 index 00000000..4ae44148 --- /dev/null +++ b/src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f @@ -0,0 +1,145 @@ + BEGIN_PROVIDER [ double precision, reigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)] +&BEGIN_PROVIDER [ double precision, leigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)] +&BEGIN_PROVIDER [ double precision, eigval_tc_cisd_sc2_bi_ortho, (N_states)] + implicit none + integer :: it,n_real,degree,i,istate + double precision :: e_before, e_current,thr, hmono,htwoe,hthree,accu + double precision, allocatable :: e_corr_dets(:),h0j(:), h_sc2(:,:), dressing_dets(:) + double precision, allocatable :: leigvec_tc_bi_orth_tmp(:,:),reigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:) + allocate(leigvec_tc_bi_orth_tmp(N_det,N_det),reigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det)) + allocate(e_corr_dets(N_det),h0j(N_det),h_sc2(N_det,N_det),dressing_dets(N_det)) + allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states)) + dressing_dets = 0.d0 + do i = 1, N_det + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i)) + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree == 1 .or. degree == 2)then + call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i)) + endif + enddo + reigvec_tc_bi_orth_tmp = 0.d0 + do i = 1, N_det + reigvec_tc_bi_orth_tmp(i,1) = psi_r_coef_bi_ortho(i,1) + enddo + vec_tmp = 0.d0 + do istate = 1, N_states + vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate) + enddo + do istate = N_states+1, n_states_diag + vec_tmp(istate,istate) = 1.d0 + enddo + print*,'Diagonalizing the TC CISD ' + call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav) + do i = 1, N_det + e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1) + enddo + E_before = eigval_tmp(1) + print*,'Starting from ',E_before + + e_current = 10.d0 + thr = 1.d-5 + it = 0 + dressing_dets = 0.d0 + double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:) + external htc_bi_ortho_calc_tdav + external htcdag_bi_ortho_calc_tdav + logical :: converged + do while (dabs(E_before-E_current).gt.thr) + it += 1 + E_before = E_current +! h_sc2 = htilde_matrix_elmt_bi_ortho + call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets) + do i = 1, N_det +! print*,'dressing_dets(i) = ',dressing_dets(i) + h_sc2(i,i) += dressing_dets(i) + enddo + print*,'********************' + print*,'iteration ',it +! call non_hrmt_real_diag(N_det,h_sc2,& +! leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,& +! n_real,eigval_right_tmp) +! print*,'eigval_right_tmp(1)',eigval_right_tmp(1) + vec_tmp = 0.d0 + do istate = 1, N_states + vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate) + enddo + do istate = N_states+1, n_states_diag + vec_tmp(istate,istate) = 1.d0 + enddo + call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav) + print*,'outside Davidson' + print*,'eigval_tmp(1) = ',eigval_tmp(1) + do i = 1, N_det + reigvec_tc_bi_orth_tmp(i,1) = vec_tmp(i,1) + e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1) + enddo +! E_current = eigval_right_tmp(1) + E_current = eigval_tmp(1) + print*,'it, E(SC)^2 = ',it,E_current + enddo + eigval_tc_cisd_sc2_bi_ortho(1:N_states) = eigval_right_tmp(1:N_states) + reigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = reigvec_tc_bi_orth_tmp(1:N_det,1:N_states) + leigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = leigvec_tc_bi_orth_tmp(1:N_det,1:N_states) + +END_PROVIDER + +subroutine get_cisd_sc2_dressing(dets,e_corr_dets,ndet,dressing_dets) + implicit none + use bitmasks + integer, intent(in) :: ndet + integer(bit_kind), intent(in) :: dets(N_int,2,ndet) + double precision, intent(in) :: e_corr_dets(ndet) + double precision, intent(out) :: dressing_dets(ndet) + integer, allocatable :: degree(:),hole(:,:),part(:,:),spin(:,:) + integer(bit_kind), allocatable :: hole_part(:,:,:) + integer :: i,j,k, exc(0:2,2,2),h1,p1,h2,p2,s1,s2 + integer(bit_kind) :: xorvec(2,N_int) + + double precision :: phase + dressing_dets = 0.d0 + allocate(degree(ndet),hole(2,ndet),part(2,ndet), spin(2,ndet),hole_part(N_int,2,ndet)) + do i = 2, ndet + call get_excitation_degree(HF_bitmask,dets(1,1,i),degree(i),N_int) + do j = 1, N_int + hole_part(j,1,i) = xor( HF_bitmask(j,1), dets(j,1,i)) + hole_part(j,2,i) = xor( HF_bitmask(j,2), dets(j,2,i)) + enddo + if(degree(i) == 1)then + call get_single_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int) + else if(degree(i) == 2)then + call get_double_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int) + endif + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + hole(1,i) = h1 + hole(2,i) = h2 + part(1,i) = p1 + part(2,i) = p2 + spin(1,i) = s1 + spin(2,i) = s2 + enddo + + integer :: same + if(elec_alpha_num+elec_beta_num<3)return + do i = 2, ndet + do j = i+1, ndet + same = 0 + if(degree(i) == degree(j) .and. degree(i)==1)cycle + do k = 1, N_int + xorvec(k,1) = iand(hole_part(k,1,i),hole_part(k,1,j)) + xorvec(k,2) = iand(hole_part(k,2,i),hole_part(k,2,j)) + same += popcnt(xorvec(k,1)) + popcnt(xorvec(k,2)) + enddo +! print*,'i,j',i,j +! call debug_det(dets(1,1,i),N_int) +! call debug_det(hole_part(1,1,i),N_int) +! call debug_det(dets(1,1,j),N_int) +! call debug_det(hole_part(1,1,j),N_int) +! print*,'same = ',same + if(same.eq.0)then + dressing_dets(i) += e_corr_dets(j) + dressing_dets(j) += e_corr_dets(i) + endif + enddo + enddo + +end diff --git a/src/tc_bi_ortho/tc_h_eigvectors.irp.f b/src/tc_bi_ortho/tc_h_eigvectors.irp.f new file mode 100644 index 00000000..d39b7a29 --- /dev/null +++ b/src/tc_bi_ortho/tc_h_eigvectors.irp.f @@ -0,0 +1,183 @@ + use bitmasks + + BEGIN_PROVIDER [ integer, index_HF_psi_det] + implicit none + integer :: i,degree + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_HF_psi_det = i + exit + endif + enddo + END_PROVIDER + + + + BEGIN_PROVIDER [double precision, eigval_right_tc_bi_orth, (N_states)] +&BEGIN_PROVIDER [double precision, eigval_left_tc_bi_orth, (N_states)] +&BEGIN_PROVIDER [double precision, reigvec_tc_bi_orth, (N_det,N_states)] +&BEGIN_PROVIDER [double precision, leigvec_tc_bi_orth, (N_det,N_states)] +&BEGIN_PROVIDER [double precision, norm_ground_left_right_bi_orth ] + + BEGIN_DOC + ! eigenvalues, right and left eigenvectors of the transcorrelated Hamiltonian on the BI-ORTHO basis + END_DOC + + implicit none + integer :: i, idx_dress, j, istate + logical :: converged, dagger + integer :: n_real_tc_bi_orth_eigval_right,igood_r,igood_l + double precision, allocatable :: reigvec_tc_bi_orth_tmp(:,:),leigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:) + + PROVIDE N_det N_int + + if(n_det.le.N_det_max_full)then + allocate(reigvec_tc_bi_orth_tmp(N_det,N_det),leigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det)) + call non_hrmt_real_diag(N_det,htilde_matrix_elmt_bi_ortho,& + leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,& + n_real_tc_bi_orth_eigval_right,eigval_right_tmp) + double precision, allocatable :: coef_hf_r(:),coef_hf_l(:) + integer, allocatable :: iorder(:) + allocate(coef_hf_r(N_det),coef_hf_l(N_det),iorder(N_det)) + do i = 1,N_det + iorder(i) = i + coef_hf_r(i) = -dabs(reigvec_tc_bi_orth_tmp(index_HF_psi_det,i)) + enddo + call dsort(coef_hf_r,iorder,N_det) + igood_r = iorder(1) + print*,'igood_r, coef_hf_r = ',igood_r,coef_hf_r(1) + do i = 1,N_det + iorder(i) = i + coef_hf_l(i) = -dabs(leigvec_tc_bi_orth_tmp(index_HF_psi_det,i)) + enddo + call dsort(coef_hf_l,iorder,N_det) + igood_l = iorder(1) + print*,'igood_l, coef_hf_l = ',igood_l,coef_hf_l(1) + + if(igood_r.ne.igood_l.and.igood_r.ne.1)then + print *,'' + print *,'Warning, the left and right eigenvectors are "not the same" ' + print *,'Warning, the ground state is not dominated by HF...' + print *,'State with largest RIGHT coefficient of HF ',igood_r + print *,'coef of HF in RIGHT eigenvector = ',reigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_r) + print *,'State with largest LEFT coefficient of HF ',igood_l + print *,'coef of HF in LEFT eigenvector = ',leigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_l) + endif + if(state_following_tc)then + print *,'Following the states with the largest coef on HF' + print *,'igood_r,igood_l',igood_r,igood_l + i= igood_r + eigval_right_tc_bi_orth(1) = eigval_right_tmp(i) + do j = 1, N_det + reigvec_tc_bi_orth(j,1) = reigvec_tc_bi_orth_tmp(j,i) +! print*,reigvec_tc_bi_orth(j,1) + enddo + i= igood_l + eigval_left_tc_bi_orth(1) = eigval_right_tmp(i) + do j = 1, N_det + leigvec_tc_bi_orth(j,1) = leigvec_tc_bi_orth_tmp(j,i) + enddo + else + do i = 1, N_states + eigval_right_tc_bi_orth(i) = eigval_right_tmp(i) + eigval_left_tc_bi_orth(i) = eigval_right_tmp(i) + do j = 1, N_det + reigvec_tc_bi_orth(j,i) = reigvec_tc_bi_orth_tmp(j,i) + leigvec_tc_bi_orth(j,i) = leigvec_tc_bi_orth_tmp(j,i) + enddo + enddo + endif + else + double precision, allocatable :: H_jj(:),vec_tmp(:,:) + external htc_bi_ortho_calc_tdav + external htcdag_bi_ortho_calc_tdav + external H_tc_u_0_opt + external H_tc_dagger_u_0_opt + allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag)) + do i = 1, N_det + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i)) + enddo + !!!! Preparing the left-eigenvector + print*,'Computing the left-eigenvector ' + vec_tmp = 0.d0 + do istate = 1, N_states + vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate) + enddo + do istate = N_states+1, n_states_diag + vec_tmp(istate,istate) = 1.d0 + enddo +! call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, htcdag_bi_ortho_calc_tdav) + call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_dagger_u_0_opt) + do istate = 1, N_states + leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate) + enddo + + print*,'Computing the right-eigenvector ' + !!!! Preparing the right-eigenvector + vec_tmp = 0.d0 + do istate = 1, N_states + vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate) + enddo + do istate = N_states+1, n_states_diag + vec_tmp(istate,istate) = 1.d0 + enddo +! call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav) + call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_u_0_opt) + do istate = 1, N_states + reigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate) + enddo + + deallocate(H_jj) + endif + call bi_normalize(leigvec_tc_bi_orth,reigvec_tc_bi_orth,size(reigvec_tc_bi_orth,1),N_det,N_states) + print*,'leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) = ',leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) + norm_ground_left_right_bi_orth = 0.d0 + do j = 1, N_det + norm_ground_left_right_bi_orth += leigvec_tc_bi_orth(j,1) * reigvec_tc_bi_orth(j,1) + enddo + print*,'norm l/r = ',norm_ground_left_right_bi_orth + +END_PROVIDER + + + +subroutine bi_normalize(u_l,u_r,n,ld,nstates) + !!!! Normalization of the scalar product of the left/right eigenvectors + double precision, intent(inout) :: u_l(ld,nstates), u_r(ld,nstates) + integer, intent(in) :: n,ld,nstates + integer :: i + double precision :: accu, tmp + do i = 1, nstates + !!!! Normalization of right eigenvectors |Phi> + accu = 0.d0 + do j = 1, n + accu += u_r(j,i) * u_r(j,i) + enddo + accu = 1.d0/dsqrt(accu) + print*,'accu_r = ',accu + do j = 1, n + u_r(j,i) *= accu + enddo + tmp = u_r(1,i) / dabs(u_r(1,i)) + do j = 1, n + u_r(j,i) *= tmp + enddo + !!!! Adaptation of the norm of the left eigenvector such that = 1 + accu = 0.d0 + do j = 1, n + accu += u_l(j,i) * u_r(j,i) +! print*,j, u_l(j,i) , u_r(j,i) + enddo + if(accu.gt.0.d0)then + accu = 1.d0/dsqrt(accu) + else + accu = 1.d0/dsqrt(-accu) + endif + tmp = (u_l(1,i) * u_r(1,i) )/dabs(u_l(1,i) * u_r(1,i)) + do j = 1, n + u_l(j,i) *= accu * tmp + u_r(j,i) *= accu + enddo + enddo +end diff --git a/src/tc_bi_ortho/tc_hmat.irp.f b/src/tc_bi_ortho/tc_hmat.irp.f new file mode 100644 index 00000000..44e27e7c --- /dev/null +++ b/src/tc_bi_ortho/tc_hmat.irp.f @@ -0,0 +1,45 @@ + + BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)] + + BEGIN_DOC + ! htilde_matrix_elmt_bi_ortho(j,i) = + ! + ! WARNING !!!!!!!!! IT IS NOT HERMITIAN !!!!!!!!! + END_DOC + + implicit none + integer :: i, j + double precision :: hmono,htwoe,hthree,htot + + PROVIDE N_int + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hmono, htwoe, hthree, htot) & + !$OMP SHARED (N_det, psi_det, N_int,htilde_matrix_elmt_bi_ortho) + do i = 1, N_det + do j = 1, N_det + ! < J | Htilde | I > + call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + + !print *, ' hmono = ', hmono + !print *, ' htwoe = ', htwoe + !print *, ' hthree = ', hthree + htilde_matrix_elmt_bi_ortho(j,i) = htot + enddo + enddo + !$OMP END PARALLEL DO +! print*,'htilde_matrix_elmt_bi_ortho = ' +! do i = 1, min(100,N_det) +! write(*,'(100(F16.10,X))')htilde_matrix_elmt_bi_ortho(1:min(100,N_det),i) +! enddo + + +END_PROVIDER + + BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho_tranp, (N_det,N_det)] + implicit none + integer ::i,j + do i = 1, N_det + do j = 1, N_det + htilde_matrix_elmt_bi_ortho_tranp(j,i) = htilde_matrix_elmt_bi_ortho(i,j) + enddo + enddo +END_PROVIDER diff --git a/src/tc_bi_ortho/tc_natorb.irp.f b/src/tc_bi_ortho/tc_natorb.irp.f new file mode 100644 index 00000000..33410570 --- /dev/null +++ b/src/tc_bi_ortho/tc_natorb.irp.f @@ -0,0 +1,218 @@ + +! --- + + BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_mo, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_mo, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, natorb_tc_eigval, (mo_num)] + + BEGIN_DOC + ! + ! natorb_tc_reigvec_mo : RIGHT eigenvectors of the ground state transition matrix (equivalent of natural orbitals) + ! natorb_tc_leigvec_mo : LEFT eigenvectors of the ground state transition matrix (equivalent of natural orbitals) + ! natorb_tc_eigval : eigenvalues of the ground state transition matrix (equivalent of the occupation numbers). WARNINING :: can be negative !! + ! + END_DOC + + implicit none + integer :: i, j, k + double precision :: thr_d, thr_nd, thr_deg, accu + double precision :: accu_d, accu_nd + double precision, allocatable :: dm_tmp(:,:), fock_diag(:) + + allocate(dm_tmp(mo_num,mo_num), fock_diag(mo_num)) + + dm_tmp(:,:) = -tc_transition_matrix(:,:,1,1) + + print *, ' dm_tmp' + do i = 1, mo_num + fock_diag(i) = fock_matrix_tc_mo_tot(i,i) + write(*, '(100(F16.10,X))') -dm_tmp(:,i) + enddo + + thr_d = 1.d-6 + thr_nd = 1.d-6 + thr_deg = 1.d-3 + call diag_mat_per_fock_degen( fock_diag, dm_tmp, mo_num, thr_d, thr_nd, thr_deg & + , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval) +! call non_hrmt_bieig( mo_num, dm_tmp& +! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo& +! , mo_num, natorb_tc_eigval ) + + accu = 0.d0 + do i = 1, mo_num + print*,'natorb_tc_eigval(i) = ',-natorb_tc_eigval(i) + accu += -natorb_tc_eigval(i) + enddo + print *, ' accu = ', accu + + dm_tmp = 0.d0 + do i = 1, mo_num + accu = 0.d0 + do k = 1, mo_num + accu += natorb_tc_reigvec_mo(k,i) * natorb_tc_leigvec_mo(k,i) + enddo + accu = 1.d0/dsqrt(dabs(accu)) + natorb_tc_reigvec_mo(:,i) *= accu + natorb_tc_leigvec_mo(:,i) *= accu + do j = 1, mo_num + do k = 1, mo_num + dm_tmp(j,i) += natorb_tc_reigvec_mo(k,i) * natorb_tc_leigvec_mo(k,j) + enddo + enddo + enddo + + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, mo_num + accu_d += dm_tmp(i,i) + !write(*,'(100(F16.10,X))')dm_tmp(:,i) + do j = 1, mo_num + if(i==j)cycle + accu_nd += dabs(dm_tmp(j,i)) + enddo + enddo + print *, ' Trace of the overlap between TC natural orbitals ', accu_d + print *, ' L1 norm of extra diagonal elements of overlap matrix ', accu_nd + + deallocate(dm_tmp, fock_diag) + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [ double precision, fock_diag_sorted_r_natorb, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, fock_diag_sorted_l_natorb, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, fock_diag_sorted_v_natorb, (mo_num)] + + implicit none + integer :: i,j,k + integer, allocatable :: iorder(:) + double precision, allocatable :: fock_diag(:) + + print *, ' Diagonal elements of the Fock matrix before ' + + do i = 1, mo_num + write(*,*) i, Fock_matrix_tc_mo_tot(i,i) + enddo + + allocate(fock_diag(mo_num)) + fock_diag = 0.d0 + do i = 1, mo_num + fock_diag(i) = 0.d0 + do j = 1, mo_num + do k = 1, mo_num + fock_diag(i) += natorb_tc_leigvec_mo(k,i) * Fock_matrix_tc_mo_tot(k,j) * natorb_tc_reigvec_mo(j,i) + enddo + enddo + enddo + + allocate(iorder(mo_num)) + do i = 1, mo_num + iorder(i) = i + enddo + call dsort(fock_diag, iorder, mo_num) + + print *, ' Diagonal elements of the Fock matrix after ' + do i = 1, mo_num + write(*,*) i, fock_diag(i) + enddo + deallocate(fock_diag) + + do i = 1, mo_num + fock_diag_sorted_v_natorb(i) = natorb_tc_eigval(iorder(i)) + do j = 1, mo_num + fock_diag_sorted_r_natorb(j,i) = natorb_tc_reigvec_mo(j,iorder(i)) + fock_diag_sorted_l_natorb(j,i) = natorb_tc_leigvec_mo(j,iorder(i)) + enddo + enddo + deallocate(iorder) + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_ao, (ao_num, mo_num)] +&BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_ao, (ao_num, mo_num)] +&BEGIN_PROVIDER [ double precision, overlap_natorb_tc_eigvec_ao, (mo_num, mo_num) ] + + BEGIN_DOC + ! EIGENVECTORS OF FOCK MATRIX ON THE AO BASIS and their OVERLAP + ! + ! THE OVERLAP SHOULD BE THE SAME AS overlap_natorb_tc_eigvec_mo + END_DOC + + implicit none + integer :: i, j, k, q, p + double precision :: accu, accu_d + double precision, allocatable :: tmp(:,:) + + + ! ! MO_R x R + call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 & + , mo_r_coef, size(mo_r_coef, 1) & + , fock_diag_sorted_r_natorb, size(fock_diag_sorted_r_natorb, 1) & + , 0.d0, natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) ) + ! + ! MO_L x L + call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 & + , mo_l_coef, size(mo_l_coef, 1) & + , fock_diag_sorted_l_natorb, size(fock_diag_sorted_l_natorb, 1) & + , 0.d0, natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1) ) + + + allocate( tmp(mo_num,ao_num) ) + + ! tmp <-- L.T x S_ao + call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 & + , natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) & + , 0.d0, tmp, size(tmp, 1) ) + + ! S <-- tmp x R + call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 & + , tmp, size(tmp, 1), natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) & + , 0.d0, overlap_natorb_tc_eigvec_ao, size(overlap_natorb_tc_eigvec_ao, 1) ) + + deallocate( tmp ) + + ! --- + double precision :: norm + do i = 1, mo_num + norm = 1.d0/dsqrt(dabs(overlap_natorb_tc_eigvec_ao(i,i))) + do j = 1, mo_num + natorb_tc_reigvec_ao(j,i) *= norm + natorb_tc_leigvec_ao(j,i) *= norm + enddo + enddo + + allocate( tmp(mo_num,ao_num) ) + + ! tmp <-- L.T x S_ao + call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 & + , natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) & + , 0.d0, tmp, size(tmp, 1) ) + + ! S <-- tmp x R + call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 & + , tmp, size(tmp, 1), natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) & + , 0.d0, overlap_natorb_tc_eigvec_ao, size(overlap_natorb_tc_eigvec_ao, 1) ) + + + + deallocate( tmp ) + + accu_d = 0.d0 + accu = 0.d0 + do i = 1, mo_num + accu_d += overlap_natorb_tc_eigvec_ao(i,i) + do j = 1, mo_num + if(i==j)cycle + accu += dabs(overlap_natorb_tc_eigvec_ao(j,i)) + enddo + enddo + print*,'Trace of the overlap_natorb_tc_eigvec_ao = ',accu_d + print*,'mo_num = ',mo_num + print*,'L1 norm of extra diagonal elements of overlap matrix ',accu + accu = accu / dble(mo_num**2) + + END_PROVIDER + diff --git a/src/tc_bi_ortho/tc_prop.irp.f b/src/tc_bi_ortho/tc_prop.irp.f new file mode 100644 index 00000000..c7f6c986 --- /dev/null +++ b/src/tc_bi_ortho/tc_prop.irp.f @@ -0,0 +1,80 @@ + +BEGIN_PROVIDER [ double precision, tc_transition_matrix, (mo_num, mo_num,N_states,N_states) ] + implicit none + BEGIN_DOC + ! tc_transition_matrix(p,h,istate,jstate) = + ! + ! where are the left/right eigenvectors on a bi-ortho basis + END_DOC + integer :: i,j,istate,jstate,m,n,p,h + double precision :: phase + integer, allocatable :: occ(:,:) + integer :: n_occ_ab(2),degree,exc(0:2,2,2) + allocate(occ(N_int*bit_kind_size,2)) + tc_transition_matrix = 0.d0 + do istate = 1, N_states + do jstate = 1, N_states + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree.gt.1)then + cycle + else if (degree == 0)then + call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) + do p = 1, n_occ_ab(1) ! browsing the alpha electrons + m = occ(p,1) + tc_transition_matrix(m,m,istate,jstate)+= psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate) + enddo + do p = 1, n_occ_ab(2) ! browsing the beta electrons + m = occ(p,1) + tc_transition_matrix(m,m,istate,jstate)+= psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate) + enddo + else + call get_single_excitation(psi_det(1,1,j),psi_det(1,1,i),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Single alpha + h = exc(1,1,1) ! hole in psi_det(1,1,j) + p = exc(1,2,1) ! particle in psi_det(1,1,j) + else + ! Single beta + h = exc(1,1,2) ! hole in psi_det(1,1,j) + p = exc(1,2,2) ! particle in psi_det(1,1,j) + endif + tc_transition_matrix(p,h,istate,jstate)+= phase * psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate) + endif + enddo + enddo + enddo + enddo + END_PROVIDER + + + BEGIN_PROVIDER [double precision, tc_bi_ortho_dipole, (3,N_states)] + implicit none + integer :: i,j,istate,m + double precision :: nuclei_part(3) + tc_bi_ortho_dipole = 0.d0 + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + tc_bi_ortho_dipole(1,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_x(j,i) + tc_bi_ortho_dipole(2,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_y(j,i) + tc_bi_ortho_dipole(3,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_z(j,i) + enddo + enddo + enddo + + nuclei_part = 0.d0 + do m = 1, 3 + do i = 1,nucl_num + nuclei_part(m) += nucl_charge(i) * nucl_coord(i,m) + enddo + enddo +! + do istate = 1, N_states + do m = 1, 3 + tc_bi_ortho_dipole(m,istate) += nuclei_part(m) + enddo + enddo + END_PROVIDER + diff --git a/src/tc_bi_ortho/tc_som.irp.f b/src/tc_bi_ortho/tc_som.irp.f new file mode 100644 index 00000000..291c52ef --- /dev/null +++ b/src/tc_bi_ortho/tc_som.irp.f @@ -0,0 +1,70 @@ +! --- + +program tc_som + + BEGIN_DOC + ! TODO : Put the documentation of the program here + END_DOC + + implicit none + + print *, ' starting ...' + print *, ' do not forget to do tc-scf first' + + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 +! my_n_pt_r_grid = 10 ! small grid for quick debug +! my_n_pt_a_grid = 26 ! small grid for quick debug + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + PROVIDE mu_erf + print *, ' mu = ', mu_erf + PROVIDE j1b_type + print *, ' j1b_type = ', j1b_type + print *, j1b_pen + + read_wf = .true. + touch read_wf + + call main() + +end + +! --- + +subroutine main() + + implicit none + integer :: i, i_HF, degree + double precision :: hmono_1, htwoe_1, hthree_1, htot_1 + double precision :: hmono_2, htwoe_2, hthree_2, htot_2 + double precision :: U_SOM + + PROVIDE N_int N_det + + do i = 1, N_det + call get_excitation_degree(HF_bitmask, psi_det(1,1,i), degree, N_int) + if(degree == 0) then + i_HF = i + exit + endif + enddo + print *, ' HF determinants:', i_HF + print *, ' N_det :', N_det + + U_SOM = 0.d0 + do i = 1, N_det + if(i == i_HF) cycle + call htilde_mu_mat_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1) + call htilde_mu_mat_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2) + U_SOM += htot_1 * htot_2 + enddo + U_SOM = 0.5d0 * U_SOM + print *, ' U_SOM = ', U_SOM + + return +end subroutine main + +! --- + diff --git a/src/tc_bi_ortho/test_natorb.irp.f b/src/tc_bi_ortho/test_natorb.irp.f new file mode 100644 index 00000000..54c9a827 --- /dev/null +++ b/src/tc_bi_ortho/test_natorb.irp.f @@ -0,0 +1,51 @@ +program test_natorb + implicit none + BEGIN_DOC +! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end. + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call routine +! call test + +end + +subroutine routine + implicit none + double precision, allocatable :: fock_diag(:),eigval(:),leigvec(:,:),reigvec(:,:),mat_ref(:,:) + allocate(eigval(mo_num),leigvec(mo_num,mo_num),reigvec(mo_num,mo_num),fock_diag(mo_num),mat_ref(mo_num, mo_num)) + double precision, allocatable :: eigval_ref(:),leigvec_ref(:,:),reigvec_ref(:,:) + allocate(eigval_ref(mo_num),leigvec_ref(mo_num,mo_num),reigvec_ref(mo_num,mo_num)) + + double precision :: thr_deg + integer :: i,n_real,j + print*,'fock_matrix' + do i = 1, mo_num + fock_diag(i) = Fock_matrix_mo(i,i) + print*,i,fock_diag(i) + enddo + thr_deg = 1.d-6 + mat_ref = -one_e_dm_mo + print*,'diagonalization by block' + call diag_mat_per_fock_degen(fock_diag,mat_ref,mo_num,thr_deg,leigvec,reigvec,eigval) + call non_hrmt_bieig( mo_num, mat_ref& + , leigvec_ref, reigvec_ref& + , n_real, eigval_ref) + print*,'TEST ***********************************' + double precision :: accu_l, accu_r + do i = 1, mo_num + accu_l = 0.d0 + accu_r = 0.d0 + do j = 1, mo_num + accu_r += reigvec_ref(j,i) * reigvec(j,i) + accu_l += leigvec_ref(j,i) * leigvec(j,i) + enddo + print*,i + write(*,'(I3,X,100(F16.10,X))')i,eigval(i),eigval_ref(i),accu_l,accu_r + enddo +end diff --git a/src/tc_bi_ortho/test_normal_order.irp.f b/src/tc_bi_ortho/test_normal_order.irp.f new file mode 100644 index 00000000..118e481a --- /dev/null +++ b/src/tc_bi_ortho/test_normal_order.irp.f @@ -0,0 +1,131 @@ +program test_normal_order + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call provide_all_three_ints_bi_ortho + call test +end + +subroutine test + implicit none + use bitmasks ! you need to include the bitmasks_module.f90 features + integer :: h1,h2,p1,p2,s1,s2,i_ok,degree,Ne(2) + integer :: exc(0:2,2,2) + integer(bit_kind), allocatable :: det_i(:,:) + double precision :: hmono,htwoe,hthree,htilde_ij,accu,phase,normal + integer, allocatable :: occ(:,:) + allocate( occ(N_int*bit_kind_size,2) ) + call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) + allocate(det_i(N_int,2)) + s1 = 1 + s2 = 2 + accu = 0.d0 + do h1 = 1, elec_beta_num + do p1 = elec_alpha_num+1, mo_num + do h2 = 1, elec_beta_num + do p2 = elec_beta_num+1, mo_num + det_i = ref_bitmask + call do_single_excitation(det_i,h1,p1,s1,i_ok) + call do_single_excitation(det_i,h2,p2,s2,i_ok) + call htilde_mu_mat_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call get_excitation_degree(ref_bitmask,det_i,degree,N_int) + call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) + hthree *= phase +! !normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1) + call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal) +! normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1) + accu += dabs(hthree-normal) + enddo + enddo + enddo + enddo +print*,'accu opposite spin = ',accu +stop + +! p2=6 +! p1=5 +! h2=2 +! h1=1 + +s1 = 1 +s2 = 1 +accu = 0.d0 +do h1 = 1, elec_alpha_num + do p1 = elec_alpha_num+1, mo_num + do p2 = p1+1, mo_num + do h2 = h1+1, elec_alpha_num + det_i = ref_bitmask + call do_single_excitation(det_i,h1,p1,s1,i_ok) + if(i_ok.ne.1)cycle + call do_single_excitation(det_i,h2,p2,s2,i_ok) + if(i_ok.ne.1)cycle + call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call get_excitation_degree(ref_bitmask,det_i,degree,N_int) + call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) + integer :: hh1, pp1, hh2, pp2, ss1, ss2 + call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2) + hthree *= phase +! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) + normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1) + if(dabs(hthree).lt.1.d-10)cycle + if(dabs(hthree-normal).gt.1.d-10)then + print*,pp2,pp1,hh2,hh1 + print*,p2,p1,h2,h1 + print*,hthree,normal,dabs(hthree-normal) + stop + endif +! print*,hthree,normal,dabs(hthree-normal) + accu += dabs(hthree-normal) + enddo + enddo + enddo +enddo +print*,'accu same spin alpha = ',accu + + +s1 = 2 +s2 = 2 +accu = 0.d0 +do h1 = 1, elec_beta_num + do p1 = elec_beta_num+1, mo_num + do p2 = p1+1, mo_num + do h2 = h1+1, elec_beta_num + det_i = ref_bitmask + call do_single_excitation(det_i,h1,p1,s1,i_ok) + if(i_ok.ne.1)cycle + call do_single_excitation(det_i,h2,p2,s2,i_ok) + if(i_ok.ne.1)cycle + call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call get_excitation_degree(ref_bitmask,det_i,degree,N_int) + call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) + call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2) + hthree *= phase +! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) + normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1) + if(dabs(hthree).lt.1.d-10)cycle + if(dabs(hthree-normal).gt.1.d-10)then + print*,pp2,pp1,hh2,hh1 + print*,p2,p1,h2,h1 + print*,hthree,normal,dabs(hthree-normal) + stop + endif +! print*,hthree,normal,dabs(hthree-normal) + accu += dabs(hthree-normal) + enddo + enddo + enddo +enddo +print*,'accu same spin beta = ',accu + + +end + + diff --git a/src/tc_bi_ortho/test_tc_bi_ortho.irp.f b/src/tc_bi_ortho/test_tc_bi_ortho.irp.f new file mode 100644 index 00000000..6721c285 --- /dev/null +++ b/src/tc_bi_ortho/test_tc_bi_ortho.irp.f @@ -0,0 +1,254 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + call test_h_u0 +! call test_slater_tc_opt +! call timing_tot +! call timing_diag +! call timing_single +! call timing_double +end + +subroutine test_h_u0 + implicit none + double precision, allocatable :: v_0_ref(:),v_0_new(:),u_0(:), v_0_ref_dagger(:) + double precision :: accu + logical :: do_right + integer :: i + allocate(v_0_new(N_det),v_0_ref(N_det),u_0(N_det),v_0_ref_dagger(N_det)) + do_right = .True. + do i = 1, N_det + u_0(i) = psi_r_coef_bi_ortho(i,1) + enddo + call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right) + call htc_bi_ortho_calc_tdav (v_0_ref,u_0,N_states,N_det) + print*,'difference right ' + accu = 0.d0 + do i = 1, N_det + print*,dabs(v_0_new(i) - v_0_ref(i)),v_0_new(i) , v_0_ref(i) + accu += dabs(v_0_new(i) - v_0_ref(i)) + enddo + print*,'accu = ',accu + do_right = .False. + v_0_new = 0.d0 + call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right) + call htcdag_bi_ortho_calc_tdav(v_0_ref_dagger,u_0,N_states,N_det, do_right) + print*,'difference left' + accu = 0.d0 + do i = 1, N_det + print*,dabs(v_0_new(i) - v_0_ref_dagger(i)),v_0_new(i) , v_0_ref_dagger(i) + accu += dabs(v_0_new(i) - v_0_ref_dagger(i)) + enddo + print*,'accu = ',accu +end + +subroutine test_slater_tc_opt + implicit none + integer :: i,j,degree + double precision :: hmono, htwoe, htot, hthree + double precision :: hnewmono, hnewtwoe, hnewthree, hnewtot + double precision :: accu_d ,i_count, accu + accu = 0.d0 + accu_d = 0.d0 + i_count = 0.d0 + do i = 1, N_det + do j = 1,N_det + call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot) + if(dabs(htot).gt.1.d-15)then + i_count += 1.D0 + accu += dabs(htot-hnewtot) + if(dabs(htot-hnewtot).gt.1.d-8.or.dabs(htot-hnewtot).gt.dabs(htot))then + call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int) + print*,j,i,degree + call debug_det(psi_det(1,1,i),N_int) + call debug_det(psi_det(1,1,j),N_int) + print*,htot,hnewtot,dabs(htot-hnewtot) + print*,hthree,hnewthree,dabs(hthree-hnewthree) + stop + endif + endif + enddo + enddo + print*,'accu = ',accu/i_count + +end + +subroutine timing_tot + implicit none + integer :: i,j + double precision :: wall0, wall1 + double precision, allocatable :: mat_old(:,:),mat_new(:,:) + double precision :: hmono, htwoe, hthree, htot, i_count + integer :: degree + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot) + call wall_time(wall0) + i_count = 0.d0 + do i = 1, N_det + do j = 1, N_det +! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int) + i_count += 1.d0 + call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + enddo + enddo + call wall_time(wall1) + print*,'i_count = ',i_count + print*,'time for old hij for total = ',wall1 - wall0 + + call wall_time(wall0) + i_count = 0.d0 + do i = 1, N_det + do j = 1, N_det +! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int) + i_count += 1.d0 + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + enddo + enddo + call wall_time(wall1) + print*,'i_count = ',i_count + print*,'time for new hij for total = ',wall1 - wall0 + call i_H_j(psi_det(1,1,1), psi_det(1,1,2),N_int,htot) + call wall_time(wall0) + i_count = 0.d0 + do i = 1, N_det + do j = 1, N_det + call i_H_j(psi_det(1,1,j), psi_det(1,1,i),N_int,htot) + i_count += 1.d0 + enddo + enddo + call wall_time(wall1) + print*,'i_count = ',i_count + print*,'time for new hij STANDARD = ',wall1 - wall0 + +end + +subroutine timing_diag + implicit none + integer :: i,j + double precision :: wall0, wall1 + double precision, allocatable :: mat_old(:,:),mat_new(:,:) + double precision :: hmono, htwoe, hthree, htot, i_count + integer :: degree + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot) + call wall_time(wall0) + i_count = 0.d0 + do i = 1, N_det + do j = i,i + i_count += 1.d0 + call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + enddo + enddo + call wall_time(wall1) + print*,'i_count = ',i_count + print*,'time for old hij for diagonal= ',wall1 - wall0 + + call wall_time(wall0) + i_count = 0.d0 + do i = 1, N_det + do j = i,i + i_count += 1.d0 + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + enddo + enddo + call wall_time(wall1) + print*,'i_count = ',i_count + print*,'time for new hij for diagonal= ',wall1 - wall0 + +end + +subroutine timing_single + implicit none + integer :: i,j + double precision :: wall0, wall1,accu + double precision, allocatable :: mat_old(:,:),mat_new(:,:) + double precision :: hmono, htwoe, hthree, htot, i_count + integer :: degree + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot) + i_count = 0.d0 + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int) + if(degree.ne.1)cycle + i_count += 1.d0 + call wall_time(wall0) + call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call wall_time(wall1) + accu += wall1 - wall0 + enddo + enddo + print*,'i_count = ',i_count + print*,'time for old hij for singles = ',accu + + i_count = 0.d0 + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int) + if(degree.ne.1)cycle + i_count += 1.d0 + call wall_time(wall0) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call wall_time(wall1) + accu += wall1 - wall0 + enddo + enddo + print*,'i_count = ',i_count + print*,'time for new hij for singles = ',accu + +end + +subroutine timing_double + implicit none + integer :: i,j + double precision :: wall0, wall1,accu + double precision, allocatable :: mat_old(:,:),mat_new(:,:) + double precision :: hmono, htwoe, hthree, htot, i_count + integer :: degree + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot) + i_count = 0.d0 + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int) + if(degree.ne.2)cycle + i_count += 1.d0 + call wall_time(wall0) + call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call wall_time(wall1) + accu += wall1 - wall0 + enddo + enddo + print*,'i_count = ',i_count + print*,'time for old hij for doubles = ',accu + + i_count = 0.d0 + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int) + if(degree.ne.2)cycle + i_count += 1.d0 + call wall_time(wall0) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call wall_time(wall1) + accu += wall1 - wall0 + enddo + enddo + call wall_time(wall1) + print*,'i_count = ',i_count + print*,'time for new hij for doubles = ',accu + +end + diff --git a/src/tc_bi_ortho/test_tc_fock.irp.f b/src/tc_bi_ortho/test_tc_fock.irp.f new file mode 100644 index 00000000..ebd43a7a --- /dev/null +++ b/src/tc_bi_ortho/test_tc_fock.irp.f @@ -0,0 +1,194 @@ +program test_tc_fock + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + !call routine_1 + !call routine_2 +! call routine_3() + +! call test_3e + call routine_tot +end + +! --- + +subroutine test_3e + implicit none + double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu + double precision :: hmono, htwoe, hthree, htot + call htilde_mu_mat_bi_ortho(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot) +! call diag_htilde_three_body_ints_bi_ort(N_int, ref_bitmask, hthree) + print*,'hmono = ',hmono + print*,'htwoe = ',htwoe + print*,'hthree= ',hthree + print*,'htot = ',htot + print*,'' + print*,'' + print*,'TC_one= ',tc_hf_one_e_energy + print*,'TC_two= ',TC_HF_two_e_energy + print*,'TC_3e = ',diag_three_elem_hf + print*,'TC_tot= ',TC_HF_energy + print*,'' + print*,'' + call give_aaa_contrib(integral_aaa) + print*,'integral_aaa = ',integral_aaa + call give_aab_contrib(integral_aab) + print*,'integral_aab = ',integral_aab + call give_abb_contrib(integral_abb) + print*,'integral_abb = ',integral_abb + call give_bbb_contrib(integral_bbb) + print*,'integral_bbb = ',integral_bbb + accu = integral_aaa + integral_aab + integral_abb + integral_bbb + print*,'accu = ',accu + print*,'delta = ',hthree - accu + +end + +subroutine routine_3() + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer :: i, a, i_ok, s1 + double precision :: hmono, htwoe, hthree, htilde_ij + double precision :: err_ai, err_tot, ref, new + integer(bit_kind), allocatable :: det_i(:,:) + + allocate(det_i(N_int,2)) + + err_tot = 0.d0 + + do s1 = 1, 2 + + det_i = ref_bitmask + call debug_det(det_i, N_int) + print*, ' HF det' + call debug_det(det_i, N_int) + + do i = 1, elec_num_tab(s1) + do a = elec_num_tab(s1)+1, mo_num ! virtual + + + det_i = ref_bitmask + call do_single_excitation(det_i, i, a, s1, i_ok) + if(i_ok == -1) then + print*, 'PB !!' + print*, i, a + stop + endif + print*, ' excited det' + call debug_det(det_i, N_int) + + call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) + if(dabs(hthree).lt.1.d-10)cycle + ref = hthree + if(s1 == 1)then + new = fock_a_tot_3e_bi_orth(a,i) + else if(s1 == 2)then + new = fock_b_tot_3e_bi_orth(a,i) + endif + err_ai = dabs(dabs(ref) - dabs(new)) + if(err_ai .gt. 1d-7) then + print*,'s1 = ',s1 + print*, ' warning on', i, a + print*, ref,new,err_ai + endif + print*, ref,new,err_ai + err_tot += err_ai + + write(22, *) htilde_ij + enddo + enddo + enddo + + print *, ' err_tot = ', err_tot + + deallocate(det_i) + +end subroutine routine_3 + +! --- +subroutine routine_tot() + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer :: i, a, i_ok, s1,other_spin(2) + double precision :: hmono, htwoe, hthree, htilde_ij + double precision :: err_ai, err_tot, ref, new + integer(bit_kind), allocatable :: det_i(:,:) + + allocate(det_i(N_int,2)) + other_spin(1) = 2 + other_spin(2) = 1 + + err_tot = 0.d0 + +! do s1 = 1, 2 + s1 = 2 + det_i = ref_bitmask + call debug_det(det_i, N_int) + print*, ' HF det' + call debug_det(det_i, N_int) + +! do i = 1, elec_num_tab(s1) +! do a = elec_num_tab(s1)+1, mo_num ! virtual + do i = 1, elec_beta_num + do a = elec_beta_num+1, elec_alpha_num! virtual +! do i = elec_beta_num+1, elec_alpha_num +! do a = elec_alpha_num+1, mo_num! virtual + print*,i,a + + det_i = ref_bitmask + call do_single_excitation(det_i, i, a, s1, i_ok) + if(i_ok == -1) then + print*, 'PB !!' + print*, i, a + stop + endif + + call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) + print*,htilde_ij + if(dabs(htilde_ij).lt.1.d-10)cycle + print*, ' excited det' + call debug_det(det_i, N_int) + + if(s1 == 1)then + new = Fock_matrix_tc_mo_alpha(a,i) + else + new = Fock_matrix_tc_mo_beta(a,i) + endif + ref = htilde_ij +! if(s1 == 1)then +! new = fock_a_tot_3e_bi_orth(a,i) +! else if(s1 == 2)then +! new = fock_b_tot_3e_bi_orth(a,i) +! endif + err_ai = dabs(dabs(ref) - dabs(new)) + if(err_ai .gt. 1d-7) then + print*,'s1 = ',s1 + print*, ' warning on', i, a + print*, ref,new,err_ai + endif + print*, ref,new,err_ai + err_tot += err_ai + + write(22, *) htilde_ij + enddo + enddo +! enddo + + print *, ' err_tot = ', err_tot + + deallocate(det_i) + +end subroutine routine_3 diff --git a/src/tc_bi_ortho/u0_h_u0.irp.f b/src/tc_bi_ortho/u0_h_u0.irp.f new file mode 100644 index 00000000..afbe15a7 --- /dev/null +++ b/src/tc_bi_ortho/u0_h_u0.irp.f @@ -0,0 +1,770 @@ +subroutine u_0_H_tc_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze, do_right) + use bitmasks + implicit none + BEGIN_DOC + ! Computes $E_0 = \frac{\langle u_0 | H_TC | u_0 \rangle}{\langle u_0 | u_0 \rangle}$ + ! + ! n : number of determinants + ! + ! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi> + END_DOC + integer, intent(in) :: n,Nint, N_st, sze + logical, intent(in) :: do_right + double precision, intent(out) :: e_0(N_st) + double precision, intent(inout) :: u_0(sze,N_st) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + + double precision, allocatable :: v_0(:,:), u_1(:,:) + double precision :: u_dot_u,u_dot_v,diag_H_mat_elem + integer :: i,j, istate + + allocate (v_0(n,N_st),u_1(n,N_st)) + u_1(:,:) = 0.d0 + u_1(1:n,1:N_st) = u_0(1:n,1:N_st) + call H_tc_u_0_nstates_openmp(v_0,u_1,N_st,n, do_right) + u_0(1:n,1:N_st) = u_1(1:n,1:N_st) + deallocate(u_1) + double precision :: norm + !$OMP PARALLEL DO PRIVATE(i,norm) DEFAULT(SHARED) + do i=1,N_st + norm = u_dot_u(u_0(1,i),n) + if (norm /= 0.d0) then + e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n) / dsqrt(norm) + else + e_0(i) = 0.d0 + endif + enddo + !$OMP END PARALLEL DO + deallocate (v_0) +end + + +subroutine H_tc_u_0_opt(v_0,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes $v_0 = H | u_0\rangle$. + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st) + logical :: do_right + do_right = .True. + call H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right) +end + +subroutine H_tc_dagger_u_0_opt(v_0,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes $v_0 = H | u_0\rangle$. + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st) + logical :: do_right + do_right = .False. + call H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right) +end + + +subroutine H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right) + use bitmasks + implicit none + BEGIN_DOC + ! Computes $v_0 = H | u_0\rangle$. + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + ! + ! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi> + END_DOC + integer, intent(in) :: N_st,sze + double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st) + logical, intent(in) :: do_right + integer :: k + double precision, allocatable :: u_t(:,:), v_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det),v_t(N_st,N_det)) + provide mo_bi_ortho_tc_one_e mo_bi_ortho_tc_two_e + provide ref_tc_energy_tot fock_op_2_e_tc_closed_shell + provide eff_2_e_from_3_e_ab eff_2_e_from_3_e_aa eff_2_e_from_3_e_bb + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + v_t = 0.d0 + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call H_tc_u_0_nstates_openmp_work(v_t,u_t,N_st,sze,1,N_det,0,1, do_right) + deallocate(u_t) + + call dtranspose( & + v_t, & + size(v_t, 1), & + v_0, & + size(v_0, 1), & + N_st, N_det) + deallocate(v_t) + + do k=1,N_st + call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + + +subroutine H_tc_u_0_nstates_openmp_work(v_t,u_t,N_st,sze,istart,iend,ishift,istep, do_right) + use bitmasks + implicit none + BEGIN_DOC + ! Computes $v_t = H | u_t\rangle$ + ! + ! Default should be 1,N_det,0,1 + ! + ! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi> + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + logical, intent(in) :: do_right + double precision, intent(out) :: v_t(N_st,sze) + + + PROVIDE ref_bitmask_energy N_int + + select case (N_int) + case (1) + call H_tc_u_0_nstates_openmp_work_1(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right) + case (2) + call H_tc_u_0_nstates_openmp_work_2(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right) + case (3) + call H_tc_u_0_nstates_openmp_work_3(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right) + case (4) + call H_tc_u_0_nstates_openmp_work_4(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right) + case default + call H_tc_u_0_nstates_openmp_work_N_int(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right) + end select +end +BEGIN_TEMPLATE + +subroutine H_tc_u_0_nstates_openmp_work_$N_int(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right) + use bitmasks + implicit none + BEGIN_DOC + ! Computes $v_t = H | u_t \\rangle$ + ! + ! Default should be 1,N_det,0,1 + ! + ! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi> + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + logical, intent(in) :: do_right + double precision, intent(out) :: v_t(N_st,sze) + + double precision :: hij + integer :: i,j,k,l,kk + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + logical :: compute_singles + integer*8 :: last_found, left, right, right_max + double precision :: rss, mem, ratio + double precision, allocatable :: utl(:,:) + integer, parameter :: block_size=128 + logical :: u_is_sparse + +! call resident_memory(rss) +! mem = dble(singles_beta_csc_size) / 1024.d0**3 +! +! compute_singles = (mem+rss > qp_max_mem) +! +! if (.not.compute_singles) then +! provide singles_beta_csc +! endif +compute_singles=.True. + + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + !$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads_davidson) & + !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + !$OMP psi_bilinear_matrix_columns, & + !$OMP psi_det_alpha_unique, psi_det_beta_unique, & + !$OMP n_det_alpha_unique, n_det_beta_unique, N_int, & + !$OMP psi_bilinear_matrix_transp_rows, & + !$OMP psi_bilinear_matrix_transp_columns, & + !$OMP psi_bilinear_matrix_transp_order, N_st, & + !$OMP psi_bilinear_matrix_order_transp_reverse, & + !$OMP psi_bilinear_matrix_columns_loc, & + !$OMP psi_bilinear_matrix_transp_rows_loc, & + !$OMP istart, iend, istep, irp_here, v_t, & + !$OMP ishift, idx0, u_t, maxab, compute_singles, & + !$OMP singles_alpha_csc,singles_alpha_csc_idx, & + !$OMP singles_beta_csc,singles_beta_csc_idx) & + !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & + !$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, & + !$OMP buffer, doubles, n_doubles, umax, & + !$OMP tmp_det2, hij, idx, l, kcol_prev,hmono, htwoe, hthree, & + !$OMP singles_a, n_singles_a, singles_b, ratio, & + !$OMP n_singles_b, k8, last_found,left,right,right_max) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab), utl(N_st,block_size)) + + kcol_prev=-1 + + ! Check if u has multiple zeros + kk=1 ! Avoid division by zero + !$OMP DO + do k=1,N_det + umax = 0.d0 + do l=1,N_st + umax = max(umax, dabs(u_t(l,k))) + enddo + if (umax < 1.d-20) then + !$OMP ATOMIC + kk = kk+1 + endif + enddo + !$OMP END DO + u_is_sparse = N_det / kk < 20 ! 5% + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !$OMP DO SCHEDULE(guided,64) + do k_a=istart+ishift,iend,istep ! Loop over all determinants (/!\ not in psidet order) + + krow = psi_bilinear_matrix_rows(k_a) ! Index of alpha part of determinant k_a + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) ! Index of beta part of determinant k_a + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + + if (kcol /= kcol_prev) then + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + if (compute_singles) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + else + n_singles_b = 0 + !DIR$ LOOP COUNT avg(1000) + do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1 + n_singles_b = n_singles_b+1 + singles_b(n_singles_b) = singles_beta_csc(k8) + enddo + endif + endif + kcol_prev = kcol + + ! -> Here, tmp_det is determinant k_a + + ! Loop over singly excited beta columns + ! ------------------------------------- + + !DIR$ LOOP COUNT avg(1000) + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + ! tmp_det2 is a single excitation of tmp_det in the beta spin + ! the alpha part is not defined yet + +!--- +! if (compute_singles) then + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + ! rows : | 1 2 3 4 | 1 3 4 6 | .... | 1 2 4 5 | + ! cols : | 1 1 1 1 | 2 2 2 2 | .... | 8 8 8 8 | + ! index : | 1 2 3 4 | 5 6 7 8 | .... | 58 59 60 61 | + ! ^ ^ + ! | | + ! l_a N_det + ! l_a is the index in the big vector os size Ndet of the position of the first element of column lcol + + ! Below we identify all the determinants with the same beta part + + !DIR$ UNROLL(8) + !DIR$ LOOP COUNT avg(50000) + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) ! hot spot + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + ! Get all single excitations from tmp_det(1,1) to buffer(1,?) + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + double precision :: umax + + !DIR$ LOOP COUNT avg(1000) + do k = 1,n_singles_a,block_size + umax = 0.d0 + ! Prefetch u_t(:,l_a) + if (u_is_sparse) then + do kk=0,block_size-1 + if (k+kk > n_singles_a) exit + l_a = singles_a(k+kk) + ASSERT (l_a <= N_det) + + do l=1,N_st + utl(l,kk+1) = u_t(l,l_a) + umax = max(umax, dabs(utl(l,kk+1))) + enddo + enddo + else + do kk=0,block_size-1 + if (k+kk > n_singles_a) exit + l_a = singles_a(k+kk) + ASSERT (l_a <= N_det) + utl(:,kk+1) = u_t(:,l_a) + enddo + umax = 1.d0 + endif + if (umax < 1.d-20) cycle + + do kk=0,block_size-1 + if (k+kk > n_singles_a) exit + l_a = singles_a(k+kk) + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) +! call i_H_j( tmp_det, tmp_det2, $N_int, hij) ! double alpha-beta + if(do_right)then + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij) + else + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij) + endif + !DIR$ LOOP COUNT AVG(4) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1) + enddo + enddo + enddo + + enddo + + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(guided,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + + !DIR$ LOOP COUNT avg(200000) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) ! Hot spot + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + !DIR$ LOOP COUNT avg(1000) + do i=1,n_singles_a,block_size + umax = 0.d0 + ! Prefetch u_t(:,l_a) + if (u_is_sparse) then + do kk=0,block_size-1 + if (i+kk > n_singles_a) exit + l_a = singles_a(i+kk) + ASSERT (l_a <= N_det) + + do l=1,N_st + utl(l,kk+1) = u_t(l,l_a) + umax = max(umax, dabs(utl(l,kk+1))) + enddo + enddo + else + do kk=0,block_size-1 + if (i+kk > n_singles_a) exit + l_a = singles_a(i+kk) + ASSERT (l_a <= N_det) + utl(:,kk+1) = u_t(:,l_a) + enddo + umax = 1.d0 + endif + if (umax < 1.d-20) cycle + + do kk=0,block_size-1 + if (i+kk > n_singles_a) exit + l_a = singles_a(i+kk) + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) +! call i_h_j_single_spin( tmp_det, tmp_det2, $N_int, 1, hij) + if(do_right)then + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij) + else + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij) + endif + + !DIR$ LOOP COUNT AVG(4) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1) + enddo + enddo + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + !DIR$ LOOP COUNT avg(50000) + do i=1,n_doubles,block_size + umax = 0.d0 + ! Prefetch u_t(:,l_a) + if (u_is_sparse) then + do kk=0,block_size-1 + if (i+kk > n_doubles) exit + l_a = doubles(i+kk) + ASSERT (l_a <= N_det) + + do l=1,N_st + utl(l,kk+1) = u_t(l,l_a) + umax = max(umax, dabs(utl(l,kk+1))) + enddo + enddo + else + do kk=0,block_size-1 + if (i+kk > n_doubles) exit + l_a = doubles(i+kk) + ASSERT (l_a <= N_det) + utl(:,kk+1) = u_t(:,l_a) + enddo + umax = 1.d0 + endif + if (umax < 1.d-20) cycle + + do kk=0,block_size-1 + if (i+kk > n_doubles) exit + l_a = doubles(i+kk) + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) +! call i_H_j( tmp_det, tmp_det2, $N_int, hij) +! call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) + if(do_right)then + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij) + else + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij) + endif + + !DIR$ LOOP COUNT AVG(4) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1) + enddo + enddo + enddo + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + !DIR$ LOOP COUNT avg(200000) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + !DIR$ LOOP COUNT avg(1000) + do i=1,n_singles_b,block_size + umax = 0.d0 + if (u_is_sparse) then + do kk=0,block_size-1 + if (i+kk > n_singles_b) exit + l_b = singles_b(i+kk) + l_a = psi_bilinear_matrix_transp_order(l_b) + ASSERT (l_b <= N_det) + ASSERT (l_a <= N_det) + + do l=1,N_st + utl(l,kk+1) = u_t(l,l_a) + umax = max(umax, dabs(utl(l,kk+1))) + enddo + enddo + else + do kk=0,block_size-1 + if (i+kk > n_singles_b) exit + l_b = singles_b(i+kk) + l_a = psi_bilinear_matrix_transp_order(l_b) + ASSERT (l_b <= N_det) + ASSERT (l_a <= N_det) + utl(:,kk+1) = u_t(:,l_a) + enddo + umax = 1.d0 + endif + if (umax < 1.d-20) cycle + + do kk=0,block_size-1 + if (i+kk > n_singles_b) exit + l_b = singles_b(i+kk) + l_a = psi_bilinear_matrix_transp_order(l_b) + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) +! call i_H_j_single_spin( tmp_det, tmp_det2, $N_int, 2, hij) + if(do_right)then + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij) + else + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij) + endif + !DIR$ LOOP COUNT AVG(4) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1) + enddo + enddo + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + !DIR$ LOOP COUNT avg(50000) + do i=1,n_doubles,block_size + umax = 0.d0 + if (u_is_sparse) then + do kk=0,block_size-1 + if (i+kk > n_doubles) exit + l_b = doubles(i+kk) + l_a = psi_bilinear_matrix_transp_order(l_b) + ASSERT (l_b <= N_det) + ASSERT (l_a <= N_det) + do l=1,N_st + utl(l,kk+1) = u_t(l,l_a) + umax = max(umax, dabs(utl(l,kk+1))) + enddo + enddo + else + do kk=0,block_size-1 + if (i+kk > n_doubles) exit + l_b = doubles(i+kk) + l_a = psi_bilinear_matrix_transp_order(l_b) + ASSERT (l_b <= N_det) + ASSERT (l_a <= N_det) + utl(:,kk+1) = u_t(:,l_a) + enddo + umax = 1.d0 + endif + if (umax < 1.d-20) cycle + + do kk=0,block_size-1 + if (i+kk > n_doubles) exit + l_b = doubles(i+kk) + l_a = psi_bilinear_matrix_transp_order(l_b) + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) +! call i_H_j( tmp_det, tmp_det2, $N_int, hij) +! call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) + if(do_right)then + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij) + else + call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij) + endif + + !DIR$ LOOP COUNT AVG(4) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1) + enddo + enddo + enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + if (u_is_sparse) then + umax = 0.d0 + do l=1,N_st + umax = max(umax, dabs(u_t(l,k_a))) + enddo + else + umax = 1.d0 + endif + if (umax < 1.d-20) cycle + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_H_mat_elem + double precision :: hmono, htwoe, hthree + +! hij = diag_H_mat_elem(tmp_det,$N_int) + call diag_htilde_mu_mat_fock_bi_ortho ($N_int, tmp_det, hmono, htwoe, hthree, hij) + !DIR$ LOOP COUNT AVG(4) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) + enddo + + end do + !$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx, utl) + !$OMP END PARALLEL + +end + +SUBST [ N_int ] + +1;; +2;; +3;; +4;; +N_int;; + +END_TEMPLATE + + diff --git a/src/tc_scf/11.tc_scf.bats b/src/tc_scf/11.tc_scf.bats index a5171902..91b52540 100644 --- a/src/tc_scf/11.tc_scf.bats +++ b/src/tc_scf/11.tc_scf.bats @@ -9,11 +9,13 @@ function run_Ne() { echo Ne > Ne.xyz qp create_ezfio -b cc-pcvdz Ne.xyz -o Ne_tc_scf qp run scf + + qp set ao_two_e_erf_ints mu_erf 0.87 + qp set tc_keywords j1b_type 3 + qp set tc_keywords j1b_pen [1.5] qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp set ao_two_e_erf_ints mu_erf 0.87 - qp set tc_keywords j1b_pen [1.5] - qp set tc_keywords j1b_type 3 + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-128.552134 energy="$(qp get tc_scf bitc_energy)" @@ -25,3 +27,75 @@ function run_Ne() { run_Ne } +function run_C() { + rm -rf C_tc_scf + echo C > C.xyz + qp create_ezfio -b cc-pcvdz C.xyz -o C_tc_scf -m 3 + qp run scf + + qp set ao_two_e_erf_ints mu_erf 0.87 + qp set tc_keywords j1b_type 3 + qp set tc_keywords j1b_pen [1.5] + qp set tc_keywords bi_ortho True + qp set tc_keywords test_cycle_tc True + + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + eref=-37.691254356408791 + energy="$(qp get tc_scf bitc_energy)" + eq $energy $eref 1e-6 +} + + +@test "C" { + run_C +} + + +function run_O() { + rm -rf O_tc_scf + echo O > O.xyz + qp create_ezfio -b cc-pcvdz O.xyz -o O_tc_scf -m 3 + qp run scf + + qp set ao_two_e_erf_ints mu_erf 0.87 + qp set tc_keywords j1b_type 3 + qp set tc_keywords j1b_pen [1.5] + qp set tc_keywords bi_ortho True + qp set tc_keywords test_cycle_tc True + + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + eref=-74.814687229354590 + energy="$(qp get tc_scf bitc_energy)" + eq $energy $eref 1e-6 +} + + +@test "O" { + run_O +} + + + +function run_ch2() { + rm -rf ch2_tc_scf + cp ${QP_ROOT}/tests/input/ch2.xyz . + qp create_ezfio -b "C:cc-pcvdz|H:cc-pvdz" ch2.xyz -o ch2_tc_scf + qp run scf + + qp set ao_two_e_erf_ints mu_erf 0.87 + qp set tc_keywords j1b_type 3 + qp set tc_keywords j1b_pen '[1.5,10000,10000]' + qp set tc_keywords bi_ortho True + qp set tc_keywords test_cycle_tc True + + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + eref=-38.903247818077737 + energy="$(qp get tc_scf bitc_energy)" + eq $energy $eref 1e-6 +} + + +@test "ch2" { + run_ch2 +} + diff --git a/src/tc_scf/NEED b/src/tc_scf/NEED index 4e340cfe..84b0f792 100644 --- a/src/tc_scf/NEED +++ b/src/tc_scf/NEED @@ -1,6 +1,6 @@ hartree_fock bi_ortho_mos -three_body_ints +ortho_three_e_ints bi_ort_ints tc_keywords non_hermit_dav diff --git a/src/tc_scf/diago_bi_ort_tcfock.irp.f b/src/tc_scf/diago_bi_ort_tcfock.irp.f index 726169d9..02545315 100644 --- a/src/tc_scf/diago_bi_ort_tcfock.irp.f +++ b/src/tc_scf/diago_bi_ort_tcfock.irp.f @@ -38,33 +38,9 @@ , fock_tc_leigvec_mo, fock_tc_reigvec_mo & , n_real_tc, eigval_right_tmp ) - !if(max_ov_tc_scf)then - ! call non_hrmt_fock_mat( mo_num, F_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag & - ! , fock_tc_leigvec_mo, fock_tc_reigvec_mo & - ! , n_real_tc, eigval_right_tmp ) - !else - ! call non_hrmt_diag_split_degen_bi_orthog( mo_num, F_tmp & - ! , fock_tc_leigvec_mo, fock_tc_reigvec_mo & - ! , n_real_tc, eigval_right_tmp ) - !endif - deallocate(F_tmp) - -! if(n_real_tc .ne. mo_num)then -! print*,'n_real_tc ne mo_num ! ',n_real_tc -! stop -! endif - eigval_fock_tc_mo = eigval_right_tmp -! print*,'Eigenvalues of Fock_matrix_tc_mo_tot' -! do i = 1, elec_alpha_num -! print*, i, eigval_fock_tc_mo(i) -! enddo -! do i = elec_alpha_num+1, mo_num -! print*, i, eigval_fock_tc_mo(i) - level_shift_tcscf -! enddo -! deallocate( eigval_right_tmp ) ! L.T x R call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 & diff --git a/src/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/src/tc_scf/fock_3e_bi_ortho_uhf.irp.f index fccfd837..d8b962d7 100644 --- a/src/tc_scf/fock_3e_bi_ortho_uhf.irp.f +++ b/src/tc_scf/fock_3e_bi_ortho_uhf.irp.f @@ -49,6 +49,11 @@ END_PROVIDER BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)] + BEGIN_DOC +! ALPHA part of the Fock matrix from three-electron terms +! +! WARNING :: non hermitian if bi-ortho MOS used + END_DOC implicit none integer :: a, b, i, j, o double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia @@ -145,6 +150,11 @@ END_PROVIDER ! --- BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)] + BEGIN_DOC +! BETA part of the Fock matrix from three-electron terms +! +! WARNING :: non hermitian if bi-ortho MOS used + END_DOC implicit none integer :: a, b, i, j, o diff --git a/src/tc_scf/fock_for_right.irp.f b/src/tc_scf/fock_hermit.irp.f similarity index 100% rename from src/tc_scf/fock_for_right.irp.f rename to src/tc_scf/fock_hermit.irp.f diff --git a/src/tc_scf/fock_tc.irp.f b/src/tc_scf/fock_tc.irp.f index 6796666d..e21938de 100644 --- a/src/tc_scf/fock_tc.irp.f +++ b/src/tc_scf/fock_tc.irp.f @@ -6,10 +6,11 @@ BEGIN_DOC ! - ! two_e_tc_non_hermit_integral_seq_alpha(k,i) = + ! two_e_tc_non_hermit_integral_seq_alpha(k,i) = ON THE AO BASIS ! - ! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions + ! where F^tc is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions ! + ! works in SEQUENTIAL END_DOC implicit none @@ -17,8 +18,6 @@ double precision :: density, density_a, density_b double precision :: t0, t1 - !print*, ' providing two_e_tc_non_hermit_integral_seq ...' - !call wall_time(t0) two_e_tc_non_hermit_integral_seq_alpha = 0.d0 two_e_tc_non_hermit_integral_seq_beta = 0.d0 @@ -32,24 +31,6 @@ density_b = TCSCF_density_matrix_ao_beta (l,j) density = density_a + density_b - !! rho(l,j) * < k l| T | i j> - !two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i) - !! rho(l,j) * < k l| T | i j> - !two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i) - !! rho_a(l,j) * < l k| T | i j> - !two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i) - !! rho_b(l,j) * < l k| T | i j> - !two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i) - - !! rho(l,j) * < k l| T | i j> - !two_e_tc_non_hermit_integral_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i) - !! rho(l,j) * < k l| T | i j> - !two_e_tc_non_hermit_integral_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i) - !! rho_a(l,j) * < l k| T | i j> - !two_e_tc_non_hermit_integral_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i) - !! rho_b(l,j) * < l k| T | i j> - !two_e_tc_non_hermit_integral_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i) - ! rho(l,j) * < k l| T | i j> two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(k,i,l,j) ! rho(l,j) * < k l| T | i j> @@ -64,8 +45,6 @@ enddo enddo - !call wall_time(t1) - !print*, ' wall time for two_e_tc_non_hermit_integral_seq after = ', t1 - t0 END_PROVIDER @@ -76,9 +55,9 @@ END_PROVIDER BEGIN_DOC ! - ! two_e_tc_non_hermit_integral_alpha(k,i) = + ! two_e_tc_non_hermit_integral_alpha(k,i) = ON THE AO BASIS ! - ! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions + ! where F^tc is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions ! END_DOC @@ -88,8 +67,6 @@ END_PROVIDER double precision :: t0, t1 double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) - !print*, ' providing two_e_tc_non_hermit_integral ...' - !call wall_time(t0) two_e_tc_non_hermit_integral_alpha = 0.d0 two_e_tc_non_hermit_integral_beta = 0.d0 @@ -135,8 +112,6 @@ END_PROVIDER deallocate(tmp_a, tmp_b) !$OMP END PARALLEL - !call wall_time(t1) - !print*, ' wall time for two_e_tc_non_hermit_integral after = ', t1 - t0 END_PROVIDER @@ -181,14 +156,6 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ] if(bi_ortho) then - !allocate(tmp(ao_num,ao_num)) - !tmp = Fock_matrix_tc_ao_alpha - !if(three_body_h_tc) then - ! tmp += fock_3e_uhf_ao_a - !endif - !call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1)) - !deallocate(tmp) - call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) if(three_body_h_tc) then @@ -217,14 +184,6 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ] if(bi_ortho) then - !allocate(tmp(ao_num,ao_num)) - !tmp = Fock_matrix_tc_ao_beta - !if(three_body_h_tc) then - ! tmp += fock_3e_uhf_ao_b - !endif - !call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1)) - !deallocate(tmp) - call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) if(three_body_h_tc) then diff --git a/src/tc_scf/fock_tc_mo_tot.irp.f b/src/tc_scf/fock_tc_mo_tot.irp.f index 2f33cd17..a03a0624 100644 --- a/src/tc_scf/fock_tc_mo_tot.irp.f +++ b/src/tc_scf/fock_tc_mo_tot.irp.f @@ -3,7 +3,7 @@ &BEGIN_PROVIDER [ double precision, Fock_matrix_tc_diag_mo_tot, (mo_num)] implicit none BEGIN_DOC - ! Fock matrix on the MO basis. + ! TC-Fock matrix on the MO basis. WARNING !!! NON HERMITIAN !!! ! For open shells, the ROHF Fock Matrix is :: ! ! | F-K | F + K/2 | F | diff --git a/src/tc_scf/fock_three_bi_ortho.irp.f b/src/tc_scf/fock_three_bi_ortho.irp.f index 279670b8..7c776ce5 100644 --- a/src/tc_scf/fock_three_bi_ortho.irp.f +++ b/src/tc_scf/fock_three_bi_ortho.irp.f @@ -1,178 +1,296 @@ -BEGIN_PROVIDER [ double precision, fock_a_abb_3e_bi_orth_old, (mo_num, mo_num)] - implicit none - BEGIN_DOC -! fock_a_abb_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,beta,beta contribution - END_DOC - fock_a_abb_3e_bi_orth_old = 0.d0 - integer :: i,a,j,k - double precision :: direct_int, exch_23_int - do i = 1, mo_num - do a = 1, mo_num - - do j = 1, elec_beta_num - do k = j+1, elec_beta_num - ! see contrib_3e_soo - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23 - fock_a_abb_3e_bi_orth_old(a,i) += direct_int - exch_23_int + +! --- + +BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth, (mo_num, mo_num)] + + BEGIN_DOC +! Alpha part of the Fock matrix from three-electron terms +! +! WARNING :: non hermitian if bi-ortho MOS used + END_DOC + implicit none + integer :: i, a + + PROVIDE mo_l_coef mo_r_coef + + fock_a_tot_3e_bi_orth = 0.d0 + + do i = 1, mo_num + do a = 1, mo_num + fock_a_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i) + fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp1_bi_ortho(a,i) + fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp2_bi_ortho(a,i) enddo - enddo - enddo - enddo - fock_a_abb_3e_bi_orth_old = - fock_a_abb_3e_bi_orth_old + END_PROVIDER -BEGIN_PROVIDER [ double precision, fock_a_aba_3e_bi_orth_old, (mo_num, mo_num)] - implicit none - BEGIN_DOC -! fock_a_aba_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,beta contribution - END_DOC - fock_a_aba_3e_bi_orth_old = 0.d0 - integer :: i,a,j,k - double precision :: direct_int, exch_13_int - do i = 1, mo_num - do a = 1, mo_num - - do j = 1, elec_alpha_num ! a - do k = 1, elec_beta_num ! b - ! a b a a b a - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13 - fock_a_aba_3e_bi_orth_old(a,i) += direct_int - exch_13_int +! --- + +BEGIN_PROVIDER [double precision, fock_b_tot_3e_bi_orth, (mo_num, mo_num)] + + BEGIN_DOC +! Beta part of the Fock matrix from three-electron terms +! +! WARNING :: non hermitian if bi-ortho MOS used + END_DOC + implicit none + integer :: i, a + + PROVIDE mo_l_coef mo_r_coef + + fock_b_tot_3e_bi_orth = 0.d0 + + do i = 1, mo_num + do a = 1, mo_num + fock_b_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i) + fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp2_bi_ortho(a,i) + fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp1_bi_ortho(a,i) enddo - enddo - enddo - enddo - fock_a_aba_3e_bi_orth_old = - fock_a_aba_3e_bi_orth_old + END_PROVIDER -BEGIN_PROVIDER [ double precision, fock_a_aaa_3e_bi_orth_old, (mo_num, mo_num)] - implicit none - BEGIN_DOC -! fock_a_aaa_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,alpha contribution - END_DOC - fock_a_aaa_3e_bi_orth_old = 0.d0 - integer :: i,a,j,k - double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int - do i = 1, mo_num - do a = 1, mo_num - - do j = 1, elec_alpha_num - do k = j+1, elec_alpha_num - ! positive terms :: cycle contrib - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > - call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > - fock_a_aaa_3e_bi_orth_old(a,i) += direct_int + c_3_int + c_minus_3_int - ! negative terms :: exchange contrib - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 - call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 - fock_a_aaa_3e_bi_orth_old(a,i) += - exch_13_int - exch_23_int - exch_12_int +! --- + +BEGIN_PROVIDER [double precision, fock_cs_3e_bi_orth, (mo_num, mo_num)] + + implicit none + integer :: i, a, j, k + double precision :: contrib_sss, contrib_sos, contrib_soo, contrib + double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int + double precision :: new + + PROVIDE mo_l_coef mo_r_coef + + fock_cs_3e_bi_orth = 0.d0 + + do i = 1, mo_num + do a = 1, mo_num + + do j = 1, elec_beta_num + do k = 1, elec_beta_num + + !!call contrib_3e_sss(a,i,j,k,contrib_sss) + !!call contrib_3e_soo(a,i,j,k,contrib_soo) + !!call contrib_3e_sos(a,i,j,k,contrib_sos) + !!contrib = 0.5d0 * (contrib_sss + contrib_soo) + contrib_sos + + call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > + call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > + call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > + + ! negative terms :: exchange contrib + call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 + call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 + call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 + + new = 2.d0 * direct_int + 0.5d0 * (c_3_int + c_minus_3_int - exch_12_int) -1.5d0 * exch_13_int - exch_23_int + + fock_cs_3e_bi_orth(a,i) += new + enddo + enddo enddo - enddo - enddo - enddo - fock_a_aaa_3e_bi_orth_old = - fock_a_aaa_3e_bi_orth_old -END_PROVIDER - -BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth_old, (mo_num, mo_num)] - implicit none - BEGIN_DOC - ! fock_a_tot_3e_bi_orth_old = bi-ortho 3-e Fock matrix for alpha electrons from all possible spin contributions - END_DOC - fock_a_tot_3e_bi_orth_old = fock_a_abb_3e_bi_orth_old + fock_a_aba_3e_bi_orth_old + fock_a_aaa_3e_bi_orth_old + + fock_cs_3e_bi_orth = - fock_cs_3e_bi_orth END_PROVIDER -BEGIN_PROVIDER [ double precision, fock_b_baa_3e_bi_orth_old, (mo_num, mo_num)] - implicit none - BEGIN_DOC -! fock_b_baa_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for beta electrons from beta,alpha,alpha contribution - END_DOC - fock_b_baa_3e_bi_orth_old = 0.d0 - integer :: i,a,j,k - double precision :: direct_int, exch_23_int - do i = 1, mo_num - do a = 1, mo_num - - do j = 1, elec_alpha_num - do k = j+1, elec_alpha_num - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23 - fock_b_baa_3e_bi_orth_old(a,i) += direct_int - exch_23_int +! --- + +BEGIN_PROVIDER [double precision, fock_a_tmp1_bi_ortho, (mo_num, mo_num)] + + implicit none + integer :: i, a, j, k + double precision :: contrib_sss, contrib_sos, contrib_soo, contrib + double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int + double precision :: new + + PROVIDE mo_l_coef mo_r_coef + + fock_a_tmp1_bi_ortho = 0.d0 + + do i = 1, mo_num + do a = 1, mo_num + + do j = elec_beta_num + 1, elec_alpha_num + do k = 1, elec_beta_num + call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > + call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > + call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > + call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 + call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 + call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 + + fock_a_tmp1_bi_ortho(a,i) += 1.5d0 * (direct_int - exch_13_int) + 0.5d0 * (c_3_int + c_minus_3_int - exch_23_int - exch_12_int) + enddo + enddo enddo - enddo - enddo - enddo - fock_b_baa_3e_bi_orth_old = - fock_b_baa_3e_bi_orth_old + + fock_a_tmp1_bi_ortho = - fock_a_tmp1_bi_ortho + END_PROVIDER -BEGIN_PROVIDER [ double precision, fock_b_bab_3e_bi_orth_old, (mo_num, mo_num)] - implicit none - BEGIN_DOC -! fock_b_bab_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for beta electrons from beta,alpha,beta contribution - END_DOC - fock_b_bab_3e_bi_orth_old = 0.d0 - integer :: i,a,j,k - double precision :: direct_int, exch_13_int - do i = 1, mo_num - do a = 1, mo_num - - do j = 1, elec_beta_num - do k = 1, elec_alpha_num - ! b a b b a b - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13 - fock_b_bab_3e_bi_orth_old(a,i) += direct_int - exch_13_int +! --- + +BEGIN_PROVIDER [double precision, fock_a_tmp2_bi_ortho, (mo_num, mo_num)] + + implicit none + integer :: i, a, j, k + double precision :: contrib_sss + + PROVIDE mo_l_coef mo_r_coef + + fock_a_tmp2_bi_ortho = 0.d0 + + do i = 1, mo_num + do a = 1, mo_num + do j = 1, elec_alpha_num + do k = elec_beta_num+1, elec_alpha_num + call contrib_3e_sss(a, i, j, k, contrib_sss) + + fock_a_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_sss + enddo + enddo enddo - enddo - enddo - enddo - fock_b_bab_3e_bi_orth_old = - fock_b_bab_3e_bi_orth_old + END_PROVIDER -BEGIN_PROVIDER [ double precision, fock_b_bbb_3e_bi_orth_old, (mo_num, mo_num)] - implicit none - BEGIN_DOC -! fock_b_bbb_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,alpha contribution - END_DOC - fock_b_bbb_3e_bi_orth_old = 0.d0 - integer :: i,a,j,k - double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int - do i = 1, mo_num - do a = 1, mo_num - - do j = 1, elec_beta_num - do k = j+1, elec_beta_num - ! positive terms :: cycle contrib - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > - call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > - fock_b_bbb_3e_bi_orth_old(a,i) += direct_int + c_3_int + c_minus_3_int - ! negative terms :: exchange contrib - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 - call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 - fock_b_bbb_3e_bi_orth_old(a,i) += - exch_13_int - exch_23_int - exch_12_int +! --- + +BEGIN_PROVIDER [double precision, fock_b_tmp1_bi_ortho, (mo_num, mo_num)] + + implicit none + integer :: i, a, j, k + double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int + double precision :: new + + PROVIDE mo_l_coef mo_r_coef + + fock_b_tmp1_bi_ortho = 0.d0 + + do i = 1, mo_num + do a = 1, mo_num + do j = 1, elec_beta_num + do k = elec_beta_num+1, elec_alpha_num + call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > + call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 + call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 + + fock_b_tmp1_bi_ortho(a,i) += 1.5d0 * direct_int - 0.5d0 * exch_23_int - exch_13_int + enddo + enddo enddo - enddo - enddo - enddo - fock_b_bbb_3e_bi_orth_old = - fock_b_bbb_3e_bi_orth_old -END_PROVIDER -BEGIN_PROVIDER [ double precision, fock_b_tot_3e_bi_orth_old, (mo_num, mo_num)] - implicit none - BEGIN_DOC - ! fock_b_tot_3e_bi_orth_old = bi-ortho 3-e Fock matrix for alpha electrons from all possible spin contributions - END_DOC - fock_b_tot_3e_bi_orth_old = fock_b_bbb_3e_bi_orth_old + fock_b_bab_3e_bi_orth_old + fock_b_baa_3e_bi_orth_old + fock_b_tmp1_bi_ortho = - fock_b_tmp1_bi_ortho END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, fock_b_tmp2_bi_ortho, (mo_num, mo_num)] + + implicit none + integer :: i, a, j, k + double precision :: contrib_soo + + PROVIDE mo_l_coef mo_r_coef + + fock_b_tmp2_bi_ortho = 0.d0 + + do i = 1, mo_num + do a = 1, mo_num + do j = elec_beta_num + 1, elec_alpha_num + do k = 1, elec_alpha_num + call contrib_3e_soo(a, i, j, k, contrib_soo) + + fock_b_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_soo + enddo + enddo + enddo + enddo + +END_PROVIDER + +! --- + +subroutine contrib_3e_sss(a, i, j, k, integral) + + BEGIN_DOC + ! returns the pure same spin contribution to F(a,i) from two orbitals j,k + END_DOC + + implicit none + integer, intent(in) :: a, i, j, k + double precision, intent(out) :: integral + double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int + + PROVIDE mo_l_coef mo_r_coef + + call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > + call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > + call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > + integral = direct_int + c_3_int + c_minus_3_int + + ! negative terms :: exchange contrib + call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 + call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 + call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 + integral += - exch_13_int - exch_23_int - exch_12_int + + integral = -integral + +end + +! --- + +subroutine contrib_3e_soo(a,i,j,k,integral) + + BEGIN_DOC + ! returns the same spin / opposite spin / opposite spin contribution to F(a,i) from two orbitals j,k + END_DOC + + implicit none + integer, intent(in) :: a, i, j, k + double precision, intent(out) :: integral + double precision :: direct_int, exch_23_int + + PROVIDE mo_l_coef mo_r_coef + + call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j > + call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23 + integral = direct_int - exch_23_int + + integral = -integral + +end + +! --- + +subroutine contrib_3e_sos(a, i, j, k, integral) + + BEGIN_DOC + ! returns the same spin / opposite spin / same spin contribution to F(a,i) from two orbitals j,k + END_DOC + + PROVIDE mo_l_coef mo_r_coef + + implicit none + integer, intent(in) :: a, i, j, k + double precision, intent(out) :: integral + double precision :: direct_int, exch_13_int + + call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j > + call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13 + integral = direct_int - exch_13_int + + integral = -integral + +end + +! --- + diff --git a/src/tc_scf/fock_three_bi_ortho_new_new.irp.f b/src/tc_scf/fock_three_bi_ortho_new_new.irp.f deleted file mode 100644 index f73171a3..00000000 --- a/src/tc_scf/fock_three_bi_ortho_new_new.irp.f +++ /dev/null @@ -1,286 +0,0 @@ - -! --- - -BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth, (mo_num, mo_num)] - - implicit none - integer :: i, a - - PROVIDE mo_l_coef mo_r_coef - - fock_a_tot_3e_bi_orth = 0.d0 - - do i = 1, mo_num - do a = 1, mo_num - fock_a_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i) - fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp1_bi_ortho(a,i) - fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp2_bi_ortho(a,i) - enddo - enddo - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, fock_b_tot_3e_bi_orth, (mo_num, mo_num)] - - implicit none - integer :: i, a - - PROVIDE mo_l_coef mo_r_coef - - fock_b_tot_3e_bi_orth = 0.d0 - - do i = 1, mo_num - do a = 1, mo_num - fock_b_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i) - fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp2_bi_ortho(a,i) - fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp1_bi_ortho(a,i) - enddo - enddo - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, fock_cs_3e_bi_orth, (mo_num, mo_num)] - - implicit none - integer :: i, a, j, k - double precision :: contrib_sss, contrib_sos, contrib_soo, contrib - double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int - double precision :: new - - PROVIDE mo_l_coef mo_r_coef - - fock_cs_3e_bi_orth = 0.d0 - - do i = 1, mo_num - do a = 1, mo_num - - do j = 1, elec_beta_num - do k = 1, elec_beta_num - - !!call contrib_3e_sss(a,i,j,k,contrib_sss) - !!call contrib_3e_soo(a,i,j,k,contrib_soo) - !!call contrib_3e_sos(a,i,j,k,contrib_sos) - !!contrib = 0.5d0 * (contrib_sss + contrib_soo) + contrib_sos - - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > - call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > - - ! negative terms :: exchange contrib - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 - call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 - - new = 2.d0 * direct_int + 0.5d0 * (c_3_int + c_minus_3_int - exch_12_int) -1.5d0 * exch_13_int - exch_23_int - - fock_cs_3e_bi_orth(a,i) += new - enddo - enddo - enddo - enddo - - fock_cs_3e_bi_orth = - fock_cs_3e_bi_orth - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, fock_a_tmp1_bi_ortho, (mo_num, mo_num)] - - implicit none - integer :: i, a, j, k - double precision :: contrib_sss, contrib_sos, contrib_soo, contrib - double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int - double precision :: new - - PROVIDE mo_l_coef mo_r_coef - - fock_a_tmp1_bi_ortho = 0.d0 - - do i = 1, mo_num - do a = 1, mo_num - - do j = elec_beta_num + 1, elec_alpha_num - do k = 1, elec_beta_num - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > - call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 - call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 - - fock_a_tmp1_bi_ortho(a,i) += 1.5d0 * (direct_int - exch_13_int) + 0.5d0 * (c_3_int + c_minus_3_int - exch_23_int - exch_12_int) - enddo - enddo - enddo - enddo - - fock_a_tmp1_bi_ortho = - fock_a_tmp1_bi_ortho - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, fock_a_tmp2_bi_ortho, (mo_num, mo_num)] - - implicit none - integer :: i, a, j, k - double precision :: contrib_sss - - PROVIDE mo_l_coef mo_r_coef - - fock_a_tmp2_bi_ortho = 0.d0 - - do i = 1, mo_num - do a = 1, mo_num - do j = 1, elec_alpha_num - do k = elec_beta_num+1, elec_alpha_num - call contrib_3e_sss(a, i, j, k, contrib_sss) - - fock_a_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_sss - enddo - enddo - enddo - enddo - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, fock_b_tmp1_bi_ortho, (mo_num, mo_num)] - - implicit none - integer :: i, a, j, k - double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int - double precision :: new - - PROVIDE mo_l_coef mo_r_coef - - fock_b_tmp1_bi_ortho = 0.d0 - - do i = 1, mo_num - do a = 1, mo_num - do j = 1, elec_beta_num - do k = elec_beta_num+1, elec_alpha_num - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 - - fock_b_tmp1_bi_ortho(a,i) += 1.5d0 * direct_int - 0.5d0 * exch_23_int - exch_13_int - enddo - enddo - enddo - enddo - - fock_b_tmp1_bi_ortho = - fock_b_tmp1_bi_ortho - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, fock_b_tmp2_bi_ortho, (mo_num, mo_num)] - - implicit none - integer :: i, a, j, k - double precision :: contrib_soo - - PROVIDE mo_l_coef mo_r_coef - - fock_b_tmp2_bi_ortho = 0.d0 - - do i = 1, mo_num - do a = 1, mo_num - do j = elec_beta_num + 1, elec_alpha_num - do k = 1, elec_alpha_num - call contrib_3e_soo(a, i, j, k, contrib_soo) - - fock_b_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_soo - enddo - enddo - enddo - enddo - -END_PROVIDER - -! --- - -subroutine contrib_3e_sss(a, i, j, k, integral) - - BEGIN_DOC - ! returns the pure same spin contribution to F(a,i) from two orbitals j,k - END_DOC - - implicit none - integer, intent(in) :: a, i, j, k - double precision, intent(out) :: integral - double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int - - PROVIDE mo_l_coef mo_r_coef - - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > - call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > - integral = direct_int + c_3_int + c_minus_3_int - - ! negative terms :: exchange contrib - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 - call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 - integral += - exch_13_int - exch_23_int - exch_12_int - - integral = -integral - -end - -! --- - -subroutine contrib_3e_soo(a,i,j,k,integral) - - BEGIN_DOC - ! returns the same spin / opposite spin / opposite spin contribution to F(a,i) from two orbitals j,k - END_DOC - - implicit none - integer, intent(in) :: a, i, j, k - double precision, intent(out) :: integral - double precision :: direct_int, exch_23_int - - PROVIDE mo_l_coef mo_r_coef - - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23 - integral = direct_int - exch_23_int - - integral = -integral - -end - -! --- - -subroutine contrib_3e_sos(a, i, j, k, integral) - - BEGIN_DOC - ! returns the same spin / opposite spin / same spin contribution to F(a,i) from two orbitals j,k - END_DOC - - PROVIDE mo_l_coef mo_r_coef - - implicit none - integer, intent(in) :: a, i, j, k - double precision, intent(out) :: integral - double precision :: direct_int, exch_13_int - - call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j > - call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13 - integral = direct_int - exch_13_int - - integral = -integral - -end - -! --- - diff --git a/src/tc_scf/fock_three.irp.f b/src/tc_scf/fock_three_hermit.irp.f similarity index 68% rename from src/tc_scf/fock_three.irp.f rename to src/tc_scf/fock_three_hermit.irp.f index 424eeffd..fe8fbfd7 100644 --- a/src/tc_scf/fock_three.irp.f +++ b/src/tc_scf/fock_three_hermit.irp.f @@ -161,7 +161,6 @@ BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh, (mo_num, mo_num)] !F_a^{aa}(h,p) do i = 1, elec_beta_num ! alpha do j = elec_beta_num+1, elec_alpha_num ! alpha - direct_int = three_body_4_index(j,i,h,p) call give_integrals_3_body(h,j,i,p,j,i,direct_int) call give_integrals_3_body(h,j,i,i,p,j,exchange_int_231) call give_integrals_3_body(h,j,i,j,i,p,exchange_int_312) @@ -227,3 +226,144 @@ BEGIN_PROVIDER [ double precision, fock_3_mat_b_op_sh, (mo_num, mo_num)] enddo END_PROVIDER + + +BEGIN_PROVIDER [ double precision, fock_3_w_kk_sum, (n_points_final_grid,3)] + implicit none + integer :: mm, ipoint,k + double precision :: w_kk + fock_3_w_kk_sum = 0.d0 + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kk = x_W_ij_erf_rk(ipoint,mm,k,k) + fock_3_w_kk_sum(ipoint,mm) += w_kk + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_ki_mos_k, (n_points_final_grid,3,mo_num)] + implicit none + integer :: mm, ipoint,k,i + double precision :: w_ki, mo_k + fock_3_w_ki_mos_k = 0.d0 + do i = 1, mo_num + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) + mo_k = mos_in_r_array(k,ipoint) + fock_3_w_ki_mos_k(ipoint,mm,i) += w_ki * mo_k + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_w_kl, (n_points_final_grid,3)] + implicit none + integer :: k,j,ipoint,mm + double precision :: w_kj + fock_3_w_kl_w_kl = 0.d0 + do j = 1, elec_beta_num + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kj = x_W_ij_erf_rk(ipoint,mm,k,j) + fock_3_w_kl_w_kl(ipoint,mm) += w_kj * w_kj + enddo + enddo + enddo + enddo + + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_rho_beta, (n_points_final_grid)] + implicit none + integer :: ipoint,k + fock_3_rho_beta = 0.d0 + do ipoint = 1, n_points_final_grid + do k = 1, elec_beta_num + fock_3_rho_beta(ipoint) += mos_in_r_array(k,ipoint) * mos_in_r_array(k,ipoint) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_mo_k_mo_l, (n_points_final_grid,3)] + implicit none + integer :: ipoint,k,l,mm + double precision :: mos_k, mos_l, w_kl + fock_3_w_kl_mo_k_mo_l = 0.d0 + do k = 1, elec_beta_num + do l = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + mos_k = mos_in_r_array_transp(ipoint,k) + mos_l = mos_in_r_array_transp(ipoint,l) + w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) + fock_3_w_kl_mo_k_mo_l(ipoint,mm) += w_kl * mos_k * mos_l + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_ki_wk_a, (n_points_final_grid,3,mo_num, mo_num)] + implicit none + integer :: ipoint,i,a,k,mm + double precision :: w_ki,w_ka + fock_3_w_ki_wk_a = 0.d0 + do i = 1, mo_num + do a = 1, mo_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + do k = 1, elec_beta_num + w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) + w_ka = x_W_ij_erf_rk(ipoint,mm,k,a) + fock_3_w_ki_wk_a(ipoint,mm,a,i) += w_ki * w_ka + enddo + enddo + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_trace_w_tilde, (n_points_final_grid,3)] + implicit none + integer :: ipoint,k,mm + fock_3_trace_w_tilde = 0.d0 + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + fock_3_trace_w_tilde(ipoint,mm) += fock_3_w_ki_wk_a(ipoint,mm,k,k) + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3,mo_num)] + implicit none + integer :: ipoint,a,k,mm,l + double precision :: w_kl,w_la, mo_k + fock_3_w_kl_wla_phi_k = 0.d0 + do a = 1, mo_num + do k = 1, elec_beta_num + do l = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) + w_la = x_W_ij_erf_rk(ipoint,mm,l,a) + mo_k = mos_in_r_array_transp(ipoint,k) + fock_3_w_kl_wla_phi_k(ipoint,mm,a) += w_kl * w_la * mo_k + enddo + enddo + enddo + enddo + enddo +END_PROVIDER + diff --git a/src/tc_scf/fock_three_utils.irp.f b/src/tc_scf/fock_three_utils.irp.f deleted file mode 100644 index 5aec1d9e..00000000 --- a/src/tc_scf/fock_three_utils.irp.f +++ /dev/null @@ -1,140 +0,0 @@ - -BEGIN_PROVIDER [ double precision, fock_3_w_kk_sum, (n_points_final_grid,3)] - implicit none - integer :: mm, ipoint,k - double precision :: w_kk - fock_3_w_kk_sum = 0.d0 - do k = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - w_kk = x_W_ij_erf_rk(ipoint,mm,k,k) - fock_3_w_kk_sum(ipoint,mm) += w_kk - enddo - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_ki_mos_k, (n_points_final_grid,3,mo_num)] - implicit none - integer :: mm, ipoint,k,i - double precision :: w_ki, mo_k - fock_3_w_ki_mos_k = 0.d0 - do i = 1, mo_num - do k = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) - mo_k = mos_in_r_array(k,ipoint) - fock_3_w_ki_mos_k(ipoint,mm,i) += w_ki * mo_k - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_kl_w_kl, (n_points_final_grid,3)] - implicit none - integer :: k,j,ipoint,mm - double precision :: w_kj - fock_3_w_kl_w_kl = 0.d0 - do j = 1, elec_beta_num - do k = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - w_kj = x_W_ij_erf_rk(ipoint,mm,k,j) - fock_3_w_kl_w_kl(ipoint,mm) += w_kj * w_kj - enddo - enddo - enddo - enddo - - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_rho_beta, (n_points_final_grid)] - implicit none - integer :: ipoint,k - fock_3_rho_beta = 0.d0 - do ipoint = 1, n_points_final_grid - do k = 1, elec_beta_num - fock_3_rho_beta(ipoint) += mos_in_r_array(k,ipoint) * mos_in_r_array(k,ipoint) - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_kl_mo_k_mo_l, (n_points_final_grid,3)] - implicit none - integer :: ipoint,k,l,mm - double precision :: mos_k, mos_l, w_kl - fock_3_w_kl_mo_k_mo_l = 0.d0 - do k = 1, elec_beta_num - do l = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - mos_k = mos_in_r_array_transp(ipoint,k) - mos_l = mos_in_r_array_transp(ipoint,l) - w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) - fock_3_w_kl_mo_k_mo_l(ipoint,mm) += w_kl * mos_k * mos_l - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_ki_wk_a, (n_points_final_grid,3,mo_num, mo_num)] - implicit none - integer :: ipoint,i,a,k,mm - double precision :: w_ki,w_ka - fock_3_w_ki_wk_a = 0.d0 - do i = 1, mo_num - do a = 1, mo_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - do k = 1, elec_beta_num - w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) - w_ka = x_W_ij_erf_rk(ipoint,mm,k,a) - fock_3_w_ki_wk_a(ipoint,mm,a,i) += w_ki * w_ka - enddo - enddo - enddo - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_trace_w_tilde, (n_points_final_grid,3)] - implicit none - integer :: ipoint,k,mm - fock_3_trace_w_tilde = 0.d0 - do k = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - fock_3_trace_w_tilde(ipoint,mm) += fock_3_w_ki_wk_a(ipoint,mm,k,k) - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3,mo_num)] - implicit none - integer :: ipoint,a,k,mm,l - double precision :: w_kl,w_la, mo_k - fock_3_w_kl_wla_phi_k = 0.d0 - do a = 1, mo_num - do k = 1, elec_beta_num - do l = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) - w_la = x_W_ij_erf_rk(ipoint,mm,l,a) - mo_k = mos_in_r_array_transp(ipoint,k) - fock_3_w_kl_wla_phi_k(ipoint,mm,a) += w_kl * w_la * mo_k - enddo - enddo - enddo - enddo - enddo -END_PROVIDER - diff --git a/src/tc_scf/minimize_tc_angles.irp.f b/src/tc_scf/minimize_tc_angles.irp.f index cb729eb2..1363e62b 100644 --- a/src/tc_scf/minimize_tc_angles.irp.f +++ b/src/tc_scf/minimize_tc_angles.irp.f @@ -1,10 +1,11 @@ program print_angles implicit none + BEGIN_DOC +! program that minimizes the angle between left- and right-orbitals when degeneracies are found in the TC-Fock matrix + END_DOC my_grid_becke = .True. my_n_pt_r_grid = 30 my_n_pt_a_grid = 50 -! my_n_pt_r_grid = 10 ! small grid for quick debug -! my_n_pt_a_grid = 14 ! small grid for quick debug touch my_n_pt_r_grid my_n_pt_a_grid ! call sort_by_tc_fock call minimize_tc_orb_angles diff --git a/src/tc_scf/print_angle_tc_orb.irp.f b/src/tc_scf/print_angle_tc_orb.irp.f deleted file mode 100644 index 09260395..00000000 --- a/src/tc_scf/print_angle_tc_orb.irp.f +++ /dev/null @@ -1,9 +0,0 @@ -program print_angles - implicit none - my_grid_becke = .True. -! my_n_pt_r_grid = 30 -! my_n_pt_a_grid = 50 - my_n_pt_r_grid = 10 ! small grid for quick debug - my_n_pt_a_grid = 14 ! small grid for quick debug - call print_angles_tc -end diff --git a/src/tc_scf/rotate_tcscf_orbitals.irp.f b/src/tc_scf/rotate_tcscf_orbitals.irp.f index fc4a7935..31999c18 100644 --- a/src/tc_scf/rotate_tcscf_orbitals.irp.f +++ b/src/tc_scf/rotate_tcscf_orbitals.irp.f @@ -4,7 +4,7 @@ program rotate_tcscf_orbitals BEGIN_DOC - ! TODO : Put the documentation of the program here + ! TODO : Rotate the bi-orthonormal orbitals in order to minimize left-right angles when degenerate END_DOC implicit none diff --git a/src/tc_scf/routines_rotates.irp.f b/src/tc_scf/routines_rotates.irp.f index 596ae500..3c12118f 100644 --- a/src/tc_scf/routines_rotates.irp.f +++ b/src/tc_scf/routines_rotates.irp.f @@ -1,7 +1,54 @@ + +! --- + +subroutine LTxSxR(n, m, L, S, R, C) + + implicit none + integer, intent(in) :: n, m + double precision, intent(in) :: L(n,m), S(n,n), R(n,m) + double precision, intent(out) :: C(m,m) + integer :: i, j + double precision :: accu_d, accu_nd + double precision, allocatable :: tmp(:,:) + + ! L.T x S x R + allocate(tmp(m,n)) + call dgemm( 'T', 'N', m, n, n, 1.d0 & + , L, size(L, 1), S, size(S, 1) & + , 0.d0, tmp, size(tmp, 1) ) + call dgemm( 'N', 'N', m, m, n, 1.d0 & + , tmp, size(tmp, 1), R, size(R, 1) & + , 0.d0, C, size(C, 1) ) + deallocate(tmp) + + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, m + do j = 1, m + if(j.eq.i) then + accu_d += dabs(C(j,i)) + else + accu_nd += C(j,i) * C(j,i) + endif + enddo + enddo + accu_nd = dsqrt(accu_nd) + + print*, ' accu_d = ', accu_d + print*, ' accu_nd = ', accu_nd + +end subroutine LTxR + +! --- + + ! --- subroutine minimize_tc_orb_angles() + BEGIN_DOC + ! routine that minimizes the angle between left- and right-orbitals when degeneracies are found + END_DOC implicit none logical :: good_angles diff --git a/src/tc_scf/tc_scf_dm.irp.f b/src/tc_scf/tc_scf_dm.irp.f index 90719f47..07da8a58 100644 --- a/src/tc_scf/tc_scf_dm.irp.f +++ b/src/tc_scf/tc_scf_dm.irp.f @@ -2,6 +2,9 @@ BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num) ] + BEGIN_DOC + ! TC-SCF transition density matrix on the AO basis for BETA electrons + END_DOC implicit none if(bi_ortho) then @@ -16,6 +19,9 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num) ] + BEGIN_DOC + ! TC-SCF transition density matrix on the AO basis for ALPHA electrons + END_DOC implicit none if(bi_ortho) then @@ -31,6 +37,9 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num) ] implicit none + BEGIN_DOC + ! TC-SCF transition density matrix on the AO basis for ALPHA+BETA electrons + END_DOC TCSCF_density_matrix_ao_tot = TCSCF_density_matrix_ao_beta + TCSCF_density_matrix_ao_alpha END_PROVIDER diff --git a/src/tc_scf/tc_scf_utils.irp.f b/src/tc_scf/tc_scf_utils.irp.f deleted file mode 100644 index dde477c4..00000000 --- a/src/tc_scf/tc_scf_utils.irp.f +++ /dev/null @@ -1,43 +0,0 @@ - -! --- - -subroutine LTxSxR(n, m, L, S, R, C) - - implicit none - integer, intent(in) :: n, m - double precision, intent(in) :: L(n,m), S(n,n), R(n,m) - double precision, intent(out) :: C(m,m) - integer :: i, j - double precision :: accu_d, accu_nd - double precision, allocatable :: tmp(:,:) - - ! L.T x S x R - allocate(tmp(m,n)) - call dgemm( 'T', 'N', m, n, n, 1.d0 & - , L, size(L, 1), S, size(S, 1) & - , 0.d0, tmp, size(tmp, 1) ) - call dgemm( 'N', 'N', m, m, n, 1.d0 & - , tmp, size(tmp, 1), R, size(R, 1) & - , 0.d0, C, size(C, 1) ) - deallocate(tmp) - - accu_d = 0.d0 - accu_nd = 0.d0 - do i = 1, m - do j = 1, m - if(j.eq.i) then - accu_d += dabs(C(j,i)) - else - accu_nd += C(j,i) * C(j,i) - endif - enddo - enddo - accu_nd = dsqrt(accu_nd) - - print*, ' accu_d = ', accu_d - print*, ' accu_nd = ', accu_nd - -end subroutine LTxR - -! --- - diff --git a/src/tc_scf/test_Ne.sh b/src/tc_scf/test_Ne.sh deleted file mode 100755 index a6422931..00000000 --- a/src/tc_scf/test_Ne.sh +++ /dev/null @@ -1,13 +0,0 @@ -QP_ROOT=/home/eginer/new_qp2/qp2 -source ${QP_ROOT}/quantum_package.rc - echo Ne > Ne.xyz - echo $QP_ROOT - qp create_ezfio -b cc-pcvdz Ne.xyz -o Ne_tc_scf - qp run scf - qp set tc_keywords bi_ortho True - qp set ao_two_e_erf_ints mu_erf 0.87 - qp set tc_keywords j1b_pen [1.5] - qp set tc_keywords j1b_type 3 - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out - grep "TC energy =" Ne.ezfio.tc_scf.out | tail -1 - eref=-128.552134 diff --git a/src/tc_scf/test_int.irp.f b/src/tc_scf/test_int.irp.f deleted file mode 100644 index a14c4126..00000000 --- a/src/tc_scf/test_int.irp.f +++ /dev/null @@ -1,1003 +0,0 @@ -program test_ints - - BEGIN_DOC -! TODO : Put the documentation of the program here - END_DOC - - implicit none - - print *, ' starting test_ints ...' - - my_grid_becke = .True. - my_n_pt_r_grid = 30 - my_n_pt_a_grid = 50 -! my_n_pt_r_grid = 15 ! small grid for quick debug -! my_n_pt_a_grid = 26 ! small grid for quick debug - touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid - - my_extra_grid_becke = .True. - my_n_pt_r_extra_grid = 30 - my_n_pt_a_extra_grid = 50 ! small extra_grid for quick debug - touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid - -!! OK -!call routine_int2_u_grad1u_j1b2 -!! OK -!call routine_v_ij_erf_rk_cst_mu_j1b -!! OK -! call routine_x_v_ij_erf_rk_cst_mu_j1b -!! OK -! call routine_v_ij_u_cst_mu_j1b - -!! OK -!call routine_int2_u2_j1b2 - -!! OK -!call routine_int2_u_grad1u_x_j1b2 - -!! OK -! call routine_int2_grad1u2_grad2u2_j1b2 -! call routine_int2_u_grad1u_j1b2 -! call test_total_grad_lapl -! call test_total_grad_square -! call test_ao_tc_int_chemist -! call test_grid_points_ao -! call test_tc_scf - !call test_int_gauss - - !call test_fock_3e_uhf_ao() - !call test_fock_3e_uhf_mo() - - !call test_tc_grad_and_lapl_ao() - !call test_tc_grad_square_ao() - - call test_two_e_tc_non_hermit_integral() - -end - -! --- - -subroutine test_tc_scf - implicit none - integer :: i -! provide int2_u_grad1u_x_j1b2_test - provide x_v_ij_erf_rk_cst_mu_j1b_test -! provide x_v_ij_erf_rk_cst_mu_j1b_test -! print*,'TC_HF_energy = ',TC_HF_energy -! print*,'grad_non_hermit = ',grad_non_hermit -end - -subroutine test_ao_tc_int_chemist - implicit none - provide ao_tc_int_chemist -! provide ao_tc_int_chemist_test -! provide tc_grad_square_ao_test -! provide tc_grad_and_lapl_ao_test -end - -! --- - -subroutine routine_test_j1b - implicit none - integer :: i,icount,j - icount = 0 - do i = 1, List_all_comb_b3_size - if(dabs(List_all_comb_b3_coef(i)).gt.1.d-10)then - print*,'' - print*,List_all_comb_b3_expo(i),List_all_comb_b3_coef(i) - print*,List_all_comb_b3_cent(1:3,i) - print*,'' - icount += 1 - endif - - enddo - print*,'List_all_comb_b3_coef,icount = ',List_all_comb_b3_size,icount - do i = 1, ao_num - do j = 1, ao_num - do icount = 1, List_comb_thr_b3_size(j,i) - print*,'',j,i - print*,List_comb_thr_b3_expo(icount,j,i),List_comb_thr_b3_coef(icount,j,i) - print*,List_comb_thr_b3_cent(1:3,icount,j,i) - print*,'' - enddo -! enddo - enddo - enddo - print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size,List_all_comb_b3_size - -end - -subroutine routine_int2_u_grad1u_j1b2 - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:) - - allocate(array(ao_num, ao_num, ao_num, ao_num)) - array = 0.d0 - allocate(array_ref(ao_num, ao_num, ao_num, ao_num)) - array_ref = 0.d0 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - array(j,i,l,k) += int2_u_grad1u_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += int2_u_grad1u_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - enddo - enddo - enddo - enddo - enddo - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k)) - accu_abs += contrib - if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(array_ref(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - - -end - -subroutine routine_v_ij_erf_rk_cst_mu_j1b - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:) -! print*,'ao_overlap_abs = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_overlap_abs(i,:) -! enddo -! print*,'center = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_center(2,i,:) -! enddo -! print*,'sigma = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_sigma(i,:) -! enddo - - - allocate(array(ao_num, ao_num, ao_num, ao_num)) - array = 0.d0 - allocate(array_ref(ao_num, ao_num, ao_num, ao_num)) - array_ref = 0.d0 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - array(j,i,l,k) += v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += v_ij_erf_rk_cst_mu_j1b(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - enddo - enddo - enddo - enddo - enddo - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k)) - accu_abs += contrib - if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(array_ref(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - - -end - - -subroutine routine_x_v_ij_erf_rk_cst_mu_j1b - implicit none - integer :: i,j,ipoint,k,l,m - double precision :: weight,accu_relat, accu_abs, contrib - double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:) -! print*,'ao_overlap_abs = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_overlap_abs(i,:) -! enddo -! print*,'center = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_center(2,i,:) -! enddo -! print*,'sigma = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_sigma(i,:) -! enddo - - - allocate(array(ao_num, ao_num, ao_num, ao_num)) - array = 0.d0 - allocate(array_ref(ao_num, ao_num, ao_num, ao_num)) - array_ref = 0.d0 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - do m = 1, 3 - array(j,i,l,k) += x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += x_v_ij_erf_rk_cst_mu_j1b (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight - enddo - enddo - enddo - enddo - enddo - enddo - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k)) - accu_abs += contrib - if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(array_ref(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - - -end - - - -subroutine routine_v_ij_u_cst_mu_j1b_test - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:) -! print*,'ao_overlap_abs = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_overlap_abs(i,:) -! enddo -! print*,'center = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_center(2,i,:) -! enddo -! print*,'sigma = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_sigma(i,:) -! enddo - - - allocate(array(ao_num, ao_num, ao_num, ao_num)) - array = 0.d0 - allocate(array_ref(ao_num, ao_num, ao_num, ao_num)) - array_ref = 0.d0 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - array(j,i,l,k) += v_ij_u_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += v_ij_u_cst_mu_j1b(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - enddo - enddo - enddo - enddo - enddo - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k)) - accu_abs += contrib - if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(array_ref(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - - -end - -subroutine routine_int2_grad1u2_grad2u2_j1b2 - implicit none - integer :: i,j,ipoint,k,l - integer :: ii , jj - double precision :: weight,accu_relat, accu_abs, contrib - double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:) - double precision, allocatable :: ints(:,:,:) - allocate(ints(ao_num, ao_num, n_points_final_grid)) -! do ipoint = 1, n_points_final_grid -! do i = 1, ao_num -! do j = 1, ao_num -! read(33,*)ints(j,i,ipoint) -! enddo -! enddo -! enddo - - allocate(array(ao_num, ao_num, ao_num, ao_num)) - array = 0.d0 - allocate(array_ref(ao_num, ao_num, ao_num, ao_num)) - array_ref = 0.d0 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - array(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! !array(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! !array(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! if(dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)).gt.1.d-6)then -! if(dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)).gt.1.d-6)then -! print*,j,i,ipoint -! print*,int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) , int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint), dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)) -! print*,int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) , int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint), dabs(int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) - int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint)) -! stop -! endif -! endif - enddo - enddo - enddo - enddo - enddo - double precision :: e_ref, e_new - accu_relat = 0.d0 - accu_abs = 0.d0 - e_ref = 0.d0 - e_new = 0.d0 - do ii = 1, elec_alpha_num - do jj = ii, elec_alpha_num - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - e_ref += mo_coef(j,ii) * mo_coef(i,ii) * array_ref(j,i,l,k) * mo_coef(l,jj) * mo_coef(k,jj) - e_new += mo_coef(j,ii) * mo_coef(i,ii) * array(j,i,l,k) * mo_coef(l,jj) * mo_coef(k,jj) - contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k)) - accu_abs += contrib -! if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then -! accu_relat += contrib/dabs(array_ref(j,i,l,k)) -! endif - enddo - enddo - enddo - enddo - - enddo - enddo - print*,'e_ref = ',e_ref - print*,'e_new = ',e_new -! print*,'accu_abs = ',accu_abs/dble(ao_num)**4 -! print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - - -end - -subroutine routine_int2_u2_j1b2 - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:) -! print*,'ao_overlap_abs = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_overlap_abs(i,:) -! enddo -! print*,'center = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_center(2,i,:) -! enddo -! print*,'sigma = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_sigma(i,:) -! enddo - - - allocate(array(ao_num, ao_num, ao_num, ao_num)) - array = 0.d0 - allocate(array_ref(ao_num, ao_num, ao_num, ao_num)) - array_ref = 0.d0 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - array(j,i,l,k) += int2_u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += int2_u2_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - enddo - enddo - enddo - enddo - enddo - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k)) - accu_abs += contrib - if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(array_ref(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - - -end - - -subroutine routine_int2_u_grad1u_x_j1b2 - implicit none - integer :: i,j,ipoint,k,l,m - double precision :: weight,accu_relat, accu_abs, contrib - double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:) -! print*,'ao_overlap_abs = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_overlap_abs(i,:) -! enddo -! print*,'center = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_center(2,i,:) -! enddo -! print*,'sigma = ' -! do i = 1, ao_num -! write(*,'(100(F10.5,X))')ao_prod_sigma(i,:) -! enddo - - - allocate(array(ao_num, ao_num, ao_num, ao_num)) - array = 0.d0 - allocate(array_ref(ao_num, ao_num, ao_num, ao_num)) - array_ref = 0.d0 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - do m = 1, 3 - array(j,i,l,k) += int2_u_grad1u_x_j1b2_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += int2_u_grad1u_x_j1b2 (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight - enddo - enddo - enddo - enddo - enddo - enddo - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k)) - accu_abs += contrib - if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(array_ref(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - - -end - -subroutine routine_v_ij_u_cst_mu_j1b - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:) - - allocate(array(ao_num, ao_num, ao_num, ao_num)) - array = 0.d0 - allocate(array_ref(ao_num, ao_num, ao_num, ao_num)) - array_ref = 0.d0 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - array(j,i,l,k) += v_ij_u_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += v_ij_u_cst_mu_j1b(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - enddo - enddo - enddo - enddo - enddo - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k)) - accu_abs += contrib - if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(array_ref(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - -end - -! --- - -subroutine test_fock_3e_uhf_ao() - - implicit none - integer :: i, j - double precision :: diff_tot, diff_ij, thr_ih, norm - double precision, allocatable :: fock_3e_uhf_ao_a_mo(:,:), fock_3e_uhf_ao_b_mo(:,:) - - thr_ih = 1d-7 - - PROVIDE fock_a_tot_3e_bi_orth fock_b_tot_3e_bi_orth - PROVIDE fock_3e_uhf_ao_a fock_3e_uhf_ao_b - - ! --- - - allocate(fock_3e_uhf_ao_a_mo(mo_num,mo_num)) - call ao_to_mo_bi_ortho( fock_3e_uhf_ao_a , size(fock_3e_uhf_ao_a , 1) & - , fock_3e_uhf_ao_a_mo, size(fock_3e_uhf_ao_a_mo, 1) ) - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, mo_num - do j = 1, mo_num - - diff_ij = dabs(fock_3e_uhf_ao_a_mo(j,i) - fock_a_tot_3e_bi_orth(j,i)) - if(diff_ij .gt. thr_ih) then - print *, ' difference on ', j, i - print *, ' MANU : ', fock_a_tot_3e_bi_orth(j,i) - print *, ' UHF : ', fock_3e_uhf_ao_a_mo (j,i) - !stop - endif - - norm += dabs(fock_a_tot_3e_bi_orth(j,i)) - diff_tot += diff_ij - enddo - enddo - print *, ' diff on F_a = ', diff_tot / norm - print *, ' ' - - deallocate(fock_3e_uhf_ao_a_mo) - - ! --- - - allocate(fock_3e_uhf_ao_b_mo(mo_num,mo_num)) - call ao_to_mo_bi_ortho( fock_3e_uhf_ao_b , size(fock_3e_uhf_ao_b , 1) & - , fock_3e_uhf_ao_b_mo, size(fock_3e_uhf_ao_b_mo, 1) ) - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, mo_num - do j = 1, mo_num - - diff_ij = dabs(fock_3e_uhf_ao_b_mo(j,i) - fock_b_tot_3e_bi_orth(j,i)) - if(diff_ij .gt. thr_ih) then - print *, ' difference on ', j, i - print *, ' MANU : ', fock_b_tot_3e_bi_orth(j,i) - print *, ' UHF : ', fock_3e_uhf_ao_b_mo (j,i) - !stop - endif - - norm += dabs(fock_b_tot_3e_bi_orth(j,i)) - diff_tot += diff_ij - enddo - enddo - print *, ' diff on F_b = ', diff_tot/norm - print *, ' ' - - deallocate(fock_3e_uhf_ao_b_mo) - - ! --- - -end subroutine test_fock_3e_uhf_ao() - -! --- - -subroutine test_fock_3e_uhf_mo() - - implicit none - integer :: i, j - double precision :: diff_tot, diff_ij, thr_ih, norm - - thr_ih = 1d-12 - - PROVIDE fock_a_tot_3e_bi_orth fock_b_tot_3e_bi_orth - PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_b - - ! --- - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, mo_num - do j = 1, mo_num - - diff_ij = dabs(fock_3e_uhf_mo_a(j,i) - fock_a_tot_3e_bi_orth(j,i)) - if(diff_ij .gt. thr_ih) then - print *, ' difference on ', j, i - print *, ' MANU : ', fock_a_tot_3e_bi_orth(j,i) - print *, ' UHF : ', fock_3e_uhf_mo_a (j,i) - !stop - endif - - norm += dabs(fock_a_tot_3e_bi_orth(j,i)) - diff_tot += diff_ij - enddo - enddo - print *, ' diff on F_a = ', diff_tot / norm - print *, ' norm_a = ', norm - print *, ' ' - - ! --- - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, mo_num - do j = 1, mo_num - - diff_ij = dabs(fock_3e_uhf_mo_b(j,i) - fock_b_tot_3e_bi_orth(j,i)) - if(diff_ij .gt. thr_ih) then - print *, ' difference on ', j, i - print *, ' MANU : ', fock_b_tot_3e_bi_orth(j,i) - print *, ' UHF : ', fock_3e_uhf_mo_b (j,i) - !stop - endif - - norm += dabs(fock_b_tot_3e_bi_orth(j,i)) - diff_tot += diff_ij - enddo - enddo - print *, ' diff on F_b = ', diff_tot/norm - print *, ' norm_b = ', norm - print *, ' ' - - ! --- - -end subroutine test_fock_3e_uhf_mo - -! --- - -subroutine test_total_grad_lapl - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(tc_grad_and_lapl_ao_test(j,i,l,k) - tc_grad_and_lapl_ao(j,i,l,k)) - accu_abs += contrib - if(dabs(tc_grad_and_lapl_ao(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(tc_grad_and_lapl_ao(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - -end - -subroutine test_total_grad_square - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(tc_grad_square_ao_test(j,i,l,k) - tc_grad_square_ao(j,i,l,k)) - accu_abs += contrib - if(dabs(tc_grad_square_ao(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(tc_grad_square_ao(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - -end - -subroutine test_grid_points_ao - implicit none - integer :: i,j,ipoint,icount,icount_good, icount_bad,icount_full - double precision :: thr - thr = 1.d-10 -! print*,'max_n_pts_grid_ao_prod = ',max_n_pts_grid_ao_prod -! print*,'n_pts_grid_ao_prod' - do i = 1, ao_num - do j = i, ao_num - icount = 0 - icount_good = 0 - icount_bad = 0 - icount_full = 0 - do ipoint = 1, n_points_final_grid -! if(dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,1)) & -! + dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,2)) & -! + dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,3)) ) -! if(dabs(int2_u2_j1b2_test(j,i,ipoint)).gt.thr)then -! icount += 1 -! endif - if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then - icount_full += 1 - endif - if(dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)).gt.thr)then - icount += 1 - if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then - icount_good += 1 - else - print*,j,i,ipoint - print*,dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint))/dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)) - icount_bad += 1 - endif - endif -! if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr)then -! endif - enddo - print*,'' - print*,j,i - print*,icount,icount_full, icount_bad!,n_pts_grid_ao_prod(j,i) - print*,dble(icount)/dble(n_points_final_grid),dble(icount_full)/dble(n_points_final_grid) -! dble(n_pts_grid_ao_prod(j,i))/dble(n_points_final_grid) -! if(icount.gt.n_pts_grid_ao_prod(j,i))then -! print*,'pb !!' -! endif - enddo - enddo -end - -subroutine test_int_gauss - implicit none - integer :: i,j - print*,'center' - do i = 1, ao_num - do j = i, ao_num - print*,j,i - print*,ao_prod_sigma(j,i),ao_overlap_abs_grid(j,i) - print*,ao_prod_center(1:3,j,i) - enddo - enddo - print*,'' - double precision :: weight, r(3),integral_1,pi,center(3),f_r,alpha,distance,integral_2 - center = 0.d0 - pi = dacos(-1.d0) - integral_1 = 0.d0 - integral_2 = 0.d0 - alpha = 0.75d0 - do i = 1, n_points_final_grid - ! you get x, y and z of the ith grid point - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - weight = final_weight_at_r_vector(i) - distance = dsqrt( (r(1) - center(1))**2 + (r(2) - center(2))**2 + (r(3) - center(3))**2 ) - f_r = dexp(-alpha * distance*distance) - ! you add the contribution of the grid point to the integral - integral_1 += f_r * weight - integral_2 += f_r * distance * weight - enddo - print*,'integral_1 =',integral_1 - print*,'(pi/alpha)**1.5 =',(pi / alpha)**1.5 - print*,'integral_2 =',integral_2 - print*,'(pi/alpha)**1.5 =',2.d0*pi / (alpha)**2 - - -end - -! --- - -subroutine test_tc_grad_and_lapl_ao() - - implicit none - integer :: i, j, k, l - double precision :: diff_tot, diff, thr_ih, norm - - thr_ih = 1d-10 - - PROVIDE tc_grad_and_lapl_ao tc_grad_and_lapl_ao_loop - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - do k = 1, ao_num - do l = 1, ao_num - - diff = dabs(tc_grad_and_lapl_ao_loop(l,k,j,i) - tc_grad_and_lapl_ao(l,k,j,i)) - if(diff .gt. thr_ih) then - print *, ' difference on ', l, k, j, i - print *, ' loops : ', tc_grad_and_lapl_ao_loop(l,k,j,i) - print *, ' lapack: ', tc_grad_and_lapl_ao (l,k,j,i) - !stop - endif - - norm += dabs(tc_grad_and_lapl_ao_loop(l,k,j,i)) - diff_tot += diff - enddo - enddo - enddo - enddo - - print *, ' diff tot = ', diff_tot / norm - print *, ' norm = ', norm - print *, ' ' - - return - -end - -! --- - -subroutine test_tc_grad_square_ao() - - implicit none - integer :: i, j, k, l - double precision :: diff_tot, diff, thr_ih, norm - - thr_ih = 1d-10 - - PROVIDE tc_grad_square_ao tc_grad_square_ao_loop - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - do k = 1, ao_num - do l = 1, ao_num - - diff = dabs(tc_grad_square_ao_loop(l,k,j,i) - tc_grad_square_ao(l,k,j,i)) - if(diff .gt. thr_ih) then - print *, ' difference on ', l, k, j, i - print *, ' loops : ', tc_grad_square_ao_loop(l,k,j,i) - print *, ' lapack: ', tc_grad_square_ao (l,k,j,i) - !stop - endif - - norm += dabs(tc_grad_square_ao_loop(l,k,j,i)) - diff_tot += diff - enddo - enddo - enddo - enddo - - print *, ' diff tot = ', diff_tot / norm - print *, ' norm = ', norm - print *, ' ' - - return - -end - -! --- - -subroutine test_two_e_tc_non_hermit_integral() - - implicit none - integer :: i, j - double precision :: diff_tot, diff, thr_ih, norm - - thr_ih = 1d-10 - - PROVIDE two_e_tc_non_hermit_integral_beta two_e_tc_non_hermit_integral_alpha - PROVIDE two_e_tc_non_hermit_integral_seq_beta two_e_tc_non_hermit_integral_seq_alpha - - ! --- - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - - diff = dabs(two_e_tc_non_hermit_integral_seq_alpha(j,i) - two_e_tc_non_hermit_integral_alpha(j,i)) - if(diff .gt. thr_ih) then - print *, ' difference on ', j, i - print *, ' seq : ', two_e_tc_non_hermit_integral_seq_alpha(j,i) - print *, ' // : ', two_e_tc_non_hermit_integral_alpha (j,i) - !stop - endif - - norm += dabs(two_e_tc_non_hermit_integral_seq_alpha(j,i)) - diff_tot += diff - enddo - enddo - - print *, ' diff tot a = ', diff_tot / norm - print *, ' norm a = ', norm - print *, ' ' - - ! --- - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - - diff = dabs(two_e_tc_non_hermit_integral_seq_beta(j,i) - two_e_tc_non_hermit_integral_beta(j,i)) - if(diff .gt. thr_ih) then - print *, ' difference on ', j, i - print *, ' seq : ', two_e_tc_non_hermit_integral_seq_beta(j,i) - print *, ' // : ', two_e_tc_non_hermit_integral_beta (j,i) - !stop - endif - - norm += dabs(two_e_tc_non_hermit_integral_seq_beta(j,i)) - diff_tot += diff - enddo - enddo - - print *, ' diff tot b = ', diff_tot / norm - print *, ' norm b = ', norm - print *, ' ' - - ! --- - - return - -end - -! --- - ->>>>>>> 92a4e33f8a21717cab0c0e4f8412ed6903afb04a diff --git a/src/three_body_ints/EZFIO.cfg b/src/three_body_ints/EZFIO.cfg deleted file mode 100644 index 9624c161..00000000 --- a/src/three_body_ints/EZFIO.cfg +++ /dev/null @@ -1,20 +0,0 @@ -[io_three_body_ints] -type: Disk_access -doc: Read/Write the 6 index tensor three-body terms from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[symm_3_body_tensor] -type: logical -doc: If |true|, you have a symmetrized two body tensor -interface: ezfio,provider,ocaml -default: False - - -[read_3_body_tc_ints] -type: logical -doc: If |true|, you read the 3 body integrals from an FCIDUMP like file -interface: ezfio,provider,ocaml -default: False - - diff --git a/src/three_body_ints/three_body_tensor.irp.f b/src/three_body_ints/three_body_tensor.irp.f deleted file mode 100644 index 2b65a925..00000000 --- a/src/three_body_ints/three_body_tensor.irp.f +++ /dev/null @@ -1,106 +0,0 @@ -BEGIN_PROVIDER [ double precision, three_body_ints, (mo_num, mo_num, mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! matrix element of the -L three-body operator -! -! notice the -1 sign: in this way three_body_ints can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_ints = 0.d0 - print*,'Providing the three_body_ints ...' - call wall_time(wall0) - name_file = 'six_index_tensor' - if(read_three_body_ints)then - call read_fcidump_3_tc(three_body_ints) - else - if(read_three_body_ints)then - print*,'Reading three_body_ints from disk ...' - call read_array_6_index_tensor(mo_num,three_body_ints,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,l,m,n,integral) & - !$OMP SHARED (mo_num,three_body_ints) - !$OMP DO SCHEDULE (dynamic) - do n = 1, mo_num - do l = 1, mo_num - do k = 1, mo_num - do m = n, mo_num - do j = l, mo_num - do i = k, mo_num -!! if(i>=j)then - integral = 0.d0 - call give_integrals_3_body(i,j,m,k,l,n,integral) - - three_body_ints(i,j,m,k,l,n) = -1.d0 * integral - - ! permutation with k,i - three_body_ints(k,j,m,i,l,n) = -1.d0 * integral ! i,k - ! two permutations with k,i - three_body_ints(k,l,m,i,j,n) = -1.d0 * integral - three_body_ints(k,j,n,i,l,m) = -1.d0 * integral - ! three permutations with k,i - three_body_ints(k,l,n,i,j,m) = -1.d0 * integral - - ! permutation with l,j - three_body_ints(i,l,m,k,j,n) = -1.d0 * integral ! j,l - ! two permutations with l,j - three_body_ints(k,l,m,i,j,n) = -1.d0 * integral - three_body_ints(i,l,n,k,j,m) = -1.d0 * integral - ! two permutations with l,j -!!!! three_body_ints(k,l,n,i,j,m) = -1.d0 * integral - - ! permutation with m,n - three_body_ints(i,j,n,k,l,m) = -1.d0 * integral ! m,n - ! two permutations with m,n - three_body_ints(k,j,n,i,l,m) = -1.d0 * integral ! m,n - three_body_ints(i,l,n,k,j,m) = -1.d0 * integral ! m,n - ! three permutations with k,i -!!!! three_body_ints(k,l,n,i,j,m) = -1.d0 * integral ! m,n - -!! endif - enddo - enddo - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - endif - call wall_time(wall1) - print*,'wall time for three_body_ints',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_ints on disk ...' - call write_array_6_index_tensor(mo_num,three_body_ints,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - - - -subroutine give_integrals_3_body(i,j,m,k,l,n,integral) - implicit none - double precision, intent(out) :: integral - integer, intent(in) :: i,j,m,k,l,n - double precision :: weight - BEGIN_DOC -! - END_DOC - integer :: ipoint,mm - integral = 0.d0 - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - integral += weight * mos_in_r_array_transp(ipoint,i) * mos_in_r_array_transp(ipoint,k) * x_W_ij_erf_rk(ipoint,mm,m,n) * x_W_ij_erf_rk(ipoint,mm,j,l) - integral += weight * mos_in_r_array_transp(ipoint,j) * mos_in_r_array_transp(ipoint,l) * x_W_ij_erf_rk(ipoint,mm,m,n) * x_W_ij_erf_rk(ipoint,mm,i,k) - integral += weight * mos_in_r_array_transp(ipoint,m) * mos_in_r_array_transp(ipoint,n) * x_W_ij_erf_rk(ipoint,mm,j,l) * x_W_ij_erf_rk(ipoint,mm,i,k) - enddo - enddo -end - diff --git a/src/three_body_ints/three_e_3_idx.irp.f b/src/three_body_ints/three_e_3_idx.irp.f deleted file mode 100644 index 13210f00..00000000 --- a/src/three_body_ints/three_e_3_idx.irp.f +++ /dev/null @@ -1,338 +0,0 @@ - -BEGIN_PROVIDER [ double precision, three_body_3_index, (mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 3 index matrix element of the -L three-body operator -! -! three_body_3_index(k,l,n) = < phi_k phi_l phi_n | phi_k phi_l phi_n > -! -! notice the -1 sign: in this way three_body_3_index can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,m - double precision :: integral, wall1, wall0 - character*(128) :: name_file - print*,'Providing the three_body_3_index ...' - name_file = 'three_body_3_index' - call wall_time(wall0) - if(read_three_body_ints)then - print*,'Reading three_body_ints from disk ...' - call read_array_3_index_tensor(mo_num,three_body_3_index,name_file) - else - provide x_W_ij_erf_rk - three_body_3_index = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,integral) & - !$OMP SHARED (mo_num,three_body_3_index) - !$OMP DO SCHEDULE (guided) COLLAPSE(3) - do m = 1, mo_num ! 3 - do j = 1, mo_num ! 2 - do i = 1, mo_num ! 1 - integral = 0.d0 - ! 1 2 3 1 2 3 - call give_integrals_3_body(i,j,m,i,j,m,integral) - - three_body_3_index(i,j,m) = -1.d0 * integral - - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_3_index',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_3_index on disk ...' - call write_array_3_index_tensor(mo_num,three_body_3_index,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_3_index_exch_12, (mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 3 index matrix EXCHANGE element of the -L three-body operator -! -! three_body_3_index_exch_12(k,l,n) = < phi_k phi_l phi_n | phi_l phi_k phi_n > -! -! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,m - double precision :: integral, wall1, wall0 - character*(128) :: name_file - name_file = 'three_body_3_index_exch_12' - print*,'Providing the three_body_3_index_exch_12 ...' - call wall_time(wall0) - if(read_three_body_ints)then - print*,'Reading three_body_ints from disk ...' - call read_array_3_index_tensor(mo_num,three_body_3_index_exch_12,name_file) - else - provide x_W_ij_erf_rk - three_body_3_index_exch_12 = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,integral) & - !$OMP SHARED (mo_num,three_body_3_index_exch_12) - !$OMP DO SCHEDULE (guided) COLLAPSE(3) - do m = 1, mo_num ! 3 - do j = 1, mo_num ! 2 - do i = 1, mo_num ! 1 - integral = 0.d0 - ! 1 2 3 1 2 3 - call give_integrals_3_body(i,j,m,j,i,m,integral) - - three_body_3_index_exch_12(i,j,m) = -1.d0 * integral - - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - endif - call wall_time(wall1) - print*,'wall time for three_body_3_index_exch_12',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_3_index_exch_12 on disk ...' - call write_array_3_index_tensor(mo_num,three_body_3_index_exch_12,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_3_index_exch_23, (mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 3 index matrix EXCHANGE element of the -L three-body operator -! -! three_body_3_index_exch_12(k,l,n) = < phi_k phi_l phi_n | phi_k phi_n phi_l > -! -! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,m - double precision :: integral, wall1, wall0 - character*(128) :: name_file - print*,'Providing the three_body_3_index_exch_23 ...' - call wall_time(wall0) - name_file = 'three_body_3_index_exch_23' - if(read_three_body_ints)then - print*,'Reading three_body_ints from disk ...' - call read_array_3_index_tensor(mo_num,three_body_3_index_exch_23,name_file) - else - provide x_W_ij_erf_rk - three_body_3_index_exch_23 = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,integral) & - !$OMP SHARED (mo_num,three_body_3_index_exch_23) - !$OMP DO SCHEDULE (guided) COLLAPSE(3) - do m = 1, mo_num ! 3 - do j = 1, mo_num ! 2 - do i = 1, mo_num ! 1 - integral = 0.d0 - ! 1 2 3 1 2 3 - call give_integrals_3_body(i,j,m,i,m,j,integral) - - three_body_3_index_exch_23(i,j,m) = -1.d0 * integral - - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - call wall_time(wall1) - endif - print*,'wall time for three_body_3_index_exch_23',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_3_index_exch_23 on disk ...' - call write_array_3_index_tensor(mo_num,three_body_3_index_exch_23,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_3_index_exch_13, (mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 3 index matrix EXCHANGE element of the -L three-body operator -! -! three_body_3_index_exch_12(k,l,n) = < phi_k phi_l phi_n | phi_k phi_n phi_l > -! -! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,m - double precision :: integral, wall1, wall0 - character*(128) :: name_file - print*,'Providing the three_body_3_index_exch_13 ...' - call wall_time(wall0) - name_file = 'three_body_3_index_exch_13' - if(read_three_body_ints)then - print*,'Reading three_body_ints from disk ...' - call read_array_3_index_tensor(mo_num,three_body_3_index_exch_13,name_file) - else - provide x_W_ij_erf_rk - three_body_3_index_exch_13 = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,integral) & - !$OMP SHARED (mo_num,three_body_3_index_exch_13) - !$OMP DO SCHEDULE (guided) - do m = 1, mo_num ! 3 - do j = 1, mo_num ! 2 - do i = 1, mo_num ! 1 - integral = 0.d0 - ! 1 2 3 1 2 3 - call give_integrals_3_body(i,j,m,m,j,i,integral) - - three_body_3_index_exch_13(i,j,m) = -1.d0 * integral - - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - - call wall_time(wall1) - print*,'wall time for three_body_3_index_exch_13',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_3_index_exch_13 on disk ...' - call write_array_3_index_tensor(mo_num,three_body_3_index_exch_13,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, three_body_3_index_exch_231, (mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 3 index matrix element of the -L three-body operator -! -! three_body_3_index_exch_231(k,l,n) = < phi_k phi_l phi_n | phi_l phi_n phi_k > -! -! notice the -1 sign: in this way three_body_3_index can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,m - double precision :: integral, wall1, wall0 - character*(128) :: name_file - print*,'Providing the three_body_3_index_231 ...' - call wall_time(wall0) - name_file = 'three_body_3_index_exch_231' - if(read_three_body_ints)then - print*,'Reading three_body_ints from disk ...' - call read_array_3_index_tensor(mo_num,three_body_3_index_exch_231,name_file) - else - provide x_W_ij_erf_rk - three_body_3_index_exch_231 = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,integral) & - !$OMP SHARED (mo_num,three_body_3_index_exch_231) - !$OMP DO SCHEDULE (guided) COLLAPSE(3) - do m = 1, mo_num ! 3 - do j = 1, mo_num ! 2 - do i = 1, mo_num ! 1 - integral = 0.d0 - ! 1 2 3 1 2 3 - call give_integrals_3_body(i,j,m,j,m,i,integral) - - three_body_3_index_exch_231(i,j,m) = -1.d0 * integral - - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_3_index_exch_231 ',wall1 - wall0 - - if(write_three_body_ints)then - print*,'Writing three_body_3_index_exch_231 on disk ...' - call write_array_3_index_tensor(mo_num,three_body_3_index_exch_231,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_3_index_exch_312, (mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 3 index matrix element of the -L three-body operator -! -! three_body_3_index(k,l,n) = < phi_k phi_l phi_n | phi_l phi_n phi_k > -! -! notice the -1 sign: in this way three_body_3_index can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,m - double precision :: integral, wall1, wall0 - character*(128) :: name_file - print*,'Providing the three_body_3_index_312 ...' - call wall_time(wall0) - name_file = 'three_body_3_index_exch_312' - if(read_three_body_ints)then - print*,'Reading three_body_ints from disk ...' - call read_array_3_index_tensor(mo_num,three_body_3_index_exch_312,name_file) - else - provide x_W_ij_erf_rk - three_body_3_index_exch_312 = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,integral) & - !$OMP SHARED (mo_num,three_body_3_index_exch_312) - !$OMP DO SCHEDULE (guided) COLLAPSE(3) - do m = 1, mo_num ! 3 - do j = 1, mo_num ! 2 - do i = 1, mo_num ! 1 - integral = 0.d0 - ! 1 2 3 1 2 3 - call give_integrals_3_body(i,j,m,m,i,j,integral) - - three_body_3_index_exch_312(i,j,m) = -1.d0 * integral - - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_3_index_312',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_3_index_exch_312 on disk ...' - call write_array_3_index_tensor(mo_num,three_body_3_index_exch_312,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -subroutine write_array_3_index_tensor(n_orb,array_tmp,name_file) - implicit none - integer, intent(in) :: n_orb - character*(128), intent(in) :: name_file - double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb) - - character*(128) :: output - integer :: i_unit_output,getUnitAndOpen - PROVIDE ezfio_filename - output=trim(ezfio_filename)//'/work/'//trim(name_file) - i_unit_output = getUnitAndOpen(output,'W') - write(i_unit_output)array_tmp - close(unit=i_unit_output) -end - -subroutine read_array_3_index_tensor(n_orb,array_tmp,name_file) - implicit none - character*(128) :: output - integer :: i_unit_output,getUnitAndOpen - integer, intent(in) :: n_orb - character*(128), intent(in) :: name_file - double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb) - PROVIDE ezfio_filename - output=trim(ezfio_filename)//'/work/'//trim(name_file) - i_unit_output = getUnitAndOpen(output,'R') - read(i_unit_output)array_tmp - close(unit=i_unit_output) -end diff --git a/src/three_body_ints/three_e_4_idx.irp.f b/src/three_body_ints/three_e_4_idx.irp.f deleted file mode 100644 index 0c6743f0..00000000 --- a/src/three_body_ints/three_e_4_idx.irp.f +++ /dev/null @@ -1,347 +0,0 @@ - -BEGIN_PROVIDER [ double precision, three_body_4_index, (mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 4 index matrix direct element of the -L three-body operator -! -! three_body_4_index(j,m,k,i) = < phi_j phi_m phi_k | phi_j phi_m phi_i > -! -! notice the -1 sign: in this way three_body_4_index can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_4_index = 0.d0 - print*,'Providing the three_body_4_index ...' - call wall_time(wall0) - - name_file = 'three_body_4_index' - if(read_three_body_ints)then - print*,'Reading three_body_4_index from disk ...' - call read_array_4_index_tensor(mo_num,three_body_4_index,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,k,integral) & - !$OMP SHARED (mo_num,three_body_4_index) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do i = 1, mo_num - do k = 1, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - call give_integrals_3_body(i,j,m,k,j,m,integral) - - three_body_4_index(j,m,k,i) = -1.d0 * integral - - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_4_index',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_4_index on disk ...' - call write_array_4_index_tensor(mo_num,three_body_4_index,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_4_index_exch_12, (mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 4 index matrix EXCHANGE element of the -L three-body operator -! -! three_body_4_index_exch_12(j,m,k,i) = < phi_m phi_j phi_i | phi_j phi_m phi_k > -! -! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_4_index_exch_12 = 0.d0 - print*,'Providing the three_body_4_index_exch_12 ...' - call wall_time(wall0) - - name_file = 'three_body_4_index_exch_12' - if(read_three_body_ints)then - print*,'Reading three_body_4_index_exch_12 from disk ...' - call read_array_4_index_tensor(mo_num,three_body_4_index_exch_12,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,k,integral) & - !$OMP SHARED (mo_num,three_body_4_index_exch_12) - !$OMP DO SCHEDULE (guided) COLLAPSE(4) - do i = 1, mo_num - do k = 1, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - call give_integrals_3_body(i,m,j,k,j,m,integral) - - three_body_4_index_exch_12(j,m,k,i) = -1.d0 * integral - - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_4_index_exch_12',wall1 - wall0 - - if(write_three_body_ints)then - print*,'Writing three_body_4_index_exch_12 on disk ...' - call write_array_4_index_tensor(mo_num,three_body_4_index_exch_12,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_4_index_exch_12_part, (mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 4 index matrix EXCHANGE element of the -L three-body operator -! -! three_body_4_index_exch_12_part(j,m,k,i) = < phi_m phi_j phi_i | phi_m phi_k phi_j > -! -! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_4_index_exch_12_part = 0.d0 - print*,'Providing the three_body_4_index_exch_12_part ...' - call wall_time(wall0) - - name_file = 'three_body_4_index_exch_12_part' - if(read_three_body_ints)then - print*,'Reading three_body_4_index_exch_12_part from disk ...' - call read_array_4_index_tensor(mo_num,three_body_4_index_exch_12_part,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,k,integral) & - !$OMP SHARED (mo_num,three_body_4_index_exch_12_part) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do i = 1, mo_num - do k = 1, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - ! - call give_integrals_3_body(i,j,m,j,k,m,integral) - three_body_4_index_exch_12_part(j,m,k,i) = -1.d0 * integral - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - call wall_time(wall1) - endif - print*,'wall time for three_body_4_index_exch_12_part',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_4_index_exch_12_part on disk ...' - call write_array_4_index_tensor(mo_num,three_body_4_index_exch_12_part,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_4_index_exch_12_part_bis, (mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 4 index matrix EXCHANGE element of the -L three-body operator -! -! three_body_4_index_exch_12_part_bis(j,m,k,i) = < phi_m phi_j phi_i | phi_m phi_k phi_j > -! -! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_4_index_exch_12_part_bis = 0.d0 - print*,'Providing the three_body_4_index_exch_12_part_bis ...' - call wall_time(wall0) - - name_file = 'three_body_4_index_exch_12_part_bis' - if(read_three_body_ints)then - print*,'Reading three_body_4_index_exch_12_part_bisfrom disk ...' - call read_array_4_index_tensor(mo_num,three_body_4_index_exch_12_part_bis,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,k,integral) & - !$OMP SHARED (mo_num,three_body_4_index_exch_12_part_bis) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do i = 1, mo_num - do k = 1, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - ! - call give_integrals_3_body(i,j,m,m,j,k,integral) - - three_body_4_index_exch_12_part_bis(j,m,k,i) = -1.d0 * integral - - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_4_index_exch_12_part_bis',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_4_index_exch_12_part_bis on disk ...' - call write_array_4_index_tensor(mo_num,three_body_4_index_exch_12_part_bis,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, three_body_4_index_exch_231, (mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 4 index matrix direct element of the -L three-body operator -! -! three_body_4_index_exch_231(j,m,k,i) = < phi_j phi_m phi_k | phi_j phi_m phi_i > -! -! notice the -1 sign: in this way three_body_4_index_exch_231 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_4_index_exch_231 = 0.d0 - print*,'Providing the three_body_4_index_exch_231 ...' - call wall_time(wall0) - name_file = 'three_body_4_index_exch_231' - if(read_three_body_ints)then - print*,'Reading three_body_4_index_exch_231 from disk ...' - call read_array_4_index_tensor(mo_num,three_body_4_index_exch_231,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,k,integral) & - !$OMP SHARED (mo_num,three_body_4_index_exch_231) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do i = 1, mo_num - do k = 1, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - call give_integrals_3_body(i,j,m,j,m,k,integral) - - three_body_4_index_exch_231(j,m,k,i) = -1.d0 * integral - - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_4_index_exch_231',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_4_index_exch_231 on disk ...' - call write_array_4_index_tensor(mo_num,three_body_4_index_exch_231,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_4_index_exch_312, (mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 4 index matrix direct element of the -L three-body operator -! -! three_body_4_index_exch_312(j,m,k,i) = < phi_j phi_m phi_k | phi_j phi_m phi_i > -! -! notice the -1 sign: in this way three_body_4_index_exch_312 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_4_index_exch_312 = 0.d0 - print*,'Providing the three_body_4_index_exch_312 ...' - call wall_time(wall0) - name_file = 'three_body_4_index_exch_312' - if(read_three_body_ints)then - print*,'Reading three_body_4_index_exch_312 from disk ...' - call read_array_4_index_tensor(mo_num,three_body_4_index_exch_312,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,k,integral) & - !$OMP SHARED (mo_num,three_body_4_index_exch_312) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do i = 1, mo_num - do k = 1, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - call give_integrals_3_body(i,j,m,m,k,j,integral) - - three_body_4_index_exch_312(j,m,k,i) = -1.d0 * integral - - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_4_index_exch_312',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_4_index_exch_312 on disk ...' - call write_array_4_index_tensor(mo_num,three_body_4_index_exch_312,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -subroutine write_array_4_index_tensor(n_orb,array_tmp,name_file) - implicit none - integer, intent(in) :: n_orb - character*(128), intent(in) :: name_file - double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb,n_orb) - - character*(128) :: output - integer :: i_unit_output,getUnitAndOpen - PROVIDE ezfio_filename - output=trim(ezfio_filename)//'/work/'//trim(name_file) - i_unit_output = getUnitAndOpen(output,'W') - write(i_unit_output)array_tmp - close(unit=i_unit_output) -end - -subroutine read_array_4_index_tensor(n_orb,array_tmp,name_file) - implicit none - character*(128) :: output - integer :: i_unit_output,getUnitAndOpen - integer, intent(in) :: n_orb - character*(128), intent(in) :: name_file - double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb,n_orb) - PROVIDE ezfio_filename - output=trim(ezfio_filename)//'/work/'//trim(name_file) - i_unit_output = getUnitAndOpen(output,'R') - read(i_unit_output)array_tmp - close(unit=i_unit_output) -end diff --git a/src/three_body_ints/three_e_5_idx.irp.f b/src/three_body_ints/three_e_5_idx.irp.f deleted file mode 100644 index 914601ff..00000000 --- a/src/three_body_ints/three_e_5_idx.irp.f +++ /dev/null @@ -1,453 +0,0 @@ - -BEGIN_PROVIDER [ double precision, three_body_5_index, (mo_num, mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 5 index matrix element of the -L three-body operator -! -! three_body_5_index(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > -! -! notice the -1 sign: in this way three_body_5_index can be directly used to compute Slater rules :) - END_DOC - integer :: j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_5_index(1:mo_num, 1:mo_num, 1:mo_num, 1:mo_num, 1:mo_num) = 0.d0 - print*,'Providing the three_body_5_index ...' - name_file = 'three_body_5_index' - call wall_time(wall0) - if(read_three_body_ints)then - print*,'Reading three_body_5_index from disk ...' - call read_array_5_index_tensor(mo_num,three_body_5_index,name_file) - else - provide x_W_ij_erf_rk - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (j,k,l,m,n,integral) & - !$OMP SHARED (mo_num,three_body_5_index) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do n = 1, mo_num - do l = 1, mo_num - do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - - call give_integrals_3_body(j,m,k,l,n,k,integral) - - three_body_5_index(k,j,m,l,n) = -1.d0 * integral - - enddo - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_5_index',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_5_index on disk ...' - call write_array_5_index_tensor(mo_num,three_body_5_index,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif -! do n = 1, mo_num -! do l = 1, mo_num -! do k = 1, mo_num -! do m = 1, n-1 -! do j = 1, l-1 -! three_body_5_index(k,j,m,l,n) = three_body_5_index(k,l,n,j,m) -! three_body_5_index(k,j,m,l,n) -! enddo -! enddo -! enddo -! enddo -! enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_5_index_exch_13, (mo_num, mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 5 index matrix element of the -L three-body operator -! -! three_body_5_index_exch_13(k,j,m,l,n) = < phi_j phi_m phi_k | phi_k phi_n phi_l > -! -! notice the -1 sign: in this way three_body_5_index_exch_13 can be directly used to compute Slater rules :) - END_DOC - integer :: j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - - three_body_5_index_exch_13 = 0.d0 - - name_file = 'three_body_5_index_exch_13' - print*,'Providing the three_body_5_index_exch_13 ...' - call wall_time(wall0) - if(read_three_body_ints)then - print*,'Reading three_body_5_index_exch_13 from disk ...' - call read_array_5_index_tensor(mo_num,three_body_5_index_exch_13,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (j,k,l,m,n,integral) & - !$OMP SHARED (mo_num,three_body_5_index_exch_13) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do n = 1, mo_num - do l = 1, mo_num - do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 -!! j,m,k,l,n,k : direct (case 2) - call give_integrals_3_body(j,m,k,k,n,l,integral) -!! j,m,k,k,n,l : exchange 1 3 - - three_body_5_index_exch_13(k,j,m,l,n) = -1.d0 * integral - enddo - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_5_index_exch_13',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_5_index_exch_13 on disk ...' - call write_array_5_index_tensor(mo_num,three_body_5_index_exch_13,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif -! do n = 1, mo_num -! do l = 1, mo_num -! do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num -! three_body_5_index_exch_13(k,l,n,j,m) = three_body_5_index_exch_13(k,j,m,l,n) -! enddo -! enddo -! enddo -! enddo -! enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_5_index_exch_32, (mo_num, mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 5 index matrix element of the -L three-body operator -! -! three_body_5_index_exch_32(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > -! -! notice the -1 sign: in this way three_body_5_index_exch_32 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(328) :: name_file - - three_body_5_index_exch_32 = 0.d0 - name_file = 'three_body_5_index_exch_32' - print*,'Providing the three_body_5_index_exch_32 ...' - call wall_time(wall0) - - if(read_three_body_ints)then - print*,'Reading three_body_5_index_exch_32 from disk ...' - call read_array_5_index_tensor(mo_num,three_body_5_index_exch_32,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (j,k,l,m,n,integral) & - !$OMP SHARED (mo_num,three_body_5_index_exch_32) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do n = 1, mo_num - do l = 1, mo_num - do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 -!! j,m,k,l,n,k : direct (case 3) - call give_integrals_3_body(j,m,k,l,k,n,integral) -!! j,m,k,l,k,n : exchange 2 3 - - three_body_5_index_exch_32(k,j,m,l,n) = -1.d0 * integral - - enddo - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_5_index_exch_32',wall1 - wall0 - if(write_three_body_ints)then - print*,'Writing three_body_5_index_exch_32 on disk ...' - call write_array_5_index_tensor(mo_num,three_body_5_index_exch_32,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif -! do n = 1, mo_num -! do l = 1, mo_num -! do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num -! three_body_5_index_exch_32(k,l,n,j,m) = three_body_5_index_exch_32(k,j,m,l,n) -! enddo -! enddo -! enddo -! enddo -! enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_5_index_exch_12, (mo_num, mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 5 index matrix element of the -L three-body operator -! -! three_body_5_index_exch_12(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > -! -! notice the -1 sign: in this way three_body_5_index_exch_12 can be directly used to compute Slater rules :) - END_DOC - integer :: i,j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(328) :: name_file - - three_body_5_index_exch_12 = 0.d0 - name_file = 'three_body_5_index_exch_12' - print*,'Providing the three_body_5_index_exch_12 ...' - call wall_time(wall0) - - if(read_three_body_ints)then - print*,'Reading three_body_5_index_exch_12 from disk ...' - call read_array_5_index_tensor(mo_num,three_body_5_index_exch_12,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (j,k,l,m,n,integral) & - !$OMP SHARED (mo_num,three_body_5_index_exch_12) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do n = 1, mo_num - do l = 1, mo_num - do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 -!! j,m,k,l,n,k : direct (case 1) - call give_integrals_3_body(j,m,k,n,l,k,integral) -!! j,m,k,l,k,n : exchange 2 3 - - three_body_5_index_exch_12(k,j,m,l,n) = -1.d0 * integral - - enddo - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_5_index_exch_12',wall1 - wall0 -! do n = 1, mo_num -! do l = 1, mo_num -! do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num -! three_body_5_index_exch_12(k,l,n,j,m) = three_body_5_index_exch_12(k,j,m,l,n) -! enddo -! enddo -! enddo -! enddo -! enddo - if(write_three_body_ints)then - print*,'Writing three_body_5_index_exch_12 on disk ...' - call write_array_5_index_tensor(mo_num,three_body_5_index_exch_12,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, three_body_5_index_312, (mo_num, mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 5 index matrix element of the -L three-body operator -! -! three_body_5_index_312(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > -! -! notice the -1 sign: in this way three_body_5_index_312 can be directly used to compute Slater rules :) - END_DOC - integer :: j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - - three_body_5_index_312 = 0.d0 - name_file = 'three_body_5_index_312' - print*,'Providing the three_body_5_index_312 ...' - call wall_time(wall0) - - if(read_three_body_ints)then - print*,'Reading three_body_5_index_312 from disk ...' - call read_array_5_index_tensor(mo_num,three_body_5_index_312,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (j,k,l,m,n,integral) & - !$OMP SHARED (mo_num,three_body_5_index_312) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do n = 1, mo_num - do l = 1, mo_num - do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - - ! - > - call give_integrals_3_body(j,m,k,n,k,l,integral) - - three_body_5_index_312(k,j,m,l,n) = -1.d0 * integral - - enddo - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_5_index_312',wall1 - wall0 -! do n = 1, mo_num -! do l = 1, mo_num -! do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num -! three_body_5_index_312(k,l,n,j,m) = three_body_5_index_312(k,j,m,l,n) -! enddo -! enddo -! enddo -! enddo -! enddo - if(write_three_body_ints)then - print*,'Writing three_body_5_index_312 on disk ...' - call write_array_5_index_tensor(mo_num,three_body_5_index_312,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_body_5_index_132, (mo_num, mo_num, mo_num, mo_num, mo_num)] - implicit none - BEGIN_DOC -! 5 index matrix element of the -L three-body operator -! -! three_body_5_index_132(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > -! -! notice the -1 sign: in this way three_body_5_index_132 can be directly used to compute Slater rules :) - END_DOC - integer :: j,k,l,m,n - double precision :: integral, wall1, wall0 - character*(128) :: name_file - three_body_5_index_132 = 0.d0 - name_file = 'three_body_5_index_132' - print*,'Providing the three_body_5_index_132 ...' - call wall_time(wall0) - - if(read_three_body_ints)then - print*,'Reading three_body_5_index_132 from disk ...' - call read_array_5_index_tensor(mo_num,three_body_5_index_132,name_file) - else - provide x_W_ij_erf_rk - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (j,k,l,m,n,integral) & - !$OMP SHARED (mo_num,three_body_5_index_132) - !$OMP DO SCHEDULE (guided) COLLAPSE(2) - do n = 1, mo_num - do l = 1, mo_num - do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num - do m = 1, mo_num - do j = 1, mo_num - integral = 0.d0 - - ! - > - call give_integrals_3_body(j,m,k,k,l,n,integral) - - three_body_5_index_132(k,j,m,l,n) = -1.d0 * integral - - enddo - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - call wall_time(wall1) - print*,'wall time for three_body_5_index_132',wall1 - wall0 -! do n = 1, mo_num -! do l = 1, mo_num -! do k = 1, mo_num -! do m = n, mo_num -! do j = l, mo_num -! three_body_5_index_132(k,l,n,j,m) = three_body_5_index_132(k,j,m,l,n) -! enddo -! enddo -! enddo -! enddo -! enddo - if(write_three_body_ints)then - print*,'Writing three_body_5_index_132 on disk ...' - call write_array_5_index_tensor(mo_num,three_body_5_index_132,name_file) - call ezfio_set_three_body_ints_io_three_body_ints("Read") - endif - -END_PROVIDER - -subroutine write_array_5_index_tensor(n_orb,array_tmp,name_file) - implicit none - integer, intent(in) :: n_orb - character*(128), intent(in) :: name_file - double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb,n_orb,n_orb) - - character*(128) :: output - integer :: i_unit_output,getUnitAndOpen - PROVIDE ezfio_filename - output=trim(ezfio_filename)//'/work/'//trim(name_file) - i_unit_output = getUnitAndOpen(output,'W') - write(i_unit_output)array_tmp - close(unit=i_unit_output) -end - -subroutine read_array_5_index_tensor(n_orb,array_tmp,name_file) - implicit none - character*(128) :: output - integer :: i_unit_output,getUnitAndOpen - integer, intent(in) :: n_orb - character*(128), intent(in) :: name_file - double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb,n_orb,n_orb) - PROVIDE ezfio_filename - output=trim(ezfio_filename)//'/work/'//trim(name_file) - i_unit_output = getUnitAndOpen(output,'R') - read(i_unit_output)array_tmp - close(unit=i_unit_output) -end diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f index 405d2d20..51df33c5 100644 --- a/src/utils/linear_algebra.irp.f +++ b/src/utils/linear_algebra.irp.f @@ -1649,3 +1649,185 @@ subroutine restore_symmetry(m,n,A,LDA,thresh) enddo end + +subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim) + + implicit none + + integer, intent(in) :: n, A_ldim, V_ldim, E_ldim + double precision, intent(in) :: A(A_ldim,n) + double precision, intent(out) :: energy(E_ldim), V(V_ldim,n) + + character*1 :: JOBVL, JOBVR, BALANC, SENSE + integer :: i, j + integer :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO + double precision :: ABNRM + integer, allocatable :: iorder(:), IWORK(:) + double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:) + double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:) + double precision, allocatable :: energy_loc(:), V_loc(:,:) + + allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) ) + do i = 1, n + do j = 1, n + Atmp(j,i) = A(j,i) + enddo + enddo + + JOBVL = "N" ! computes the left eigenvectors + JOBVR = "V" ! computes the right eigenvectors + BALANC = "B" ! Diagonal scaling and Permutation for optimization + SENSE = "V" ! Determines which reciprocal condition numbers are computed + lda = n + ldvr = n + ldvl = 1 + + allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) ) + + LWORK = -1 ! to ask for the optimal size of WORK + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & ! CHARACTERS + , n, Atmp, lda & ! MATRIX TO DIAGONALIZE + , WR, WI & ! REAL AND IMAGINARY PART OF EIGENVALUES + , VL, ldvl, VR, ldvr & ! LEFT AND RIGHT EIGENVECTORS + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION + , WORK, LWORK, IWORK, INFO ) + + if(INFO .ne. 0) then + print*, 'dgeevx failed !!', INFO + stop + endif + + LWORK = max(int(work(1)), 1) ! this is the optimal size of WORK + deallocate(WORK) + allocate(WORK(LWORK)) + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & + , n, Atmp, lda & + , WR, WI & + , VL, ldvl, VR, ldvr & + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & + , WORK, LWORK, IWORK, INFO ) + if(INFO .ne. 0) then + print*, 'dgeevx failed !!', INFO + stop + endif + + deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK ) + deallocate( VL, Atmp ) + + + allocate( energy_loc(n), V_loc(n,n) ) + energy_loc = 0.d0 + V_loc = 0.d0 + + i = 1 + do while(i .le. n) + +! print*, i, WR(i), WI(i) + + if( dabs(WI(i)) .gt. 1e-7 ) then + + print*, ' Found an imaginary component to eigenvalue' + print*, ' Re(i) + Im(i)', i, WR(i), WI(i) + + energy_loc(i) = WR(i) + do j = 1, n + V_loc(j,i) = WR(i) * VR(j,i) - WI(i) * VR(j,i+1) + enddo + energy_loc(i+1) = WI(i) + do j = 1, n + V_loc(j,i+1) = WR(i) * VR(j,i+1) + WI(i) * VR(j,i) + enddo + i = i + 2 + + else + + energy_loc(i) = WR(i) + do j = 1, n + V_loc(j,i) = VR(j,i) + enddo + i = i + 1 + + endif + + enddo + + deallocate(WR, WI, VR) + + + ! ordering +! do j = 1, n +! write(444, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) +! enddo + allocate( iorder(n) ) + do i = 1, n + iorder(i) = i + enddo + call dsort(energy_loc, iorder, n) + do i = 1, n + energy(i) = energy_loc(i) + do j = 1, n + V(j,i) = V_loc(j,iorder(i)) + enddo + enddo + deallocate(iorder) +! do j = 1, n +! write(445, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) +! enddo + deallocate(V_loc, energy_loc) + +end subroutine diag_nonsym_right + +! --- + +! Taken from GammCor thanks to Michal Hapka :-) + + +subroutine pivoted_cholesky( A, rank, tol, ndim, U) +! +! A = U**T * U +! +! matrix A is destroyed inside this subroutine +! Cholesky vectors are stored in U +! dimension of U: U(1:rank, 1:n) +! U is allocated inside this subroutine +! rank is the number of Cholesky vectors depending on tol +! +integer :: ndim +integer, intent(inout) :: rank +double precision, dimension(ndim, ndim), intent(inout) :: A +double precision, dimension(ndim, rank), intent(out) :: U +double precision, intent(in) :: tol + +integer, dimension(:), allocatable :: piv +double precision, dimension(:), allocatable :: work +character, parameter :: uplo = "U" +integer :: N, LDA +integer :: info +integer :: k, l, rank0 +external :: dpstrf + +rank0 = rank +N = size(A, dim=1) +LDA = N +allocate(piv(N)) +allocate(work(2*N)) +call dpstrf(uplo, N, A, LDA, piv, rank, tol, work, info) + +if (rank > rank0) then + print *, 'Bug: rank > rank0 in pivoted cholesky. Increase rank before calling' + stop +end if + +do k = 1, N + A(k+1:, k) = 0.00D+0 +end do +! TODO: It should be possible to use only one vector of size (1:rank) as a buffer +! to do the swapping in-place +U = 0.00D+0 +do k = 1, N + l = piv(k) + U(l, :) = A(1:rank, k) +end do + +end subroutine pivoted_cholesky + diff --git a/tests/input/ch2.xyz b/tests/input/ch2.xyz new file mode 100644 index 00000000..f008490c --- /dev/null +++ b/tests/input/ch2.xyz @@ -0,0 +1,5 @@ +3 + +C 6.000000 0.000000 0.000000 0.173480 +H 1.000000 0.000000 -0.861500 -0.520430 +H 1.000000 0.000000 0.861500 -0.520430