From e8e35c82155a29e33caaa4bb47c626b82161a76e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 18:03:32 +0100 Subject: [PATCH 01/76] Corrected S2 bug in Davidson of MRCC --- plugins/MRCC_Utils/davidson.irp.f | 25 ++++++------------------ plugins/MRPT_Utils/psi_active_prov.irp.f | 2 +- src/Davidson/diagonalization_hs2.irp.f | 8 ++++---- 3 files changed, 11 insertions(+), 24 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 7033ea61..5783c5d9 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -207,19 +207,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s ! ------------------------------------------- -! do l=1,N_st_diag -! do k=1,N_st_diag -! do iter2=1,iter-1 -! h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) -! h(k,iter,l,iter2) = h(k,iter2,l,iter) -! enddo -! enddo -! do k=1,l -! h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) -! h(l,iter,k,iter) = h(k,iter,l,iter) -! enddo -! enddo - call dgemm('T','N', N_st_diag*iter, N_st_diag, sze, & 1.d0, U, size(U,1), W(1,1,iter), size(W,1), & 0.d0, h(1,1,1,iter), size(h,1)*size(h,2)) @@ -788,13 +775,13 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ------------------------------------------- - call dgemm('T','N', shift2, N_st_diag, sze, & - 1.d0, U, size(U,1), W(1,shift+1), size(W,1), & - 0.d0, h(1,shift+1), size(h,1)) + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U, size(U,1), W, size(W,1), & + 0.d0, h, size(h,1)) - call dgemm('T','N', shift2, N_st_diag, sze, & - 1.d0, U, size(U,1), S(1,shift+1), size(S,1), & - 0.d0, s_(1,shift+1), size(s_,1)) + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U, size(U,1), S, size(S,1), & + 0.d0, s_, size(s_,1)) ! Diagonalize h ! ------------- diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 67501727..794742b4 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -415,7 +415,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) i_hole = list_inact_reverse(h1) i_part = list_virt_reverse(p1) do i_state = 1, N_states -! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) + delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) enddo endif else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 12265810..d82d9f84 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -230,12 +230,12 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ------------------------------------------- call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U(1,1), size(U,1), W(1,1), size(W,1), & - 0.d0, h(1,1), size(h,1)) + 1.d0, U, size(U,1), W, size(W,1), & + 0.d0, h, size(h,1)) call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U(1,1), size(U,1), S(1,1), size(S,1), & - 0.d0, s_(1,1), size(s_,1)) + 1.d0, U, size(U,1), S, size(S,1), & + 0.d0, s_, size(s_,1)) ! Diagonalize h From 6f075d8c37f6ee5851b4329cf15736cde945393e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 18:08:20 +0100 Subject: [PATCH 02/76] Repaired map_integrals --- src/Integrals_Bielec/map_integrals.irp.f | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 5f6df0bd..1f2a7a1b 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -677,7 +677,6 @@ integer function load_$ao_integrals(filename) real(integral_kind), pointer :: val(:) integer :: iknd, kknd integer*8 :: n, j - double precision :: get_$ao_bielec_integral load_$ao_integrals = 1 open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') read(66,err=98,end=98) iknd, kknd @@ -712,7 +711,7 @@ integer function load_$ao_integrals(filename) end -SUBST [ ao_integrals_map, ao_integrals, ao_num , get_ao_bielec_integral ] -ao_integrals_map ; ao_integrals ; ao_num ; get_ao_bielec_integral ;; -mo_integrals_map ; mo_integrals ; mo_tot_num ; get_mo_bielec_integral ;; +SUBST [ ao_integrals_map, ao_integrals, ao_num ] +ao_integrals_map ; ao_integrals ; ao_num ;; +mo_integrals_map ; mo_integrals ; mo_tot_num ;; END_TEMPLATE From 4aec6f2f008a5ff03639b832435aaa27017d3135 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 18:39:36 +0100 Subject: [PATCH 03/76] Gained 10% by merging selection files --- plugins/Full_CI_ZMQ/selection.irp.f | 1084 ++++++++++++++++++++ plugins/Full_CI_ZMQ/selection_double.irp.f | 726 ------------- plugins/Full_CI_ZMQ/selection_single.irp.f | 354 ------- 3 files changed, 1084 insertions(+), 1080 deletions(-) delete mode 100644 plugins/Full_CI_ZMQ/selection_double.irp.f delete mode 100644 plugins/Full_CI_ZMQ/selection_single.irp.f diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index a0209cc5..b2fda694 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -104,3 +104,1087 @@ end subroutine +! Selection single +! ---------------- + +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_gen + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, j, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + bannedOrb = .true. + do j=1,N_particles(sp) + bannedOrb(particle_list(j, sp)) = .false. + end do + call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) + if(fullMatch) cycle + vect = 0d0 + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision, external :: diag_H_mat_elem_fock + + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, sp, p1, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + val = vect(istate, p1) + delta_E = E0(istate) - Hii + if (delta_E < 0.d0) then + e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + else + e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + endif + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) + end do +end subroutine + + +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do genl +end subroutine + + + + +! Selection double +! ---------------- + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + preinteresting(0) = 0 + prefullinteresting(0) = 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)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + 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) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + if (delta_E < 0.d0) then + e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + else + e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + endif + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_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) +! logical :: bandon +! +! bandon = .false. + mat = 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 ! interesting(0) + !i = interesting(ii) + + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + 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 = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + 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 = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + 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 = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + 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 = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_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 + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, 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 = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f deleted file mode 100644 index 977622fd..00000000 --- a/plugins/Full_CI_ZMQ/selection_double.irp.f +++ /dev/null @@ -1,726 +0,0 @@ - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - - preinteresting(0) = 0 - prefullinteresting(0) = 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)) - end do - - do i=1,N_det - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - do i=1,N_int - negMask(i,1) = not(pmask(i,1)) - negMask(i,2) = not(pmask(i,2)) - end do - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end do - - do s2=s1,2 - sp = s1 - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - 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) - - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - banned = .false. - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - - if(fullMatch) cycle - - bannedOrb(1:mo_tot_num, 1:2) = .true. - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - enddo - enddo - enddo - enddo -end subroutine - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, j, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert - double precision, external :: diag_H_mat_elem_fock - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) - if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - endif - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end subroutine - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_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) -! logical :: bandon -! -! bandon = .false. - mat = 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 ! interesting(0) - !i = interesting(ii) - - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 4) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(interesting(i) < i_gen) then - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - else - if(interesting(i) == i_gen) then -! bandon = .true. - if(sp == 3) then - banned(:,:,2) = transpose(banned(:,:,1)) - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - end if - end do -end subroutine - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - 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 = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - do i = 1,2 - do j = 1,2 - puti = p(i, 1) - putj = p(j, 2) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - p2 = p(turn2(j), 2) - h1 = h(1,1) - h2 = h(1,2) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - 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 = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - 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 = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end subroutine - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - 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 = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end subroutine - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_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 - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, 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 = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end subroutine - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end subroutine - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end subroutine - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - end do - - call bitstring_to_list(myMask(1,1), list(1), na, N_int) - call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end subroutine - diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f deleted file mode 100644 index f107db11..00000000 --- a/plugins/Full_CI_ZMQ/selection_single.irp.f +++ /dev/null @@ -1,354 +0,0 @@ - - -subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_gen - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: vect(N_states, mo_tot_num) - logical :: bannedOrb(mo_tot_num) - integer :: i, j, k - integer :: h1,h2,s1,s2,i1,i2,ib,sp - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) - logical :: fullMatch, ok - - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - do sp=1,2 - do i=1, N_holes(sp) - h1 = hole_list(i,sp) - call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) - bannedOrb = .true. - do j=1,N_particles(sp) - bannedOrb(particle_list(j, sp)) = .false. - end do - call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) - if(fullMatch) cycle - vect = 0d0 - call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) - call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - end do - enddo -end subroutine - - -subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1 - double precision, intent(in) :: vect(N_states, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert - double precision, external :: diag_H_mat_elem_fock - - - call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1)) cycle - if(vect(1, p1) == 0d0) cycle - call apply_particle(mask, sp, p1, det, ok, N_int) - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - val = vect(istate, p1) - delta_E = E0(istate) - Hii - if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - endif - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) - end do -end subroutine - - -subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) - double precision, intent(in) :: coefs(N_states, N_sel) - integer, intent(in) :: sp, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - - integer :: i, j, h(0:2,2), p(0:3,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 3) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(nt == 3) then - call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else if(nt == 2) then - call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else - call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - end if - end do -end subroutine - - -subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, parameter :: turn2(2) = (/2,1/) - - if(h(0,sp) == 2) then - h1 = h(1, sp) - h2 = h(2, sp) - do i=1,3 - puti = p(i, sp) - if(bannedOrb(puti)) cycle - p1 = p(turn3_2(1,i), sp) - p2 = p(turn3_2(2,i), sp) - hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) - hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end do - else if(h(0,sp) == 1) then - sfix = turn2(sp) - hfix = h(1,sfix) - pfix = p(1,sfix) - hmob = h(1,sp) - do j=1,2 - puti = p(j, sp) - if(bannedOrb(puti)) cycle - pmob = p(turn2(j), sp) - hij = integral8(pfix, pmob, hfix, hmob) - hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - vect(:, puti) += hij * coefs - end do - else - puti = p(1,sp) - if(.not. bannedOrb(puti)) then - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end if - end if -end subroutine - - - -subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, hole, p1, p2, sh - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - lbanned = bannedOrb - sh = 1 - if(h(0,2) == 1) sh = 2 - hole = h(1, sh) - lbanned(p(1,sp)) = .true. - if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. - !print *, "SPm1", sp, sh - - p1 = p(1, sp) - - if(sp == sh) then - p2 = p(2, sp) - lbanned(p2) = .true. - - do i=1,hole-1 - if(lbanned(i)) cycle - hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) - hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - do i=hole+1,mo_tot_num - if(lbanned(i)) cycle - hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) - hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs - end do - - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - else - p2 = p(1, sh) - do i=1,mo_tot_num - if(lbanned(i)) cycle - hij = integral8(p1, p2, i, hole) - hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - end if - - call apply_particle(mask, sp, p1, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs -end subroutine - - -subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - - lbanned = bannedOrb - lbanned(p(1,sp)) = .true. - do i=1,mo_tot_num - if(lbanned(i)) cycle - call apply_particle(mask, sp, i, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs - end do -end subroutine - - -subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N, sp - logical, intent(inout) :: banned(mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3), nt - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - nt = 0 - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) - end do - - if(nt > 3) cycle - - if(nt <= 2 .and. i < i_gen) then - fullMatch = .true. - return - end if - - call bitstring_to_list(myMask(1,sp), list(1), na, N_int) - - if(nt == 3 .and. i < i_gen) then - do j=1,na - banned(list(j)) = .true. - end do - else if(nt == 1 .and. na == 1) then - banned(list(1)) = .true. - end if - end do genl -end subroutine - - - From ab7735e3f362a8f7430484c96dae716dc116c1ee Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 19:15:45 +0100 Subject: [PATCH 04/76] Accelerated (7%) access to integrals in PT2 --- plugins/Full_CI_ZMQ/selection.irp.f | 40 +++++++++++++++++++---------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index b2fda694..3f351004 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -6,8 +6,20 @@ double precision function integral8(i,j,k,l) integer, intent(in) :: i,j,k,l double precision, external :: get_mo_bielec_integral - - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif end function @@ -179,7 +191,7 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, logical :: ok integer :: s1, s2, p1, p2, ib, istate integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp double precision, external :: diag_H_mat_elem_fock @@ -195,13 +207,13 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, max_e_pert = 0d0 do istate=1,N_states - val = vect(istate, p1) + val = vect(istate, p1) + vect(istate, p1) delta_E = E0(istate) - Hii + tmp = dsqrt(delta_E * delta_E + val * val) if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + tmp = -tmp endif + e_pert = 0.5d0 * ( tmp - delta_E) pt2(istate) += e_pert if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert end do @@ -632,7 +644,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d logical :: ok integer :: s1, s2, p1, p2, ib, j, istate integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp double precision, external :: diag_H_mat_elem_fock logical, external :: detEq @@ -664,14 +676,14 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d do istate=1,N_states delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + tmp = -tmp endif - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) end do if(dabs(max_e_pert) > buf%mini) then From ea36e3aa284b4bf69d360f443abf1ea3446810eb Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 22:31:55 +0100 Subject: [PATCH 05/76] Cleaned MRPT --- .../MRPT_Utils.main.irp.f | 0 plugins/MRPT/NEEDED_CHILDREN_MODULES | 1 + plugins/MRPT/README.rst | 14 +++++++ plugins/MRPT/mrpt.irp.f | 38 +++++++++++++++++++ plugins/{MRPT_Utils => MRPT}/print_1h2p.irp.f | 0 plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES | 2 +- 6 files changed, 54 insertions(+), 1 deletion(-) rename plugins/{MRPT_Utils => MRPT}/MRPT_Utils.main.irp.f (100%) create mode 100644 plugins/MRPT/NEEDED_CHILDREN_MODULES create mode 100644 plugins/MRPT/README.rst create mode 100644 plugins/MRPT/mrpt.irp.f rename plugins/{MRPT_Utils => MRPT}/print_1h2p.irp.f (100%) diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f similarity index 100% rename from plugins/MRPT_Utils/MRPT_Utils.main.irp.f rename to plugins/MRPT/MRPT_Utils.main.irp.f diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..7340c609 --- /dev/null +++ b/plugins/MRPT/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MRPT_Utils Selectors_full Generators_full diff --git a/plugins/MRPT/README.rst b/plugins/MRPT/README.rst new file mode 100644 index 00000000..a9a0860c --- /dev/null +++ b/plugins/MRPT/README.rst @@ -0,0 +1,14 @@ +==== +MRPT +==== + +Executables for Multi-reference perturbation. + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/MRPT/mrpt.irp.f b/plugins/MRPT/mrpt.irp.f new file mode 100644 index 00000000..8c8d746d --- /dev/null +++ b/plugins/MRPT/mrpt.irp.f @@ -0,0 +1,38 @@ +program MRPT + implicit none + BEGIN_DOC +! TODO + END_DOC + print *, ' _/ ' + print *, ' -:\_?, _Jm####La ' + print *, 'J"(:" > _]#AZ#Z#UUZ##, ' + print *, '_,::./ %(|i%12XmX1*1XL _?, ' + print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( ' + print *, ' .:< ]J=mQD?WXn|,)nr" ' + print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" ' + print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 ' + print *, ' "23Z#1S2oo2XXSnnnoSo2>v" ' + print *, ' miX#L -~`""!!1}oSoe|i7 ' + print *, ' 4cn#m, v221=|v[ ' + print *, ' ]hI3Zma,;..__wXSe=+vo ' + print *, ' ]Zov*XSUXXZXZXSe||vo2 ' + print *, ' ]Z#>=|< ' + print *, ' -ziiiii||||||+||==+> ' + print *, ' -%|+++||=|=+|=|==/ ' + print *, ' -a>====+|====-:- ' + print *, ' "~,- -- /- ' + print *, ' -. )> ' + print *, ' .~ +- ' + print *, ' . .... : . ' + print *, ' -------~ ' + print *, '' +end diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/print_1h2p.irp.f rename to plugins/MRPT/print_1h2p.irp.f diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES index a613d5f2..34de8ddb 100644 --- a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Selectors_full Generators_full Davidson +Determinants Davidson From 4cd2976678d673a8cd7d12e2a6ebd9295d194aeb Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 23:17:38 +0100 Subject: [PATCH 06/76] Fixed bug in occ_pattern --- src/Davidson/diagonalization_hs2.irp.f | 6 +----- src/Determinants/occ_pattern.irp.f | 2 +- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index d82d9f84..8a4cb2d2 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -320,10 +320,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo - if (.not.converged) then - iter = itermax-1 - endif - ! Re-contract to u_in ! ----------- @@ -331,7 +327,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s energies(k) = lambda(k) enddo - call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & + 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)) enddo diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 6abdf13e..3f6a2c87 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -186,7 +186,7 @@ end endif enddo j+=1 - if (j>N_det) then + if (j>=N_det) then exit endif enddo From af2780860e563ed3d128201150b0d82cbcce97f0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 23:44:14 +0100 Subject: [PATCH 07/76] Removed s2_eig -> Bug --- scripts/generate_h_apply.py | 2 +- src/Determinants/H_apply.irp.f | 4 ++-- src/Determinants/occ_pattern.irp.f | 11 +++++++---- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index cfb1d6bf..c7714e8a 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -422,7 +422,7 @@ class H_apply(object): if (s2_eig) then call make_s2_eigenfunction endif -! SOFT_TOUCH psi_det psi_coef N_det + SOFT_TOUCH psi_det psi_coef N_det selection_criterion_min = min(selection_criterion_min, maxval(select_max))*0.1d0 selection_criterion = selection_criterion_min call write_double(output_determinants,selection_criterion,'Selection criterion') diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 20eb3e83..887b8938 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -248,7 +248,6 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) enddo if (found_duplicates) then - call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') k=0 do i=1,N_det if (.not.duplicate(i)) then @@ -258,7 +257,8 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) endif enddo N_det = k - TOUCH N_det psi_det psi_coef + call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') + SOFT_TOUCH N_det psi_det psi_coef endif deallocate (duplicate,bit_tmp) end diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 3f6a2c87..42032937 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -213,10 +213,13 @@ subroutine make_s2_eigenfunction integer :: i,j,k integer :: smax, s integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new, iproc + integer :: N_det_new integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction + return + stop 'make_s2_eigenfunction has a bug. It should not be used!!!' + allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) smax = 1 N_det_new = 0 @@ -248,13 +251,13 @@ subroutine make_s2_eigenfunction if (N_det_new > 0) then call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) ! call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0) - call copy_H_apply_buffer_to_wf - SOFT_TOUCH N_det psi_coef psi_det endif deallocate(d,det_buffer) - call write_int(output_determinants,N_det_new, 'Added determinants for S^2') + call copy_H_apply_buffer_to_wf + SOFT_TOUCH N_det psi_coef psi_det + print *, 'Added determinants for S^2' end From 7ac373c1b3e814945048a064965de4c71408c8f3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 10:24:36 +0100 Subject: [PATCH 08/76] Fixed make_s2_eigenfunction --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 17 ++++++----- src/Determinants/H_apply.irp.f | 1 + src/Determinants/occ_pattern.irp.f | 49 ++++++++++++++++++++---------- 3 files changed, 44 insertions(+), 23 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 964edf62..45f3362e 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -122,13 +122,15 @@ subroutine ZMQ_selection(N_in, pt2) double precision, intent(out) :: pt2(N_states) - N = max(N_in,1) - provide nproc - provide ci_electronic_energy - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) + if (.True.) then + N = max(N_in,1) + provide nproc + provide ci_electronic_energy + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy)) + call zmq_set_running(zmq_to_qp_run_socket) + call create_selection_buffer(N, N*2, b) + endif integer :: i_generator, i_generator_start, i_generator_max, step ! step = int(max(1.,10*elec_num/mo_tot_num) @@ -154,6 +156,7 @@ subroutine ZMQ_selection(N_in, pt2) if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() + call make_s2_eigenfunction endif end subroutine diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 887b8938..c8f32c3a 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -259,6 +259,7 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) N_det = k call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') SOFT_TOUCH N_det psi_det psi_coef + stop 'duplicates in psi_det' endif deallocate (duplicate,bit_tmp) end diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 42032937..df7a5f00 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -35,7 +35,8 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) bmax += popcnt( o(k,1) ) amax -= popcnt( o(k,2) ) enddo - sze = 2*int( min(binom_func(bmax, amax), 1.d8) ) + sze = int( min(binom_func(bmax, amax), 1.d8) ) + sze = sze*sze end @@ -123,8 +124,8 @@ end implicit none BEGIN_DOC ! array of the occ_pattern present in the wf - ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation - ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupations + ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupations END_DOC integer :: i,j,k @@ -144,7 +145,7 @@ end logical,allocatable :: duplicate(:) - allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) ) + allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,N_det) ) do i=1,N_det iorder(i) = i @@ -161,18 +162,16 @@ end duplicate(i) = .False. enddo - i=1 - integer (bit_kind) :: occ_pattern_tmp - do i=1,N_det - duplicate(i) = .False. - enddo - + ! Find duplicates do i=1,N_det-1 if (duplicate(i)) then cycle endif j = i+1 do while (bit_tmp(j)==bit_tmp(i)) + if (j>N_det) then + exit + endif if (duplicate(j)) then j+=1 cycle @@ -186,12 +185,10 @@ end endif enddo j+=1 - if (j>=N_det) then - exit - endif enddo enddo + ! Copy filtered result N_occ_pattern=0 do i=1,N_det if (duplicate(i)) then @@ -204,6 +201,28 @@ end enddo enddo +!- Check +! do i=1,N_occ_pattern +! do j=i+1,N_occ_pattern +! duplicate(1) = .True. +! do k=1,N_int +! if (psi_occ_pattern(k,1,i) /= psi_occ_pattern(k,1,j)) then +! duplicate(1) = .False. +! exit +! endif +! if (psi_occ_pattern(k,2,i) /= psi_occ_pattern(k,2,j)) then +! duplicate(1) = .False. +! exit +! endif +! enddo +! if (duplicate(1)) then +! call debug_det(psi_occ_pattern(1,1,i),N_int) +! call debug_det(psi_occ_pattern(1,1,j),N_int) +! stop 'DUPLICATE' +! endif +! enddo +! enddo +!- deallocate(iorder,duplicate,bit_tmp,tmp_array) END_PROVIDER @@ -217,9 +236,6 @@ subroutine make_s2_eigenfunction integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction - return - stop 'make_s2_eigenfunction has a bug. It should not be used!!!' - allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) smax = 1 N_det_new = 0 @@ -258,6 +274,7 @@ subroutine make_s2_eigenfunction call copy_H_apply_buffer_to_wf SOFT_TOUCH N_det psi_coef psi_det print *, 'Added determinants for S^2' +! call remove_duplicates_in_psi_det end From 86494251887721ca7f9d3fa376727f96fbabeae3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 12:05:07 +0100 Subject: [PATCH 09/76] Fixed make_s2_eigenfunction --- config/gfortran_debug.cfg | 2 +- src/Determinants/occ_pattern.irp.f | 38 ++++++++++++++++++++++++++---- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 03663eea..4b06c5e9 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -13,7 +13,7 @@ FC : gfortran -g -ffree-line-length-none -I . -static-libgcc LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 -IRPF90_FLAGS : --ninja --assert --align=32 +IRPF90_FLAGS : --ninja --align=32 # Global options ################ diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index df7a5f00..6ee54677 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -69,13 +69,24 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) sze = nd + integer :: ne(2), l + l=0 do i=1,nd + ne(1) = 0 + ne(2) = 0 + l=l+1 ! Doubly occupied orbitals do k=1,Nint - d(k,1,i) = ior(d(k,1,i),o(k,2)) - d(k,2,i) = ior(d(k,2,i),o(k,2)) + d(k,1,l) = ior(d(k,1,i),o(k,2)) + d(k,2,l) = ior(d(k,2,i),o(k,2)) + ne(1) += popcnt(d(k,1,l)) + ne(2) += popcnt(d(k,2,l)) enddo + if ( (ne(1) /= elec_alpha_num).or.(ne(2) /= elec_beta_num) ) then + l = l-1 + endif enddo + sze = l end @@ -169,11 +180,11 @@ end endif j = i+1 do while (bit_tmp(j)==bit_tmp(i)) - if (j>N_det) then - exit - endif if (duplicate(j)) then j+=1 + if (j>N_det) then + exit + endif cycle endif duplicate(j) = .True. @@ -185,6 +196,9 @@ end endif enddo j+=1 + if (j>N_det) then + exit + endif enddo enddo @@ -256,6 +270,20 @@ subroutine make_s2_eigenfunction det_buffer(k,1,N_det_new) = d(k,1,j) det_buffer(k,2,N_det_new) = d(k,2,j) enddo +! integer :: ne(2) +! ne(:) = 0 +! do k=1,N_int +! ne(1) += popcnt(d(k,1,j)) +! ne(2) += popcnt(d(k,2,j)) +! enddo +! if (ne(1) /= elec_alpha_num) then +! call debug_det(d(1,1,j),N_int) +! stop "ALPHA" +! endif +! if (ne(2) /= elec_beta_num) then +! call debug_det(d(1,1,j),N_int) +! stop "BETA" +! endif if (N_det_new == bufsze) then call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) N_det_new = 0 From ee4e3eaa8ebacbca972a7a680676febb2139e0f7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 12:05:07 +0100 Subject: [PATCH 10/76] Fixed make_s2_eigenfunction --- config/gfortran_debug.cfg | 2 +- src/Determinants/H_apply.irp.f | 6 +++- src/Determinants/occ_pattern.irp.f | 45 ++++++++++++++++++++++++------ 3 files changed, 43 insertions(+), 10 deletions(-) diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 03663eea..4b06c5e9 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -13,7 +13,7 @@ FC : gfortran -g -ffree-line-length-none -I . -static-libgcc LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 -IRPF90_FLAGS : --ninja --assert --align=32 +IRPF90_FLAGS : --ninja --align=32 # Global options ################ diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index c8f32c3a..88affa21 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -222,7 +222,11 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) do while (bit_tmp(j)==bit_tmp(i)) if (duplicate(j)) then j += 1 - cycle + if (j > N_det) then + exit + else + cycle + endif endif duplicate(j) = .True. do k=1,N_int diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index df7a5f00..42bca8eb 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -52,8 +52,8 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) integer(bit_kind),intent(out) :: d(Nint,2,sze) integer :: i, k, nt, na, nd, amax - integer :: list_todo(n_alpha) - integer :: list_a(n_alpha) + integer :: list_todo(2*n_alpha) + integer :: list_a(2*n_alpha) amax = n_alpha do k=1,Nint @@ -69,13 +69,24 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) sze = nd + integer :: ne(2), l + l=0 do i=1,nd + ne(1) = 0 + ne(2) = 0 + l=l+1 ! Doubly occupied orbitals do k=1,Nint - d(k,1,i) = ior(d(k,1,i),o(k,2)) - d(k,2,i) = ior(d(k,2,i),o(k,2)) + d(k,1,l) = ior(d(k,1,i),o(k,2)) + d(k,2,l) = ior(d(k,2,i),o(k,2)) + ne(1) += popcnt(d(k,1,l)) + ne(2) += popcnt(d(k,2,l)) enddo + if ( (ne(1) /= elec_alpha_num).or.(ne(2) /= elec_beta_num) ) then + l = l-1 + endif enddo + sze = l end @@ -169,11 +180,11 @@ end endif j = i+1 do while (bit_tmp(j)==bit_tmp(i)) - if (j>N_det) then - exit - endif if (duplicate(j)) then j+=1 + if (j>N_det) then + exit + endif cycle endif duplicate(j) = .True. @@ -185,6 +196,9 @@ end endif enddo j+=1 + if (j>N_det) then + exit + endif enddo enddo @@ -256,6 +270,20 @@ subroutine make_s2_eigenfunction det_buffer(k,1,N_det_new) = d(k,1,j) det_buffer(k,2,N_det_new) = d(k,2,j) enddo +! integer :: ne(2) +! ne(:) = 0 +! do k=1,N_int +! ne(1) += popcnt(d(k,1,j)) +! ne(2) += popcnt(d(k,2,j)) +! enddo +! if (ne(1) /= elec_alpha_num) then +! call debug_det(d(1,1,j),N_int) +! stop "ALPHA" +! endif +! if (ne(2) /= elec_beta_num) then +! call debug_det(d(1,1,j),N_int) +! stop "BETA" +! endif if (N_det_new == bufsze) then call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) N_det_new = 0 @@ -274,7 +302,8 @@ subroutine make_s2_eigenfunction call copy_H_apply_buffer_to_wf SOFT_TOUCH N_det psi_coef psi_det print *, 'Added determinants for S^2' -! call remove_duplicates_in_psi_det +! logical :: found +! call remove_duplicates_in_psi_det(found) end From a1a2d888267b782bd83d0fc2e36d17eeb8c41767 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 16:59:29 +0100 Subject: [PATCH 11/76] Removed ZMQ parallelization in Davidson --- src/Davidson/diagonalization_hs2.irp.f | 1 + src/Davidson/u0Hu0.irp.f | 155 ++++++++++++++++++++++++- 2 files changed, 155 insertions(+), 1 deletion(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 8a4cb2d2..778a5702 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -223,6 +223,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ----------------------------------------- +! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 9ab30476..d13b4db4 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -177,7 +177,7 @@ BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] END_PROVIDER -subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) +subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) use bitmasks use f77_zmq implicit none @@ -280,3 +280,156 @@ end +subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8 + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + integer :: blockb, blockb2, istep + double precision :: ave_workload, workload, target_workload_inv + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut + + N_st_8 = align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + allocate(ut(N_st_8,n)) + + v_0 = 0.d0 + s_0 = 0.d0 + + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(i,istate) + enddo + enddo + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + allocate(vt(N_st_8,n),st(N_st_8,n)) + Vt = 0.d0 + St = 0.d0 + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,1) + do sh2=sh,shortcut(0,1) + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1,1)-1 + end if + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),endi + org_j = sort_idx(j,1) + ext = exa + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + end do + if(ext <= 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) + st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + enddo + endif + enddo + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),i-1 + org_j = sort_idx(j,2) + ext = 0 + do ni=1,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + end do + if(ext == 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) + st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + enddo + end if + end do + end do + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + do istate=1,N_st + do i=n,1,-1 + v_0(i,istate) = v_0(i,istate) + vt(istate,i) + s_0(i,istate) = s_0(i,istate) + st(istate,i) + enddo + enddo + !$OMP END CRITICAL + + deallocate(vt,st) + !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version, ut) +end + From 2d1f40cae70041ef9c6ccfb10e5657be97f7b829 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 23:03:11 +0100 Subject: [PATCH 12/76] Better convergence of MRCC --- plugins/MRCC_Utils/mrcc_utils.irp.f | 30 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 48fa2e80..5a35a792 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -884,28 +884,26 @@ END_PROVIDER !$OMP END PARALLEL + + res = 0.d0 - - - if (res < resold) then - do a_coll=1,nactive ! nex - a_col = active_pp_idx(a_coll) - do j=1,N_det_non_ref - i = A_ind(j,a_coll) - if (i==0) exit - rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col) - enddo - res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) - X(a_col) = X_new(a_col) - end do - factor = 1.d0 - else + do a_coll=1,nactive ! nex + a_col = active_pp_idx(a_coll) + do j=1,N_det_non_ref + i = A_ind(j,a_coll) + if (i==0) exit + rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col) + enddo + res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) + X(a_col) = X_new(a_col) + end do + if (res > resold) then factor = -factor * 0.5d0 endif resold = res if(mod(k, 100) == 0) then - print *, "res ", k, res + print *, "res ", k, res, factor end if if(res < 1d-9) exit From 2a2e099bca536b1f27f34859f410459690a67a76 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 9 Nov 2016 15:42:27 +0100 Subject: [PATCH 13/76] Cleaned MRCC --- plugins/MRCC_Utils/amplitudes.irp.f | 228 +++++++++++++++++++++++++ plugins/MRCC_Utils/mrcc_utils.irp.f | 237 ++++++-------------------- plugins/mrcepa0/mrcepa0_general.irp.f | 2 +- src/Determinants/slater_rules.irp.f | 2 +- 4 files changed, 282 insertions(+), 187 deletions(-) create mode 100644 plugins/MRCC_Utils/amplitudes.irp.f diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f new file mode 100644 index 00000000..718d5340 --- /dev/null +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -0,0 +1,228 @@ + BEGIN_PROVIDER [ integer, n_exc_active ] +&BEGIN_PROVIDER [ integer, active_pp_idx, (hh_nex) ] +&BEGIN_PROVIDER [ integer, active_hh_idx, (hh_nex) ] +&BEGIN_PROVIDER [ logical, is_active_exc, (hh_nex) ] + implicit none + BEGIN_DOC + ! is_active_exc : True if the excitation involves at least one active MO + ! + ! n_exc_active : Number of active excitations : Number of excitations without the inactive ones. + ! + ! active_hh_idx : + ! + ! active_pp_idx : + END_DOC + integer :: hh, pp, II + integer :: ind + logical :: ok + integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) + + integer, allocatable :: pathTo(:) + integer, external :: searchDet + + allocate(pathTo(N_det_non_ref)) + + pathTo(:) = 0 + is_active_exc(:) = .false. + n_exc_active = 0 + + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + do II = 1, N_det_ref + + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind == -1) cycle + + ind = psi_non_ref_sorted_idx(ind) + if(pathTo(ind) == 0) then + pathTo(ind) = pp + else + is_active_exc(pp) = .true. + is_active_exc(pathTo(ind)) = .true. + end if + end do + end do + end do + + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + if(is_active_exc(pp)) then + n_exc_active = n_exc_active + 1 + active_hh_idx(n_exc_active) = hh + active_pp_idx(n_exc_active) = pp + end if + end do + end do + + deallocate(pathTo) + + print *, n_exc_active, "inactive excitations /", hh_nex + +END_PROVIDER + + + BEGIN_PROVIDER [ integer, active_excitation_to_determinants_idx, (0:N_det_ref+1, n_exc_active) ] +&BEGIN_PROVIDER [ double precision, active_excitation_to_determinants_val, (N_states,N_det_ref+1, n_exc_active) ] + implicit none + BEGIN_DOC + ! Sparse matrix A containing the matrix to transform the active excitations to + ! determinants : A | \Psi_0 > = | \Psi_SD > + END_DOC + integer :: s, ppp, pp, hh, II, ind, wk, i + integer, allocatable :: lref(:) + integer(bit_kind) :: myDet(N_int,2), myMask(N_int,2) + double precision :: phase + logical :: ok + integer, external :: searchDet + + + !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,& + !$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)& + !$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, & + !$OMP psi_non_ref_sorted_idx, psi_ref, N_det_ref, N_states)& + !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& + !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) + allocate(lref(N_det_non_ref)) + !$OMP DO schedule(static,10) + do ppp=1,n_exc_active + active_excitation_to_determinants_val(:,:,ppp) = 0d0 + active_excitation_to_determinants_idx(:,ppp) = 0 + pp = active_pp_idx(ppp) + hh = active_hh_idx(ppp) + lref = 0 + do II = 1, N_det_ref + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind /= -1) then + call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) + if (phase > 0.d0) then + lref(psi_non_ref_sorted_idx(ind)) = II + else + lref(psi_non_ref_sorted_idx(ind)) = -II + endif + end if + end do + wk = 0 + do i=1, N_det_non_ref + if(lref(i) > 0) then + wk += 1 + do s=1,N_states + active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s) + enddo + active_excitation_to_determinants_idx(wk, ppp) = i + else if(lref(i) < 0) then + wk += 1 + do s=1,N_states + active_excitation_to_determinants_val(s,wk, ppp) = -psi_ref_coef(-lref(i), s) + enddo + active_excitation_to_determinants_idx(wk, ppp) = i + end if + end do + active_excitation_to_determinants_idx(0,ppp) = wk + end do + !$OMP END DO + deallocate(lref) + !$OMP END PARALLEL + +END_PROVIDER + + BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] +&BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active) ] +&BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active) ] +&BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active) ] + implicit none + BEGIN_DOC + ! A is active_excitation_to_determinants in At.A + END_DOC + integer :: AtA_size, i,k + integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s + double precision, allocatable :: t(:), A_val_mwen(:,:) + integer, allocatable :: A_ind_mwen(:) + + mrcc_AtA_ind(:) = 0 + mrcc_AtA_val(:,:) = 0.d0 + mrcc_col_shortcut(:) = 0 + mrcc_N_col(:) = 0 + AtA_size = 0 + + + !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& + !$OMP active_excitation_to_determinants_val, hh_nex) & + !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, n_exc_active, active_pp_idx) + allocate(A_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states)) + + !$OMP DO schedule(dynamic, 100) + do at_roww = 1, n_exc_active ! hh_nex + at_row = active_pp_idx(at_roww) + wk = 0 + if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", hh_nex + + do a_coll = 1, n_exc_active + a_col = active_pp_idx(a_coll) + t(:) = 0d0 + r1 = 1 + r2 = 1 + do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0)) + if(active_excitation_to_determinants_idx(r1, at_roww) > active_excitation_to_determinants_idx(r2, a_coll)) then + r2 = r2+1 + else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then + r1 = r1+1 + else + do s=1,N_states + t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) + enddo + r1 = r1+1 + r2 = r2+1 + end if + end do + + if(a_col == at_row) then + do s=1,N_states + t(s) = t(s) + 1.d0 + enddo + end if + if(sum(abs(t)) /= 0.d0) then + wk += 1 + A_ind_mwen(wk) = a_col + do s=1,N_states + A_val_mwen(s,wk) = t(s) + enddo + end if + end do + + if(wk /= 0) then + !$OMP CRITICAL + mrcc_col_shortcut(at_roww) = AtA_size+1 + mrcc_N_col(at_roww) = wk + if (AtA_size+wk > size(mrcc_AtA_ind,1)) then + print *, AtA_size+wk , size(mrcc_AtA_ind,1) + stop 'too small' + endif + do i=1,wk + mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i) + do s=1,N_states + mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i) + enddo + enddo + AtA_size += wk + !$OMP END CRITICAL + end if + end do + !$OMP END DO NOWAIT + deallocate (A_ind_mwen, A_val_mwen, t) + !$OMP END PARALLEL + + print *, "ATA SIZE", ata_size + +END_PROVIDER + diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 5a35a792..191866aa 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -614,207 +614,60 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, N_states) ] + BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ] &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ] implicit none logical :: ok - integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, nex, a_col, at_row + integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, a_col, at_row integer, external :: searchDet, unsortedSearchDet integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) - integer :: N, INFO, AtA_size, r1, r2 - double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:) - double precision :: t, norm, cx, res - integer, allocatable :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:) + integer :: N, INFO, r1, r2 + double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:) + double precision :: norm, cx, res + integer, allocatable :: lref(:), A_ind_mwen(:) double precision :: phase +! double precision , allocatable :: mrcc_AtA_val(:,:) +! integer, allocatable :: mrcc_AtA_ind(:), col_shortcut(:), , mrcc_N_col(:) - integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:) - logical, allocatable :: active(:) double precision, allocatable :: rho_mrcc_init(:,:) - integer :: nactive + integer :: a_coll, at_roww - nex = hh_shortcut(hh_shortcut(0)+1)-1 - print *, "TI", nex, N_det_non_ref - - allocate(pathTo(N_det_non_ref), active(nex)) - allocate(active_pp_idx(nex), active_hh_idx(nex)) - allocate(rho_mrcc_init(N_det_non_ref, N_states)) - - pathTo = 0 - active = .false. - nactive = 0 - - - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - do II = 1, N_det_ref - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind == -1) cycle - ind = psi_non_ref_sorted_idx(ind) - if(pathTo(ind) == 0) then - pathTo(ind) = pp - else - active(pp) = .true. - active(pathTo(ind)) = .true. - end if - end do - end do - end do - - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(active(pp)) then - nactive = nactive + 1 - active_hh_idx(nactive) = hh - active_pp_idx(nactive) = pp - end if - end do - end do - - print *, nactive, "inact/", size(active) - - allocate(A_ind(0:N_det_ref+1, nactive), A_val(N_det_ref+1, nactive)) - allocate(AtA_ind(N_det_ref * nactive), AtA_val(N_det_ref * nactive)) - allocate(x(nex), AtB(nex)) - allocate(N_col(nactive), col_shortcut(nactive)) - allocate(x_new(nex)) - + print *, "TI", hh_nex, N_det_non_ref - do s=1, N_states - - A_val = 0d0 - A_ind = 0 - AtA_ind = 0 - AtB = 0d0 - AtA_val = 0d0 - x = 0d0 - N_col = 0 - col_shortcut = 0 - - !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind)& - !$OMP shared(s, hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref)& - !$OMP shared(active, active_hh_idx, active_pp_idx, nactive) & - !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh) - allocate(lref(N_det_non_ref)) - !$OMP DO schedule(static,10) - do ppp=1,nactive - pp = active_pp_idx(ppp) - hh = active_hh_idx(ppp) - lref = 0 - do II = 1, N_det_ref - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind /= -1) then - call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - if (phase > 0.d0) then - lref(psi_non_ref_sorted_idx(ind)) = II - else - lref(psi_non_ref_sorted_idx(ind)) = -II - endif - end if - end do - wk = 0 - do i=1, N_det_non_ref - if(lref(i) > 0) then - wk += 1 - A_val(wk, ppp) = psi_ref_coef(lref(i), s) - A_ind(wk, ppp) = i - else if(lref(i) < 0) then - wk += 1 - A_val(wk, ppp) = -psi_ref_coef(-lref(i), s) - A_ind(wk, ppp) = i - end if - end do - A_ind(0,ppp) = wk - end do - !$OMP END DO - deallocate(lref) - !$OMP END PARALLEL - - - print *, 'Done building A_val, A_ind' - - AtA_size = 0 - col_shortcut = 0 - N_col = 0 - integer :: a_coll, at_roww - - - !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref)& + + allocate(rho_mrcc_init(N_det_non_ref, N_states)) + + allocate(x(hh_nex), AtB(hh_nex)) + x = 0d0 + allocate(x_new(hh_nex)) + + + do s=1,N_states + + AtB(:) = 0.d0 + !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,& + !$OMP active_excitation_to_determinants_val, x, N_det_ref, hh_nex, N_det_non_ref) & !$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& - !$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s, nactive, active_pp_idx) - allocate(A_val_mwen(nex), A_ind_mwen(nex)) + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) + allocate(A_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states)) !$OMP DO schedule(dynamic, 100) - do at_roww = 1, nactive ! nex + do at_roww = 1, n_exc_active ! hh_nex at_row = active_pp_idx(at_roww) - wk = 0 - if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex - do i=1,A_ind(0,at_roww) - j = active_pp_idx(i) - AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_roww), s) * A_val(i, at_roww) + do i=1,active_excitation_to_determinants_idx(0,at_roww) + AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww) end do - - do a_coll = 1, nactive - a_col = active_pp_idx(a_coll) - t = 0d0 - r1 = 1 - r2 = 1 - do while ((A_ind(r1, at_roww) /= 0).and.(A_ind(r2, a_coll) /= 0)) - if(A_ind(r1, at_roww) > A_ind(r2, a_coll)) then - r2 = r2+1 - else if(A_ind(r1, at_roww) < A_ind(r2, a_coll)) then - r1 = r1+1 - else - t = t - A_val(r1, at_roww) * A_val(r2, a_coll) - r1 = r1+1 - r2 = r2+1 - end if - end do - - if(a_col == at_row) then - t = t + 1.d0 - end if - if(t /= 0.d0) then - wk += 1 - A_ind_mwen(wk) = a_col - A_val_mwen(wk) = t - end if - end do - - if(wk /= 0) then - !$OMP CRITICAL - col_shortcut(at_roww) = AtA_size+1 - N_col(at_roww) = wk - if (AtA_size+wk > size(AtA_ind,1)) then - print *, AtA_size+wk , size(AtA_ind,1) - stop 'too small' - endif - do i=1,wk - AtA_ind(AtA_size+i) = A_ind_mwen(i) - AtA_val(AtA_size+i) = A_val_mwen(i) - enddo - AtA_size += wk - !$OMP END CRITICAL - end if end do !$OMP END DO NOWAIT deallocate (A_ind_mwen, A_val_mwen) !$OMP END PARALLEL - - print *, "ATA SIZE", ata_size + x = 0d0 - do a_coll = 1, nactive + do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) X(a_col) = AtB(a_col) end do @@ -827,7 +680,7 @@ END_PROVIDER !$OMP DO schedule(static, 1) do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(active(pp)) cycle + if(is_active_exc(pp)) cycle lref = 0 do II=1,N_det_ref call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) @@ -872,11 +725,11 @@ END_PROVIDER !$OMP END DO !$OMP DO - do a_coll = 1, nactive !: nex + do a_coll = 1, n_exc_active !: hh_nex a_col = active_pp_idx(a_coll) cx = 0d0 - do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1 - cx = cx + x(AtA_ind(i)) * AtA_val(i) + do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 + cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) end do x_new(a_col) = AtB(a_col) + cx * factor end do @@ -887,12 +740,12 @@ END_PROVIDER res = 0.d0 - do a_coll=1,nactive ! nex + do a_coll=1,n_exc_active ! hh_nex a_col = active_pp_idx(a_coll) do j=1,N_det_non_ref - i = A_ind(j,a_coll) + i = active_excitation_to_determinants_idx(j,a_coll) if (i==0) exit - rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col) + rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * X_new(a_col) enddo res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) X(a_col) = X_new(a_col) @@ -1051,6 +904,7 @@ END_PROVIDER ! Avoid numerical instabilities f = min(f,2.d0) f = max(f,-2.d0) + f = 1.d0 norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f @@ -1180,9 +1034,21 @@ end function BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ] -&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] &BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ] +&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] +&BEGIN_PROVIDER [ integer, hh_nex ] implicit none + BEGIN_DOC + ! + ! hh_exists : + ! + ! pp_exists : + ! + ! hh_shortcut : + ! + ! hh_nex : Total number of excitation operators + ! + END_DOC integer*2,allocatable :: num(:,:) integer :: exc(0:2, 2, 2), degree, n, on, s, l, i integer*2 :: h1, h2, p1, p2 @@ -1248,6 +1114,7 @@ end function end if end do end do + hh_nex = hh_shortcut(hh_shortcut(0)+1)-1 END_PROVIDER diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 63f03360..c7b31ea9 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -66,7 +66,7 @@ subroutine print_cas_coefs print *, 'CAS' print *, '===' do i=1,N_det_cas - print *, psi_cas_coef(i,:) + print *, (psi_cas_coef(i,j), j=1,N_states) call debug_det(psi_cas(1,1,i),N_int) enddo call write_double(6,ci_energy(1),"Initial CI energy") diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index ed299447..789dc93c 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -513,7 +513,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase,phase_2 integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map + PROVIDE mo_bielec_integrals_in_map mo_integrals_map big_array_exchange_integrals ASSERT (Nint > 0) ASSERT (Nint == N_int) From 5c56e066fc66a5ca2eb660f4a638672ccea172f0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 9 Nov 2016 22:00:44 +0100 Subject: [PATCH 14/76] MRCC eigenfunction of S2 --- plugins/MRCC_Utils/amplitudes.irp.f | 25 ++++++++++--- plugins/MRCC_Utils/mrcc_utils.irp.f | 29 +++++++++------- src/Determinants/s2.irp.f | 54 ++++++++++++++--------------- 3 files changed, 63 insertions(+), 45 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 718d5340..2694aa75 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -137,6 +137,7 @@ END_PROVIDER BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] &BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active) ] +&BEGIN_PROVIDER [ double precision, mrcc_AtS2A_val, (N_states, N_det_ref * n_exc_active) ] &BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active) ] &BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active) ] implicit none @@ -145,11 +146,15 @@ END_PROVIDER END_DOC integer :: AtA_size, i,k integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s - double precision, allocatable :: t(:), A_val_mwen(:,:) + double precision, allocatable :: t(:), ts(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) + integer(bit_kind) :: det1(N_int,2), det2(N_int,2) + double precision :: sij + PROVIDE psi_non_ref S_z2_Sz S_z mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 + mrcc_AtS2A_val(:,:) = 0.d0 mrcc_col_shortcut(:) = 0 mrcc_N_col(:) = 0 AtA_size = 0 @@ -157,9 +162,11 @@ END_PROVIDER !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & - !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& - !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, n_exc_active, active_pp_idx) - allocate(A_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states)) + !$OMP private(at_row, a_col, t, ts, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& + !$OMP det1,det2,As2_val_mwen, a_coll, at_roww,sij) & + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & + !$OMP n_exc_active, active_pp_idx,psi_non_ref,N_int,S_z2_Sz, mrcc_AtS2A_val) + allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states), ts(N_states)) !$OMP DO schedule(dynamic, 100) do at_roww = 1, n_exc_active ! hh_nex @@ -170,6 +177,7 @@ END_PROVIDER do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) t(:) = 0d0 + ts(:) = 0d0 r1 = 1 r2 = 1 do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0)) @@ -178,8 +186,12 @@ END_PROVIDER else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then r1 = r1+1 else + det1(:,:) = psi_non_ref(:,:, active_excitation_to_determinants_idx(r1,at_roww)) + det2(:,:) = psi_non_ref(:,:, active_excitation_to_determinants_idx(r2,a_coll)) + call get_s2(det1, det2,N_int,sij) do s=1,N_states t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) + ts(s) = ts(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) * sij enddo r1 = r1+1 r2 = r2+1 @@ -189,6 +201,7 @@ END_PROVIDER if(a_col == at_row) then do s=1,N_states t(s) = t(s) + 1.d0 + ts(s) = ts(s) + S_z2_Sz enddo end if if(sum(abs(t)) /= 0.d0) then @@ -196,6 +209,7 @@ END_PROVIDER A_ind_mwen(wk) = a_col do s=1,N_states A_val_mwen(s,wk) = t(s) + As2_val_mwen(s,wk) = ts(s) enddo end if end do @@ -212,6 +226,7 @@ END_PROVIDER mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i) do s=1,N_states mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i) + mrcc_AtS2A_val(s,AtA_size+i) = As2_val_mwen(s,i) enddo enddo AtA_size += wk @@ -219,7 +234,7 @@ END_PROVIDER end if end do !$OMP END DO NOWAIT - deallocate (A_ind_mwen, A_val_mwen, t) + deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t, ts) !$OMP END PARALLEL print *, "ATA SIZE", ata_size diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 191866aa..f864dd08 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -626,8 +626,6 @@ END_PROVIDER double precision :: norm, cx, res integer, allocatable :: lref(:), A_ind_mwen(:) double precision :: phase -! double precision , allocatable :: mrcc_AtA_val(:,:) -! integer, allocatable :: mrcc_AtA_ind(:), col_shortcut(:), , mrcc_N_col(:) double precision, allocatable :: rho_mrcc_init(:,:) @@ -635,13 +633,10 @@ END_PROVIDER print *, "TI", hh_nex, N_det_non_ref - - allocate(rho_mrcc_init(N_det_non_ref, N_states)) - + allocate(x_new(hh_nex)) allocate(x(hh_nex), AtB(hh_nex)) x = 0d0 - allocate(x_new(hh_nex)) do s=1,N_states @@ -712,28 +707,37 @@ END_PROVIDER x_new = x + double precision :: s2(N_states), s2_local, dx double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) + !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll, s2_local) !$OMP DO do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i,s) ! 0d0 + rho_mrcc(i,s) = rho_mrcc_init(i,s) enddo !$OMP END DO + s2(s) = 0.d0 !$OMP DO - do a_coll = 1, n_exc_active !: hh_nex + do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) - cx = 0d0 + cx = 0.d0 + dx = 0.d0 do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) + dx = dx + x(mrcc_AtA_ind(i)) * mrcc_AtS2A_val(s,i) + s2_local = s2_local + X(a_col)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) end do - x_new(a_col) = AtB(a_col) + cx * factor + x_new(a_col) = AtB(a_col) + (cx+dx) * factor end do !$OMP END DO + + !$OMP CRITICAL + s2(s) = s2(s) + s2_local + !$OMP END CRITICAL !$OMP END PARALLEL @@ -756,14 +760,13 @@ END_PROVIDER resold = res if(mod(k, 100) == 0) then - print *, "res ", k, res, factor + print *, "res ", k, res, s2(s) end if if(res < 1d-9) exit end do - norm = 0.d0 do i=1,N_det_non_ref norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index c6bb8390..7e62befb 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -1,36 +1,36 @@ subroutine get_s2(key_i,key_j,Nint,s2) - implicit none - use bitmasks - BEGIN_DOC -! Returns - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2) - integer(bit_kind), intent(in) :: key_j(Nint,2) - double precision, intent(out) :: s2 - integer :: exc(0:2,2,2) - integer :: degree - double precision :: phase_spsm - integer :: nup, i - - s2 = 0.d0 - !$FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case(2) - call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint) - if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta - if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then - s2 = -phase_spsm - endif - endif - case(0) + implicit none + use bitmasks + BEGIN_DOC + ! Returns + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer(bit_kind), intent(in) :: key_j(Nint,2) + double precision, intent(out) :: s2 + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase_spsm + integer :: nup, i + + s2 = 0.d0 + !$FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case(2) + call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint) + if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta + if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then + s2 = -phase_spsm + endif + endif + case(0) nup = 0 do i=1,Nint nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) enddo s2 = dble(nup) - end select + end select end BEGIN_PROVIDER [ double precision, S_z ] From 12d3c31b48fce17e041b87ba5a800856b650fbad Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 10 Nov 2016 13:27:06 +0100 Subject: [PATCH 15/76] Version with S2A in MRCC. Broken --- plugins/MRCC_Utils/amplitudes.irp.f | 85 ++++++++++++++++++++++++----- plugins/MRCC_Utils/mrcc_utils.irp.f | 40 ++++++++++---- 2 files changed, 101 insertions(+), 24 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 2694aa75..77360d93 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -49,7 +49,7 @@ end do end do end do - +!is_active_exc=.true. do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) then @@ -133,6 +133,55 @@ END_PROVIDER deallocate(lref) !$OMP END PARALLEL +END_PROVIDER + + BEGIN_PROVIDER [ integer, mrcc_S2A_ind, (0:N_det_ref*mo_tot_num, n_exc_active) ] +&BEGIN_PROVIDER [ double precision, mrcc_S2A_val, (N_states, N_det_ref*mo_tot_num, n_exc_active) ] + implicit none + BEGIN_DOC + ! A is active_excitation_to_determinants in S^2. + END_DOC + integer :: a_coll, a_col + integer :: i,j,idx,s + double precision :: sij + double precision, allocatable :: tmp(:,:) + logical, allocatable :: ok(:) + mrcc_S2A_val = 0.d0 + print *, 'Computing S2A' + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(a_coll,idx,i,sij,s,tmp,ok,j) + allocate(tmp(N_states,N_det_non_ref), ok(N_det_non_ref)) + !$OMP DO + do a_coll=1, n_exc_active + tmp = 0.d0 + ok = .False. + do idx=1, active_excitation_to_determinants_idx(0,a_coll) + i = active_excitation_to_determinants_idx(idx,a_coll) + do j=1,N_det_non_ref + call get_s2(psi_non_ref(1,1,i), psi_non_ref(1,1,j), N_int, sij) + if (sij /= 0.d0) then + do s=1,N_states + tmp(s,j) = tmp(s,j) + sij*active_excitation_to_determinants_val(s,idx,a_coll) + enddo + ok(j) = .True. + endif + enddo + enddo + idx = 0 + do j=1,N_det_non_ref + if (ok(j)) then + idx = idx+1 + mrcc_S2A_ind(idx,a_coll) = j + do s=1,N_states + mrcc_S2A_val(s,idx,a_coll) = tmp(s,j) + enddo + endif + enddo + mrcc_S2A_ind(0,a_coll) = idx + enddo + !$OMP END DO + deallocate(tmp,ok) + !$OMP END PARALLEL + END_PROVIDER BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] @@ -148,9 +197,8 @@ END_PROVIDER integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s double precision, allocatable :: t(:), ts(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) - integer(bit_kind) :: det1(N_int,2), det2(N_int,2) double precision :: sij - PROVIDE psi_non_ref S_z2_Sz S_z + PROVIDE psi_non_ref mrcc_S2A_val mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 @@ -163,9 +211,9 @@ END_PROVIDER !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & !$OMP private(at_row, a_col, t, ts, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& - !$OMP det1,det2,As2_val_mwen, a_coll, at_roww,sij) & - !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & - !$OMP n_exc_active, active_pp_idx,psi_non_ref,N_int,S_z2_Sz, mrcc_AtS2A_val) + !$OMP As2_val_mwen, a_coll, at_roww,sij) & + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_S2A_val, mrcc_S2A_ind, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & + !$OMP n_exc_active, active_pp_idx,psi_non_ref,mrcc_AtS2A_val) allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states), ts(N_states)) !$OMP DO schedule(dynamic, 100) @@ -177,7 +225,6 @@ END_PROVIDER do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) t(:) = 0d0 - ts(:) = 0d0 r1 = 1 r2 = 1 do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0)) @@ -186,12 +233,25 @@ END_PROVIDER else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then r1 = r1+1 else - det1(:,:) = psi_non_ref(:,:, active_excitation_to_determinants_idx(r1,at_roww)) - det2(:,:) = psi_non_ref(:,:, active_excitation_to_determinants_idx(r2,a_coll)) - call get_s2(det1, det2,N_int,sij) do s=1,N_states t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) - ts(s) = ts(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) * sij + enddo + r1 = r1+1 + r2 = r2+1 + end if + end do + + ts(:) = 0d0 + r1 = 1 + r2 = 1 + do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(mrcc_S2A_ind(r2, a_coll) /= 0)) + if(active_excitation_to_determinants_idx(r1, at_roww) > mrcc_S2A_ind(r2, a_coll)) then + r2 = r2+1 + else if(active_excitation_to_determinants_idx(r1, at_roww) < mrcc_S2A_ind(r2, a_coll)) then + r1 = r1+1 + else + do s=1,N_states + ts(s) = ts(s) + active_excitation_to_determinants_val(s,r1, at_roww) * mrcc_S2A_val(s,r2, a_coll) enddo r1 = r1+1 r2 = r2+1 @@ -201,10 +261,9 @@ END_PROVIDER if(a_col == at_row) then do s=1,N_states t(s) = t(s) + 1.d0 - ts(s) = ts(s) + S_z2_Sz enddo end if - if(sum(abs(t)) /= 0.d0) then + if(sum(abs(t)+abs(ts)) /= 0.d0) then wk += 1 A_ind_mwen(wk) = a_col do s=1,N_states diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f864dd08..970802de 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -707,12 +707,24 @@ END_PROVIDER x_new = x - double precision :: s2(N_states), s2_local, dx + double precision :: s2(N_states), s2_local, dx, s2_init(N_states) double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) + + s2_init(s) = S_z2_Sz + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + if(is_active_exc(pp)) cycle + do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 + s2_init(s) = s2_init(s) + X(pp)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) + end do + enddo + end do + do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll, s2_local) + s2_local = s2_init(s) + !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll) !$OMP DO do i=1,N_det_non_ref @@ -720,7 +732,15 @@ END_PROVIDER enddo !$OMP END DO - s2(s) = 0.d0 + !$OMP DO REDUCTION(+:s2_local) + do a_coll = 1, n_exc_active + a_col = active_pp_idx(a_coll) + do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 + s2_local = s2_local + X(a_col)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) + end do + end do + !$OMP END DO + !$OMP DO do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) @@ -728,23 +748,19 @@ END_PROVIDER dx = 0.d0 do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) - dx = dx + x(mrcc_AtA_ind(i)) * mrcc_AtS2A_val(s,i) - s2_local = s2_local + X(a_col)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) + dx = dx + (s2_local-expected_s2)*x(mrcc_AtA_ind(i)) * mrcc_AtS2A_val(s,i) end do x_new(a_col) = AtB(a_col) + (cx+dx) * factor end do !$OMP END DO - !$OMP CRITICAL - s2(s) = s2(s) + s2_local - !$OMP END CRITICAL - !$OMP END PARALLEL + s2(s) = s2_local res = 0.d0 - do a_coll=1,n_exc_active ! hh_nex + do a_coll=1,n_exc_active a_col = active_pp_idx(a_coll) do j=1,N_det_non_ref i = active_excitation_to_determinants_idx(j,a_coll) @@ -765,7 +781,7 @@ END_PROVIDER if(res < 1d-9) exit end do - + s2(s) = s2_local norm = 0.d0 do i=1,N_det_non_ref @@ -928,6 +944,7 @@ END_PROVIDER norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) + print *, 'S^2 |T Psi_0> = ', s2(s) do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) @@ -936,6 +953,7 @@ END_PROVIDER do i=1,N_det_non_ref rho_mrcc(i,s) = rho_mrcc(i,s) * f enddo +rho_mrcc = 1.d0 ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant From 76a0d69d3bf117af847036524b93fb4b99e6c30c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 10 Nov 2016 13:30:41 +0100 Subject: [PATCH 16/76] Removed S2 in MRCC --- plugins/MRCC_Utils/amplitudes.irp.f | 95 +++-------------------------- plugins/MRCC_Utils/mrcc_utils.irp.f | 33 +--------- 2 files changed, 9 insertions(+), 119 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 77360d93..095eebbe 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -135,58 +135,9 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ integer, mrcc_S2A_ind, (0:N_det_ref*mo_tot_num, n_exc_active) ] -&BEGIN_PROVIDER [ double precision, mrcc_S2A_val, (N_states, N_det_ref*mo_tot_num, n_exc_active) ] - implicit none - BEGIN_DOC - ! A is active_excitation_to_determinants in S^2. - END_DOC - integer :: a_coll, a_col - integer :: i,j,idx,s - double precision :: sij - double precision, allocatable :: tmp(:,:) - logical, allocatable :: ok(:) - mrcc_S2A_val = 0.d0 - print *, 'Computing S2A' - !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(a_coll,idx,i,sij,s,tmp,ok,j) - allocate(tmp(N_states,N_det_non_ref), ok(N_det_non_ref)) - !$OMP DO - do a_coll=1, n_exc_active - tmp = 0.d0 - ok = .False. - do idx=1, active_excitation_to_determinants_idx(0,a_coll) - i = active_excitation_to_determinants_idx(idx,a_coll) - do j=1,N_det_non_ref - call get_s2(psi_non_ref(1,1,i), psi_non_ref(1,1,j), N_int, sij) - if (sij /= 0.d0) then - do s=1,N_states - tmp(s,j) = tmp(s,j) + sij*active_excitation_to_determinants_val(s,idx,a_coll) - enddo - ok(j) = .True. - endif - enddo - enddo - idx = 0 - do j=1,N_det_non_ref - if (ok(j)) then - idx = idx+1 - mrcc_S2A_ind(idx,a_coll) = j - do s=1,N_states - mrcc_S2A_val(s,idx,a_coll) = tmp(s,j) - enddo - endif - enddo - mrcc_S2A_ind(0,a_coll) = idx - enddo - !$OMP END DO - deallocate(tmp,ok) - !$OMP END PARALLEL - -END_PROVIDER BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] &BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active) ] -&BEGIN_PROVIDER [ double precision, mrcc_AtS2A_val, (N_states, N_det_ref * n_exc_active) ] &BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active) ] &BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active) ] implicit none @@ -195,14 +146,13 @@ END_PROVIDER END_DOC integer :: AtA_size, i,k integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s - double precision, allocatable :: t(:), ts(:), A_val_mwen(:,:), As2_val_mwen(:,:) + double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) double precision :: sij - PROVIDE psi_non_ref mrcc_S2A_val + PROVIDE psi_non_ref mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 - mrcc_AtS2A_val(:,:) = 0.d0 mrcc_col_shortcut(:) = 0 mrcc_N_col(:) = 0 AtA_size = 0 @@ -210,11 +160,11 @@ END_PROVIDER !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & - !$OMP private(at_row, a_col, t, ts, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& + !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& !$OMP As2_val_mwen, a_coll, at_roww,sij) & - !$OMP shared(N_states,mrcc_col_shortcut, mrcc_S2A_val, mrcc_S2A_ind, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & - !$OMP n_exc_active, active_pp_idx,psi_non_ref,mrcc_AtS2A_val) - allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states), ts(N_states)) + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & + !$OMP n_exc_active, active_pp_idx,psi_non_ref) + allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states) ) !$OMP DO schedule(dynamic, 100) do at_roww = 1, n_exc_active ! hh_nex @@ -241,36 +191,6 @@ END_PROVIDER end if end do - ts(:) = 0d0 - r1 = 1 - r2 = 1 - do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(mrcc_S2A_ind(r2, a_coll) /= 0)) - if(active_excitation_to_determinants_idx(r1, at_roww) > mrcc_S2A_ind(r2, a_coll)) then - r2 = r2+1 - else if(active_excitation_to_determinants_idx(r1, at_roww) < mrcc_S2A_ind(r2, a_coll)) then - r1 = r1+1 - else - do s=1,N_states - ts(s) = ts(s) + active_excitation_to_determinants_val(s,r1, at_roww) * mrcc_S2A_val(s,r2, a_coll) - enddo - r1 = r1+1 - r2 = r2+1 - end if - end do - - if(a_col == at_row) then - do s=1,N_states - t(s) = t(s) + 1.d0 - enddo - end if - if(sum(abs(t)+abs(ts)) /= 0.d0) then - wk += 1 - A_ind_mwen(wk) = a_col - do s=1,N_states - A_val_mwen(s,wk) = t(s) - As2_val_mwen(s,wk) = ts(s) - enddo - end if end do if(wk /= 0) then @@ -285,7 +205,6 @@ END_PROVIDER mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i) do s=1,N_states mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i) - mrcc_AtS2A_val(s,AtA_size+i) = As2_val_mwen(s,i) enddo enddo AtA_size += wk @@ -293,7 +212,7 @@ END_PROVIDER end if end do !$OMP END DO NOWAIT - deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t, ts) + deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t) !$OMP END PARALLEL print *, "ATA SIZE", ata_size diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 970802de..e81fce53 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -707,23 +707,11 @@ END_PROVIDER x_new = x - double precision :: s2(N_states), s2_local, dx, s2_init(N_states) double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) - s2_init(s) = S_z2_Sz - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(is_active_exc(pp)) cycle - do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 - s2_init(s) = s2_init(s) + X(pp)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) - end do - enddo - end do - do k=0,100000 - s2_local = s2_init(s) !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll) !$OMP DO @@ -732,31 +720,18 @@ END_PROVIDER enddo !$OMP END DO - !$OMP DO REDUCTION(+:s2_local) - do a_coll = 1, n_exc_active - a_col = active_pp_idx(a_coll) - do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 - s2_local = s2_local + X(a_col)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) - end do - end do - !$OMP END DO - !$OMP DO do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) cx = 0.d0 - dx = 0.d0 do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) - dx = dx + (s2_local-expected_s2)*x(mrcc_AtA_ind(i)) * mrcc_AtS2A_val(s,i) end do - x_new(a_col) = AtB(a_col) + (cx+dx) * factor + x_new(a_col) = AtB(a_col) + cx * factor end do !$OMP END DO !$OMP END PARALLEL - s2(s) = s2_local - res = 0.d0 @@ -776,12 +751,11 @@ END_PROVIDER resold = res if(mod(k, 100) == 0) then - print *, "res ", k, res, s2(s) + print *, "res ", k, res end if if(res < 1d-9) exit end do - s2(s) = s2_local norm = 0.d0 do i=1,N_det_non_ref @@ -923,7 +897,6 @@ END_PROVIDER ! Avoid numerical instabilities f = min(f,2.d0) f = max(f,-2.d0) - f = 1.d0 norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f @@ -944,7 +917,6 @@ END_PROVIDER norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) - print *, 'S^2 |T Psi_0> = ', s2(s) do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) @@ -953,7 +925,6 @@ END_PROVIDER do i=1,N_det_non_ref rho_mrcc(i,s) = rho_mrcc(i,s) * f enddo -rho_mrcc = 1.d0 ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant From 57632c6d87c1cd365d4080f905539110be414869 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 10 Nov 2016 13:34:40 +0100 Subject: [PATCH 17/76] Added lambda_type=2 --- plugins/MRCC_Utils/mrcc_utils.irp.f | 11 +++++++++-- plugins/mrcepa0/EZFIO.cfg | 2 +- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index e81fce53..074039e1 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -712,7 +712,7 @@ END_PROVIDER resold = huge(1.d0) do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll) + !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) !$OMP DO do i=1,N_det_non_ref @@ -966,9 +966,16 @@ double precision function get_dij_index(II, i, s, Nint) call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase get_dij_index = get_dij_index * rho_mrcc(i,s) - else + else if(lambda_type == 1) then + call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) + get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase + get_dij_index = get_dij_index * rho_mrcc(i,s) call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) get_dij_index = HIi * lambda_mrcc(s, i) + else if(lambda_type == 2) then + call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) + get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase + get_dij_index = get_dij_index end if end function diff --git a/plugins/mrcepa0/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg index 61f3392f..b64637e6 100644 --- a/plugins/mrcepa0/EZFIO.cfg +++ b/plugins/mrcepa0/EZFIO.cfg @@ -23,7 +23,7 @@ interface: ezfio type: Threshold doc: Threshold on the convergence of the dressed CI energy interface: ezfio,provider,ocaml -default: 5.e-5 +default: 1.e-5 [n_it_max_dressed_ci] type: Strictly_positive_int From b49fd6280d0bba0de26f55c79a4f9df827653a18 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 10 Nov 2016 14:24:54 +0100 Subject: [PATCH 18/76] Moved threshold_perturbation_pt2 --- plugins/Full_CI/EZFIO.cfg | 12 ------------ plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- plugins/Perturbation/EZFIO.cfg | 12 ++++++++++++ 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/plugins/Full_CI/EZFIO.cfg b/plugins/Full_CI/EZFIO.cfg index afb25d2e..9a552cd0 100644 --- a/plugins/Full_CI/EZFIO.cfg +++ b/plugins/Full_CI/EZFIO.cfg @@ -8,15 +8,3 @@ type: double precision doc: Calculated FCI energy + PT2 interface: ezfio -[threshold_generators_pt2] -type: Threshold -doc: Thresholds on generators (fraction of the norm) for final PT2 calculation -interface: ezfio,provider,ocaml -default: 0.999 - -[threshold_selectors_pt2] -type: Threshold -doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation -interface: ezfio,provider,ocaml -default: 1. - diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f864dd08..50079651 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -907,7 +907,7 @@ END_PROVIDER ! Avoid numerical instabilities f = min(f,2.d0) f = max(f,-2.d0) - f = 1.d0 +! f = 1.d0 norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f diff --git a/plugins/Perturbation/EZFIO.cfg b/plugins/Perturbation/EZFIO.cfg index 9023accf..4f0457a2 100644 --- a/plugins/Perturbation/EZFIO.cfg +++ b/plugins/Perturbation/EZFIO.cfg @@ -18,3 +18,15 @@ doc: The selection process stops when the energy ratio variational/(variational+ interface: ezfio,provider,ocaml default: 0.75 +[threshold_generators_pt2] +type: Threshold +doc: Thresholds on generators (fraction of the norm) for final PT2 calculation +interface: ezfio,provider,ocaml +default: 0.999 + +[threshold_selectors_pt2] +type: Threshold +doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation +interface: ezfio,provider,ocaml +default: 1. + From fe54cb26754a7ef5b78a0990aa9c19bddde0580d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 11 Nov 2016 23:07:58 +0100 Subject: [PATCH 19/76] Introduced PT2 energy denomitator provider --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 26 ++++++++++--------- .../selection_davidson_slave.irp.f | 2 +- plugins/Full_CI_ZMQ/selection_slave.irp.f | 2 +- plugins/MRCC_Utils/amplitudes.irp.f | 2 +- plugins/MRCC_Utils/davidson.irp.f | 23 ++++++---------- plugins/MRCC_Utils/mrcc_utils.irp.f | 5 +--- plugins/Selectors_full/selectors.irp.f | 2 +- src/Davidson/diagonalization_hs2.irp.f | 11 ++++---- src/Davidson/u0Hu0.irp.f | 8 +++--- 9 files changed, 36 insertions(+), 45 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index a3488655..e03db458 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -123,11 +123,11 @@ subroutine ZMQ_selection(N_in, pt2) if (.True.) then + PROVIDE pt2_e0_denominator N = max(N_in,1) provide nproc - provide ci_electronic_energy call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy)) + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) call zmq_set_running(zmq_to_qp_run_socket) call create_selection_buffer(N, N*2, b) endif @@ -144,19 +144,21 @@ subroutine ZMQ_selection(N_in, pt2) call add_task_to_taskserver(zmq_to_qp_run_socket,task) end do - !$OMP PARALLEL DEFAULT(none) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) shared(ci_electronic_energy_is_built, n_det_generators_is_built, n_states_is_built, n_int_is_built, nproc_is_built) - i = omp_get_thread_num() - if (i==0) then - call selection_collector(b, pt2) - else - call selection_slave_inproc(i) - endif + !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(b, pt2) + else + call selection_slave_inproc(i) + endif !$OMP END PARALLEL - call end_parallel_job(zmq_to_qp_run_socket, 'selection') + call end_parallel_job(zmq_to_qp_run_socket, 'selection') if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() - call make_s2_eigenfunction + if (s2_eig) then + call make_s2_eigenfunction + endif endif end subroutine @@ -165,7 +167,7 @@ subroutine selection_slave_inproc(i) implicit none integer, intent(in) :: i - call run_selection_slave(1,i,ci_electronic_energy) + call run_selection_slave(1,i,pt2_e0_denominator) end subroutine selection_collector(b, pt2) diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 6e4cf44f..5041e731 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -13,7 +13,7 @@ end subroutine provide_everything PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context mo_mono_elec_integral -! PROVIDE ci_electronic_energy mo_tot_num N_int +! PROVIDE pt2_e0_denominator mo_tot_num N_int end subroutine run_wf diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 06bcf533..b9e530e0 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -13,7 +13,7 @@ end subroutine provide_everything PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context -! PROVIDE ci_electronic_energy mo_tot_num N_int + PROVIDE pt2_e0_denominator mo_tot_num N_int end subroutine run_wf diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 095eebbe..053527f7 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -62,7 +62,7 @@ deallocate(pathTo) - print *, n_exc_active, "inactive excitations /", hh_nex + print *, n_exc_active, "active excitations /", hh_nex END_PROVIDER diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 5783c5d9..9d5e8a67 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -315,20 +315,10 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s ! ----------- do k=1,N_st_diag - energies(k) = lambda(k) do i=1,sze u_in(i,k) = 0.d0 enddo enddo -! do k=1,N_st_diag -! do i=1,sze -! do iter2=1,iter -! do l=1,N_st_diag -! u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) -! enddo -! enddo -! enddo -! enddo call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & U, size(U,1), y, N_st_diag*davidson_sze_max, & @@ -336,6 +326,9 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s enddo + do k=1,N_st_diag + energies(k) = lambda(k) + enddo write_buffer = '===== ' do i=1,N_st write_buffer = trim(write_buffer)//' ================ ================' @@ -557,7 +550,7 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit, istate integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st) + double precision, intent(out) :: energies(N_st_diag) double precision, allocatable :: H_jj(:), S2_jj(:) double precision :: diag_h_mat_elem @@ -962,7 +955,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) exa = 0 @@ -1004,8 +997,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i enddo enddo enddo - !$OMP END DO NOWAIT - !$OMP DO SCHEDULE(dynamic) + !$OMP END DO + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -1028,7 +1021,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i end do end do enddo - !$OMP END DO NOWAIT + !$OMP END DO ! -------------------------- ! Begin Specific to dressing diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 074039e1..7005fa19 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -712,7 +712,7 @@ END_PROVIDER resold = huge(1.d0) do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) + !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) !$OMP DO do i=1,N_det_non_ref @@ -967,9 +967,6 @@ double precision function get_dij_index(II, i, s, Nint) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase get_dij_index = get_dij_index * rho_mrcc(i,s) else if(lambda_type == 1) then - call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) - get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase - get_dij_index = get_dij_index * rho_mrcc(i,s) call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) get_dij_index = HIi * lambda_mrcc(s, i) else if(lambda_type == 2) then diff --git a/plugins/Selectors_full/selectors.irp.f b/plugins/Selectors_full/selectors.irp.f index fd719136..e8e746c8 100644 --- a/plugins/Selectors_full/selectors.irp.f +++ b/plugins/Selectors_full/selectors.irp.f @@ -14,7 +14,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors] integer :: i double precision :: norm, norm_max call write_time(output_determinants) - N_det_selectors = N_det_generators + N_det_selectors = N_det if (threshold_generators < 1.d0) then norm = 0.d0 do i=1,N_det diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 778a5702..fddac471 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -22,7 +22,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st), s2_out(N_st_diag) + double precision, intent(out) :: energies(N_st_diag), s2_out(N_st_diag) double precision, allocatable :: H_jj(:), S2_jj(:) double precision :: diag_h_mat_elem @@ -116,7 +116,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s stop -1 endif - PROVIDE nuclear_repulsion + PROVIDE nuclear_repulsion expected_s2 call write_time(iunit) call wall_time(wall) @@ -253,6 +253,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call dgemm('T','N',shift2,shift2,shift2, & 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & 0.d0, s_, size(s_,1)) + + do k=1,shift2 s2(k) = s_(k,k) + S_z2_Sz @@ -324,16 +326,13 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! Re-contract to u_in ! ----------- - do k=1,N_st_diag - energies(k) = lambda(k) - 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)) enddo do k=1,N_st_diag + energies(k) = lambda(k) S2_jj(k) = s2(k) enddo write_buffer = '===== ' diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index d13b4db4..18004e02 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -344,7 +344,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) exa = 0 @@ -386,8 +386,8 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo enddo enddo - !$OMP END DO NOWAIT - !$OMP DO SCHEDULE(dynamic) + !$OMP END DO + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -410,7 +410,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) end do end do enddo - !$OMP END DO NOWAIT + !$OMP END DO !$OMP CRITICAL do istate=1,N_st From b97ca19a8c691e7b9d5b0e2e117664b8e34ad371 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 11 Nov 2016 23:12:48 +0100 Subject: [PATCH 20/76] Made MRPT_Utils a core module --- {plugins => src}/MRPT_Utils/EZFIO.cfg | 0 {plugins => src}/MRPT_Utils/H_apply.irp.f | 0 {plugins => src}/MRPT_Utils/NEEDED_CHILDREN_MODULES | 0 {plugins => src}/MRPT_Utils/README.rst | 0 {plugins => src}/MRPT_Utils/energies_cas.irp.f | 0 {plugins => src}/MRPT_Utils/excitations_cas.irp.f | 0 {plugins => src}/MRPT_Utils/fock_like_operators.irp.f | 0 {plugins => src}/MRPT_Utils/give_2h2p.irp.f | 0 {plugins => src}/MRPT_Utils/mrpt_dress.irp.f | 0 {plugins => src}/MRPT_Utils/mrpt_utils.irp.f | 0 {plugins => src}/MRPT_Utils/new_way.irp.f | 0 {plugins => src}/MRPT_Utils/new_way_second_order_coef.irp.f | 0 {plugins => src}/MRPT_Utils/psi_active_prov.irp.f | 0 {plugins => src}/MRPT_Utils/second_order_new.irp.f | 0 {plugins => src}/MRPT_Utils/second_order_new_2p.irp.f | 0 {plugins => src}/MRPT_Utils/utils_bitmask.irp.f | 0 16 files changed, 0 insertions(+), 0 deletions(-) rename {plugins => src}/MRPT_Utils/EZFIO.cfg (100%) rename {plugins => src}/MRPT_Utils/H_apply.irp.f (100%) rename {plugins => src}/MRPT_Utils/NEEDED_CHILDREN_MODULES (100%) rename {plugins => src}/MRPT_Utils/README.rst (100%) rename {plugins => src}/MRPT_Utils/energies_cas.irp.f (100%) rename {plugins => src}/MRPT_Utils/excitations_cas.irp.f (100%) rename {plugins => src}/MRPT_Utils/fock_like_operators.irp.f (100%) rename {plugins => src}/MRPT_Utils/give_2h2p.irp.f (100%) rename {plugins => src}/MRPT_Utils/mrpt_dress.irp.f (100%) rename {plugins => src}/MRPT_Utils/mrpt_utils.irp.f (100%) rename {plugins => src}/MRPT_Utils/new_way.irp.f (100%) rename {plugins => src}/MRPT_Utils/new_way_second_order_coef.irp.f (100%) rename {plugins => src}/MRPT_Utils/psi_active_prov.irp.f (100%) rename {plugins => src}/MRPT_Utils/second_order_new.irp.f (100%) rename {plugins => src}/MRPT_Utils/second_order_new_2p.irp.f (100%) rename {plugins => src}/MRPT_Utils/utils_bitmask.irp.f (100%) diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/src/MRPT_Utils/EZFIO.cfg similarity index 100% rename from plugins/MRPT_Utils/EZFIO.cfg rename to src/MRPT_Utils/EZFIO.cfg diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/src/MRPT_Utils/H_apply.irp.f similarity index 100% rename from plugins/MRPT_Utils/H_apply.irp.f rename to src/MRPT_Utils/H_apply.irp.f diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/src/MRPT_Utils/NEEDED_CHILDREN_MODULES similarity index 100% rename from plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES rename to src/MRPT_Utils/NEEDED_CHILDREN_MODULES diff --git a/plugins/MRPT_Utils/README.rst b/src/MRPT_Utils/README.rst similarity index 100% rename from plugins/MRPT_Utils/README.rst rename to src/MRPT_Utils/README.rst diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/src/MRPT_Utils/energies_cas.irp.f similarity index 100% rename from plugins/MRPT_Utils/energies_cas.irp.f rename to src/MRPT_Utils/energies_cas.irp.f diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/src/MRPT_Utils/excitations_cas.irp.f similarity index 100% rename from plugins/MRPT_Utils/excitations_cas.irp.f rename to src/MRPT_Utils/excitations_cas.irp.f diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/src/MRPT_Utils/fock_like_operators.irp.f similarity index 100% rename from plugins/MRPT_Utils/fock_like_operators.irp.f rename to src/MRPT_Utils/fock_like_operators.irp.f diff --git a/plugins/MRPT_Utils/give_2h2p.irp.f b/src/MRPT_Utils/give_2h2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/give_2h2p.irp.f rename to src/MRPT_Utils/give_2h2p.irp.f diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/src/MRPT_Utils/mrpt_dress.irp.f similarity index 100% rename from plugins/MRPT_Utils/mrpt_dress.irp.f rename to src/MRPT_Utils/mrpt_dress.irp.f diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/src/MRPT_Utils/mrpt_utils.irp.f similarity index 100% rename from plugins/MRPT_Utils/mrpt_utils.irp.f rename to src/MRPT_Utils/mrpt_utils.irp.f diff --git a/plugins/MRPT_Utils/new_way.irp.f b/src/MRPT_Utils/new_way.irp.f similarity index 100% rename from plugins/MRPT_Utils/new_way.irp.f rename to src/MRPT_Utils/new_way.irp.f diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/src/MRPT_Utils/new_way_second_order_coef.irp.f similarity index 100% rename from plugins/MRPT_Utils/new_way_second_order_coef.irp.f rename to src/MRPT_Utils/new_way_second_order_coef.irp.f diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/src/MRPT_Utils/psi_active_prov.irp.f similarity index 100% rename from plugins/MRPT_Utils/psi_active_prov.irp.f rename to src/MRPT_Utils/psi_active_prov.irp.f diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/src/MRPT_Utils/second_order_new.irp.f similarity index 100% rename from plugins/MRPT_Utils/second_order_new.irp.f rename to src/MRPT_Utils/second_order_new.irp.f diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/src/MRPT_Utils/second_order_new_2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/second_order_new_2p.irp.f rename to src/MRPT_Utils/second_order_new_2p.irp.f diff --git a/plugins/MRPT_Utils/utils_bitmask.irp.f b/src/MRPT_Utils/utils_bitmask.irp.f similarity index 100% rename from plugins/MRPT_Utils/utils_bitmask.irp.f rename to src/MRPT_Utils/utils_bitmask.irp.f From b51cfbcfbe973b394e9e248bab72d8479d1e4ce2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 11 Nov 2016 23:42:59 +0100 Subject: [PATCH 21/76] Forgot file --- plugins/Full_CI_ZMQ/energy.irp.f | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 plugins/Full_CI_ZMQ/energy.irp.f diff --git a/plugins/Full_CI_ZMQ/energy.irp.f b/plugins/Full_CI_ZMQ/energy.irp.f new file mode 100644 index 00000000..4999c176 --- /dev/null +++ b/plugins/Full_CI_ZMQ/energy.irp.f @@ -0,0 +1,11 @@ +BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] + implicit none + BEGIN_DOC + ! E0 in the denominator of the PT2 + END_DOC + pt2_E0_denominator(:) = CI_electronic_energy(:) +! pt2_E0_denominator(:) = HF_energy - nuclear_repulsion +! pt2_E0_denominator(:) = barycentric_electronic_energy(:) + call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') +END_PROVIDER + From 23e5036718d98ae8009c8f2a2eab38b367d0af58 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 13:33:36 +0100 Subject: [PATCH 22/76] Better parallelization of Davidson --- src/Davidson/u0Hu0.irp.f | 102 +++++++++++++++++++++------------------ 1 file changed, 55 insertions(+), 47 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 18004e02..e34ba3ce 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -344,50 +344,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(guided) - do sh=1,shortcut(0,1) - do sh2=sh,shortcut(0,1) - exa = 0 - do ni=1,Nint - exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) - end do - if(exa > 2) then - cycle - end if - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - if(sh==sh2) then - endi = i-1 - else - endi = shortcut(sh2+1,1)-1 - end if - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh2,1),endi - org_j = sort_idx(j,1) - ext = exa - do ni=1,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - end do - if(ext <= 4) then - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) - st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) - enddo - endif - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP DO SCHEDULE(guided) + !$OMP DO SCHEDULE(static,1) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -410,16 +367,67 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) end do end do enddo - !$OMP END DO + !$OMP END DO NOWAIT + do sh=1,shortcut(0,1) + !$OMP DO SCHEDULE(static,1) + do sh2=sh,shortcut(0,1) + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if - !$OMP CRITICAL + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1,1)-1 + end if + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),endi + ext = exa + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) + st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + enddo + endif + endif + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + enddo + + !$OMP CRITICAL (u0Hu0) do istate=1,N_st do i=n,1,-1 v_0(i,istate) = v_0(i,istate) + vt(istate,i) s_0(i,istate) = s_0(i,istate) + st(istate,i) enddo enddo - !$OMP END CRITICAL + !$OMP END CRITICAL (u0Hu0) deallocate(vt,st) !$OMP END PARALLEL From 8ef4332406326e1ae3d87d2a301f28c29874a37d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 15:50:28 +0100 Subject: [PATCH 23/76] Introduced CASSD ZMQ --- .travis.yml | 2 +- plugins/CAS_SD_ZMQ/README.rst | 14 + plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 234 ++++ plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f | 79 ++ plugins/CAS_SD_ZMQ/energy.irp.f | 11 + plugins/CAS_SD_ZMQ/ezfio_interface.irp.f | 4 + plugins/CAS_SD_ZMQ/run_selection_slave.irp.f | 156 +++ plugins/CAS_SD_ZMQ/selection.irp.f | 1202 ++++++++++++++++++ plugins/CAS_SD_ZMQ/selection_buffer.irp.f | 70 + plugins/CAS_SD_ZMQ/selection_types.f90 | 9 + plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES | 2 +- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 4 +- src/Integrals_Bielec/ao_bi_integrals.irp.f | 3 +- tests/bats/cassd.bats | 8 +- tests/bats/fci.bats | 6 +- tests/bats/pseudo.bats | 6 +- 16 files changed, 1794 insertions(+), 16 deletions(-) create mode 100644 plugins/CAS_SD_ZMQ/README.rst create mode 100644 plugins/CAS_SD_ZMQ/cassd_zmq.irp.f create mode 100644 plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f create mode 100644 plugins/CAS_SD_ZMQ/energy.irp.f create mode 100644 plugins/CAS_SD_ZMQ/ezfio_interface.irp.f create mode 100644 plugins/CAS_SD_ZMQ/run_selection_slave.irp.f create mode 100644 plugins/CAS_SD_ZMQ/selection.irp.f create mode 100644 plugins/CAS_SD_ZMQ/selection_buffer.irp.f create mode 100644 plugins/CAS_SD_ZMQ/selection_types.f90 diff --git a/.travis.yml b/.travis.yml index 5e032609..40c09bbc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -26,7 +26,7 @@ python: script: - ./configure --production ./config/gfortran.cfg - - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles + - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v diff --git a/plugins/CAS_SD_ZMQ/README.rst b/plugins/CAS_SD_ZMQ/README.rst new file mode 100644 index 00000000..45ba97e4 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/README.rst @@ -0,0 +1,14 @@ +========== +CAS_SD_ZMQ +========== + +Selected CAS+SD module with Zero-MQ parallelization. + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f new file mode 100644 index 00000000..eb2d911f --- /dev/null +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -0,0 +1,234 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: degree + + allocate (pt2(N_states)) + + pt2 = 1.d0 + diag_algorithm = "Lapack" + + if (N_det > N_det_max) then + call diagonalize_CI + call save_wavefunction + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1,N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E+PT2 = ', CI_energy(k) + pt2(k) + print *, '-----' + enddo + endif + double precision :: E_CI_before(N_states) + + + integer :: n_det_before + print*,'Beginning the selection ...' + E_CI_before(1:N_states) = CI_energy(1:N_states) + + do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) + n_det_before = N_det + call ZMQ_selection(max(256-N_det, N_det), pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo + print *, '-----' + if(N_states.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_states + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_states + print*,'Delta E = ',E_CI_before(i)+ pt2(i) - (E_CI_before(1) + pt2(1)) + enddo + endif + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + enddo + + integer :: exc_max, degree_min + exc_max = 0 + print *, 'CAS determinants : ', N_det_cas + do i=1,min(N_det_cas,10) + do k=i,N_det_cas + call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int) + exc_max = max(exc_max,degree) + enddo + print *, psi_cas_coef(i,:) + call debug_det(psi_cas(1,1,i),N_int) + print *, '' + enddo + print *, 'Max excitation degree in the CAS :', exc_max + + if(do_pt2_end)then + print*,'Last iteration only to compute the PT2' + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + TOUCH threshold_selectors threshold_generators + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ZMQ_selection(0, pt2) + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1,N_states + print *, 'State', k + print *, 'PT2 = ', pt2 + print *, 'E = ', E_CI_before + print *, 'E+PT2 = ', E_CI_before+pt2 + print *, '-----' + enddo + call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) + endif + call save_wavefunction + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) + +end + + + + +subroutine ZMQ_selection(N_in, pt2) + use f77_zmq + use selection_types + + implicit none + + character*(512) :: task + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer, intent(in) :: N_in + type(selection_buffer) :: b + integer :: i, N + integer, external :: omp_get_thread_num + double precision, intent(out) :: pt2(N_states) + + + if (.True.) then + PROVIDE pt2_e0_denominator + N = max(N_in,1) + provide nproc + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call zmq_set_running(zmq_to_qp_run_socket) + call create_selection_buffer(N, N*2, b) + endif + + integer :: i_generator, i_generator_start, i_generator_max, step +! step = int(max(1.,10*elec_num/mo_tot_num) + + step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) + step = max(1,step) + do i= N_det_generators, 1, -step + i_generator_start = max(i-step+1,1) + i_generator_max = i + write(task,*) i_generator_start, i_generator_max, 1, N + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + end do + + !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(b, pt2) + else + call selection_slave_inproc(i) + endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'selection') + if (N_in > 0) then + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN + call copy_H_apply_buffer_to_wf() + if (s2_eig) then + call make_s2_eigenfunction + endif + endif +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(b, pt2) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + type(selection_buffer), intent(inout) :: b + double precision, intent(out) :: pt2(N_states) + double precision :: pt2_mwen(N_states) + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + integer :: done + real :: time, time0 + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) + done = 0 + more = 1 + pt2(:) = 0d0 + call CPU_TIME(time0) + do while (more == 1) + call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) + pt2 += pt2_mwen + do i=1, N + call add_to_selection_buffer(b, det(1,1,i), val(i)) + end do + + do i=1, ntask + if(task_id(i) == 0) then + print *, "Error in collector" + endif + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) + end do + done += ntask + call CPU_TIME(time) +! print *, "DONE" , done, time - time0 + end do + + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + call sort_selection_buffer(b) +end subroutine + diff --git a/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f b/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f new file mode 100644 index 00000000..fec480f0 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f @@ -0,0 +1,79 @@ + +use bitmasks + BEGIN_PROVIDER [integer, exc_degree_per_selectors, (N_det_selectors)] +&BEGIN_PROVIDER [integer, double_index_selectors, (N_det_selectors)] +&BEGIN_PROVIDER [integer, n_double_selectors] + implicit none + BEGIN_DOC + ! degree of excitation respect to Hartree Fock for the wave function + ! + ! for the all the selectors determinants + ! + ! double_index_selectors = list of the index of the double excitations + ! + ! n_double_selectors = number of double excitations in the selectors determinants + END_DOC + integer :: i,degree + n_double_selectors = 0 + do i = 1, N_det_selectors + call get_excitation_degree(psi_selectors(1,1,i),ref_bitmask,degree,N_int) + exc_degree_per_selectors(i) = degree + if(degree==2)then + n_double_selectors += 1 + double_index_selectors(n_double_selectors) =i + endif + enddo +END_PROVIDER + + BEGIN_PROVIDER[double precision, coef_hf_selector] + &BEGIN_PROVIDER[double precision, inv_selectors_coef_hf] + &BEGIN_PROVIDER[double precision, inv_selectors_coef_hf_squared] + &BEGIN_PROVIDER[double precision, E_corr_per_selectors, (N_det_selectors)] + &BEGIN_PROVIDER[double precision, i_H_HF_per_selectors, (N_det_selectors)] + &BEGIN_PROVIDER[double precision, Delta_E_per_selector, (N_det_selectors)] + &BEGIN_PROVIDER[double precision, E_corr_double_only ] + &BEGIN_PROVIDER[double precision, E_corr_second_order ] + implicit none + BEGIN_DOC + ! energy of correlation per determinant respect to the Hartree Fock determinant + ! + ! for the all the double excitations in the selectors determinants + ! + ! E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + ! + ! E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + ! + ! coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + END_DOC + PROVIDE ref_bitmask_energy psi_selectors ref_bitmask N_int psi_selectors + integer :: i,degree + double precision :: hij,diag_H_mat_elem + E_corr_double_only = 0.d0 + E_corr_second_order = 0.d0 + do i = 1, N_det_selectors + if(exc_degree_per_selectors(i)==2)then + call i_H_j(ref_bitmask,psi_selectors(1,1,i),N_int,hij) + i_H_HF_per_selectors(i) = hij + E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij + E_corr_double_only += E_corr_per_selectors(i) +! E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int)) + elseif(exc_degree_per_selectors(i) == 0)then + coef_hf_selector = psi_selectors_coef(i,1) + E_corr_per_selectors(i) = -1000.d0 + Delta_E_per_selector(i) = 0.d0 + else + E_corr_per_selectors(i) = -1000.d0 + endif + enddo + if (dabs(coef_hf_selector) > 1.d-8) then + inv_selectors_coef_hf = 1.d0/coef_hf_selector + inv_selectors_coef_hf_squared = inv_selectors_coef_hf * inv_selectors_coef_hf + else + inv_selectors_coef_hf = 0.d0 + inv_selectors_coef_hf_squared = 0.d0 + endif + do i = 1,n_double_selectors + E_corr_per_selectors(double_index_selectors(i)) *=inv_selectors_coef_hf + enddo + E_corr_double_only = E_corr_double_only * inv_selectors_coef_hf + END_PROVIDER diff --git a/plugins/CAS_SD_ZMQ/energy.irp.f b/plugins/CAS_SD_ZMQ/energy.irp.f new file mode 100644 index 00000000..4999c176 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/energy.irp.f @@ -0,0 +1,11 @@ +BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] + implicit none + BEGIN_DOC + ! E0 in the denominator of the PT2 + END_DOC + pt2_E0_denominator(:) = CI_electronic_energy(:) +! pt2_E0_denominator(:) = HF_energy - nuclear_repulsion +! pt2_E0_denominator(:) = barycentric_electronic_energy(:) + call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') +END_PROVIDER + diff --git a/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f b/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f new file mode 100644 index 00000000..8adab518 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f @@ -0,0 +1,4 @@ +! DO NOT MODIFY BY HAND +! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py +! from file /home/scemama/quantum_package/src/CAS_SD_ZMQ/EZFIO.cfg + diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f new file mode 100644 index 00000000..36550116 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f @@ -0,0 +1,156 @@ + +subroutine run_selection_slave(thread,iproc,energy) + use f77_zmq + use selection_types + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, task_id(1), ctask, ltask + character*(512) :: task + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + type(selection_buffer) :: buf, buf2 + logical :: done + double precision :: pt2(N_states) + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + if(worker_id == -1) then + print *, "WORKER -1" + !call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + return + end if + buf%N = 0 + ctask = 1 + pt2 = 0d0 + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) + done = task_id(ctask) == 0 + if (done) then + ctask = ctask - 1 + else + integer :: i_generator, i_generator_start, i_generator_max, step, N + read (task,*) i_generator_start, i_generator_max, step, N + if(buf%N == 0) then + ! Only first time + call create_selection_buffer(N, N*2, buf) + call create_selection_buffer(N, N*3, buf2) + else + if(N /= buf%N) stop "N changed... wtf man??" + end if + !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) + !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) + do i_generator=i_generator_start,i_generator_max,step + call select_connected(i_generator,energy,pt2,buf) + enddo + endif + + if(done .or. ctask == size(task_id)) then + if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer" + do i=1, ctask + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) + end do + if(ctask > 0) then + call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) + do i=1,buf%cur + call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) + enddo + call sort_selection_buffer(buf2) + buf%mini = buf2%mini + pt2 = 0d0 + buf%cur = 0 + end if + ctask = 0 + end if + + if(done) exit + ctask = ctask + 1 + end do + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) +end subroutine + + +subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(in) :: pt2(N_states) + type(selection_buffer), intent(inout) :: b + integer, intent(in) :: ntask, task_id(*) + integer :: rc + + call sort_selection_buffer(b) + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE) + if(rc /= 8*N_states) stop "push" + + rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE) + if(rc /= 8*b%cur) stop "push" + + rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE) + if(rc /= bit_kind*N_int*2*b%cur) stop "push" + + rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + + rc = f77_zmq_send( zmq_socket_push, task_id(1), ntask*4, 0) + if(rc /= 4*ntask) stop "push" + +! Activate is zmq_socket_push is a REQ +! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) +end subroutine + + +subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, ntask) + use f77_zmq + use selection_types + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + double precision, intent(inout) :: pt2(N_states) + double precision, intent(out) :: val(*) + integer(bit_kind), intent(out) :: det(N_int, 2, *) + integer, intent(out) :: N, ntask, task_id(*) + integer :: rc, rn, i + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0) + if(rc /= 8*N_states) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0) + if(rc /= 8*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0) + if(rc /= bit_kind*N_int*2*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntask*4, 0) + if(rc /= 4*ntask) stop "pull" + +! Activate is zmq_socket_pull is a REP +! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) +end subroutine + + + diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f new file mode 100644 index 00000000..6e7ba359 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -0,0 +1,1202 @@ +use bitmasks + + +double precision function integral8(i,j,k,l) + implicit none + + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif +end function + + +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] + use bitmasks + implicit none + + integer :: i + do i=1, N_det + call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert fail: "//msg + stop + end if +end subroutine + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) + integer :: s, ni, i + logical :: change + + phasemask = 0_1 + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 + end do + end do + end do +end subroutine + + +subroutine select_connected(i_generator,E0,pt2,b) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + enddo + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + enddo +end subroutine + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer(1) :: np + double precision, parameter :: res(0:1) = (/1d0, -1d0/) + + np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) + if(p1 < h1) np = np + 1_1 + if(p2 < h2) np = np + 1_1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 + get_phase_bi = res(iand(np,1_1)) +end subroutine + + + +! Selection single +! ---------------- + +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_gen + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, j, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + bannedOrb = .true. + do j=1,N_particles(sp) + bannedOrb(particle_list(j, sp)) = .false. + end do + call spot_hasBeen(mask, sp, psi_selectors, i_gen, N_det, bannedOrb, fullMatch) + if(fullMatch) cycle + vect = 0d0 + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp + double precision, external :: diag_H_mat_elem_fock + + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, sp, p1, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + val = vect(istate, p1) + vect(istate, p1) + delta_E = E0(istate) - Hii + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) + end do +end subroutine + + +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do +end subroutine + + + + +! Selection double +! ---------------- + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + preinteresting(0) = 0 + prefullinteresting(0) = 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)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_selectors(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + 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) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_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) +! logical :: bandon +! +! bandon = .false. + mat = 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 ! interesting(0) + !i = interesting(ii) + + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + 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 = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + 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 = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + 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 = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + 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 = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_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 + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, 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 = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/CAS_SD_ZMQ/selection_buffer.irp.f b/plugins/CAS_SD_ZMQ/selection_buffer.irp.f new file mode 100644 index 00000000..2bcb11d3 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_buffer.irp.f @@ -0,0 +1,70 @@ + +subroutine create_selection_buffer(N, siz, res) + use selection_types + implicit none + + integer, intent(in) :: N, siz + type(selection_buffer), intent(out) :: res + + allocate(res%det(N_int, 2, siz), res%val(siz)) + + res%val = 0d0 + res%det = 0_8 + res%N = N + res%mini = 0d0 + res%cur = 0 +end subroutine + + +subroutine add_to_selection_buffer(b, det, val) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + integer(bit_kind), intent(in) :: det(N_int, 2) + double precision, intent(in) :: val + integer :: i + + if(dabs(val) >= b%mini) then + b%cur += 1 + b%det(:,:,b%cur) = det(:,:) + b%val(b%cur) = val + if(b%cur == size(b%val)) then + call sort_selection_buffer(b) + end if + end if +end subroutine + + +subroutine sort_selection_buffer(b) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + double precision, allocatable :: vals(:), absval(:) + integer, allocatable :: iorder(:) + integer(bit_kind), allocatable :: detmp(:,:,:) + integer :: i, nmwen + logical, external :: detEq + nmwen = min(b%N, b%cur) + + + allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen)) + absval = -dabs(b%val(:b%cur)) + do i=1,b%cur + iorder(i) = i + end do + call dsort(absval, iorder, b%cur) + + do i=1, nmwen + detmp(:,:,i) = b%det(:,:,iorder(i)) + vals(i) = b%val(iorder(i)) + end do + b%det(:,:,:nmwen) = detmp(:,:,:) + b%det(:,:,nmwen+1:) = 0_bit_kind + b%val(:nmwen) = vals(:) + b%val(nmwen+1:) = 0d0 + b%mini = max(b%mini,dabs(b%val(b%N))) + b%cur = nmwen +end subroutine + diff --git a/plugins/CAS_SD_ZMQ/selection_types.f90 b/plugins/CAS_SD_ZMQ/selection_types.f90 new file mode 100644 index 00000000..9506629c --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_types.f90 @@ -0,0 +1,9 @@ +module selection_types + type selection_buffer + integer :: N, cur + integer(8), allocatable :: det(:,:,:) + double precision, allocatable :: val(:) + double precision :: mini + endtype +end module + diff --git a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES index cb6ff46e..7ff203d4 100644 --- a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full ZMQ Full_CI +Perturbation Selectors_full Generators_full ZMQ diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index e03db458..8b9488d2 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -79,7 +79,7 @@ program fci_zmq enddo endif E_CI_before(1:N_states) = CI_energy(1:N_states) - call ezfio_set_full_ci_energy(CI_energy) + call ezfio_set_full_ci_zmq_energy(CI_energy) enddo if(do_pt2_end)then @@ -99,7 +99,7 @@ program fci_zmq print *, 'E+PT2 = ', E_CI_before+pt2 print *, '-----' enddo - call ezfio_set_full_ci_energy_pt2(E_CI_before+pt2) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2) endif call save_wavefunction end diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index d8a18437..68a7a050 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -350,8 +350,7 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] integral = ao_bielec_integral(1,1,1,1) real :: map_mb - print*, 'read_ao_integrals',read_ao_integrals - print*, 'disk_access_ao_integrals',disk_access_ao_integrals + PROVIDE read_ao_integrals disk_access_ao_integrals if (read_ao_integrals) then print*,'Reading the AO integrals' call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map) diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 07d79f1a..44b44ee6 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -3,15 +3,15 @@ source $QP_ROOT/tests/bats/common.bats.sh @test "CAS_SD H2O cc-pVDZ" { - test_exe cas_sd_selected || skip + test_exe cassd_zmq || skip INPUT=h2o.ezfio qp_edit -c $INPUT ezfio set_file $INPUT ezfio set perturbation do_pt2_end False - ezfio set determinants n_det_max 1000 + ezfio set determinants n_det_max 2000 qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" - qp_run cas_sd_selected $INPUT - energy="$(ezfio get cas_sd energy)" + qp_run cassd_zmq $INPUT + energy="$(ezfio get cas_sd_zmq energy)" eq $energy -76.2221842108163 1.E-5 } diff --git a/tests/bats/fci.bats b/tests/bats/fci.bats index 174c8f61..79ff91ab 100644 --- a/tests/bats/fci.bats +++ b/tests/bats/fci.bats @@ -20,7 +20,7 @@ function run_FCI() { function run_FCI_ZMQ() { thresh=5.e-5 - test_exe full_ci || skip + test_exe fci_zmq || skip qp_edit -c $1 ezfio set_file $1 ezfio set perturbation do_pt2_end True @@ -28,9 +28,9 @@ function run_FCI_ZMQ() { ezfio set davidson threshold_davidson 1.e-10 qp_run fci_zmq $1 - energy="$(ezfio get full_ci energy)" + energy="$(ezfio get full_ci_zmq energy)" eq $energy $3 $thresh - energy_pt2="$(ezfio get full_ci energy_pt2)" + energy_pt2="$(ezfio get full_ci_zmq energy_pt2)" eq $energy_pt2 $4 $thresh } diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats index 8cccf229..a20b0842 100644 --- a/tests/bats/pseudo.bats +++ b/tests/bats/pseudo.bats @@ -23,7 +23,7 @@ function run_HF() { function run_FCI_ZMQ() { thresh=5.e-5 - test_exe full_ci || skip + test_exe fci_zmq|| skip qp_edit -c $1 ezfio set_file $1 ezfio set perturbation do_pt2_end True @@ -31,9 +31,9 @@ function run_FCI_ZMQ() { ezfio set davidson threshold_davidson 1.e-10 qp_run fci_zmq $1 - energy="$(ezfio get full_ci energy)" + energy="$(ezfio get full_ci_zmq energy)" eq $energy $3 $thresh - energy_pt2="$(ezfio get full_ci energy_pt2)" + energy_pt2="$(ezfio get full_ci_zmq energy_pt2)" eq $energy_pt2 $4 $thresh } From 5e1b0775761e333c2416a1f103d5c5dba1d096e2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:41:30 +0100 Subject: [PATCH 24/76] CAS_SD_ZMQ works with is_in_wavefunction --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 1 + plugins/CAS_SD_ZMQ/selection.irp.f | 12 +++++++++++- src/Determinants/H_apply.irp.f | 4 +++- 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index eb2d911f..01e57649 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -164,6 +164,7 @@ subroutine ZMQ_selection(N_in, pt2) if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() +call remove_duplicates_in_psi_det if (s2_eig) then call make_s2_eigenfunction endif diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index 6e7ba359..39131520 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -202,6 +202,10 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, if(vect(1, p1) == 0d0) cycle call apply_particle(mask, sp, p1, det, ok, N_int) +logical, external :: is_in_wavefunction +if (is_in_wavefunction(det,N_int)) then + cycle +endif Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) max_e_pert = 0d0 @@ -218,7 +222,9 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert end do - if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + endif end do end subroutine @@ -669,6 +675,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if(banned(p1,p2)) cycle if(mat(1, p1, p2) == 0d0) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) +logical, external :: is_in_wavefunction +if (is_in_wavefunction(det,N_int)) then + cycle +endif Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 88affa21..411fe703 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -258,12 +258,14 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) k += 1 psi_det(:,:,k) = psi_det_sorted_bit (:,:,i) psi_coef(k,:) = psi_coef_sorted_bit(i,:) + else + call debug_det(psi_det_sorted_bit(1,1,i),N_int) + stop 'duplicates in psi_det' endif enddo N_det = k call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') SOFT_TOUCH N_det psi_det psi_coef - stop 'duplicates in psi_det' endif deallocate (duplicate,bit_tmp) end From 1de1e540fe07abbf25d8e4b1b079f473b378349e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:48:46 +0100 Subject: [PATCH 25/76] Forgot file --- plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES diff --git a/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..ae599426 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES @@ -0,0 +1,2 @@ +Generators_CAS Perturbation Selectors_CASSD ZMQ + From 576d4df3fb1128d3f581fc286d790dc42558425f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:49:22 +0100 Subject: [PATCH 26/76] Forgot file --- .../Selectors_CASSD/NEEDED_CHILDREN_MODULES | 1 + plugins/Selectors_CASSD/README.rst | 12 ++ plugins/Selectors_CASSD/selectors.irp.f | 95 ++++++++++++++ plugins/Selectors_CASSD/zmq.irp.f | 123 ++++++++++++++++++ 4 files changed, 231 insertions(+) create mode 100644 plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES create mode 100644 plugins/Selectors_CASSD/README.rst create mode 100644 plugins/Selectors_CASSD/selectors.irp.f create mode 100644 plugins/Selectors_CASSD/zmq.irp.f diff --git a/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES b/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ + diff --git a/plugins/Selectors_CASSD/README.rst b/plugins/Selectors_CASSD/README.rst new file mode 100644 index 00000000..19b4ec2b --- /dev/null +++ b/plugins/Selectors_CASSD/README.rst @@ -0,0 +1,12 @@ +=============== +Selectors_CASSD +=============== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/Selectors_CASSD/selectors.irp.f b/plugins/Selectors_CASSD/selectors.irp.f new file mode 100644 index 00000000..9263b706 --- /dev/null +++ b/plugins/Selectors_CASSD/selectors.irp.f @@ -0,0 +1,95 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, psi_selectors_size ] + implicit none + psi_selectors_size = psi_det_size +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 + N_det_selectors = N_det +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) ] + implicit none + BEGIN_DOC + ! Determinants on which we apply for perturbation. + END_DOC + integer :: i, k, l, m + logical :: good + + do i=1,N_det_generators + do k=1,N_int + psi_selectors(k,1,i) = psi_det_generators(k,1,i) + psi_selectors(k,2,i) = psi_det_generators(k,2,i) + enddo + enddo + do k=1,N_states + do i=1,N_det_selectors + psi_selectors_coef(i,k) = psi_coef_generators(i,k) + enddo + enddo + + m=N_det_generators + + do i=1,N_det + do l=1,n_cas_bitmask + good = .True. + do k=1,N_int + good = good .and. ( & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) + enddo + if (good) then + exit + endif + enddo + if (.not.good) then + m = m+1 + do k=1,N_int + psi_selectors(k,1,m) = psi_det_sorted(k,1,i) + psi_selectors(k,2,m) = psi_det_sorted(k,2,i) + enddo + psi_selectors_coef(m,:) = psi_coef_sorted(m,:) + endif + enddo + if (N_det /= m) then + print *, N_det, m + stop 'N_det /= m' + endif +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,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) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ] + implicit none + BEGIN_DOC + ! Diagonal elements of the H matrix for each selectors + END_DOC + integer :: i + double precision :: diag_H_mat_elem + do i = 1, N_det_selectors + psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int) + enddo +END_PROVIDER + + diff --git a/plugins/Selectors_CASSD/zmq.irp.f b/plugins/Selectors_CASSD/zmq.irp.f new file mode 100644 index 00000000..8046212b --- /dev/null +++ b/plugins/Selectors_CASSD/zmq.irp.f @@ -0,0 +1,123 @@ +subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) + use f77_zmq + implicit none + BEGIN_DOC +! Put the wave function on the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer, intent(in) :: size_energy + double precision, intent(out) :: energy(size_energy) + integer :: rc + character*(256) :: msg + + write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors + + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) + if (rc /= len(trim(msg))) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) + if (rc /= N_int*2*N_det*bit_kind) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) + if (rc /= psi_det_size*N_states*8) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0) + if (rc /= size_energy*8) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:rc) /= 'put_psi_reply 1') then + print *, rc, trim(msg) + print *, 'Error in put_psi_reply' + stop 'error' + endif + +end + + + +subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) + use f77_zmq + implicit none + BEGIN_DOC +! Get the wave function from the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer, intent(in) :: size_energy + double precision, intent(out) :: energy(size_energy) + integer :: rc + character*(64) :: msg + + write(msg,*) 'get_psi ', worker_id + + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) + if (rc /= len(trim(msg))) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:13) /= 'get_psi_reply') then + print *, rc, trim(msg) + print *, 'Error in get_psi_reply' + stop 'error' + endif + + integer :: N_states_read, N_det_read, psi_det_size_read + integer :: N_det_selectors_read, N_det_generators_read + read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & + N_det_generators_read, N_det_selectors_read + if (rc /= worker_id) then + print *, 'Wrong worker ID' + stop 'error' + endif + + N_states = N_states_read + N_det = N_det_read + psi_det_size = psi_det_size_read + TOUCH psi_det_size N_det N_states + + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) + if (rc /= N_int*2*N_det*bit_kind) then + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) + if (rc /= psi_det_size*N_states*8) then + print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + stop 'error' + endif + TOUCH psi_det psi_coef + + rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0) + if (rc /= size_energy*8) then + print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' + stop 'error' + endif + + if (N_det_generators_read > 0) then + N_det_generators = N_det_generators_read + TOUCH N_det_generators + endif + if (N_det_selectors_read > 0) then + N_det_selectors = N_det_selectors_read + TOUCH N_det_selectors + endif + +end + + From 9dcc0ba7d92ca07d1532519c7a35db825812a5b8 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:55:33 +0100 Subject: [PATCH 27/76] Forgot file --- plugins/Full_CI_ZMQ/EZFIO.cfg | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 plugins/Full_CI_ZMQ/EZFIO.cfg diff --git a/plugins/Full_CI_ZMQ/EZFIO.cfg b/plugins/Full_CI_ZMQ/EZFIO.cfg new file mode 100644 index 00000000..26f1a8e5 --- /dev/null +++ b/plugins/Full_CI_ZMQ/EZFIO.cfg @@ -0,0 +1,11 @@ +[energy] +type: double precision +doc: Calculated Selected FCI energy +interface: ezfio + +[energy_pt2] +type: double precision +doc: Calculated FCI energy + PT2 +interface: ezfio + + From 5e99f335ba5344a3f4cdc9308f380ebc65eedee4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:58:21 +0100 Subject: [PATCH 28/76] Forgot file --- plugins/CAS_SD_ZMQ/EZFIO.cfg | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 plugins/CAS_SD_ZMQ/EZFIO.cfg diff --git a/plugins/CAS_SD_ZMQ/EZFIO.cfg b/plugins/CAS_SD_ZMQ/EZFIO.cfg new file mode 100644 index 00000000..7425c8ba --- /dev/null +++ b/plugins/CAS_SD_ZMQ/EZFIO.cfg @@ -0,0 +1,10 @@ +[energy] +type: double precision +doc: "Calculated CAS-SD energy" +interface: ezfio + +[energy_pt2] +type: double precision +doc: "Calculated selected CAS-SD energy with PT2 correction" +interface: ezfio + From 4bd6cdee2378ed3f19d56c3fd11e3dc1660f2cd0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 18:55:20 +0100 Subject: [PATCH 29/76] Updated tests --- tests/bats/cassd.bats | 4 ++-- tests/bats/mrcepa0.bats | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 44b44ee6..bbc2e1eb 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -8,10 +8,10 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_edit -c $INPUT ezfio set_file $INPUT ezfio set perturbation do_pt2_end False - ezfio set determinants n_det_max 2000 + ezfio set determinants n_det_max 1000 qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2221842108163 1.E-5 + eq $energy -76.2220702263996 1.E-5 } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index 8b56c606..77c1b756 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -65,6 +65,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.23199784430074 1.e-4 + eq $energy -76.2318658231035 1.e-4 } From ecd9ffd48d0bc9f111e761f81fcc0e18fcf86f8f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 19:19:00 +0100 Subject: [PATCH 30/76] Removed QP_TASK_DEBUG in tests --- tests/run_tests.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 4664ce82..9e560d38 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -14,7 +14,7 @@ mrcepa0.bats export QP_PREFIX="timeout -s 9 300" -export QP_TASK_DEBUG=1 +#export QP_TASK_DEBUG=1 rm -rf work output From 40d5274daebefa652d2a8ba7d5634fa16260c48c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 19:32:53 +0100 Subject: [PATCH 31/76] logical comparisons with .eqv. --- .travis.yml | 2 +- plugins/FOBOCI/SC2_1h1p.irp.f | 2 +- plugins/loc_cele/loc_exchange_int.irp.f | 6 +++--- plugins/loc_cele/loc_exchange_int_act.irp.f | 2 +- plugins/loc_cele/loc_exchange_int_inact.irp.f | 2 +- plugins/loc_cele/loc_exchange_int_virt.irp.f | 2 +- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.travis.yml b/.travis.yml index 40c09bbc..57991ba3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,7 +25,7 @@ python: - "2.6" script: - - ./configure --production ./config/gfortran.cfg + - ./configure --production ./config/travis.cfg - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f index b9378575..7733831c 100644 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -210,7 +210,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni integer, intent(in) :: dim_in, sze, N_st, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: diag_H_elements(dim_in) + double precision, intent(out) :: diag_H_elements(0:dim_in) double precision, intent(in) :: convergence integer :: i,j,k,l diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f index d7cc5c65..8bb47d89 100644 --- a/plugins/loc_cele/loc_exchange_int.irp.f +++ b/plugins/loc_cele/loc_exchange_int.irp.f @@ -14,7 +14,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb @@ -46,7 +46,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb @@ -78,7 +78,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f index b9bbeb82..f332dd5d 100644 --- a/plugins/loc_cele/loc_exchange_int_act.irp.f +++ b/plugins/loc_cele/loc_exchange_int_act.irp.f @@ -15,7 +15,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_inact.irp.f b/plugins/loc_cele/loc_exchange_int_inact.irp.f index 2ff3c85f..fcf20ced 100644 --- a/plugins/loc_cele/loc_exchange_int_inact.irp.f +++ b/plugins/loc_cele/loc_exchange_int_inact.irp.f @@ -14,7 +14,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_virt.irp.f b/plugins/loc_cele/loc_exchange_int_virt.irp.f index 333f189b..8302b5d2 100644 --- a/plugins/loc_cele/loc_exchange_int_virt.irp.f +++ b/plugins/loc_cele/loc_exchange_int_virt.irp.f @@ -15,7 +15,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb From 2b86f755278a07e144959dcdb01adee88d38a1c6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 19:43:07 +0100 Subject: [PATCH 32/76] Fixed travis tests --- plugins/CAS_SD_ZMQ/energy.irp.f | 6 +++--- plugins/Full_CI_ZMQ/energy.irp.f | 6 +++--- plugins/mrcepa0/mrcepa0_general.irp.f | 3 +-- tests/bats/cassd.bats | 2 +- tests/bats/foboci.bats | 8 ++++---- tests/bats/hf.bats | 14 +++++++------- tests/bats/mrcepa0.bats | 2 +- 7 files changed, 20 insertions(+), 21 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/energy.irp.f b/plugins/CAS_SD_ZMQ/energy.irp.f index 4999c176..db1e7d1a 100644 --- a/plugins/CAS_SD_ZMQ/energy.irp.f +++ b/plugins/CAS_SD_ZMQ/energy.irp.f @@ -3,9 +3,9 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] BEGIN_DOC ! E0 in the denominator of the PT2 END_DOC - pt2_E0_denominator(:) = CI_electronic_energy(:) -! pt2_E0_denominator(:) = HF_energy - nuclear_repulsion -! pt2_E0_denominator(:) = barycentric_electronic_energy(:) + pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states) +! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion +! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') END_PROVIDER diff --git a/plugins/Full_CI_ZMQ/energy.irp.f b/plugins/Full_CI_ZMQ/energy.irp.f index 4999c176..db1e7d1a 100644 --- a/plugins/Full_CI_ZMQ/energy.irp.f +++ b/plugins/Full_CI_ZMQ/energy.irp.f @@ -3,9 +3,9 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] BEGIN_DOC ! E0 in the denominator of the PT2 END_DOC - pt2_E0_denominator(:) = CI_electronic_energy(:) -! pt2_E0_denominator(:) = HF_energy - nuclear_repulsion -! pt2_E0_denominator(:) = barycentric_electronic_energy(:) + pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states) +! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion +! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') END_PROVIDER diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index e3a2d1f5..25fe5f53 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -31,7 +31,6 @@ subroutine run(N_st,energy) call write_double(6,ci_energy_dressed(1),"Final MRCC energy") call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) call save_wavefunction - energy(:) = ci_energy_dressed(:) else E_new = 0.d0 delta_E = 1.d0 @@ -55,8 +54,8 @@ subroutine run(N_st,energy) endif enddo call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") - energy(:) = ci_energy_dressed(:) endif + energy(1:N_st) = ci_energy_dressed(1:N_st) end diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index bbc2e1eb..8e960b41 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -12,6 +12,6 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2220702263996 1.E-5 + eq $energy -76.2221338928418 1.E-5 } diff --git a/tests/bats/foboci.bats b/tests/bats/foboci.bats index 98255969..08032072 100644 --- a/tests/bats/foboci.bats +++ b/tests/bats/foboci.bats @@ -19,9 +19,9 @@ function run_all_1h_1p() { #=== DHNO -@test "all_1h_1p DHNO chipman-dzp" { - qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio - run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 -} +#@test "all_1h_1p DHNO chipman-dzp" { +# qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio +# run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 +#} diff --git a/tests/bats/hf.bats b/tests/bats/hf.bats index e280c986..3b9b1acd 100644 --- a/tests/bats/hf.bats +++ b/tests/bats/hf.bats @@ -23,13 +23,13 @@ function run_HF() { #=== DHNO -@test "init DHNO chipman-dzp" { - run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio -} - -@test "SCF DHNO chipman-dzp" { - run_HF dhno.ezfio -130.4278777822 -} +#@test "init DHNO chipman-dzp" { +# run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio +#} +# +#@test "SCF DHNO chipman-dzp" { +# run_HF dhno.ezfio -130.4278777822 +#} #=== HBO @test "init HBO STO-3G" { diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index 77c1b756..48b2d360 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -65,6 +65,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.2318658231035 1.e-4 + eq $energy -76.231997363623 1.e-4 } From 2b6a0b6c65159c171676b2b69ee23c1c253bab3b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 20:07:04 +0100 Subject: [PATCH 33/76] Added travis.cfg --- config/travis.cfg | 62 +++++++++++++++++++++++++++++++++++++++++ tests/bats/cassd.bats | 2 +- tests/bats/foboci.bats | 8 +++--- tests/bats/hf.bats | 14 +++++----- tests/bats/mrcepa0.bats | 8 +++--- 5 files changed, 78 insertions(+), 16 deletions(-) create mode 100644 config/travis.cfg diff --git a/config/travis.cfg b/config/travis.cfg new file mode 100644 index 00000000..024e330b --- /dev/null +++ b/config/travis.cfg @@ -0,0 +1,62 @@ +# Common flags +############## +# +# -ffree-line-length-none : Needed for IRPF90 which produces long lines +# -lblas -llapack : Link with libblas and liblapack libraries provided by the system +# -I . : Include the curent directory (Mandatory) +# +# --ninja : Allow the utilisation of ninja. (Mandatory) +# --align=32 : Align all provided arrays on a 32-byte boundary +# +# +[COMMON] +FC : gfortran -ffree-line-length-none -I . -g +LAPACK_LIB : -llapack -lblas +IRPF90 : irpf90 +IRPF90_FLAGS : --ninja --align=32 + +# Global options +################ +# +# 1 : Activate +# 0 : Deactivate +# +[OPTION] +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +CACHE : 1 ; Enable cache_compile.py +OPENMP : 1 ; Append OpenMP flags + +# Optimization flags +#################### +# +# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations. +# It also enables optimizations that are not valid +# for all standard-compliant programs. It turns on +# -ffast-math and the Fortran-specific +# -fno-protect-parens and -fstack-arrays. +[OPT] +FCFLAGS : -Ofast -march=native + +# Profiling flags +################# +# +[PROFILE] +FC : -p -g +FCFLAGS : -Ofast + +# Debugging flags +################# +# +# -fcheck=all : Checks uninitialized variables, array subscripts, etc... +# -g : Extra debugging information +# +[DEBUG] +FCFLAGS : -fcheck=all -g + +# OpenMP flags +################# +# +[OPENMP] +FC : -fopenmp +IRPF90_FLAGS : --openmp + diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 8e960b41..151997d2 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -12,6 +12,6 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2221338928418 1.E-5 + eq $energy -76.2219518185432 1.E-5 } diff --git a/tests/bats/foboci.bats b/tests/bats/foboci.bats index 08032072..98255969 100644 --- a/tests/bats/foboci.bats +++ b/tests/bats/foboci.bats @@ -19,9 +19,9 @@ function run_all_1h_1p() { #=== DHNO -#@test "all_1h_1p DHNO chipman-dzp" { -# qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio -# run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 -#} +@test "all_1h_1p DHNO chipman-dzp" { + qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio + run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 +} diff --git a/tests/bats/hf.bats b/tests/bats/hf.bats index 3b9b1acd..e280c986 100644 --- a/tests/bats/hf.bats +++ b/tests/bats/hf.bats @@ -23,13 +23,13 @@ function run_HF() { #=== DHNO -#@test "init DHNO chipman-dzp" { -# run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio -#} -# -#@test "SCF DHNO chipman-dzp" { -# run_HF dhno.ezfio -130.4278777822 -#} +@test "init DHNO chipman-dzp" { + run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio +} + +@test "SCF DHNO chipman-dzp" { + run_HF dhno.ezfio -130.4278777822 +} #=== HBO @test "init HBO STO-3G" { diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index 48b2d360..ef752b6b 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22903276183061 1.e-4 + eq $energy -76.22880979516251 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -33,7 +33,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22899302846875 1.e-4 + eq $energy -76.22879934337525 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -49,7 +49,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22647345292708 1.e-4 + eq $energy -76.2262119300426 1.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -65,6 +65,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.231997363623 1.e-4 + eq $energy -76.2315759851904 1.e-4 } From 9a9c5037bb1315ff5adf99136bcb09d7dd5084a3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 20:20:42 +0100 Subject: [PATCH 34/76] Fixed tests --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 1 - tests/bats/cassd.bats | 15 ++++++++++++--- tests/bats/mrcepa0.bats | 16 ++++++++-------- 3 files changed, 20 insertions(+), 12 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 01e57649..eb2d911f 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -164,7 +164,6 @@ subroutine ZMQ_selection(N_in, pt2) if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() -call remove_duplicates_in_psi_det if (s2_eig) then call make_s2_eigenfunction endif diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 151997d2..a1f1a736 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -5,13 +5,22 @@ source $QP_ROOT/tests/bats/common.bats.sh @test "CAS_SD H2O cc-pVDZ" { test_exe cassd_zmq || skip INPUT=h2o.ezfio + rm -rf work/h2o.ezfio/determinants/ qp_edit -c $INPUT ezfio set_file $INPUT - ezfio set perturbation do_pt2_end False - ezfio set determinants n_det_max 1000 + ezfio set perturbation do_pt2_end True + ezfio set determinants n_det_max 16384 qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT + energy="$(ezfio get cas_sd_zmq energy_pt2)" + eq $energy -76.2311177912495 2.E-5 + + ezfio set determinants n_det_max 2048 + ezfio set determinants read_wf True + ezfio set perturbation do_pt2_end True + qp_run cassd_zmq $INPUT + ezfio set determinants read_wf False energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2219518185432 1.E-5 + eq $energy -76.2300888408526 2.E-5 } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index ef752b6b..ed69681f 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -15,8 +15,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 1 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22880979516251 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.238562120457431 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -32,8 +32,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22879934337525 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.238527498388962 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -48,8 +48,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.2262119300426 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.235833732594187 1.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -64,7 +64,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.2315759851904 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.2418799284763 1.e-4 } From 80d0a9420e6d9fdfbebeb0243958b78d4db2fae6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 23:57:23 +0100 Subject: [PATCH 35/76] Corrected some bugs in MRCC --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 6 +-- plugins/MRCC_Utils/amplitudes.irp.f | 9 ++++ plugins/MRCC_Utils/mrcc_utils.irp.f | 83 +++++++++++++++-------------- plugins/mrcepa0/dressing.irp.f | 58 +++++++++++--------- 4 files changed, 90 insertions(+), 66 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index eb2d911f..92e7fe55 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -99,9 +99,9 @@ program fci_zmq print *, 'N_states = ', N_states do k=1,N_states print *, 'State', k - print *, 'PT2 = ', pt2 - print *, 'E = ', E_CI_before - print *, 'E+PT2 = ', E_CI_before+pt2 + print *, 'PT2 = ', pt2(k) + print *, 'E = ', E_CI_before(k) + print *, 'E+PT2 = ', E_CI_before(k)+pt2(k) print *, '-----' enddo call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 053527f7..82736b8f 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -191,6 +191,15 @@ END_PROVIDER end if end do + if (a_col == at_row) then + t(:) = t(:) + 1.d0 + endif + if (sum(dabs(t(:))) > 0.d0) then + wk = wk+1 + A_ind_mwen(wk) = a_col + A_val_mwen(:,wk) = t(:) + endif + end do if(wk /= 0) then diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 7005fa19..8b72ed29 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -77,18 +77,18 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] END_PROVIDER - BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] - implicit none - BEGIN_DOC - ! Dressing matrix in N_det basis - END_DOC - integer :: i,j,m - delta_ij = 0.d0 - delta_ii = 0.d0 - call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) - -END_PROVIDER +! BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] +!&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] +! implicit none +! BEGIN_DOC +! ! Dressing matrix in N_det basis +! END_DOC +! integer :: i,j,m +! delta_ij = 0.d0 +! delta_ii = 0.d0 +! call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) +! +!END_PROVIDER BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] @@ -139,7 +139,6 @@ END_PROVIDER integer :: mrcc_state - mrcc_state = N_states do j=1,min(N_states,N_det) do i=1,N_det CI_eigenvectors_dressed(i,j) = psi_coef(i,j) @@ -148,16 +147,28 @@ END_PROVIDER if (diag_algorithm == "Davidson") then -! call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,& -! size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state) - - call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,& - size(CI_eigenvectors_dressed,1), & - CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, & - output_determinants,mrcc_state) - + allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & + eigenvalues(size(CI_electronic_energy_dressed,1))) + do mrcc_state=N_states,1,-1 + do j=1,min(N_states,N_det) + do i=1,N_det + eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + call davidson_diag_mrcc_HS2(psi_det,eigenvectors,& + size(eigenvectors,1), & + eigenvalues,N_det,N_states,N_states_diag,N_int, & + output_determinants,mrcc_state) + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo + do mrcc_state=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& - N_states_diag,size(CI_eigenvectors_dressed,1)) + N_states_diag,size(CI_eigenvectors_dressed,1)) + deallocate (eigenvectors,eigenvalues) else if (diag_algorithm == "Lapack") then @@ -628,12 +639,12 @@ END_PROVIDER double precision :: phase - double precision, allocatable :: rho_mrcc_init(:,:) + double precision, allocatable :: rho_mrcc_init(:) integer :: a_coll, at_roww print *, "TI", hh_nex, N_det_non_ref - allocate(rho_mrcc_init(N_det_non_ref, N_states)) + allocate(rho_mrcc_init(N_det_non_ref)) allocate(x_new(hh_nex)) allocate(x(hh_nex), AtB(hh_nex)) x = 0d0 @@ -644,9 +655,8 @@ END_PROVIDER AtB(:) = 0.d0 !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, x, N_det_ref, hh_nex, N_det_non_ref) & - !$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& + !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) - allocate(A_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states)) !$OMP DO schedule(dynamic, 100) do at_roww = 1, n_exc_active ! hh_nex @@ -655,11 +665,11 @@ END_PROVIDER AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww) end do end do - !$OMP END DO NOWAIT - deallocate (A_ind_mwen, A_val_mwen) + !$OMP END DO + !$OMP END PARALLEL - x = 0d0 + X(:) = 0d0 do a_coll = 1, n_exc_active @@ -669,10 +679,7 @@ END_PROVIDER rho_mrcc_init = 0d0 - !$OMP PARALLEL default(shared) & - !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase) allocate(lref(N_det_ref)) - !$OMP DO schedule(static, 1) do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) cycle @@ -694,16 +701,14 @@ END_PROVIDER X(pp) = AtB(pp) / X(pp) do II=1,N_det_ref if(lref(II) > 0) then - rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp) + rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp) else if(lref(II) < 0) then - rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp) + rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp) end if end do end do end do - !$OMP END DO deallocate(lref) - !$OMP END PARALLEL x_new = x @@ -716,9 +721,9 @@ END_PROVIDER !$OMP DO do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i,s) + rho_mrcc(i,s) = rho_mrcc_init(i) enddo - !$OMP END DO + !$OMP END DO NOWAIT !$OMP DO do a_coll = 1, n_exc_active @@ -928,7 +933,7 @@ END_PROVIDER ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant - dIj_unique(:size(X), s) = X(:) + dIj_unique(1:size(X), s) = X(1:size(X)) end do END_PROVIDER diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 3646b0b2..9f041cd3 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -317,43 +317,53 @@ end &BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] use bitmasks implicit none - integer :: i, j, i_state + integer :: i, j, i_state !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - do i_state = 1, N_states - if(mrmode == 3) then + if(mrmode == 3) then do i = 1, N_det_ref - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + do i_state = 1, N_states + delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + enddo do j = 1, N_det_non_ref - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + do i_state = 1, N_states + delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + enddo end do end do -! -! do i = 1, N_det_ref -! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) -! do j = 1, N_det_non_ref -! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) -! end do -! end do - else if(mrmode == 2) then - do i = 1, N_det_ref + ! + ! do i = 1, N_det_ref + ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) + ! do j = 1, N_det_non_ref + ! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) + ! end do + ! end do + else if(mrmode == 2) then + do i = 1, N_det_ref + do i_state = 1, N_states delta_ii(i_state,i)= delta_ii_old(i_state,i) - do j = 1, N_det_non_ref + enddo + do j = 1, N_det_non_ref + do i_state = 1, N_states delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - end do + enddo end do - else if(mrmode == 1) then - do i = 1, N_det_ref + end do + else if(mrmode == 1) then + do i = 1, N_det_ref + do i_state = 1, N_states delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - do j = 1, N_det_non_ref + enddo + do j = 1, N_det_non_ref + do i_state = 1, N_states delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - end do + enddo end do - else - stop "invalid mrmode" - end if - end do + end do + else + stop "invalid mrmode" + end if END_PROVIDER From c366c201eb33cc75b8057a8416763236dfdd3ae3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 10:32:57 +0100 Subject: [PATCH 36/76] Corrected bug for multi-state MRCC --- plugins/MRCC_Utils/mrcc_utils.irp.f | 10 ++++++---- plugins/Psiref_Utils/psi_ref_utils.irp.f | 4 ++++ 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 8b72ed29..281b6760 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -684,6 +684,8 @@ END_PROVIDER do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) cycle lref = 0 + AtB(pp) = 0.d0 + X(pp) = 0.d0 do II=1,N_det_ref call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) if(.not. ok) cycle @@ -693,12 +695,12 @@ END_PROVIDER if(ind == -1) cycle ind = psi_non_ref_sorted_idx(ind) call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - X(pp) += psi_ref_coef(II,s)**2 + X(pp) = X(pp) + psi_ref_coef(II,s)*psi_ref_coef(II,s) AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase lref(II) = ind - if(phase < 0d0) lref(II) = -ind + if(phase < 0.d0) lref(II) = -ind end do - X(pp) = AtB(pp) / X(pp) + X(pp) = AtB(pp) do II=1,N_det_ref if(lref(II) > 0) then rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp) @@ -709,7 +711,7 @@ END_PROVIDER end do end do deallocate(lref) - + x_new = x double precision :: factor, resold diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index 41db2f10..c4147ebc 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -97,6 +97,10 @@ END_PROVIDER endif enddo N_det_non_ref = i_non_ref + if (N_det_non_ref < 1) then + print *, 'Error : All determinants are in the reference' + stop -1 + endif END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ] From ee658adeb707eda79a38321b59bbab8e30e575dd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 11:23:00 +0100 Subject: [PATCH 37/76] State following in MRCC --- plugins/MRCC_Utils/davidson.irp.f | 72 +++++++++++++++++------------ plugins/MRCC_Utils/mrcc_utils.irp.f | 14 +++--- 2 files changed, 50 insertions(+), 36 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 9d5e8a67..d8b0a2c3 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -628,7 +628,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: W(:,:), U(:,:), S(:,:), overlap(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -688,16 +688,17 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & - W(sze_8,N_st_diag*itermax), & - U(sze_8,N_st_diag*itermax), & - S(sze_8,N_st_diag*itermax), & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + overlap(N_st_diag*itermax,N_st_diag*itermax), & lambda(N_st_diag*itermax)) h = 0.d0 @@ -795,26 +796,39 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz s2(k) = s_(k,k) + S_z2_Sz enddo - if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) - do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + ! Compute overlap with U_in + ! ------------------------- + + integer :: coord(2), order(N_st) + overlap = -1.d0 + do k=1,N_st + do i=1,shift2 + overlap(i,k) = dabs(y(i,k)) enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo - endif - enddo - endif + enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(coord(1),coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) + endif + enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo ! Express eigenvectors of h in the determinant basis diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 281b6760..0735980d 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -149,7 +149,7 @@ END_PROVIDER allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & eigenvalues(size(CI_electronic_energy_dressed,1))) - do mrcc_state=N_states,1,-1 + do mrcc_state=1,N_states do j=1,min(N_states,N_det) do i=1,N_det eigenvectors(i,j) = psi_coef(i,j) @@ -161,10 +161,12 @@ END_PROVIDER output_determinants,mrcc_state) CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) - enddo - do mrcc_state=N_states+1,N_states_diag - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + if (mrcc_state == 1) then + do mrcc_state=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo + endif enddo call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& N_states_diag,size(CI_eigenvectors_dressed,1)) @@ -685,7 +687,6 @@ END_PROVIDER if(is_active_exc(pp)) cycle lref = 0 AtB(pp) = 0.d0 - X(pp) = 0.d0 do II=1,N_det_ref call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) if(.not. ok) cycle @@ -695,7 +696,6 @@ END_PROVIDER if(ind == -1) cycle ind = psi_non_ref_sorted_idx(ind) call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - X(pp) = X(pp) + psi_ref_coef(II,s)*psi_ref_coef(II,s) AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase lref(II) = ind if(phase < 0.d0) lref(II) = -ind From b13e351f59a98f123b1af50141567a4cb1c6d8bd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 11:35:15 +0100 Subject: [PATCH 38/76] Fixed MRCC --- plugins/MRCC_Utils/mrcc_dummy.irp.f | 4 ---- plugins/MRCC_Utils/mrcc_utils.irp.f | 6 +++--- 2 files changed, 3 insertions(+), 7 deletions(-) delete mode 100644 plugins/MRCC_Utils/mrcc_dummy.irp.f diff --git a/plugins/MRCC_Utils/mrcc_dummy.irp.f b/plugins/MRCC_Utils/mrcc_dummy.irp.f deleted file mode 100644 index 8f1deda8..00000000 --- a/plugins/MRCC_Utils/mrcc_dummy.irp.f +++ /dev/null @@ -1,4 +0,0 @@ -program pouet - - -end diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 0735980d..8ad922cf 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -162,9 +162,9 @@ END_PROVIDER CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) if (mrcc_state == 1) then - do mrcc_state=N_states+1,N_states_diag - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + do k=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) + CI_electronic_energy_dressed(k) = eigenvalues(k) enddo endif enddo From 83ff5065b9cb16648819170dd0304c7189d03d2f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 17:40:14 +0100 Subject: [PATCH 39/76] Corrected bug in CAS_SD --- plugins/CAS_SD_ZMQ/selection.irp.f | 5 ----- plugins/Selectors_CASSD/selectors.irp.f | 6 +++--- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index 39131520..f90ee488 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -202,11 +202,6 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, if(vect(1, p1) == 0d0) cycle call apply_particle(mask, sp, p1, det, ok, N_int) -logical, external :: is_in_wavefunction -if (is_in_wavefunction(det,N_int)) then - cycle -endif - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) max_e_pert = 0d0 diff --git a/plugins/Selectors_CASSD/selectors.irp.f b/plugins/Selectors_CASSD/selectors.irp.f index 9263b706..ab36527d 100644 --- a/plugins/Selectors_CASSD/selectors.irp.f +++ b/plugins/Selectors_CASSD/selectors.irp.f @@ -42,9 +42,9 @@ END_PROVIDER good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) enddo if (good) then @@ -57,7 +57,7 @@ END_PROVIDER psi_selectors(k,1,m) = psi_det_sorted(k,1,i) psi_selectors(k,2,m) = psi_det_sorted(k,2,i) enddo - psi_selectors_coef(m,:) = psi_coef_sorted(m,:) + psi_selectors_coef(m,:) = psi_coef_sorted(i,:) endif enddo if (N_det /= m) then From 508670f6935ad2ffbfa2496dd96577b431ff303b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 18:39:44 +0100 Subject: [PATCH 40/76] Corrected bug in multi-state MRCC --- plugins/MRCC_Utils/davidson.irp.f | 49 +++++++++++++++----------- plugins/MRCC_Utils/mrcc_utils.irp.f | 3 ++ plugins/mrcepa0/mrcc.irp.f | 10 +++++- plugins/mrcepa0/mrcepa0.irp.f | 12 ++++++- plugins/mrcepa0/mrcepa0_general.irp.f | 1 - plugins/mrcepa0/mrsc2.irp.f | 10 +++++- src/Davidson/diagonalization_hs2.irp.f | 14 ++------ 7 files changed, 63 insertions(+), 36 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index d8b0a2c3..8e0af39e 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -678,14 +678,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer, external :: align_double sze_8 = align_double(sze) - double precision :: delta - - if (s2_eig) then - delta = 1.d0 - else - delta = 0.d0 - endif - itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & W(sze_8,N_st_diag*itermax), & @@ -722,24 +714,17 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz converged = .False. double precision :: r1, r2 - do k=N_st+1,N_st_diag-2,2 + do k=N_st+1,N_st_diag 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) - u_in(i,k+1) = r1*dsin(r2) enddo enddo - do k=N_st_diag-1,N_st_diag - 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 + do k=1,N_st_diag + call normalize(u_in(1,k),sze) enddo @@ -796,14 +781,36 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz s2(k) = s_(k,k) + S_z2_Sz enddo + if (s2_eig) then + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + endif + + ! Compute overlap with U_in ! ------------------------- - integer :: coord(2), order(N_st) + integer :: coord(2), order(N_st_diag) overlap = -1.d0 - do k=1,N_st + do k=1,shift2 do i=1,shift2 - overlap(i,k) = dabs(y(i,k)) + overlap(k,i) = dabs(y(k,i)) enddo enddo do k=1,N_st diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 8ad922cf..f28ccf25 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -924,6 +924,9 @@ END_PROVIDER norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) + if (dsqrt(norm) > 1.d0) then + stop 'Error : Norm of the SD larger than the norm of the reference.' + endif do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f index 91592e62..a28d4be3 100644 --- a/plugins/mrcepa0/mrcc.irp.f +++ b/plugins/mrcepa0/mrcc.irp.f @@ -8,8 +8,16 @@ program mrsc2sub read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + TOUCH psi_coef + endif call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/plugins/mrcepa0/mrcepa0.irp.f b/plugins/mrcepa0/mrcepa0.irp.f index 34d3dec5..aeacbb39 100644 --- a/plugins/mrcepa0/mrcepa0.irp.f +++ b/plugins/mrcepa0/mrcepa0.irp.f @@ -8,8 +8,18 @@ program mrcepa0 read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + TOUCH psi_coef + endif + call print_cas_coefs + call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 25fe5f53..09c35e52 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -17,7 +17,6 @@ subroutine run(N_st,energy) double precision, allocatable :: lambda(:) allocate (lambda(N_states)) - thresh_mrcc = thresh_dressed_ci n_it_mrcc_max = n_it_max_dressed_ci diff --git a/plugins/mrcepa0/mrsc2.irp.f b/plugins/mrcepa0/mrsc2.irp.f index d0f44a33..948b1b5c 100644 --- a/plugins/mrcepa0/mrsc2.irp.f +++ b/plugins/mrcepa0/mrsc2.irp.f @@ -7,8 +7,16 @@ program mrsc2 mrmode = 2 read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + TOUCH psi_coef + endif call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index fddac471..102dcfb8 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -183,24 +183,16 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s converged = .False. double precision :: r1, r2 - do k=N_st+1,N_st_diag-2,2 + do k=N_st+1,N_st_diag 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) - u_in(i,k+1) = r1*dsin(r2) enddo enddo - do k=N_st_diag-1,N_st_diag - 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 + do k=1,N_st_diag + call normalize(u_in(1,k),sze) enddo From 3c230b42feec3eca2daf6f77c459b9360133c2f7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 10:17:37 +0100 Subject: [PATCH 41/76] Introduced davidson_diag_hjj_sjj_mmap --- src/Davidson/diagonalization_hs2.irp.f | 326 +++++++++++++++++++++++++ src/Davidson/u0Hu0.irp.f | 2 +- src/Utils/LinearAlgebra.irp.f | 29 ++- 3 files changed, 355 insertions(+), 2 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 102dcfb8..c3785d7f 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -46,6 +46,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d !$OMP END PARALLEL call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) +! call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) do i=1,N_st_diag s2_out(i) = S2_jj(i) enddo @@ -345,3 +346,328 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ) end +subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + use bitmasks + use mmap_module + implicit none + BEGIN_DOC + ! Davidson diagonalization with specific diagonal elements of the H matrix + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! S2_jj : specific diagonal S^2 matrix elements + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag : Number of states in which H is diagonalized. Assumed > sze + ! + ! iunit : Unit for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: H_jj(sze) + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st_diag) + + integer :: sze_8 + integer :: iter + integer :: i,j,k,l,m + logical :: converged + + double precision :: u_dot_v, u_dot_u + + integer :: k_pairs, kl + + integer :: iter2 + double precision, pointer :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) + double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) + double precision :: diag_h_mat_elem + double precision, allocatable :: residual_norm(:) + character*(16384) :: write_buffer + double precision :: to_print(3,N_st) + double precision :: cpu, wall + integer :: shift, shift2, itermax + include 'constants.include.F' + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda + if (N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 + endif + + PROVIDE nuclear_repulsion expected_s2 + + call write_time(iunit) + call wall_time(wall) + call cpu_time(cpu) + write(iunit,'(A)') '' + write(iunit,'(A)') 'Davidson Diagonalization' + write(iunit,'(A)') '------------------------' + write(iunit,'(A)') '' + call write_int(iunit,N_st,'Number of states') + call write_int(iunit,N_st_diag,'Number of states in diagonalization') + call write_int(iunit,sze,'Number of determinants') + write(iunit,'(A)') '' + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = ' Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy S^2 Residual' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + + integer, external :: align_double + integer :: fd(3) + type(c_ptr) :: c_pointer(3) + sze_8 = align_double(sze) + + itermax = min(davidson_sze_max, sze/N_st_diag) + + call mmap( & + trim(ezfio_work_dir)//'U', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(1), .False., c_pointer(1)) + call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) ) + + call mmap( & + trim(ezfio_work_dir)//'W', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(2), .False., c_pointer(2)) + call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) ) + + call mmap( & + trim(ezfio_work_dir)//'S', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(3), .False., c_pointer(3)) + call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) ) + + allocate( & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + residual_norm(N_st_diag), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + lambda(N_st_diag*itermax)) + + h = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 + U = 0.d0 + W = 0.d0 + S = 0.d0 + y = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + ! Davidson iterations + ! =================== + + converged = .False. + + double precision :: r1, r2 + do k=N_st+1,N_st_diag + do i=1,sze + call random_number(r1) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + do k=1,N_st_diag + call normalize(u_in(1,k),sze) + enddo + + + do while (.not.converged) + + do k=1,N_st_diag + do i=1,sze + U(i,k) = u_in(i,k) + enddo + enddo + + do iter=1,itermax-1 + + shift = N_st_diag*(iter-1) + shift2 = N_st_diag*iter + + call ortho_qr(U,size(U,1),sze,shift2) + + ! Compute |W_k> = \sum_i |i> + ! ----------------------------------------- + + +! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) + call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) + + + ! Compute h_kl = = + ! ------------------------------------------- + + do k=1,iter + shift = N_st_diag*(k-1) + call dgemm('T','N', N_st_diag, shift2, sze, & + 1.d0, U(1,shift+1), size(U,1), W, size(W,1), & + 0.d0, h(shift+1,1), size(h,1)) + + call dgemm('T','N', N_st_diag, shift2, sze, & + 1.d0, U(1,shift+1), size(U,1), S, size(S,1), & + 0.d0, s_(shift+1,1), size(s_,1)) + enddo + + + ! Diagonalize h + ! ------------- + call lapack_diag(lambda,y,h,size(h,1),shift2) + + ! Compute S2 for each eigenvector + ! ------------------------------- + + call dgemm('N','N',shift2,shift2,shift2, & + 1.d0, s_, size(s_,1), y, size(y,1), & + 0.d0, s_tmp, size(s_tmp,1)) + + call dgemm('T','N',shift2,shift2,shift2, & + 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & + 0.d0, s_, size(s_,1)) + + + + do k=1,shift2 + s2(k) = s_(k,k) + S_z2_Sz + enddo + + if (s2_eig) then + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + endif + + + ! Express eigenvectors of h in the determinant basis + ! -------------------------------------------------- + + 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)) + 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)) + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, S, size(S,1), y, size(y,1), 0.d0, S(1,shift2+1), size(S,1)) + + ! Compute residual vector and davidson step + ! ----------------------------------------- + + do k=1,N_st_diag + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + if (k <= N_st) then + residual_norm(k) = u_dot_u(U(1,shift2+k),sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = s2(k) + to_print(3,k) = residual_norm(k) + endif + enddo + + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st) + call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) + do k=1,N_st + if (residual_norm(k) > 1.e8) then + print *, '' + stop 'Davidson failed' + endif + enddo + if (converged) then + exit + endif + + enddo + + ! Re-contract to u_in + ! ----------- + + 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)) + + enddo + + do k=1,N_st_diag + energies(k) = lambda(k) + S2_jj(k) = s2(k) + enddo + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write(iunit,'(A)') '' + call write_time(iunit) + + call munmap( & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(1), c_pointer(1)) + + call munmap( & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(2), c_pointer(2)) + + call munmap( & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(3), c_pointer(3)) + + deallocate ( & + residual_norm, & + c, & + h, & + y, s_, s_tmp, & + lambda & + ) +end + diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index e34ba3ce..dd5ab1ab 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -422,7 +422,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) !$OMP CRITICAL (u0Hu0) do istate=1,N_st - do i=n,1,-1 + do i=1,n v_0(i,istate) = v_0(i,istate) + vt(istate,i) s_0(i,istate) = s_0(i,istate) + st(istate,i) enddo diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 9c3b35b5..98845592 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -150,7 +150,7 @@ subroutine ortho_qr(A,LDA,m,n) LWORK=-1 ! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) - LWORK=WORK(1) + LWORK=2*WORK(1) deallocate(WORK) allocate(WORK(LWORK)) ! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) @@ -159,6 +159,33 @@ subroutine ortho_qr(A,LDA,m,n) deallocate(WORK,jpvt,tau) end +subroutine ortho_qr_unblocked(A,LDA,m,n) + implicit none + BEGIN_DOC + ! Orthogonalization using Q.R factorization + ! + ! A : matrix to orthogonalize + ! + ! LDA : leftmost dimension of A + ! + ! n : Number of rows of A + ! + ! m : Number of columns of A + ! + END_DOC + integer, intent(in) :: m,n, LDA + double precision, intent(inout) :: A(LDA,n) + + integer :: info + integer, allocatable :: jpvt(:) + double precision, allocatable :: tau(:), work(:) + + allocate (jpvt(n), tau(n), work(n)) + call dgeqr2( m, n, A, LDA, TAU, WORK, INFO ) + call dorg2r(m, n, n, A, LDA, tau, WORK, INFO) + deallocate(WORK,jpvt,tau) +end + subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) implicit none BEGIN_DOC From 9e88e7f0de2063b5a25ad105492016c0118222c6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 10:37:35 +0100 Subject: [PATCH 42/76] Put davdison_sze_max in EZFIO --- src/Davidson/EZFIO.cfg | 7 ++++++- src/Davidson/parameters.irp.f | 18 ------------------ src/Utils/LinearAlgebra.irp.f | 2 -- 3 files changed, 6 insertions(+), 21 deletions(-) diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index 415e359e..b7c67465 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -6,7 +6,12 @@ default: 1.e-12 [n_states_diag] type: States_number -doc: n_states_diag +doc: Number of states to consider during the Davdison diagonalization default: 10 interface: ezfio,provider,ocaml +[davidson_sze_max] +type: Strictly_positive_int +doc: Number of micro-iterations before re-contracting +default: 10 +interface: ezfio,provider,ocaml diff --git a/src/Davidson/parameters.irp.f b/src/Davidson/parameters.irp.f index 82315495..ae8babaa 100644 --- a/src/Davidson/parameters.irp.f +++ b/src/Davidson/parameters.irp.f @@ -1,21 +1,3 @@ -BEGIN_PROVIDER [ integer, davidson_iter_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson iterations - END_DOC - davidson_iter_max = 100 -END_PROVIDER - -BEGIN_PROVIDER [ integer, davidson_sze_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson sizes - END_DOC - ASSERT (davidson_sze_max <= davidson_iter_max) - davidson_sze_max = N_states+7 -END_PROVIDER - - BEGIN_PROVIDER [ character(64), davidson_criterion ] implicit none BEGIN_DOC diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 98845592..7be59bcc 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -148,12 +148,10 @@ subroutine ortho_qr(A,LDA,m,n) allocate (jpvt(n), tau(n), work(1)) LWORK=-1 -! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) LWORK=2*WORK(1) deallocate(WORK) allocate(WORK(LWORK)) -! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) deallocate(WORK,jpvt,tau) From 4ab7c939e91814343a1699234dfa2f4626db960a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 13:59:24 +0100 Subject: [PATCH 43/76] Better load balancing in fci and cassd --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 6 +++--- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 9 ++++++--- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 92e7fe55..6844ed90 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -145,9 +145,9 @@ subroutine ZMQ_selection(N_in, pt2) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) - do i= N_det_generators, 1, -step - i_generator_start = max(i-step+1,1) - i_generator_max = i + do i= 1, N_det_generators,step + i_generator_start = i + i_generator_max = min(i+step-1,N_det_generators) write(task,*) i_generator_start, i_generator_max, 1, N call add_task_to_taskserver(zmq_to_qp_run_socket,task) end do diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 8b9488d2..636ed6d1 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -137,9 +137,12 @@ subroutine ZMQ_selection(N_in, pt2) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) - do i= N_det_generators, 1, -step - i_generator_start = max(i-step+1,1) - i_generator_max = i +! do i= N_det_generators, 1, -step +! i_generator_start = max(i-step+1,1) +! i_generator_max = i + do i= 1, N_det_generators,step + i_generator_start = i + i_generator_max = min(i+step-1,N_det_generators) write(task,*) i_generator_start, i_generator_max, 1, N call add_task_to_taskserver(zmq_to_qp_run_socket,task) end do From ba04ee0170163c7191626edec7024bada3484133 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 14:52:12 +0100 Subject: [PATCH 44/76] Added selection_cassd_slave --- .../CAS_SD_ZMQ/selection_cassd_slave.irp.f | 93 +++++++++++++++++++ plugins/Full_CI_ZMQ/fci_zmq.irp.f | 3 - 2 files changed, 93 insertions(+), 3 deletions(-) create mode 100644 plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f diff --git a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f new file mode 100644 index 00000000..b9e530e0 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f @@ -0,0 +1,93 @@ +program selection_slave + implicit none + BEGIN_DOC +! Helper program to compute the PT2 in distributed mode. + END_DOC + + read_wf = .False. + SOFT_TOUCH read_wf + call provide_everything + call switch_qp_run_to_master + call run_wf +end + +subroutine provide_everything + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context + PROVIDE pt2_e0_denominator mo_tot_num N_int +end + +subroutine run_wf + use f77_zmq + implicit none + + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + double precision :: energy(N_states_diag) + character*(64) :: states(1) + integer :: rc, i + + call provide_everything + + zmq_context = f77_zmq_ctx_new () + states(1) = 'selection' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + do + + call wait_for_states(states,zmq_state,1) + + if(trim(zmq_state) == 'Stopped') then + + exit + + else if (trim(zmq_state) == 'selection') then + + ! Selection + ! --------- + + print *, 'Selection' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call selection_slave_tcp(i, energy) + !$OMP END PARALLEL + print *, 'Selection done' + + endif + + end do +end + +subroutine update_energy(energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + BEGIN_DOC +! Update energy when it is received from ZMQ + END_DOC + integer :: j,k + do j=1,N_states + do k=1,N_det + CI_eigenvectors(k,j) = psi_coef(k,j) + enddo + enddo + call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) + if (.True.) then + do k=1,size(ci_electronic_energy) + ci_electronic_energy(k) = energy(k) + enddo + TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors + endif + + call write_double(6,ci_energy,'Energy') +end + +subroutine selection_slave_tcp(i,energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: i + + call run_selection_slave(0,i,energy) +end + diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 636ed6d1..c80b7410 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -137,9 +137,6 @@ subroutine ZMQ_selection(N_in, pt2) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) -! do i= N_det_generators, 1, -step -! i_generator_start = max(i-step+1,1) -! i_generator_max = i do i= 1, N_det_generators,step i_generator_start = i i_generator_max = min(i+step-1,N_det_generators) From 6c452bb63a95867e2589d8e49d4e1715871a20f4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 15:18:24 +0100 Subject: [PATCH 45/76] Fixed selection slave --- plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f | 8 ++++---- plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f | 8 ++++---- plugins/Full_CI_ZMQ/selection_slave.irp.f | 8 ++++---- plugins/Selectors_CASSD/zmq.irp.f | 5 ++--- 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f index b9e530e0..5e3f982a 100644 --- a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) + double precision :: energy(N_states) character*(64) :: states(1) integer :: rc, i @@ -47,7 +47,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -62,7 +62,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -85,7 +85,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 5041e731..718d4c67 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) + double precision :: energy(N_states) character*(64) :: states(2) integer :: rc, i @@ -48,7 +48,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -76,7 +76,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -99,7 +99,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index b9e530e0..5e3f982a 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) + double precision :: energy(N_states) character*(64) :: states(1) integer :: rc, i @@ -47,7 +47,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -62,7 +62,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -85,7 +85,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/Selectors_CASSD/zmq.irp.f b/plugins/Selectors_CASSD/zmq.irp.f index 8046212b..4359a876 100644 --- a/plugins/Selectors_CASSD/zmq.irp.f +++ b/plugins/Selectors_CASSD/zmq.irp.f @@ -88,7 +88,6 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) N_states = N_states_read N_det = N_det_read psi_det_size = psi_det_size_read - TOUCH psi_det_size N_det N_states rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) if (rc /= N_int*2*N_det*bit_kind) then @@ -101,11 +100,11 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' stop 'error' endif - TOUCH psi_det psi_coef + TOUCH psi_det_size N_det N_states psi_det psi_coef rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0) if (rc /= size_energy*8) then - print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' stop 'error' endif From 90042a19f428f0e6d0b56499f720b02fb9fa858a Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 16 Nov 2016 16:38:57 +0100 Subject: [PATCH 46/76] Dressed matrix for pt2 works for one state --- config/ifort.cfg | 2 +- plugins/MRPT_Utils/energies_cas.irp.f | 176 +++++++++++++------------- plugins/MRPT_Utils/mrpt_utils.irp.f | 50 ++++---- 3 files changed, 114 insertions(+), 114 deletions(-) diff --git a/config/ifort.cfg b/config/ifort.cfg index 843e887b..4cf7829e 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index ac399ce7..c1ce50e7 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -1,9 +1,9 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] implicit none integer :: i - double precision :: energies(N_states_diag) + double precision :: energies(N_states) do i = 1, N_states - call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states,i) energy_cas_dyall(i) = energies(i) print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) enddo @@ -13,9 +13,9 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] implicit none integer :: i - double precision :: energies(N_states_diag) + double precision :: energies(N_states) do i = 1, N_states - call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states,i) energy_cas_dyall_no_exchange(i) = energies(i) print*, 'energy_cas_dyall(i)_no_exchange', energy_cas_dyall_no_exchange(i) enddo @@ -28,22 +28,22 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) use bitmasks integer :: iorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = 1 spin_exc = ispin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -53,8 +53,8 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] enddo do state_target = 1,N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -68,22 +68,22 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = -1 spin_exc = ispin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -93,8 +93,8 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] enddo do state_target = 1, N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -109,15 +109,15 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -129,7 +129,7 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) hole_particle_j = 1 spin_exc_j = jspin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -139,10 +139,10 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) enddo do state_target = 1 , N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -159,16 +159,16 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb integer :: state_target state_target = 1 - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -180,7 +180,7 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) hole_particle_j = -1 spin_exc_j = jspin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -189,10 +189,10 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) enddo enddo call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -208,15 +208,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -228,7 +228,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 hole_particle_j = -1 spin_exc_j = jspin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -238,14 +238,14 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) if(orb_i == orb_j .and. ispin .ne. jspin)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) else - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) endif enddo @@ -264,16 +264,16 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -290,7 +290,7 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a hole_particle_k = -1 spin_exc_k = kspin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -301,12 +301,12 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -326,16 +326,16 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -352,7 +352,7 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a hole_particle_k = -1 spin_exc_k = kspin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -362,12 +362,12 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a enddo do state_target = 1, N_states call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -387,16 +387,16 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -413,7 +413,7 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 hole_particle_k = 1 spin_exc_k = kspin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -423,12 +423,12 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -448,16 +448,16 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -474,7 +474,7 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 hole_particle_k = -1 spin_exc_k = kspin do i = 1, n_det - do j = 1, n_states_diag + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -484,12 +484,12 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -511,15 +511,15 @@ END_PROVIDER integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -585,7 +585,7 @@ END_PROVIDER energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v) ! energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo @@ -616,15 +616,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta integer :: i,iorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -688,7 +688,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo @@ -719,15 +719,15 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) integer :: iorb,jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -791,7 +791,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) ! print*, energies(state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif @@ -825,19 +825,19 @@ END_PROVIDER integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: norm_out(N_states),diag_elem(N_det),interact_psi0(N_det) double precision :: delta_e_inact_virt(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states),H_matrix(N_det+1,N_det+1)) allocate (eigenvectors(size(H_matrix,1),N_det+1)) allocate (eigenvalues(N_det+1)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: energies_alpha_beta(N_states,2) @@ -973,21 +973,21 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: norm_out(N_states),diag_elem(N_det),interact_psi0(N_det) double precision :: delta_e_inact_virt(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) double precision, allocatable :: delta_e_det(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states),H_matrix(N_det+1,N_det+1)) allocate (eigenvectors(size(H_matrix,1),N_det+1)) allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det)) allocate (delta_e_det(N_det,N_det)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: energies_alpha_beta(N_states,2) double precision :: lamda_pt2(N_det) diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index d7b1f0f6..4e8bc7d0 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -245,13 +245,13 @@ END_PROVIDER integer, allocatable :: iorder(:) ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors - do j=1,min(N_states_diag,N_det) + do j=1,min(N_states,N_det) do i=1,N_det CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j) enddo enddo - do j=N_det+1,N_states_diag + do j=min(N_states,N_det)+1,N_states_diag do i=1,N_det CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0 enddo @@ -262,13 +262,12 @@ END_PROVIDER print*, 'Davidson not yet implemented for the dressing ... ' stop - else if (diag_algorithm == "Lapack") then - - allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + else if (diag_algorithm == "Lapack") then + allocate (eigenvectors(N_det,N_det)) allocate (eigenvalues(N_det)) call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) - CI_electronic_energy(:) = 0.d0 + Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det) + CI_electronic_dressed_pt2_new_energy(:) = 0.d0 if (s2_eig) then i_state = 0 allocate (s2_eigvalues(N_det)) @@ -279,22 +278,22 @@ END_PROVIDER do j=1,N_det ! Select at least n_states states with S^2 values closed to "expected_s2" if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then - i_state +=1 + i_state += 1 index_good_state_array(i_state) = j good_state_array(j) = .True. endif - if(i_state.eq.N_states) then + if (i_state==N_states) then exit endif enddo - if(i_state .ne.0)then + if (i_state /= 0) then ! Fill the first "i_state" states that have a correct S^2 value do j = 1, i_state do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) enddo - CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) - CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j)) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) enddo i_other_state = 0 do j = 1, N_det @@ -304,12 +303,12 @@ END_PROVIDER exit endif do i=1,N_det - CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) enddo - CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) - CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) enddo - + else print*,'' print*,'!!!!!!!! WARNING !!!!!!!!!' @@ -317,32 +316,33 @@ END_PROVIDER print*,' and the ',N_states_diag,'states requested' print*,' We did not find any state with S^2 values close to ',expected_s2 print*,' We will then set the first N_states eigenvectors of the H matrix' - print*,' as the CI_eigenvectors' + print*,' as the CI_dressed_pt2_new_eigenvectors' print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' print*,'' do j=1,min(N_states_diag,N_det) do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_electronic_energy(j) = eigenvalues(j) - CI_eigenvectors_s2(j) = s2_eigvalues(j) + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) enddo endif deallocate(index_good_state_array,good_state_array) deallocate(s2_eigvalues) else - call u_0_S2_u_0(CI_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& + call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& min(N_det,N_states_diag),size(eigenvectors,1)) ! Select the "N_states_diag" states of lowest energy do j=1,min(N_det,N_states_diag) do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_electronic_energy(j) = eigenvalues(j) + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) enddo endif deallocate(eigenvectors,eigenvalues) - endif + + endif END_PROVIDER From 13f2c5d5a9522a63e1644320bb63c5a5a3e23d36 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 20:37:13 +0100 Subject: [PATCH 47/76] Removed state-following in MRCC --- plugins/MRCC_Utils/davidson.irp.f | 68 +++++++++++++++---------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 8e0af39e..0470960a 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -784,7 +784,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (s2_eig) then logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + state_ok(k) = (dabs(s2(k)-expected_s2) < 1.d0) enddo do k=1,shift2 if (.not. state_ok(k)) then @@ -803,39 +803,39 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz endif - ! Compute overlap with U_in - ! ------------------------- - - integer :: coord(2), order(N_st_diag) - overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) - enddo - enddo - do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) - overlap(coord(1),coord(2)) = -1.d0 - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) - endif - enddo - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - endif - enddo +! ! Compute overlap with U_in +! ! ------------------------- +! +! integer :: coord(2), order(N_st_diag) +! overlap = -1.d0 +! do k=1,shift2 +! do i=1,shift2 +! overlap(k,i) = dabs(y(k,i)) +! enddo +! enddo +! do k=1,N_st +! coord = maxloc(overlap) +! order( coord(2) ) = coord(1) +! overlap(coord(1),coord(2)) = -1.d0 +! enddo +! overlap = y +! do k=1,N_st +! l = order(k) +! if (k /= l) then +! y(1:shift2,k) = overlap(1:shift2,l) +! endif +! enddo +! do k=1,N_st +! overlap(k,1) = lambda(k) +! overlap(k,2) = s2(k) +! enddo +! do k=1,N_st +! l = order(k) +! if (k /= l) then +! lambda(k) = overlap(l,1) +! s2(k) = overlap(l,2) +! endif +! enddo ! Express eigenvectors of h in the determinant basis From 3407b6df853efe24d4b04902071d0ddbad44b6f7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 21:28:10 +0100 Subject: [PATCH 48/76] Resized array energy --- plugins/CAS_SD_ZMQ/run_selection_slave.irp.f | 2 +- plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f | 2 +- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 2 +- plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f | 2 +- plugins/Full_CI_ZMQ/selection_slave.irp.f | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f index 36550116..dfaee629 100644 --- a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f @@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy) use selection_types implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: thread, iproc integer :: rc, i diff --git a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f index 5e3f982a..657ad63c 100644 --- a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f @@ -74,7 +74,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,size(ci_electronic_energy) + do k=1,N_states ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 36550116..dfaee629 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy) use selection_types implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: thread, iproc integer :: rc, i diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 718d4c67..d6204cc3 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -88,7 +88,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,size(ci_electronic_energy) + do k=1,N_states ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 5e3f982a..657ad63c 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -74,7 +74,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,size(ci_electronic_energy) + do k=1,N_states ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors From 816abadda8533158923e4f1c42840534e1a361ed Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 22:08:43 +0100 Subject: [PATCH 49/76] Bug in random number --- src/Davidson/diagonalization_hs2.irp.f | 1 + src/Utils/LinearAlgebra.irp.f | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index c3785d7f..c70a086c 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -187,6 +187,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=N_st+1,N_st_diag 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) diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 7be59bcc..44a15ddf 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -469,7 +469,12 @@ subroutine lapack_diag(eigvalues,eigvectors,H,nmax,n) print *, irp_here, ': DSYEV: the ',-info,'-th argument had an illegal value' stop 2 else if( info > 0 ) then - write(*,*)'DSYEV Failed' + write(*,*)'DSYEV Failed : ', info + do i=1,n + do j=1,n + print *, H(i,j) + enddo + enddo stop 1 end if From 8a91b293bf60c9c2e0af24ce6afa353ff7c31383 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 17 Nov 2016 17:03:48 +0100 Subject: [PATCH 50/76] now eigenfunction of S^2 --- config/ifort.cfg | 2 +- plugins/MRPT_Utils/energies_cas.irp.f | 192 ++--------------- plugins/MRPT_Utils/excitations_cas.irp.f | 259 +++++++++++++++++++---- plugins/MRPT_Utils/new_way.irp.f | 120 ----------- plugins/MRPT_Utils/print_1h2p.irp.f | 12 +- plugins/MRPT_Utils/psi_active_prov.irp.f | 35 +-- plugins/MRPT_Utils/special_hij.irp.f | 183 ++++++++++++++++ src/Bitmask/bitmask_cas_routines.irp.f | 21 ++ 8 files changed, 477 insertions(+), 347 deletions(-) create mode 100644 plugins/MRPT_Utils/special_hij.irp.f diff --git a/config/ifort.cfg b/config/ifort.cfg index 4cf7829e..843e887b 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index c1ce50e7..f09c30cb 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -520,7 +520,7 @@ END_PROVIDER integer :: iorb,jorb,i_ok integer :: state_target double precision :: energies(n_states) - double precision :: hij + double precision :: hij,hij_test double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -552,11 +552,18 @@ END_PROVIDER call debug_det(psi_in_out,N_int) print*, 'pb, i_ok ne 0 !!!' endif +! call i_H_j_no_k_operators_from_act(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij_test) call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) +! if(i==1.and.dabs(hij)>1.d-8)then +! if(dabs(hij)>1.d-8)then +! print*, ispin,vorb,iorb +! print*, i,hij,hij_test +! pause +! endif do j = 1, n_states double precision :: coef,contrib coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + psi_in_out_coef(i,j) = coef * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo enddo @@ -582,22 +589,18 @@ END_PROVIDER enddo enddo do state_target = 1, N_states - energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v) -! energies_alpha_beta(state_target, ispin) = 0.d0 + energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) +! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then -! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.5d0 * & -! ( energy_cas_dyall(state_target) - energies_alpha_beta(state_target,1) + & -! energy_cas_dyall(state_target) - energies_alpha_beta(state_target,2) ) -! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) -! print*, norm_bis(state_target,1) , norm_bis(state_target,2) - one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall(state_target) - & +! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall(state_target) - & + one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else @@ -688,24 +691,20 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & +! one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & + one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_inact(iorb,aorb,state_target) = 0.d0 endif -! print*, '********' -! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) -! print*, norm_bis(state_target,1) , norm_bis(state_target,2) -! print*, one_anhil_inact(iorb,aorb,state_target) -! print*, one_creat(aorb,1,state_target) enddo enddo enddo @@ -735,7 +734,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State double precision :: thresh_norm - thresh_norm = 1.d-10 + thresh_norm = 1.d-20 do aorb = 1,n_act_orb orb_a = list_act(aorb) @@ -791,15 +790,16 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) -! print*, energies(state_target) +! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall(state_target) - & +! one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall(state_target) - & + one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else @@ -815,154 +815,6 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State enddo deallocate(psi_in_out,psi_in_out_coef) -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt_bis, (n_inact_orb,n_virt_orb,N_det,N_States)] -&BEGIN_PROVIDER [ double precision, corr_e_from_1h1p, (N_States)] - implicit none - integer :: i,vorb,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i - integer :: orb_v - double precision :: norm_out(N_states),diag_elem(N_det),interact_psi0(N_det) - double precision :: delta_e_inact_virt(N_states) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states),H_matrix(N_det+1,N_det+1)) - allocate (eigenvectors(size(H_matrix,1),N_det+1)) - allocate (eigenvalues(N_det+1)) - - integer :: iorb,jorb,i_ok - integer :: state_target - double precision :: energies(n_states) - double precision :: hij - double precision :: energies_alpha_beta(N_states,2) - - - double precision :: accu(N_states),norm - double precision :: amplitudes_alpha_beta(N_det,2) - double precision :: delta_e_alpha_beta(N_det,2) - - corr_e_from_1h1p = 0.d0 - do vorb = 1,n_virt_orb - orb_v = list_virt(vorb) - do iorb = 1, n_inact_orb - orb_i = list_inact(iorb) -! print*, '---------------------------------------------------------------------------' - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & - - fock_virt_total_spin_trace(orb_v,j) - enddo - do ispin = 1,2 - do i = 1, n_det - do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) - enddo - call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) - if(i_ok.ne.1)then - print*, orb_i,orb_v - call debug_det(psi_in_out,N_int) - print*, 'pb, i_ok ne 0 !!!' - endif - interact_psi0(i) = 0.d0 - do j = 1 , N_det - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) - interact_psi0(i) += hij * psi_coef(j,1) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - call i_H_j_dyall(psi_active(1,1,i),psi_active(1,1,i),N_int,hij) - diag_elem(i) = hij - enddo - do state_target = 1, N_states - ! Building the Hamiltonian matrix - H_matrix(1,1) = energy_cas_dyall(state_target) - do i = 1, N_det - ! interaction with psi0 - H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) - H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) - ! diagonal elements - H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) -! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) - do j = i+1, N_det - call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) - H_matrix(i+1,j+1) = hij !0.d0 ! - H_matrix(j+1,i+1) = hij !0.d0 ! - enddo - enddo - print*, '***' - do i = 1, N_det+1 - write(*,'(100(F16.10,X))')H_matrix(i,:) - enddo - call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) - corr_e_from_1h1p(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) - norm = 0.d0 - do i = 1, N_det - psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) -!! if(dabs(psi_coef(i,state_target)*) .gt. 1.d-8)then - if(dabs(psi_in_out_coef(i,state_target)) .gt. 1.d-8)then -! if(dabs(interact_psi0(i)) .gt. 1.d-8)then - delta_e_alpha_beta(i,ispin) = H_matrix(1,i+1) / psi_in_out_coef(i,state_target) -! delta_e_alpha_beta(i,ispin) = interact_psi0(i) / psi_in_out_coef(i,state_target) - amplitudes_alpha_beta(i,ispin) = psi_in_out_coef(i,state_target) / psi_coef(i,state_target) - else - amplitudes_alpha_beta(i,ispin) = 0.d0 - delta_e_alpha_beta(i,ispin) = delta_e_inact_virt(state_target) - endif -!! one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,ispin,state_target) = amplitudes_alpha_beta(i,ispin) - norm += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) - enddo - print*, 'Coef ' - write(*,'(100(X,F16.10))')psi_coef(1:N_det,state_target) - write(*,'(100(X,F16.10))')psi_in_out_coef(:,state_target) - double precision :: coef_tmp(N_det) - do i = 1, N_det - coef_tmp(i) = psi_coef(i,1) * interact_psi0(i) / delta_e_alpha_beta(i,ispin) - enddo - write(*,'(100(X,F16.10))')coef_tmp(:) - print*, 'naked interactions' - write(*,'(100(X,F16.10))')interact_psi0(:) - print*, '' - - print*, 'norm ',norm - norm = 1.d0/(norm) - accu(state_target) = 0.d0 - do i = 1, N_det - accu(state_target) += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) * H_matrix(i+1,i+1) - do j = i+1, N_det - accu(state_target) += 2.d0 * psi_in_out_coef(i,state_target) * psi_in_out_coef(j,state_target) * H_matrix(i+1,j+1) - enddo - enddo - accu(state_target) = accu(state_target) * norm - print*, delta_e_inact_virt(state_target) - print*, eigenvalues(1),accu(state_target),eigenvectors(1,1) - print*, energy_cas_dyall(state_target) - accu(state_target), one_anhil_one_creat_inact_virt(iorb,vorb,state_target) + delta_e_inact_virt(state_target) - - enddo - enddo ! ispin - do state_target = 1, N_states - do i = 1, N_det - one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,state_target) = 0.5d0 * & - ( delta_e_alpha_beta(i,1) + delta_e_alpha_beta(i,1)) - enddo - enddo - print*, '***' - write(*,'(100(X,F16.10))') - write(*,'(100(X,F16.10))')delta_e_alpha_beta(:,2) - ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) - ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) - print*, '---------------------------------------------------------------------------' - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef,H_matrix,eigenvectors,eigenvalues) - print*, 'corr_e_from_1h1p,',corr_e_from_1h1p(:) - END_PROVIDER subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 10cfe7c0..6028d4fa 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -212,52 +212,97 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo -! print*,'core_act = ',core_act -! print*,'alpha_alpha = ',alpha_alpha -! print*,'alpha_beta = ',alpha_beta -! print*,'beta_beta = ',beta_beta -! print*,'mono_elec = ',mono_elec - -! do i = 1, n_core_inact_orb -! iorb = list_core_inact(i) -! diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1) -! enddo - - -!!!!!!!!!!!! -return -!!!!!!!!!!!! - - - ! alpha - alpha - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) - do j = i+1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) - do j = i+1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - enddo - enddo end + + + +double precision function diag_H_mat_elem_no_elec_check_no_spin(det_in,Nint) + implicit none + BEGIN_DOC + ! Computes + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + + integer :: i, j, iorb, jorb + integer :: occ(Nint*bit_kind_size,2) + integer :: elec_num_tab_local(2) + + double precision :: core_act + double precision :: alpha_alpha + double precision :: alpha_beta + double precision :: beta_beta + double precision :: mono_elec + core_act = 0.d0 + alpha_alpha = 0.d0 + alpha_beta = 0.d0 + beta_beta = 0.d0 + mono_elec = 0.d0 + + diag_H_mat_elem_no_elec_check_no_spin = 0.d0 + call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) + call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) + ! alpha - alpha + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb) + mono_elec += mo_mono_elec_integral(iorb,iorb) + do j = i+1, elec_num_tab_local(1) + jorb = occ(j,1) + diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) + alpha_alpha += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + ! beta - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb) + mono_elec += mo_mono_elec_integral(iorb,iorb) + do j = i+1, elec_num_tab_local(2) + jorb = occ(j,2) + diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) + beta_beta += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + + ! alpha - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, elec_num_tab_local(1) + jorb = occ(j,1) + diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) + alpha_beta += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + + ! alpha - core-act + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + ! beta - core-act + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + +end + + subroutine i_H_j_dyall(key_i,key_j,Nint,hij) use bitmasks implicit none @@ -389,6 +434,133 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) end +subroutine i_H_j_dyall_no_spin(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem_no_elec_check, phase,phase_2 + integer :: n_occ_ab(2) + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + hij = 0.d0 + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + if(exc(1,1,1) == exc(1,1,2) .and. exc(1,1,2) == exc(1,2,1) )then + hij = 0.d0 + else + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + endif + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, n_occ_ab(1) + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, n_occ_ab(2) + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, n_occ_ab(1) + hij = hij + mipi(occ(k,1)) !- miip(occ(k,1)) + enddo + do k = 1, n_occ_ab(2) + hij = hij + mipi(occ(k,2)) + enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, n_occ_ab(2) + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, n_occ_ab(1) + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, n_occ_ab(1) + hij = hij + mipi(occ(k,1)) + enddo + do k = 1, n_occ_ab(2) + hij = hij + mipi(occ(k,2)) !- miip(occ(k,2)) + enddo + + endif + hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) + + case (0) + double precision :: diag_H_mat_elem_no_elec_check_no_spin + hij = diag_H_mat_elem_no_elec_check_no_spin(key_i,Nint) + end select +end + + + subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) use bitmasks implicit none @@ -414,6 +586,7 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe do j = 1, ndet if(psi_coef_tmp(j)==0.d0)cycle call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) +! call i_H_j_dyall_no_spin(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij enddo enddo diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index fa5812e1..3624b7d3 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -393,126 +393,6 @@ subroutine give_1h2p_contrib(matrix_1h2p) end -subroutine give_1h1p_contrib(matrix_1h1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb - integer :: ispin,jspin - integer :: idet,jdet - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) - integer :: istate - double precision :: hja,delta_e_inact_virt(N_states) - integer :: kspin,degree_scalar -!matrix_1h1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - - fock_virt_total_spin_trace(rorb,j) - enddo - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations - do jdet = 1, idx(0) - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - double precision :: himono,delta_e(N_states),coef_mono(N_states) - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) - - do state_target = 1, N_states -! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) - delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target) - coef_mono(state_target) = himono / delta_e(state_target) - enddo - if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - aorb = (exc(1,2,1)) !!! a^{\dagger}_a - borb = (exc(1,1,1)) !!! a_{b} - jspin = 1 - else - ! Mono beta - aorb = (exc(1,2,2)) !!! a^{\dagger}_a - borb = (exc(1,1,2)) !!! a_{b} - jspin = 2 - endif - - call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) - if(degree_scalar .ne. 2)then - print*, 'pb !!!' - print*, degree_scalar - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - stop - endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(ispin == jspin )then - hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) & - + get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map) - else - hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map) - endif - hij = hij * phase - double precision :: hij_test - integer :: state_target - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) - if(dabs(hij - hij_test).gt.1.d-10)then - print*, 'ahah pb !!' - print*, 'hij .ne. hij_test' - print*, hij,hij_test - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - print*, ispin, jspin - print*,iorb,borb,rorb,aorb - print*, phase - call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) - stop - endif - do state_target = 1, N_states - matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target) - enddo - else - do state_target = 1, N_states - matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target) - enddo - endif - enddo - enddo - - - - enddo - enddo - enddo -end - subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) use bitmasks implicit none diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT_Utils/print_1h2p.irp.f index d10e1fb5..03851d8a 100644 --- a/plugins/MRPT_Utils/print_1h2p.irp.f +++ b/plugins/MRPT_Utils/print_1h2p.irp.f @@ -2,7 +2,17 @@ program print_1h2p implicit none read_wf = .True. touch read_wf - call routine + call routine_2 +end + +subroutine routine_2 + implicit none + integer :: i,j + do i =1, n_inact_orb + write(*,'(100(F16.10,X))')one_anhil_one_creat_inact_virt(i,:,1) + enddo + + end subroutine routine diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 67501727..33cb5d5b 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -293,27 +293,38 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) if (n_holes_act == 0 .and. n_particles_act == 1) then ispin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) -! call get_excitation_degree(det_1,det_2,degree,N_int) -! if(degree == 1)then -! call get_excitation(det_1,det_2,exc,degree,phase,N_int) -! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) -! i_hole = list_inact_reverse(h1) -! i_part = list_act_reverse(p1) -! do i_state = 1, N_states -! delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state) -! enddo -! else if (degree == 2)then + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 1)then + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + i_hole = list_inact_reverse(h1) + i_part = list_act_reverse(p1) + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state) + enddo + else if (degree == 2)then do i_state = 1, N_states delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state) enddo -! endif + endif else if (n_holes_act == 1 .and. n_particles_act == 0) then ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 1)then + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + i_hole = list_act_reverse(h1) + i_part = list_virt_reverse(p1) + do i_state = 1, N_states + delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state) + enddo + else if (degree == 2)then do i_state = 1, N_states delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) enddo + endif else if (n_holes_act == 1 .and. n_particles_act == 1) then ! first hole @@ -415,7 +426,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) i_hole = list_inact_reverse(h1) i_part = list_virt_reverse(p1) do i_state = 1, N_states -! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) + delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) enddo endif else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then diff --git a/plugins/MRPT_Utils/special_hij.irp.f b/plugins/MRPT_Utils/special_hij.irp.f new file mode 100644 index 00000000..597d8ee3 --- /dev/null +++ b/plugins/MRPT_Utils/special_hij.irp.f @@ -0,0 +1,183 @@ + + +subroutine i_H_j_no_k_operators_from_act(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral, phase + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem + integer :: n_occ_ab(2) + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size), miip_other(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij = 0.d0 + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + has_mipi = .False. + logical :: is_i_in_active + double precision :: accu_a, accu_b, accu_core + accu_a = 0.d0 + accu_b = 0.d0 + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + if(.not.is_i_in_active(i))then + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + else +! print*, i,get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + miip(i) = 1.0d0 * get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + accu_a += miip(i) + endif + enddo + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + if(.not.is_i_in_active(i))then + miip_other(i) = 0.d0 + else +! print*, i,get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + miip_other(i) = 1.0d0 * get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + accu_b += miip(i) + endif + enddo +! print*, accu_a,accu_b,accu_a + accu_b + accu_a = 0.d0 + accu_b = 0.d0 + accu_core = mo_mono_elec_integral(m,p) + + do k = 1, elec_alpha_num + hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) + accu_Core += mipi(occ(k,1)) + if(is_i_in_active(occ(k,1)))then + accu_a += miip(occ(k,1)) + else + accu_Core -= miip(occ(k,1)) + endif + enddo +! print*, hij,accu_core + do k = 1, elec_beta_num + hij = hij + mipi(occ(k,2)) - miip_other(occ(k,2)) + accu_Core += mipi(occ(k,2)) + if(is_i_in_active(occ(k,2)))then + accu_b += miip_other(occ(k,2)) + else + accu_Core -= miip_other(occ(k,2)) + endif + enddo +! print*, hij,accu_core,accu_core - accu_a - accu_b +! print*, accu_a,accu_b,accu_a + accu_b +! pause + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + if(.not.is_i_in_active(i))then + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + else + miip(i) = 1.0d0 * get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + endif + enddo + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + if(.not.is_i_in_active(i))then + miip_other(i) = 0.d0 + else + miip_other(i) = 1.0d0 * get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + endif + enddo + do k = 1, elec_alpha_num + hij = hij + mipi(occ(k,1)) - miip_other(occ(k,1)) + enddo + do k = 1, elec_beta_num + hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) + enddo + + endif + hij = phase*(hij + mo_mono_elec_integral(m,p)) + + case (0) + hij = diag_H_mat_elem(key_i,Nint) + end select +end + + + diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 87a02d10..5c170632 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -560,3 +560,24 @@ logical function is_i_in_virtual(i) endif end + +logical function is_i_in_active(i) + implicit none + integer,intent(in) :: i + integer(bit_kind) :: key(N_int) + integer :: k,j + integer :: accu + is_i_in_active = .False. + key= 0_bit_kind + k = ishft(i-1,-bit_kind_shift)+1 + j = i-ishft(k-1,bit_kind_shift)-1 + key(k) = ibset(key(k),j) + accu = 0 + do k = 1, N_int + accu += popcnt(iand(key(k),cas_bitmask(k,1,1))) + enddo + if(accu .ne. 0)then + is_i_in_active= .True. + endif + +end From 278c961c0fa8f7f4c0ed068b95729ae0592d772d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 17 Nov 2016 23:28:37 +0100 Subject: [PATCH 51/76] Converge MRCC to 1.e-6 --- plugins/MP2/mp2.irp.f | 6 ++++++ plugins/MP2/mp2_wf.irp.f | 6 ++++++ plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- tests/bats/cassd.bats | 2 +- 4 files changed, 14 insertions(+), 2 deletions(-) diff --git a/plugins/MP2/mp2.irp.f b/plugins/MP2/mp2.irp.f index 3a049f7b..d4721c71 100644 --- a/plugins/MP2/mp2.irp.f +++ b/plugins/MP2/mp2.irp.f @@ -1,4 +1,10 @@ program mp2 + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + call run +end + +subroutine run implicit none double precision, allocatable :: pt2(:), norm_pert(:) double precision :: H_pert_diag, E_old diff --git a/plugins/MP2/mp2_wf.irp.f b/plugins/MP2/mp2_wf.irp.f index 5efbb9cd..e7419319 100644 --- a/plugins/MP2/mp2_wf.irp.f +++ b/plugins/MP2/mp2_wf.irp.f @@ -1,4 +1,10 @@ program mp2_wf + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + call run +end + +subroutine run implicit none BEGIN_DOC ! Save the MP2 wave function diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f28ccf25..b1c68ef7 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -761,7 +761,7 @@ END_PROVIDER print *, "res ", k, res end if - if(res < 1d-9) exit + if(res < 1d-6) exit end do norm = 0.d0 diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index a1f1a736..f43ffaaa 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -13,7 +13,7 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.2311177912495 2.E-5 + eq $energy -76.23109 2.E-5 ezfio set determinants n_det_max 2048 ezfio set determinants read_wf True From 5e3201cea9c59406c6add955e40c0e30e5465f36 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 15:06:33 +0100 Subject: [PATCH 52/76] Removed spin contaminants of Davidson --- plugins/MRCC_Utils/davidson.irp.f | 72 +++++++++++++++++--------- src/Davidson/diagonalization_hs2.irp.f | 11 ++++ 2 files changed, 59 insertions(+), 24 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 0470960a..d1b82dfc 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -781,27 +781,40 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz s2(k) = s_(k,k) + S_z2_Sz enddo - if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) - do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 1.d0) - enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo - endif - enddo + if (s2_eig) then + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.5d0) + enddo + else + state_ok(k) = .True. endif + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + ! Randomize components with bad + if (.not. state_ok(k)) then + do i=1,shift2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + y(i,k) = r1*dcos(r2) + lambda(k) = 1.d0 + enddo + endif + enddo ! ! Compute overlap with U_in ! ! ------------------------- @@ -852,11 +865,22 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------- do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo +! else +! ! Randomize components with bad +! do i=1,sze +! call random_number(r1) +! call random_number(r2) +! r1 = dsqrt(-2.d0*dlog(r1)) +! r2 = dtwo_pi*r2 +! U(i,shift2+k) = r1*dcos(r2) +! enddo +! endif + if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index c70a086c..97f93526 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -587,6 +587,17 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo endif enddo + ! Randomize components with bad + if (.not. state_ok(k)) then + do i=1,shift2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + y(i,k) = r1*dcos(r2) + lambda(k) = 1.d0 + enddo + endif endif From 38c6fc7bb8c28426f0b8550d63ccf58263a59e07 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 19:17:34 +0100 Subject: [PATCH 53/76] Implemented dressed S2 matrix --- plugins/MRCC_Utils/davidson.irp.f | 95 ++++++++++++++++++++-------- plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- plugins/mrcepa0/dressing.irp.f | 81 +++++++++++++++++------- plugins/mrcepa0/dressing_slave.irp.f | 87 ++++++++++++++++--------- plugins/mrcepa0/mrcc.irp.f | 2 +- 5 files changed, 186 insertions(+), 81 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index d1b82dfc..608b427b 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -715,6 +715,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz double precision :: r1, r2 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) @@ -762,6 +763,44 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz 1.d0, U, size(U,1), S, size(S,1), & 0.d0, s_, size(s_,1)) + ! Diagonalize S^2 + ! --------------- + call lapack_diag(s2,y,s_,size(s_,1),shift2) + +! ! Rotate H in the basis of eigenfunctions of s2 +! ! --------------------------------------------- +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('T','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) +! +! ! Damp interaction between different spin states +! ! ------------------------------------------------ +! +! do k=1,shift2 +! do l=1,shift2 +! if (dabs(s2(k) - s2(l)) > 1.d0) then +! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) +! endif +! enddo +! enddo +! +! ! Rotate back H +! ! ------------- +! +! call dgemm('N','T',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) + + ! Diagonalize h ! ------------- call lapack_diag(lambda,y,h,size(h,1),shift2) @@ -784,7 +823,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (s2_eig) then logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.5d0) + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0) enddo else state_ok(k) = .True. @@ -803,22 +842,11 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz endif enddo endif - ! Randomize components with bad - if (.not. state_ok(k)) then - do i=1,shift2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - y(i,k) = r1*dcos(r2) - lambda(k) = 1.d0 - enddo - endif enddo -! ! Compute overlap with U_in -! ! ------------------------- -! + ! Compute overlap with U_in + ! ------------------------- + ! integer :: coord(2), order(N_st_diag) ! overlap = -1.d0 ! do k=1,shift2 @@ -865,21 +893,30 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------- do k=1,N_st_diag + if (state_ok(k)) then do i=1,sze U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & )/max(H_jj(i) - lambda (k),1.d-2) enddo -! else -! ! Randomize components with bad -! do i=1,sze -! call random_number(r1) -! call random_number(r2) -! r1 = dsqrt(-2.d0*dlog(r1)) -! r2 = dtwo_pi*r2 -! U(i,shift2+k) = r1*dcos(r2) -! enddo -! endif + else + ! Randomize components with bad + do i=1,sze-2,2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + U(i+1,shift2+k) = r1*dsin(r2) + enddo + do i=sze-2+1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + enddo + endif if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) @@ -914,8 +951,8 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz energies(k) = lambda(k) enddo - call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & - U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + 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)) enddo @@ -995,7 +1032,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, & - !$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij,istate_in) + !$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij, delta_ij_s2,istate_in) allocate(vt(N_st_8,n),st(N_st_8,n)) Vt = 0.d0 St = 0.d0 @@ -1080,6 +1117,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i do istate=1,N_st vt (istate,i) = vt (istate,i) + delta_ij(istate_in,jj,ii)*ut(istate,j) vt (istate,j) = vt (istate,j) + delta_ij(istate_in,jj,ii)*ut(istate,i) + st (istate,i) = st (istate,i) + delta_ij_s2(istate_in,jj,ii)*ut(istate,j) + st (istate,j) = st (istate,j) + delta_ij_s2(istate_in,jj,ii)*ut(istate,i) enddo enddo enddo diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index b1c68ef7..f28ccf25 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -761,7 +761,7 @@ END_PROVIDER print *, "res ", k, res end if - if(res < 1d-6) exit + if(res < 1d-9) exit end do norm = 0.d0 diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 9f041cd3..46c56d9d 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -4,6 +4,8 @@ use bitmasks BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ] use bitmasks implicit none integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc @@ -14,11 +16,13 @@ use bitmasks delta_ij_mrcc = 0d0 delta_ii_mrcc = 0d0 + delta_ij_s2_mrcc = 0d0 + delta_ii_s2_mrcc = 0d0 print *, "Dij", dij(1,1,1) provide hh_shortcut psi_det_size! lambda_mrcc !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & - !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) & + !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & !$OMP private(h, n, mask, omask, buf, ok, iproc) do gen= 1, N_det_generators allocate(buf(N_int, 2, N_det_non_ref)) @@ -37,7 +41,9 @@ use bitmasks end do n = n - 1 - if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) + if(n /= 0) then + call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) + endif end do deallocate(buf) @@ -52,13 +58,15 @@ END_PROVIDER ! end subroutine -subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffer,Nint,key_mask) +subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask) use bitmasks implicit none integer, intent(in) :: i_generator,n_selected, Nint double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) + double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) + double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref) integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,l,m @@ -68,8 +76,8 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe integer(bit_kind),allocatable :: tq(:,:,:) integer :: N_tq, c_ref ,degree - double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:) + double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) + double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) double precision :: haj, phase, phase2 double precision :: f(N_states), ci_inv(N_states) integer :: exc(0:2,2,2) @@ -82,7 +90,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe integer(bit_kind),intent(in) :: key_mask(Nint, 2) integer,allocatable :: idx_miniList(:) integer :: N_miniList, ni, leng - double precision, allocatable :: hij_cache(:) + double precision, allocatable :: hij_cache(:), sij_cache(:) integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) @@ -92,7 +100,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref)) + allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) @@ -117,7 +125,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe deallocate(microlist, idx_microlist) - allocate (dIa_hla(N_states,N_det_non_ref)) + allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref)) ! |I> @@ -185,6 +193,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) + call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) enddo ! |I> do i_I=1,N_det_ref @@ -282,9 +291,11 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) hla = hij_cache(k_sd) + sla = sij_cache(k_sd) ! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) do i_state=1,N_states dIa_hla(i_state,k_sd) = dIa(i_state) * hla + dIa_sla(i_state,k_sd) = dIa(i_state) * sla enddo enddo call omp_set_lock( psi_ref_lock(i_I) ) @@ -294,19 +305,22 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) + delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) enddo else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) + delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo endif enddo call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo - deallocate (dIa_hla,hij_cache) + deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) deallocate(miniList, idx_miniList) end @@ -315,6 +329,8 @@ end BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] use bitmasks implicit none integer :: i, j, i_state @@ -325,10 +341,12 @@ end do i = 1, N_det_ref do i_state = 1, N_states delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) enddo do j = 1, N_det_non_ref do i_state = 1, N_states delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) enddo end do end do @@ -343,10 +361,12 @@ end do i = 1, N_det_ref do i_state = 1, N_states delta_ii(i_state,i)= delta_ii_old(i_state,i) + delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) enddo do j = 1, N_det_non_ref do i_state = 1, N_states delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) + delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) enddo end do end do @@ -354,10 +374,12 @@ end do i = 1, N_det_ref do i_state = 1, N_states delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) + delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) enddo do j = 1, N_det_non_ref do i_state = 1, N_states delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) + delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) enddo end do end do @@ -547,28 +569,32 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] +&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] use bitmasks implicit none integer :: i,j,k - double precision :: Hjk, Hki, Hij + double precision :: Sjk,Hjk, Hki, Hij !double precision, external :: get_dij integer i_state, degree provide lambda_mrcc dIj do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij) + !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij) do i=1,N_det_ref do j=1,i call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) delta_cas(i,j,i_state) = 0d0 + delta_cas_s2(i,j,i_state) = 0d0 do k=1,N_det_non_ref call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) + call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) + delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) end do delta_cas(j,i,i_state) = delta_cas(i,j,i_state) + delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state) end do end do !$OMP END PARALLEL DO @@ -649,6 +675,8 @@ end function BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] &BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ] use bitmasks implicit none @@ -656,7 +684,7 @@ end function integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) - double precision :: contrib, contrib2, HIIi, HJk, wall + double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) integer(bit_kind),allocatable :: sortRef(:,:,:) @@ -681,14 +709,16 @@ end function ! To provide everything contrib = dij(1, 1, 1) - do i_state = 1, N_states - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 + delta_mrcepa0_ii(:,:) = 0d0 + delta_mrcepa0_ij(:,:,:) = 0d0 + delta_mrcepa0_ii_s2(:,:) = 0d0 + delta_mrcepa0_ij_s2(:,:,:) = 0d0 - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) & + do i_state = 1, N_states + !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & + !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & - !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) & + !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) & !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) do blok=1,cepa0_shortcut(0) do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 @@ -731,16 +761,21 @@ end function ! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) + contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) + contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) !$OMP ATOMIC delta_mrcepa0_ii(J,i_state) -= contrib2 + delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 else contrib = contrib * 0.5d0 + contrib_s2 = contrib_s2 * 0.5d0 end if !$OMP ATOMIC delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib + delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 end do kloop end do @@ -751,7 +786,7 @@ end function deallocate(idx_sorted_bit) call wall_time(wall) print *, "cepa0", wall, notf - !stop + END_PROVIDER @@ -870,12 +905,14 @@ subroutine set_det_bit(det, p, s) end subroutine -BEGIN_PROVIDER [ double precision, h_, (N_det_ref,N_det_non_ref) ] + BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ] +&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ] implicit none integer :: i,j do i=1,N_det_ref do j=1,N_det_non_ref - call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_(i,j)) + call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j)) + call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j)) end do end do END_PROVIDER diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index f1d6f029..ae76597c 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -37,7 +37,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push - double precision, allocatable :: delta(:,:,:) + double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) @@ -47,8 +47,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) - double precision :: contrib, wall, iwall - double precision, allocatable :: dleat(:,:,:) + double precision :: contrib, contrib_s2, wall, iwall + double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp @@ -63,6 +63,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) + allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2)) allocate(komon(0:N_det_non_ref)) do @@ -74,10 +75,14 @@ subroutine mrsc2_dressing_slave(thread,iproc) cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) end do !delta = 0.d0 + !delta_s2 = 0.d0 n = 0 delta(:,0,:) = 0d0 delta(:,:nlink(J),1) = 0d0 delta(:,:nlink(i_I),2) = 0d0 + delta_s2(:,0,:) = 0d0 + delta_s2(:,:nlink(J),1) = 0d0 + delta_s2(:,:nlink(i_I),2) = 0d0 komon(0) = 0 komoned = .false. @@ -121,8 +126,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) end if i = det_cepa0_idx(linked(m, i_I)) - if(h_(J,i) == 0.d0) cycle - if(h_(i_I,i) == 0.d0) cycle + if(h_cache(J,i) == 0.d0) cycle + if(h_cache(i_I,i) == 0.d0) cycle !ok = .false. !do i_state=1, N_states @@ -144,10 +149,13 @@ subroutine mrsc2_dressing_slave(thread,iproc) ! if(I_i == J) phase_Ii = phase_Ji do i_state = 1,N_states - dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int) - !dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i) + dkI = h_cache(J,i) * dij(i_I, i, i_state) dleat(i_state, kn, 1) = dkI dleat(i_state, kn, 2) = dkI + + dkI = s2_cache(J,i) * dij(i_I, i, i_state) + dleat_s2(i_state, kn, 1) = dkI + dleat_s2(i_state, kn, 2) = dkI end do end do @@ -173,26 +181,32 @@ subroutine mrsc2_dressing_slave(thread,iproc) !if(lambda_mrcc(i_state, i) == 0d0) cycle - !contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al + !contrib = h_cache(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) + contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) delta(i_state,ll,1) += contrib + delta_s2(i_state,ll,1) += contrib_s2 if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) + delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) endif if(I_i == J) cycle - !contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al + !contrib = h_cache(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al contrib = dij(J, l, i_state) * dleat(i_state, m, 1) + contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) delta(i_state,kk,2) += contrib + delta_s2(i_state,kk,2) += contrib_s2 if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) + delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state) end if enddo !i_state end do ! while end do ! kk - call push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) + call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) ! end if @@ -208,7 +222,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) end -subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) +subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) use f77_zmq implicit none BEGIN_DOC @@ -218,6 +232,7 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) integer, intent(in) :: i_I, J integer(ZMQ_PTR), intent(in) :: zmq_socket_push double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(in) :: task_id integer :: rc , i_state, i, kk, li integer,allocatable :: idx(:,:) @@ -278,6 +293,12 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' stop 'error' endif + + rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) if (rc /= n(kk)*4) then @@ -305,7 +326,7 @@ end -subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) +subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) use f77_zmq implicit none BEGIN_DOC @@ -315,6 +336,7 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) integer(ZMQ_PTR), intent(in) :: zmq_socket_pull integer, intent(out) :: i_I, J, n(2) double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(out) :: task_id integer :: rc , i, kk integer,intent(inout) :: idx(N_det_non_ref,2) @@ -346,9 +368,15 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) stop 'error' endif + rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif + rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)' + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)' stop 'error' endif end if @@ -372,7 +400,7 @@ end -subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) +subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_) use f77_zmq implicit none BEGIN_DOC @@ -381,11 +409,13 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) + double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) + double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) ! integer :: j,l integer :: rc - double precision, allocatable :: delta(:,:,:) + double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket @@ -401,49 +431,46 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) delta_ii_(:,:) = 0d0 delta_ij_(:,:,:) = 0d0 + delta_ii_s2_(:,:) = 0d0 + delta_ij_s2_(:,:,:) = 0d0 zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_socket_pull = new_zmq_pull_socket() - allocate ( delta(N_states,0:N_det_non_ref,2) ) + allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) ) allocate(idx(N_det_non_ref,2)) more = 1 do while (more == 1) - call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) + call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) do l=1, n(1) do i_state=1,N_states delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) + delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1) end do end do do l=1, n(2) do i_state=1,N_states - delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) + delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) end do end do -! -! do l=1,nlink(J) -! do i_state=1,N_states -! delta_ij_(i_state,det_cepa0_idx(linked(l,J)),i_I) += delta(i_state,l,1) -! delta_ij_(i_state,det_cepa0_idx(linked(l,i_I)),j) += delta(i_state,l,2) -! end do -! end do -! if(n(1) /= 0) then do i_state=1,N_states delta_ii_(i_state,i_I) += delta(i_state,0,1) + delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1) end do end if if(n(2) /= 0) then do i_state=1,N_states delta_ii_(i_state,J) += delta(i_state,0,2) + delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2) end do end if @@ -454,7 +481,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) enddo - deallocate( delta ) + deallocate( delta, delta_s2 ) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) @@ -466,6 +493,8 @@ end BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ] implicit none integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 @@ -574,10 +603,10 @@ end ! rc = pthread_create(collector_thread, mrsc2_dressing_collector) print *, nzer, ntot, float(nzer) / float(ntot) provide nproc - !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old) PRIVATE(i) NUM_THREADS(nproc+1) + !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1) i = omp_get_thread_num() if (i==0) then - call mrsc2_dressing_collector(delta_ii_old,delta_ij_old) + call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) else call mrsc2_dressing_slave_inproc(i) endif diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f index a28d4be3..a5614942 100644 --- a/plugins/mrcepa0/mrcc.irp.f +++ b/plugins/mrcepa0/mrcc.irp.f @@ -16,7 +16,7 @@ program mrsc2sub psi_coef(i,j) = CI_eigenvectors(i,j) enddo enddo - TOUCH psi_coef + SOFT_TOUCH psi_coef endif call run(N_states,energy) if(do_pt2_end)then From 8c93d3b1a818a00ac2e7e8bc2a5396ba5d6b7dfd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 21:30:48 +0100 Subject: [PATCH 54/76] State following seems to work --- plugins/MRCC_Utils/davidson.irp.f | 62 +++++++++++++++---------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 608b427b..a7c91725 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -666,7 +666,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -847,36 +847,36 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! Compute overlap with U_in ! ------------------------- -! integer :: coord(2), order(N_st_diag) -! overlap = -1.d0 -! do k=1,shift2 -! do i=1,shift2 -! overlap(k,i) = dabs(y(k,i)) -! enddo -! enddo -! do k=1,N_st -! coord = maxloc(overlap) -! order( coord(2) ) = coord(1) -! overlap(coord(1),coord(2)) = -1.d0 -! enddo -! overlap = y -! do k=1,N_st -! l = order(k) -! if (k /= l) then -! y(1:shift2,k) = overlap(1:shift2,l) -! endif -! enddo -! do k=1,N_st -! overlap(k,1) = lambda(k) -! overlap(k,2) = s2(k) -! enddo -! do k=1,N_st -! l = order(k) -! if (k /= l) then -! lambda(k) = overlap(l,1) -! s2(k) = overlap(l,2) -! endif -! enddo + integer :: coord(2), order(N_st_diag) + overlap = -1.d0 + do k=1,shift2 + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo + enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(:,coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) + endif + enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo ! Express eigenvectors of h in the determinant basis From 1446bf9ace130529ce41edb8a731fa6ce389ff9d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 22:08:08 +0100 Subject: [PATCH 55/76] Cleaned Davidson --- plugins/MRCC_Utils/davidson.irp.f | 99 +++--- src/Davidson/EZFIO.cfg | 13 + src/Davidson/diagonalization_hs2.irp.f | 439 ++++++++++++++++++------- 3 files changed, 380 insertions(+), 171 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index a7c91725..642b229c 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -640,8 +640,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda - if (N_st_diag > sze) then - stop 'error in Davidson : N_st_diag > sze' + if (N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif PROVIDE nuclear_repulsion @@ -763,10 +765,11 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz 1.d0, U, size(U,1), S, size(S,1), & 0.d0, s_, size(s_,1)) - ! Diagonalize S^2 - ! --------------- - call lapack_diag(s2,y,s_,size(s_,1),shift2) - +! ! Diagonalize S^2 +! ! --------------- +! +! call lapack_diag(s2,y,s_,size(s_,1),shift2) +! ! ! Rotate H in the basis of eigenfunctions of s2 ! ! --------------------------------------------- ! @@ -823,7 +826,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (s2_eig) then logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0) + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) enddo else state_ok(k) = .True. @@ -844,39 +847,43 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz endif enddo - ! Compute overlap with U_in - ! ------------------------- - - integer :: coord(2), order(N_st_diag) - overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) + if (state_following) then + + ! Compute overlap with U_in + ! ------------------------- + + integer :: coord(2), order(N_st_diag) + overlap = -1.d0 + do k=1,shift2 + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo enddo - enddo - do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) - overlap(:,coord(2)) = -1.d0 - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) - endif - enddo - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - endif - enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(:,coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) + endif + enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo + + endif ! Express eigenvectors of h in the determinant basis @@ -940,22 +947,18 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo - if (.not.converged) then - iter = itermax-1 - endif - ! Re-contract to u_in ! ----------- - do k=1,N_st_diag - energies(k) = lambda(k) - 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)) enddo + do k=1,N_st_diag + energies(k) = lambda(k) + enddo + write_buffer = '===== ' do i=1,N_st write_buffer = trim(write_buffer)//' ================ =========== ===========' @@ -966,7 +969,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz deallocate ( & W, residual_norm, & - U, & + U, overlap, & c, S, & h, & y, s_, s_tmp, & diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index b7c67465..7724400f 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -15,3 +15,16 @@ type: Strictly_positive_int doc: Number of micro-iterations before re-contracting default: 10 interface: ezfio,provider,ocaml + +[state_following] +type: logical +doc: If true, the states are re-ordered to match the input states +default: False +interface: ezfio,provider,ocaml + +[disk_based_davidson] +type: logical +doc: If true, disk space is used to store the vectors +default: False +interface: ezfio,provider,ocaml + diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 97f93526..0eeda5a2 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -45,8 +45,11 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d !$OMP END DO !$OMP END PARALLEL - call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) -! call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + if (disk_based_davidson) then + call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + else + call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + endif do i=1,N_st_diag s2_out(i) = S2_jj(i) enddo @@ -84,8 +87,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) - integer, intent(in) :: iunit + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) @@ -99,7 +102,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: W(:,:), U(:,:), S(:,:), overlap(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -108,17 +111,19 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s double precision :: to_print(3,N_st) double precision :: cpu, wall integer :: shift, shift2, itermax + double precision :: r1, r2 + logical :: state_ok(N_st_diag*davidson_sze_max) include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda if (N_st_diag*3 > sze) then - print *, 'error in Davidson :' - print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 - stop -1 + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif - + PROVIDE nuclear_repulsion expected_s2 - + call write_time(iunit) call wall_time(wall) call cpu_time(cpu) @@ -137,7 +142,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -145,31 +150,32 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s write_buffer = trim(write_buffer)//' ================ =========== ===========' enddo write(iunit,'(A)') trim(write_buffer) - - integer, external :: align_double + + integer, external :: align_double sze_8 = align_double(sze) - + itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & - W(sze_8,N_st_diag*itermax), & - U(sze_8,N_st_diag*itermax), & - S(sze_8,N_st_diag*itermax), & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + overlap(N_st_diag*itermax, N_st_diag*itermax), & lambda(N_st_diag*itermax)) - h = 0.d0 - s_ = 0.d0 - s_tmp = 0.d0 + h = 0.d0 U = 0.d0 W = 0.d0 S = 0.d0 y = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 ASSERT (N_st > 0) @@ -183,21 +189,21 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s converged = .False. - double precision :: r1, r2 do k=N_st+1,N_st_diag - 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 + 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 do k=1,N_st_diag call normalize(u_in(1,k),sze) enddo - - + + do while (.not.converged) do k=1,N_st_diag @@ -205,12 +211,12 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s U(i,k) = u_in(i,k) enddo enddo - + do iter=1,itermax-1 shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter - + call ortho_qr(U,size(U,1),sze,shift2) ! Compute |W_k> = \sum_i |i> @@ -233,8 +239,49 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s 0.d0, s_, size(s_,1)) +! ! Diagonalize S^2 +! ! --------------- +! +! call lapack_diag(s2,y,s_,size(s_,1),shift2) +! +! +! ! Rotate H in the basis of eigenfunctions of s2 +! ! --------------------------------------------- +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('T','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) +! +! ! Damp interaction between different spin states +! ! ------------------------------------------------ +! +! do k=1,shift2 +! do l=1,shift2 +! if (dabs(s2(k) - s2(l)) > 1.d0) then +! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) +! endif +! enddo +! enddo +! +! ! Rotate back H +! ! ------------- +! +! call dgemm('N','T',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) + + ! Diagonalize h ! ------------- + call lapack_diag(lambda,y,h,size(h,1),shift2) ! Compute S2 for each eigenvector @@ -255,24 +302,61 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + else + state_ok(k) = .True. + endif + + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + + if (state_following) then + + integer :: coord(2), order(N_st_diag) + overlap = -1.d0 do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(:,coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) endif enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo + endif @@ -290,11 +374,31 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ----------------------------------------- do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo + if (state_ok(k)) then + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + else + ! Randomize components with bad + do i=1,sze-2,2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + U(i+1,shift2+k) = r1*dsin(r2) + enddo + do i=sze-2+1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + enddo + endif + if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion @@ -339,7 +443,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s deallocate ( & W, residual_norm, & - U, & + U, overlap, & c, S, & h, & y, s_, s_tmp, & @@ -378,8 +482,8 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) - integer, intent(in) :: iunit + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) @@ -393,7 +497,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer :: k_pairs, kl integer :: iter2 - double precision, pointer :: W(:,:), U(:,:), S(:,:) + double precision, pointer :: W(:,:), U(:,:), S(:,:), overlap(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -401,18 +505,19 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz character*(16384) :: write_buffer double precision :: to_print(3,N_st) double precision :: cpu, wall + logical :: state_ok(N_st_diag*davidson_sze_max) integer :: shift, shift2, itermax include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda if (N_st_diag*3 > sze) then - print *, 'error in Davidson :' - print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 - stop -1 + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif - + PROVIDE nuclear_repulsion expected_s2 - + call write_time(iunit) call wall_time(wall) call cpu_time(cpu) @@ -431,7 +536,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -439,51 +544,52 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz write_buffer = trim(write_buffer)//' ================ =========== ===========' enddo write(iunit,'(A)') trim(write_buffer) - - integer, external :: align_double - integer :: fd(3) - type(c_ptr) :: c_pointer(3) + + integer, external :: align_double + integer :: fd(3) + type(c_ptr) :: c_pointer(3) sze_8 = align_double(sze) - + itermax = min(davidson_sze_max, sze/N_st_diag) - call mmap( & - trim(ezfio_work_dir)//'U', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + call mmap( & + trim(ezfio_work_dir)//'U', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & 8, fd(1), .False., c_pointer(1)) call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) ) - call mmap( & - trim(ezfio_work_dir)//'W', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + call mmap( & + trim(ezfio_work_dir)//'W', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & 8, fd(2), .False., c_pointer(2)) call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) ) - call mmap( & - trim(ezfio_work_dir)//'S', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + call mmap( & + trim(ezfio_work_dir)//'S', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & 8, fd(3), .False., c_pointer(3)) call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) ) allocate( & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + overlap(N_st_diag*itermax, N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & lambda(N_st_diag*itermax)) - h = 0.d0 - s_ = 0.d0 - s_tmp = 0.d0 + h = 0.d0 U = 0.d0 W = 0.d0 S = 0.d0 y = 0.d0 - - + s_ = 0.d0 + s_tmp = 0.d0 + + ASSERT (N_st > 0) ASSERT (N_st_diag >= N_st) ASSERT (sze > 0) @@ -497,6 +603,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz double precision :: r1, r2 do k=N_st+1,N_st_diag + u_in(k,k) = 10.d0 do i=1,sze call random_number(r1) r1 = dsqrt(-2.d0*dlog(r1)) @@ -546,6 +653,45 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz 0.d0, s_(shift+1,1), size(s_,1)) enddo +! ! Diagonalize S^2 +! ! --------------- +! +! call lapack_diag(s2,y,s_,size(s_,1),shift2) +! +! +! ! Rotate H in the basis of eigenfunctions of s2 +! ! --------------------------------------------- +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('T','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) +! +! ! Damp interaction between different spin states +! ! ------------------------------------------------ +! +! do k=1,shift2 +! do l=1,shift2 +! if (dabs(s2(k) - s2(l)) > 1.d0) then +! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) +! endif +! enddo +! enddo +! +! ! Rotate back H +! ! ------------- +! +! call dgemm('N','T',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) + ! Diagonalize h ! ------------- @@ -568,36 +714,63 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz s2(k) = s_(k,k) + S_z2_Sz enddo + if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + else + state_ok(k) = .True. + endif + + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + + if (state_following) then + + integer :: coord(2), order(N_st_diag) + overlap = -1.d0 do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(:,coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) endif enddo - ! Randomize components with bad - if (.not. state_ok(k)) then - do i=1,shift2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - y(i,k) = r1*dcos(r2) - lambda(k) = 1.d0 - enddo - endif + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo + endif @@ -615,11 +788,31 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------------------------- do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo + if (state_ok(k)) then + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + else + ! Randomize components with bad + do i=1,sze-2,2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + U(i+1,shift2+k) = r1*dsin(r2) + enddo + do i=sze-2+1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + enddo + endif + if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion @@ -676,7 +869,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz deallocate ( & residual_norm, & - c, & + c, overlap, & h, & y, s_, s_tmp, & lambda & From 9a06b970de32c4d35845849324ec2314e698dc53 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 22:22:46 +0100 Subject: [PATCH 56/76] State following OK --- plugins/MRCC_Utils/davidson.irp.f | 4 +++- src/Davidson/diagonalization_hs2.irp.f | 23 +++++++++++++++++------ 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 642b229c..199feb3f 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -862,7 +862,9 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz do k=1,N_st coord = maxloc(overlap) order( coord(2) ) = coord(1) - overlap(:,coord(2)) = -1.d0 + do i=1,shift2 + overlap(coord(1),i) = -1.d0 + enddo enddo overlap = y do k=1,N_st diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 0eeda5a2..b79972af 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -328,21 +328,30 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer :: coord(2), order(N_st_diag) overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 + do i=1,shift2 + do k=1,shift2 overlap(k,i) = dabs(y(k,i)) enddo enddo do k=1,N_st coord = maxloc(overlap) order( coord(2) ) = coord(1) - overlap(:,coord(2)) = -1.d0 + do i=1,shift2 + overlap(coord(1),i) = -1.d0 + enddo + enddo + print *, order(1:N_st) + do i=1,shift2 + do k=1,shift2 + overlap(k,i) = y(k,i) + enddo enddo - overlap = y do k=1,N_st l = order(k) if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) + do i=1,shift2 + y(i,k) = overlap(i,l) + enddo endif enddo do k=1,N_st @@ -750,7 +759,9 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz do k=1,N_st coord = maxloc(overlap) order( coord(2) ) = coord(1) - overlap(:,coord(2)) = -1.d0 + do i=1,shift2 + overlap(coord(1),i) = -1.d0 + enddo enddo overlap = y do k=1,N_st From fe11f2baceb153832ec7083ca764d02f85b2abaa Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 19 Nov 2016 00:39:02 +0100 Subject: [PATCH 57/76] Improved state following --- plugins/MRCC_Utils/amplitudes.irp.f | 2 +- plugins/MRCC_Utils/davidson.irp.f | 14 ++++++++++---- src/Davidson/diagonalization_hs2.irp.f | 17 +++++++++++++---- 3 files changed, 24 insertions(+), 9 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 82736b8f..e725ef3d 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -89,7 +89,7 @@ END_PROVIDER !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) allocate(lref(N_det_non_ref)) - !$OMP DO schedule(static,10) + !$OMP DO dynamic do ppp=1,n_exc_active active_excitation_to_determinants_val(:,:,ppp) = 0d0 active_excitation_to_determinants_idx(:,ppp) = 0 diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 199feb3f..f03f8bab 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -852,7 +852,8 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! Compute overlap with U_in ! ------------------------- - integer :: coord(2), order(N_st_diag) + integer :: order(N_st_diag) + double precision :: cmax overlap = -1.d0 do k=1,shift2 do i=1,shift2 @@ -860,10 +861,15 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo enddo do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) + cmax = -1.d0 do i=1,shift2 - overlap(coord(1),i) = -1.d0 + if (overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i=1,shift2 + overlap(order(k),i) = -1.d0 enddo enddo overlap = y diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index b79972af..2e05df48 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -749,7 +749,11 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (state_following) then - integer :: coord(2), order(N_st_diag) + ! Compute overlap with U_in + ! ------------------------- + + integer :: order(N_st_diag) + double precision :: cmax overlap = -1.d0 do k=1,shift2 do i=1,shift2 @@ -757,10 +761,15 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo enddo do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) + cmax = -1.d0 do i=1,shift2 - overlap(coord(1),i) = -1.d0 + if (overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i=1,shift2 + overlap(order(k),i) = -1.d0 enddo enddo overlap = y From 92c954143cf069e595ca2556cf0117d8066f09ab Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 20 Nov 2016 22:14:06 +0100 Subject: [PATCH 58/76] Bug in MRSC2 --- plugins/mrcepa0/dressing_slave.irp.f | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index ae76597c..9e9fa65a 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -455,6 +455,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2 do l=1, n(2) do i_state=1,N_states + delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) end do end do From 7f9d19346efaaaae291401c88bd1a03c6f2a9181 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 20 Nov 2016 22:46:10 +0100 Subject: [PATCH 59/76] Fixed compilation --- plugins/MRCC_Utils/amplitudes.irp.f | 2 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index e725ef3d..72d3ea67 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -89,7 +89,7 @@ END_PROVIDER !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) allocate(lref(N_det_non_ref)) - !$OMP DO dynamic + !$OMP DO schedule(dynamic) do ppp=1,n_exc_active active_excitation_to_determinants_val(:,:,ppp) = 0d0 active_excitation_to_determinants_idx(:,ppp) = 0 diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f28ccf25..ea13f8cc 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -718,7 +718,7 @@ END_PROVIDER factor = 1.d0 resold = huge(1.d0) - do k=0,100000 + do k=0,hh_nex !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) !$OMP DO From f2fdcb379d648bd85203ca6f03cd5a32770a0888 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 20 Nov 2016 22:55:10 +0100 Subject: [PATCH 60/76] Single state diagonalization in MRCC --- plugins/MRCC_Utils/mrcc_utils.irp.f | 12 +++++------- plugins/mrcepa0/mrcepa0_general.irp.f | 12 ++++++++---- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index ea13f8cc..b3b2f427 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -150,17 +150,15 @@ END_PROVIDER allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & eigenvalues(size(CI_electronic_energy_dressed,1))) do mrcc_state=1,N_states - do j=1,min(N_states,N_det) - do i=1,N_det - eigenvectors(i,j) = psi_coef(i,j) - enddo + do i=1,N_det + eigenvectors(i,1) = psi_coef(i,mrcc_state) enddo call davidson_diag_mrcc_HS2(psi_det,eigenvectors,& size(eigenvectors,1), & - eigenvalues,N_det,N_states,N_states_diag,N_int, & + eigenvalues,N_det,1,N_states_diag,N_int, & output_determinants,mrcc_state) - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,1) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(1) if (mrcc_state == 1) then do k=N_states+1,N_states_diag CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 09c35e52..1e89cc2c 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -41,11 +41,15 @@ subroutine run(N_st,energy) print *, 'MRCEPA0 Iteration', iteration print *, '===========================' print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy") + E_old = sum(ci_energy_dressed(1:N_states)) + do i=1,N_st + call write_double(6,ci_energy_dressed(i),"MRCEPA0 energy") + enddo call diagonalize_ci_dressed(lambda) - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) + E_new = sum(ci_energy_dressed(1:N_states)) + delta_E = (E_new - E_old)/dble(N_states) + call write_double(6,delta_E,"delta_E") + delta_E = dabs(delta_E) call save_wavefunction call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) if (iteration >= n_it_mrcc_max) then From ae7e9361b9957a0ab9c962c18bfc5efd84797cdc Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 21 Nov 2016 21:25:38 +0100 Subject: [PATCH 61/76] Improved convergence of multi-state --- plugins/MRCC_Utils/mrcc_utils.irp.f | 41 +++++++++++++++----------- plugins/mrcepa0/mrcepa0_general.irp.f | 8 +++-- src/Davidson/diagonalization_hs2.irp.f | 32 ++++++++++---------- 3 files changed, 44 insertions(+), 37 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index b3b2f427..3b05aaeb 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -149,26 +149,31 @@ END_PROVIDER allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & eigenvalues(size(CI_electronic_energy_dressed,1))) + do j=1,min(N_states,N_det) + do i=1,N_det + eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo do mrcc_state=1,N_states - do i=1,N_det - eigenvectors(i,1) = psi_coef(i,mrcc_state) + do j=mrcc_state,min(N_states,N_det) + do i=1,N_det + eigenvectors(i,j) = psi_coef(i,j) + enddo enddo call davidson_diag_mrcc_HS2(psi_det,eigenvectors,& size(eigenvectors,1), & - eigenvalues,N_det,1,N_states_diag,N_int, & + eigenvalues,N_det,N_states,N_states_diag,N_int, & output_determinants,mrcc_state) - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,1) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(1) - if (mrcc_state == 1) then - do k=N_states+1,N_states_diag - CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) - CI_electronic_energy_dressed(k) = eigenvalues(k) - enddo - endif - enddo - call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo + do k=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) + CI_electronic_energy_dressed(k) = eigenvalues(k) + enddo + call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& N_states_diag,size(CI_eigenvectors_dressed,1)) - deallocate (eigenvectors,eigenvalues) + deallocate (eigenvectors,eigenvalues) else if (diag_algorithm == "Lapack") then @@ -716,7 +721,7 @@ END_PROVIDER factor = 1.d0 resold = huge(1.d0) - do k=0,hh_nex + do k=0,hh_nex*hh_nex !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) !$OMP DO @@ -751,15 +756,15 @@ END_PROVIDER X(a_col) = X_new(a_col) end do if (res > resold) then - factor = -factor * 0.5d0 + factor = factor * 0.5d0 endif resold = res - if(mod(k, 100) == 0) then + if(iand(k, 4095) == 0) then print *, "res ", k, res end if - if(res < 1d-9) exit + if(res < 1d-12) exit end do norm = 0.d0 diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 1e89cc2c..d9607e6a 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -37,9 +37,9 @@ subroutine run(N_st,energy) lambda = 1.d0 do while (delta_E > thresh_mrcc) iteration += 1 - print *, '===========================' - print *, 'MRCEPA0 Iteration', iteration - print *, '===========================' + print *, '===============================================' + print *, 'MRCEPA0 Iteration', iteration, '/', n_it_mrcc_max + print *, '===============================================' print *, '' E_old = sum(ci_energy_dressed(1:N_states)) do i=1,N_st @@ -48,6 +48,8 @@ subroutine run(N_st,energy) call diagonalize_ci_dressed(lambda) E_new = sum(ci_energy_dressed(1:N_states)) delta_E = (E_new - E_old)/dble(N_states) + print *, '' + call write_double(6,thresh_mrcc,"thresh_mrcc") call write_double(6,delta_E,"delta_E") delta_E = dabs(delta_E) call save_wavefunction diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 2e05df48..8dc6e00d 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -326,32 +326,32 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s if (state_following) then - integer :: coord(2), order(N_st_diag) + integer :: order(N_st_diag) + double precision :: cmax + overlap = -1.d0 - do i=1,shift2 - do k=1,shift2 + do k=1,shift2 + do i=1,shift2 overlap(k,i) = dabs(y(k,i)) enddo enddo do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) - do i=1,shift2 - overlap(coord(1),i) = -1.d0 + cmax = -1.d0 + do i=1,N_st_diag + if (overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i=1,N_st_diag + overlap(order(k),i) = -1.d0 enddo enddo - print *, order(1:N_st) - do i=1,shift2 - do k=1,shift2 - overlap(k,i) = y(k,i) - enddo - enddo + overlap = y do k=1,N_st l = order(k) if (k /= l) then - do i=1,shift2 - y(i,k) = overlap(i,l) - enddo + y(1:shift2,k) = overlap(1:shift2,l) endif enddo do k=1,N_st From c11dfed16b950aba58ffa9d5f90f104baa60da46 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 21 Nov 2016 21:42:28 +0100 Subject: [PATCH 62/76] Improved convergence of multi-state --- plugins/MRCC_Utils/davidson.irp.f | 2 +- src/Davidson/diagonalization_hs2.irp.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index f03f8bab..e667d255 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -862,7 +862,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo do k=1,N_st cmax = -1.d0 - do i=1,shift2 + do i=1,N_st if (overlap(i,k) > cmax) then cmax = overlap(i,k) order(k) = i diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 8dc6e00d..7cba0f60 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -337,7 +337,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo do k=1,N_st cmax = -1.d0 - do i=1,N_st_diag + do i=1,N_st if (overlap(i,k) > cmax) then cmax = overlap(i,k) order(k) = i From 94d7aed238179877cbfd2f8a430ffe04fbfebe13 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 21 Nov 2016 23:17:43 +0100 Subject: [PATCH 63/76] Changed symmetrization of H_mrcc --- plugins/MRCC_Utils/mrcc_utils.irp.f | 5 +--- plugins/mrcepa0/dressing.irp.f | 44 +++++++++++++++++++++-------- 2 files changed, 34 insertions(+), 15 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 3b05aaeb..0540eed9 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -953,17 +953,14 @@ BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ] integer :: s,i,j double precision, external :: get_dij_index print *, "computing amplitudes..." - !$OMP PARALLEL DEFAULT(shared) PRIVATE(s,i,j) do s=1, N_states - !$OMP DO do i=1, N_det_non_ref do j=1, N_det_ref + !DIR$ FORCEINLINE dij(j, i, s) = get_dij_index(j, i, s, N_int) end do end do - !$OMP END DO end do - !$OMP END PARALLEL print *, "done computing amplitudes" END_PROVIDER diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 46c56d9d..cba4629b 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -18,7 +18,8 @@ use bitmasks delta_ii_mrcc = 0d0 delta_ij_s2_mrcc = 0d0 delta_ii_s2_mrcc = 0d0 - print *, "Dij", dij(1,1,1) + PROVIDE dij + print *, "Dij", dij(1,1,1:N_states) provide hh_shortcut psi_det_size! lambda_mrcc !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & @@ -300,22 +301,22 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen enddo call omp_set_lock( psi_ref_lock(i_I) ) do i_state=1,N_states - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) - delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) - delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - enddo - else +! if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then +! do l_sd=1,idx_alpha(0) +! k_sd = idx_alpha(l_sd) +! delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) +! delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) +! delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) +! delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) +! enddo +! else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo - endif +! endif enddo call omp_unset_lock( psi_ref_lock(i_I) ) enddo @@ -350,6 +351,27 @@ end enddo end do end do + + ! =-=-= BEGIN STATE AVERAGE +! do i = 1, N_det_ref +! delta_ii(:,i)= delta_ii_mrcc(1,i) +! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) +! do i_state = 2, N_states +! delta_ii(:,i) += delta_ii_mrcc(i_state,i) +! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) +! enddo +! do j = 1, N_det_non_ref +! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) +! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) +! do i_state = 2, N_states +! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) +! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) +! enddo +! end do +! end do +! delta_ij = delta_ij * (1.d0/dble(N_states)) +! delta_ii = delta_ii * (1.d0/dble(N_states)) + ! =-=-= END STATE AVERAGE ! ! do i = 1, N_det_ref ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) From f326801e565001c720f8dc8b25986f2d9307e2ab Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 21 Nov 2016 23:31:28 +0100 Subject: [PATCH 64/76] Fixed mrcepa0_general.irp.f --- plugins/mrcepa0/dressing.irp.f | 1 - plugins/mrcepa0/mrcepa0_general.irp.f | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index cba4629b..0c67ab99 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -19,7 +19,6 @@ use bitmasks delta_ij_s2_mrcc = 0d0 delta_ii_s2_mrcc = 0d0 PROVIDE dij - print *, "Dij", dij(1,1,1:N_states) provide hh_shortcut psi_det_size! lambda_mrcc !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index d9607e6a..1b2e2fcb 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -21,7 +21,7 @@ subroutine run(N_st,energy) n_it_mrcc_max = n_it_max_dressed_ci if(n_it_mrcc_max == 1) then - do j=1,N_states_diag + do j=1,N_states do i=1,N_det psi_coef(i,j) = CI_eigenvectors_dressed(i,j) enddo From c2a7d25615ffef71ea2e7649c8388541f7989540 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 22 Nov 2016 12:55:42 +0100 Subject: [PATCH 65/76] FCI stops exactly at the required number of determinants --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 7 +++++-- src/Utils/map_module.f90 | 12 ++++++------ 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index c80b7410..b3ffbe03 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -5,6 +5,7 @@ program fci_zmq double precision, allocatable :: pt2(:) integer :: degree + integer :: n_det_before, to_select allocate (pt2(N_states)) @@ -33,13 +34,15 @@ program fci_zmq double precision :: E_CI_before(N_states) - integer :: n_det_before print*,'Beginning the selection ...' E_CI_before(1:N_states) = CI_energy(1:N_states) + n_det_before = 0 do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) n_det_before = N_det - call ZMQ_selection(max(1024-N_det, N_det), pt2) + to_select = max(1024-N_det, N_det) + to_select = min(to_select, N_det_max-n_det_before) + call ZMQ_selection(to_select, pt2) PROVIDE psi_coef PROVIDE psi_det diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index 4a83582f..80260233 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -622,7 +622,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) istep = ishft(iend-ibegin,-1) idx = ibegin + istep - do while (istep > 16) + do while (istep > 64) idx = ibegin + istep ! TODO : Cache misses if (cache_key < X(idx)) then @@ -660,8 +660,8 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) endif enddo idx = ibegin - if (min(iend_in,sze) > ibegin+16) then - iend = ibegin+16 + if (min(iend_in,sze) > ibegin+64) then + iend = ibegin+64 do while (cache_key > X(idx)) idx = idx+1 end do @@ -730,7 +730,7 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in istep = ishft(iend-ibegin,-1) idx = ibegin + istep - do while (istep > 16) + do while (istep > 64) idx = ibegin + istep if (cache_key < X(idx)) then iend = idx @@ -771,8 +771,8 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in enddo idx = ibegin value = Y(idx) - if (min(iend_in,sze) > ibegin+16) then - iend = ibegin+16 + if (min(iend_in,sze) > ibegin+64) then + iend = ibegin+64 do while (cache_key > X(idx)) idx = idx+1 value = Y(idx) From 520bb45be8620da839f7a931d714991703fa561d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 22 Nov 2016 13:00:02 +0100 Subject: [PATCH 66/76] Accelerated selection --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index b3ffbe03..382e8652 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -6,11 +6,15 @@ program fci_zmq double precision, allocatable :: pt2(:) integer :: degree integer :: n_det_before, to_select + double precision :: threshold_davidson_in allocate (pt2(N_states)) pt2 = 1.d0 diag_algorithm = "Lapack" + threshold_davidson_in = threshold_davidson + SOFT_TOUCH threshold_davidson + threshold_davidson = 1.d-4 if (N_det > N_det_max) then call diagonalize_CI @@ -40,7 +44,8 @@ program fci_zmq do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) n_det_before = N_det - to_select = max(1024-N_det, N_det) + to_select = 3*N_det + to_select = max(1024-to_select, to_select) to_select = min(to_select, N_det_max-n_det_before) call ZMQ_selection(to_select, pt2) @@ -48,6 +53,10 @@ program fci_zmq PROVIDE psi_det PROVIDE psi_det_sorted + if (N_det == N_det_max) then + threshold_davidson = threshold_davidson_in + SOFT_TOUCH threshold_davidson + endif call diagonalize_CI call save_wavefunction From ed1c7eb6f46c55c5fc5f93e67666811a02397ae5 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 25 Nov 2016 19:23:09 +0100 Subject: [PATCH 67/76] minor modifs in printing --- plugins/MRPT_Utils/EZFIO.cfg | 7 + plugins/MRPT_Utils/MRPT_Utils.main.irp.f | 14 +- plugins/MRPT_Utils/energies_cas.irp.f | 21 +- plugins/MRPT_Utils/mrpt_dress.irp.f | 6 +- plugins/MRPT_Utils/mrpt_utils.irp.f | 235 ++++++++++++++--------- plugins/MRPT_Utils/print_1h2p.irp.f | 6 +- plugins/MRPT_Utils/special_hij.irp.f | 183 ------------------ plugins/loc_cele/loc_exchange_int.irp.f | 29 +-- src/Determinants/slater_rules.irp.f | 20 +- 9 files changed, 209 insertions(+), 312 deletions(-) delete mode 100644 plugins/MRPT_Utils/special_hij.irp.f diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg index 2fcc26ad..948aa735 100644 --- a/plugins/MRPT_Utils/EZFIO.cfg +++ b/plugins/MRPT_Utils/EZFIO.cfg @@ -5,3 +5,10 @@ interface: ezfio,provider,ocaml default: True +[pure_state_specific_mrpt2] +type: logical +doc: If true, diagonalize the dressed matrix for each state and do a state following of the initial states +interface: ezfio,provider,ocaml +default: True + + diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f index 13c8228a..72750f8c 100644 --- a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f +++ b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f @@ -10,16 +10,20 @@ end subroutine routine_3 implicit none + integer :: i !provide fock_virt_total_spin_trace provide delta_ij print *, 'N_det = ', N_det print *, 'N_states = ', N_states - print *, 'PT2 = ', second_order_pt_new(1) - print *, 'E = ', CI_energy(1) - print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1) - print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******' - print *, 'E dressed= ', CI_dressed_pt2_new_energy(1) + do i = 1, N_States + print*,'State',i + write(*,'(A12,X,I3,A3,XX,F16.10)') ' PT2 ', i,' = ', second_order_pt_new(i) + write(*,'(A12,X,I3,A3,XX,F16.09)') ' E ', i,' = ', CI_energy(i) + write(*,'(A12,X,I3,A3,XX,F16.09)') ' E+PT2 ', i,' = ', CI_energy(i)+second_order_pt_new(i) + write(*,'(A12,X,I3,A3,XX,F16.09)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i) + write(*,'(A12,X,I3,A3,XX,F16.09)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) + enddo end diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index f09c30cb..8f29717c 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -241,13 +241,13 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - if(orb_i == orb_j .and. ispin .ne. jspin)then + !if(orb_i == orb_j .and. ispin .ne. jspin)then call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - else - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) - one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - endif + !else + ! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + ! one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + !endif enddo enddo enddo @@ -527,7 +527,7 @@ END_PROVIDER double precision :: thresh_norm - thresh_norm = 1.d-10 + thresh_norm = 1.d-20 @@ -552,14 +552,7 @@ END_PROVIDER call debug_det(psi_in_out,N_int) print*, 'pb, i_ok ne 0 !!!' endif -! call i_H_j_no_k_operators_from_act(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij_test) call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) -! if(i==1.and.dabs(hij)>1.d-8)then -! if(dabs(hij)>1.d-8)then -! print*, ispin,vorb,iorb -! print*, i,hij,hij_test -! pause -! endif do j = 1, n_states double precision :: coef,contrib coef = psi_coef(i,j) !* psi_coef(i,j) @@ -635,7 +628,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta double precision :: thresh_norm - thresh_norm = 1.d-10 + thresh_norm = 1.d-20 do aorb = 1,n_act_orb orb_a = list_act(aorb) diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index 275af0e4..60bb2b69 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -84,7 +84,11 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip do i_state = 1, N_states coef_array(i_state) = psi_coef(index_i,i_state) enddo - call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) + if(dabs(hialpha).le.1.d-10)then + delta_e = 1.d+20 + else + call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) + endif hij_array(index_i) = hialpha call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) ! phase_array(index_i) = phase diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 4e8bc7d0..8ac8e3e0 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -121,8 +121,8 @@ ! 1h2p delta_ij_tmp = 0.d0 -!call give_1h2p_contrib(delta_ij_tmp) - call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) + call give_1h2p_contrib(delta_ij_tmp) +!!!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) accu = 0.d0 do i_state = 1, N_states do i = 1, N_det @@ -137,8 +137,8 @@ ! 2h1p delta_ij_tmp = 0.d0 -!call give_2h1p_contrib(delta_ij_tmp) - call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) + call give_2h1p_contrib(delta_ij_tmp) +!!!! call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) accu = 0.d0 do i_state = 1, N_states do i = 1, N_det @@ -152,19 +152,19 @@ print*, '2h1p = ',accu ! 2h2p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -!enddo -!second_order_pt_new_2h2p(i_state) = accu(i_state) -!enddo -!print*, '2h2p = ',accu + delta_ij_tmp = 0.d0 +!!!!!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h2p(i_state) = accu(i_state) + enddo + print*, '2h2p = ',accu double precision :: contrib_2h2p(N_states) call give_2h2p(contrib_2h2p) @@ -236,13 +236,15 @@ END_PROVIDER logical, allocatable :: good_state_array(:) double precision, allocatable :: s2_values_tmp(:) integer :: i_other_state - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:), hmatrix_tmp(:,:) integer :: i_state double precision :: s2,e_0 integer :: i,j,k double precision, allocatable :: s2_eigvalues(:) double precision, allocatable :: e_array(:) integer, allocatable :: iorder(:) + double precision :: overlap(N_det) + double precision, allocatable :: psi_tmp(:) ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors do j=1,min(N_states,N_det) @@ -265,82 +267,131 @@ END_PROVIDER else if (diag_algorithm == "Lapack") then allocate (eigenvectors(N_det,N_det)) allocate (eigenvalues(N_det)) - call lapack_diag(eigenvalues,eigenvectors, & - Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det) - CI_electronic_dressed_pt2_new_energy(:) = 0.d0 - if (s2_eig) then - i_state = 0 - allocate (s2_eigvalues(N_det)) - allocate(index_good_state_array(N_det),good_state_array(N_det)) - good_state_array = .False. - call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& - N_det,size(eigenvectors,1)) - do j=1,N_det - ! Select at least n_states states with S^2 values closed to "expected_s2" - if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then - i_state += 1 - index_good_state_array(i_state) = j - good_state_array(j) = .True. - endif - if (i_state==N_states) then - exit - endif + if(pure_state_specific_mrpt2)then + allocate (hmatrix_tmp(N_det,N_det)) + allocate (iorder(N_det)) + allocate (psi_tmp(N_det)) + print*,'' + print*,'***************************' + do i_state = 1, N_states !! Big loop over states + print*,'' + print*,'Diagonalizing with the dressing for state',i_state + do i = 1, N_det + do j = 1, N_det + hmatrix_tmp(j,i) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) + enddo enddo - if (i_state /= 0) then - ! Fill the first "i_state" states that have a correct S^2 value - do j = 1, i_state - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) - enddo - CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j)) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) - enddo - i_other_state = 0 - do j = 1, N_det - if(good_state_array(j))cycle - i_other_state +=1 - if(i_state+i_other_state.gt.n_states_diag)then - exit - endif - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) - enddo - CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) - enddo - - else - print*,'' - print*,'!!!!!!!! WARNING !!!!!!!!!' - print*,' Within the ',N_det,'determinants selected' - print*,' and the ',N_states_diag,'states requested' - print*,' We did not find any state with S^2 values close to ',expected_s2 - print*,' We will then set the first N_states eigenvectors of the H matrix' - print*,' as the CI_dressed_pt2_new_eigenvectors' - print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' - print*,'' - do j=1,min(N_states_diag,N_det) - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) - enddo - CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) - enddo - endif - deallocate(index_good_state_array,good_state_array) - deallocate(s2_eigvalues) - else - call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& - min(N_det,N_states_diag),size(eigenvectors,1)) - ! Select the "N_states_diag" states of lowest energy - do j=1,min(N_det,N_states_diag) - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) - enddo - CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) + call lapack_diag(eigenvalues,eigenvectors, & + Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det) + write(*,'(A86)')'Looking for the most overlapping state within all eigenvectors of the dressed matrix' + print*,'' + print*,'Calculating the overlap for ...' + do i = 1, N_det + overlap(i) = 0.d0 + iorder(i) = i + print*,'eigenvector',i + do j = 1, N_det + overlap(i)+= psi_coef(j,i_state) * eigenvectors(j,i) + enddo + overlap(i) = -dabs(overlap(i)) + print*,'energy = ',eigenvalues(i) + nuclear_repulsion + print*,'overlap = ',dabs(overlap(i)) enddo + print*,'' + print*,'Sorting the eigenvectors per overlap' + call dsort(overlap,iorder,n_states) + print*,'' + print*,'The most overlapping state is the ',iorder(1) + print*,'with the overlap of ',dabs(overlap(1)) + print*,'and an energy of ',eigenvalues(iorder(1)) + nuclear_repulsion + print*,'Calculating the S^2 value ...' + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,i_state) = eigenvectors(i,iorder(1)) + psi_tmp(i) = eigenvectors(i,iorder(1)) + enddo + CI_electronic_dressed_pt2_new_energy(i_state) = eigenvalues(iorder(1)) + call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2(i_state),psi_tmp,N_det,psi_det,N_int,1,N_det) + print*,'S^2 = ', CI_dressed_pt2_new_eigenvectors_s2(i_state) + enddo + else + call lapack_diag(eigenvalues,eigenvectors, & + Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det) + CI_electronic_dressed_pt2_new_energy(:) = 0.d0 + if (s2_eig) then + i_state = 0 + allocate (s2_eigvalues(N_det)) + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& + N_det,size(eigenvectors,1)) + do j=1,N_det + ! Select at least n_states states with S^2 values closed to "expected_s2" + print*, eigenvalues(j)+nuclear_repulsion, s2_eigvalues(j) + if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then + i_state += 1 + index_good_state_array(i_state) = j + good_state_array(j) = .True. + endif + if (i_state==N_states) then + exit + endif + enddo + if (i_state /= 0) then + ! Fill the first "i_state" states that have a correct S^2 value + do j = 1, i_state + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + enddo + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j)) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + enddo + i_other_state = 0 + do j = 1, N_det + if(good_state_array(j))cycle + i_other_state +=1 + if(i_state+i_other_state.gt.n_states)then + exit + endif + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + enddo + CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + enddo + + else + print*,'' + print*,'!!!!!!!! WARNING !!!!!!!!!' + print*,' Within the ',N_det,'determinants selected' + print*,' and the ',N_states_diag,'states requested' + print*,' We did not find any state with S^2 values close to ',expected_s2 + print*,' We will then set the first N_states eigenvectors of the H matrix' + print*,' as the CI_dressed_pt2_new_eigenvectors' + print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' + print*,'' + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) + enddo + endif + deallocate(index_good_state_array,good_state_array) + deallocate(s2_eigvalues) + else + call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& + min(N_det,N_states_diag),size(eigenvectors,1)) + ! Select the "N_states_diag" states of lowest energy + do j=1,min(N_det,N_states) + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) + enddo + endif + deallocate(eigenvectors,eigenvalues) endif - deallocate(eigenvectors,eigenvalues) endif @@ -361,7 +412,7 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion write(st,'(I4)') j call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st)) - call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) + call write_double(output_determinants, CI_dressed_pt2_new_eigenvectors_s2(j) ,'S^2 of state '//trim(st)) enddo END_PROVIDER diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT_Utils/print_1h2p.irp.f index 03851d8a..747e2817 100644 --- a/plugins/MRPT_Utils/print_1h2p.irp.f +++ b/plugins/MRPT_Utils/print_1h2p.irp.f @@ -8,8 +8,10 @@ end subroutine routine_2 implicit none integer :: i,j - do i =1, n_inact_orb - write(*,'(100(F16.10,X))')one_anhil_one_creat_inact_virt(i,:,1) + do i =1, n_act_orb +!do i =1, 2 + write(*,'(I3,x,100(F16.10,X))')i,one_anhil_one_creat(i,:,:,:,1) +! write(*,'(I3,x,100(F16.10,X))')i,one_anhil_one_creat(1,4,1,2,1) enddo diff --git a/plugins/MRPT_Utils/special_hij.irp.f b/plugins/MRPT_Utils/special_hij.irp.f deleted file mode 100644 index 597d8ee3..00000000 --- a/plugins/MRPT_Utils/special_hij.irp.f +++ /dev/null @@ -1,183 +0,0 @@ - - -subroutine i_H_j_no_k_operators_from_act(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral, phase - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem - integer :: n_occ_ab(2) - logical :: has_mipi(Nint*bit_kind_size) - double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size), miip_other(Nint*bit_kind_size) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_map) - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*(get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*(get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - has_mipi = .False. - logical :: is_i_in_active - double precision :: accu_a, accu_b, accu_core - accu_a = 0.d0 - accu_b = 0.d0 - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - do k = 1, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - if(.not.is_i_in_active(i))then - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - else -! print*, i,get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - miip(i) = 1.0d0 * get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - accu_a += miip(i) - endif - enddo - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - if(.not.is_i_in_active(i))then - miip_other(i) = 0.d0 - else -! print*, i,get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - miip_other(i) = 1.0d0 * get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - accu_b += miip(i) - endif - enddo -! print*, accu_a,accu_b,accu_a + accu_b - accu_a = 0.d0 - accu_b = 0.d0 - accu_core = mo_mono_elec_integral(m,p) - - do k = 1, elec_alpha_num - hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) - accu_Core += mipi(occ(k,1)) - if(is_i_in_active(occ(k,1)))then - accu_a += miip(occ(k,1)) - else - accu_Core -= miip(occ(k,1)) - endif - enddo -! print*, hij,accu_core - do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - miip_other(occ(k,2)) - accu_Core += mipi(occ(k,2)) - if(is_i_in_active(occ(k,2)))then - accu_b += miip_other(occ(k,2)) - else - accu_Core -= miip_other(occ(k,2)) - endif - enddo -! print*, hij,accu_core,accu_core - accu_a - accu_b -! print*, accu_a,accu_b,accu_a + accu_b -! pause - - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - if(.not.is_i_in_active(i))then - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - else - miip(i) = 1.0d0 * get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - endif - enddo - do k = 1, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - if(.not.is_i_in_active(i))then - miip_other(i) = 0.d0 - else - miip_other(i) = 1.0d0 * get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - endif - enddo - do k = 1, elec_alpha_num - hij = hij + mipi(occ(k,1)) - miip_other(occ(k,1)) - enddo - do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) - enddo - - endif - hij = phase*(hij + mo_mono_elec_integral(m,p)) - - case (0) - hij = diag_H_mat_elem(key_i,Nint) - end select -end - - - diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f index d7cc5c65..fa3cf8bf 100644 --- a/plugins/loc_cele/loc_exchange_int.irp.f +++ b/plugins/loc_cele/loc_exchange_int.irp.f @@ -13,21 +13,21 @@ program loc_int iorb = list_core_inact(i) exchange_int = 0.d0 iorder = 0 - print*,'' if(list_core_inact_check(iorb) == .False.)cycle do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + if(list_core_inact_check(jorb) == .False.)then + exchange_int(jorb) = 0.d0 + else + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + endif enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' @@ -45,21 +45,21 @@ program loc_int iorb = list_act(i) exchange_int = 0.d0 iorder = 0 - print*,'' if(list_core_inact_check(iorb) == .False.)cycle do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + if(list_core_inact_check(jorb) == .False.)then + exchange_int(jorb) = 0.d0 + else + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + endif enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' @@ -82,16 +82,17 @@ program loc_int do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + if(list_core_inact_check(jorb) == .False.)then + exchange_int(jorb) = 0.d0 + else + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + endif enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index ed299447..47d02758 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -2168,9 +2168,27 @@ subroutine H_u_0_stored(v_0,u_0,hmatrix,sze) double precision, intent(in) :: u_0(sze) v_0 = 0.d0 call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) - end +subroutine H_s2_u_0_stored(v_0,u_0,hmatrix,s2matrix,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> + ! + ! n : number of determinants + ! + ! uses the big_matrix_stored array + END_DOC + integer, intent(in) :: sze + double precision, intent(in) :: hmatrix(sze,sze),s2matrix(sze,sze) + double precision, intent(out) :: v_0(sze) + double precision, intent(in) :: u_0(sze) + v_0 = 0.d0 + call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) +end + + subroutine u_0_H_u_0_stored(e_0,u_0,hmatrix,sze) use bitmasks implicit none From 8c6bb03a234b02bff0b872a86706a681a914dc29 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 25 Nov 2016 23:07:45 +0100 Subject: [PATCH 68/76] Fixed the perturbation with psi_ref instead of psi_det --- .../Generators_CAS/Generators_full/.gitignore | 25 ++ .../Generators_full/NEEDED_CHILDREN_MODULES | 1 + .../Generators_CAS/Generators_full/README.rst | 61 +++++ .../Generators_full/generators.irp.f | 75 ++++++ .../Generators_full/tree_dependency.png | Bin 0 -> 82663 bytes plugins/Generators_CAS/generators.irp.f | 16 +- plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES | 2 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 41 ++++ plugins/MRPT/NEEDED_CHILDREN_MODULES | 2 +- {src => plugins}/MRPT_Utils/EZFIO.cfg | 0 {src => plugins}/MRPT_Utils/H_apply.irp.f | 0 .../MRPT_Utils/NEEDED_CHILDREN_MODULES | 0 {src => plugins}/MRPT_Utils/README.rst | 0 .../MRPT_Utils/energies_cas.irp.f | 214 +++++++++--------- .../MRPT_Utils/excitations_cas.irp.f | 0 plugins/MRPT_Utils/ezfio_interface.irp.f | 42 ++++ .../MRPT_Utils/fock_like_operators.irp.f | 0 {src => plugins}/MRPT_Utils/give_2h2p.irp.f | 0 {src => plugins}/MRPT_Utils/mrpt_dress.irp.f | 42 ++-- {src => plugins}/MRPT_Utils/mrpt_utils.irp.f | 176 +++++++------- {src => plugins}/MRPT_Utils/new_way.irp.f | 20 +- .../new_way_second_order_coef.irp.f | 8 +- .../MRPT_Utils/psi_active_prov.irp.f | 0 .../MRPT_Utils/second_order_new.irp.f | 8 +- .../MRPT_Utils/second_order_new_2p.irp.f | 4 +- .../MRPT_Utils/utils_bitmask.irp.f | 0 plugins/mrcepa0/NEEDED_CHILDREN_MODULES | 2 +- scripts/generate_h_apply.py | 6 +- src/Determinants/H_apply_nozmq.template.f | 2 +- src/Determinants/H_apply_zmq.template.f | 2 +- 30 files changed, 499 insertions(+), 250 deletions(-) create mode 100644 plugins/Generators_CAS/Generators_full/.gitignore create mode 100644 plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES create mode 100644 plugins/Generators_CAS/Generators_full/README.rst create mode 100644 plugins/Generators_CAS/Generators_full/generators.irp.f create mode 100644 plugins/Generators_CAS/Generators_full/tree_dependency.png rename {src => plugins}/MRPT_Utils/EZFIO.cfg (100%) rename {src => plugins}/MRPT_Utils/H_apply.irp.f (100%) rename {src => plugins}/MRPT_Utils/NEEDED_CHILDREN_MODULES (100%) rename {src => plugins}/MRPT_Utils/README.rst (100%) rename {src => plugins}/MRPT_Utils/energies_cas.irp.f (80%) rename {src => plugins}/MRPT_Utils/excitations_cas.irp.f (100%) create mode 100644 plugins/MRPT_Utils/ezfio_interface.irp.f rename {src => plugins}/MRPT_Utils/fock_like_operators.irp.f (100%) rename {src => plugins}/MRPT_Utils/give_2h2p.irp.f (100%) rename {src => plugins}/MRPT_Utils/mrpt_dress.irp.f (78%) rename {src => plugins}/MRPT_Utils/mrpt_utils.irp.f (72%) rename {src => plugins}/MRPT_Utils/new_way.irp.f (98%) rename {src => plugins}/MRPT_Utils/new_way_second_order_coef.irp.f (99%) rename {src => plugins}/MRPT_Utils/psi_active_prov.irp.f (100%) rename {src => plugins}/MRPT_Utils/second_order_new.irp.f (99%) rename {src => plugins}/MRPT_Utils/second_order_new_2p.irp.f (99%) rename {src => plugins}/MRPT_Utils/utils_bitmask.irp.f (100%) diff --git a/plugins/Generators_CAS/Generators_full/.gitignore b/plugins/Generators_CAS/Generators_full/.gitignore new file mode 100644 index 00000000..8d85dede --- /dev/null +++ b/plugins/Generators_CAS/Generators_full/.gitignore @@ -0,0 +1,25 @@ +# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py +IRPF90_temp +IRPF90_man +irpf90_entities +tags +irpf90.make +Makefile +Makefile.depend +build.ninja +.ninja_log +.ninja_deps +ezfio_interface.irp.f +Ezfio_files +Determinants +Integrals_Monoelec +MO_Basis +Utils +Pseudo +Bitmask +AO_Basis +Electrons +MOGuess +Nuclei +Hartree_Fock +Integrals_Bielec \ No newline at end of file diff --git a/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES b/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..54f54203 --- /dev/null +++ b/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Hartree_Fock diff --git a/plugins/Generators_CAS/Generators_full/README.rst b/plugins/Generators_CAS/Generators_full/README.rst new file mode 100644 index 00000000..c30193a2 --- /dev/null +++ b/plugins/Generators_CAS/Generators_full/README.rst @@ -0,0 +1,61 @@ +====================== +Generators_full Module +====================== + +All the determinants of the wave function are generators. In this way, the Full CI +space is explored. + +Needed Modules +============== + +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + +.. image:: tree_dependency.png + +* `Determinants `_ +* `Hartree_Fock `_ + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Determinants `_ +* `Hartree_Fock `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`degree_max_generators `_ + Max degree of excitation (respect to HF) of the generators + + +`n_det_generators `_ + For Single reference wave functions, the number of generators is 1 : the + Hartree-Fock determinant + + +`psi_coef_generators `_ + For Single reference wave functions, the generator is the + Hartree-Fock determinant + + +`psi_det_generators `_ + For Single reference wave functions, the generator is the + Hartree-Fock determinant + + +`select_max `_ + Memo to skip useless selectors + + +`size_select_max `_ + Size of the select_max array + diff --git a/plugins/Generators_CAS/Generators_full/generators.irp.f b/plugins/Generators_CAS/Generators_full/generators.irp.f new file mode 100644 index 00000000..eea5821b --- /dev/null +++ b/plugins/Generators_CAS/Generators_full/generators.irp.f @@ -0,0 +1,75 @@ +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(output_determinants) + norm = 0.d0 + N_det_generators = N_det + do i=1,N_det + norm = norm + psi_average_norm_contrib_sorted(i) + if (norm >= threshold_generators) then + N_det_generators = i + exit + endif + enddo + N_det_generators = max(N_det_generators,1) + call write_int(output_determinants,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 + integer :: i, k + psi_coef_generators = 0.d0 + psi_det_generators = 0_bit_kind + do i=1,N_det_generators + do k=1,N_int + psi_det_generators(k,1,i) = psi_det_sorted(k,1,i) + psi_det_generators(k,2,i) = psi_det_sorted(k,2,i) + enddo + psi_coef_generators(i,:) = psi_coef_sorted(i,:) + enddo + +END_PROVIDER + +BEGIN_PROVIDER [integer, degree_max_generators] + implicit none + BEGIN_DOC +! Max degree of excitation (respect to HF) of the generators + END_DOC + integer :: i,degree + degree_max_generators = 0 + do i = 1, N_det_generators + call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int) + if(degree .gt. degree_max_generators)then + degree_max_generators = degree + endif + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer, size_select_max] + implicit none + BEGIN_DOC + ! Size of the select_max array + END_DOC + size_select_max = 10000 +END_PROVIDER + +BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ] + implicit none + BEGIN_DOC + ! Memo to skip useless selectors + END_DOC + select_max = huge(1.d0) +END_PROVIDER + diff --git a/plugins/Generators_CAS/Generators_full/tree_dependency.png b/plugins/Generators_CAS/Generators_full/tree_dependency.png new file mode 100644 index 0000000000000000000000000000000000000000..eed768663d7f287bfec3d9b93f170370955e4983 GIT binary patch literal 82663 zcmXtA2RxO3`#$#GlB^^N$x6s3t5A|qWLH!oSsB?YJ1t7cuFOgyD?7Ak` zYU#NjOUwCQJ}cn(ULNJ{>EF7f>62Sg+Uq^$muB4KeZu(5lA8LLDw@AZWE%4;8&U^j z#%YdBGhhLC>|K@kf&kw#+DV~fxLHvXue(E5hol3nVYRu&7%(B+BA;e#Z+$Y^d z9h7$DW`H|^nLLj%s^ONd;PCLUZSnoK^K_waA3fshr}0vzj(ghz__KmUn1gzbU$}5VM@Q$vg}vc*HqZOFG18W1^$&RUg~w z|GO3!7mara%CwA+ZA)jCNtaA|pPilk_3Kx>_V)HJEqTZcrgzvxY6_%`baWUVCtmF} zH33Jn9@jZoc6N7ncXlQiXgQF5Xl|yCYdV={Od4oyZ7tatu!ofU1K6UNBN&24_> z%o#JYwCWc7Uz~Pf{OtOH%prkGOG^U-1IfwBtE;Pxjg1&CUhm$$+t{c*b6uA;(*FGU z^B0NN(Tq;q<@@*V9b}T{iZGX@`yPuqWIO+NIXQh-9U2%AP3i0FGfQU7fA&mFOl;0F zc&~LjOCV;tF+q)ASVE%k$&)7uC(O;GmTJZqyy)oYE?v5G?b3P-nA6$#gCT1C4%iWQ10U%Z6ckVrm?Jg0 zxw%bEP37d|FpKyBi_$kkO@iI#(1U$eP;g`6b3@d2iC@2eW4Jr$DG6%WV*UO7EiEk# z4Gs7KS7#^7yo*%lz`z-kf0w1DCFUAGo;Ld@^gjgdFoPU4+z=hbHoW03EpXKKl$Fg(XR^!io@}s>C>lVgpL_E8Qu?%ln2|}nI45c62wtSOD{5ehK=~_*)uHF`uh6Fh^4Z! zG80qWp~AA)uN@p6ZFq%byz#4*m6hv-ckbMYY_O%Hi>kp!3<#*HQN#WBukr6PAU(-X z-jb***#1bl;@Z@)GiL@8_a1+3QIMCHS6%I|rWR0Lz4h?WwHGg67RR!1NqqnQ{m`L9 zr%#{8Y~U>u3tkQi^fWZ5%iToYlxWx0uv4p7UvhS?_WUuDqUdR4WTc>=kZtgw)MZ@5 z|KEjE_$(t>lAoFS*RNkC&!1yI>{RlqIsbfkXz1>K^HR5&uCz3M*2oa|fDW@-c4`BU zj~_oqMn+bz|I)Lxp@4+ zx7pbrLuJ=CR{!+$;6xVruKfD=)HFOS3_H!1mrF)kl0qXfN>}jc(W9%QTbuV%QVg<; zb_)oM`28J@k7p(&QIXirRs7+@hs?}Oy?f$WIXT$vg=bz~ocfT$$H!;ZL?J?(t>#c- zEuGX9%d6~i>U-OX+LWSvLexXl=O+0bROx3#sI7FZl|{i5sWIJ3U;+jD+s2NxG@ z;qH`Wthvn2sD{;cp(U@MPjsS{`(+J|r(+ z-_VeMwt@rUj(59^Ft)jYP=YQiE9>S$oIhfuvd_}x{*ut6S+>0FnJYJ=qN-QEJ~(jU z!}8kNP6aoIrMZ4H9dZWx((YX`ckbPrnwVhY<=yz8_~Z7ydzff*_m$&H&isHi4L+Aw%Zeu$f`)sIIG=a7bmrmUKwI=+TNwGYKN-ljWcs1fZ`*XbRNtIH123bgG;LuRu))Px}o@7ZO zjrUvYdzXK;s;Y=`-m+L1wc?G`bX{GXK^($F?lUcTT~YD$a%a4N^*-h<8S0?*KZX9o z#db}qTPy84aeR3STSo+~|6GiJKqt1p_PA=`z!`q#fJb~kzinGy&>5S3+GQ=%(hx-; z#NQ@gUZ+X8wJo@5Lhj0tnW3RtPIqunkkQGL#j(`hWS1#4l7(btm&R&?v9jhbFK(lZ zs`g-b^P5rf0NM5HHScJH3AZnOenCn@&d)&>X>Wf)y7&sk(MZk5G2C*NmEM19gQ;%Z zxbcLEz{QNu;+h^<+V{MZIYll0gn-{uBn0apBP?I4uT81BNJ`3(4-C}QlB{q1 z2xwTHD0KLH$Be#enN&Z8_QlKE#TouxHZq}$e*$?G1Cn;ckB}!N(e&n%_4Wqnk~cP5 zFWAQ4`qgMr^1Rg}lZM=SRAp?O#LYdhK>X)V!l*A<$XlDc!mNQi{mF0KsOe#k*RAPd zeP%%u=EQlVnuI{$+tT4A^O(zf^2#}rn*1$}&At8R9NV_-@vD^xQ6>+Pp-63iRa!by za*pnv(JxRgyyZ+WxK?Be{`qW$vWLi6_UDIAF8Rfv0&Q2P@*c& zbL*kfv{mPh>q_?XLnNCr{we~@^e^i-FYV%fZ%z5&T+Q`KZN`lglYN&PQ zZc&`%&pcFMRUO+jfdGA1J-&sSKppqDvAK3>xhZxRf#1YL*H)lwB-W)&*F*O6WGEq^ zzOhQGFowbPx6oVLU4Q=QddZU#SUKfCYdm`vZ~lszaVm~*cmLt}A@%$En*3^9T=8U7 z%mii$iIwKb`lj6k{;;rSL`QS(uHLYR@_~lJ)P&~Ejl=s-m~JN_L`EIv;$jXY%*<(C z8PVjBFqw|}zB7_5Ta8@3YHQO+^v=6U*J1`T4MZ`=SZq^-+~{Dnlh#(F+`Fmt0##Hn zVcx6UY^J9$^w?PE_YZFUY9jymk(v+@SQ|mNGP!-l;pEALBFXw8o?XnF)N%TE<19Wr zJB_z#yye~U*L8WL6T7T_G0W_sxO?v&8394Ih&Y5+ z8~(P1Db=mAk`mU5sQK(;6z=Y6FWBW3nSPp1Dlh{u(7Pn3nus+FmbGyKU z7y=>HkCK^ueWg9^8U5lP5^@q{WxxsfvOTM7!8d8+?@%oLpxS3j>gVV3S3Dwe$GP#1 z->0oc9mr0l+`LIk2*}Uh-y5h#K+1BwHQ9Ra)5nilSy?ta>Qgt#3511(v~us|$l)OZ zVXP%_bkNCFm6pqW*Qrz0;orV2`rNGax4OY4(-xuW9IZK;>9w}Rz1x3d8$r@#(3B&P zu)a|{x=C4JK|(=62#_mK=Vdu?fKbEj^e#I31V@%e&ao6%506K(PF(*R04oxADBboO z>kCbOoTZd^#VN+e)1I>}F9(oOscBJ+{U!+~JE~W^x$%q5d61Go7#|;7zG`Srx4KG5 zWqQ|ITWnV|YSpierHmGXe6xV$H$j0_=x`o*i@r=}zX=i5pG1qIdNwbleis-bcU zm35cfT6ym#n&NRxp9WLJoUfLFOKIiYdY~OG*P-5~^ z_u*qH-gcjP6)7JXl{<;Lb~a7Z_E%fo`21&fGH0mBCV=$1lAy3dz&Q%4-M*VYZCW>c z7ZWr_FK&@KkKUCy>fPO7ea*)E5PfiMQAx>}H(te>0=1%)x{UgP@!3a?9NCrF@}u%E zpH;bHV|@&_t}(l+x=jV5=E$u3?S`N^A-=Z$-tUWi!EWjcqrM|wAkfFnp;L!ZzYBTBaN17HE_UR-E@bZzRxbsrz#q64C$H+2O878bM9 ze?Kh$o`GTlI3#DM|9V3ER8vEP(_krsNf`~$xr33{`tri7(HjpQKD>P8N|oQ*5^!D3 zNu&6#ZS3qk3U1SHL+RLQ0pa#z$eHP$chuOn=?8WQzO|MF3~-(6lM=tjy<^A9e8ms( z(V~^LsBuE|UH9=`51%J@K>N%RhI8YDC_=IZ$MCSWS)4dsTfm0T}W6 z%hFOHL(4Z_QgU*i>g(FIEI zfx4s6tXM!yOyA0C=j?P^XD}+M&6rE&{=0tv`USABq@+YjMn*2->7P`B;QwK3qlcOF)Rk(fo_Pu*^0Kx|P`%jyj*O^Ngr(q_(zPxpd zRc7ktix&g}Y9Nf@VM+={()p0eYD^^wsa^eO@8F<0YCse_7$1K4H_EoD-y{T0frMi@ zgZ=&KJ33JqfE>W785-h|-JuiMc3uuAR8|(h>}_^%a?;u>DJ|{l>Z-v#?Jzs^;R7RI zsG1RRGF~5M&dkd@QXZ`R_Y>9@D<_aZozmFT(}Qz>&%-Nfc!kTjP`qau6`!Th2f)Yo z;fjro4GRnF?KPncM%6md(b0j)>gcGMbnO(u{eQPi)vSnAmdr18ACaI2_oDHa0fcH#RoA6fd7Y zA2xne{Ts2iPfi27gVM>zr$T0*?tu_D!DNlqcD*d4&gfi}*C>d=7!(#B2UTM%$`>am zE&X<4!C3T;8h`Z0O`S;1x3DIJhoaS)~rm zVNR1J(Eqv{)lED=N&zIG*=kPB-l9?%r+Ao?IDb$&;*;weza{!}RoB$u0jQ zr0(ifc5#TVuD!dn4+lZXd(pwm>-D2YBd>i$m@^4p-zCWNDi4P<`YrWe7<}cd>M|B^ zM&{1f_SEA-iKG5o8(VADTTxL_bqYKVzk>2XE7)nIyUh0H<1}oJhwoHbo!^=Udr?aybe=q%y0y~8x_~g{nN6J1PE59c9=-svE{os(9on2sAIndBR ztU`X?;?Vs=jAAd1O-wkrxJ21$QJW%l=;MY zjH_{c%F=RjO$t1FkmTM~`uyEo%u%iU{Xr4KC*CD1kxuFf(-c7Q-~Ym~J16yq_x#Wy z>7;0P&7+6;nHiDXCQtzXPTgAnS;s^{O47@so=7@J7sCGs`}AoHv)P=*KGSSBSWy|$N^*U6LJFE4#UXf0;E;ESR+JTx@2;WO^` zb$L1NHnU|c(vUiN8i?B0&u_)|#<63ujl`QxOg!n~QHpq6SokB~{8bSnRhK>S;D&gB zOSt~~E9e-+$Ns@VJKorvpyx&_JS9X$zkPo-s^T`yjO@|k<_@<`79zj9hzr&tDX-C}LUKk43D+uV4)mGu4M0D&;CI0Ky#$PEZDYNk4EacN? zr=K?t4k}7XT`l3IQk!5Po+uamp|aoVVpo)ab;tub=knLDt#NyY z{@tD#mibL(9SziDQ@IG|D39HQbbXGRD_7uhKTwL#L zi!sYa&Oco_so!$qZ*doVhg|KE!_2}n_-JWq-`3TE{cL+6m-6r-@lQ>Qwo$8_*-CQa zF0k>+{kK%!``^6g>Dk`amSvQ;xw(mWWEM`Ax9?vBoK9>9O^RrYbX&}*(`II7mYI_y zflS|WYY$iq;$Q9|{v|iI851L;c53*{*jRwO{KZIpp;X|i=j|$M*p#?4K~@^#ZBY_$ zi-4it*=IUZ;pvPVg`qaO$Xi^#JeQ?+FLtLYA8zdYb8rksdx2B`Gxi{2JSHm>5d}e+FlJ;SrLC+s;a7h1R4-31c(8yQS0zwV7Z!& zwZDLd8;FUvydMP5IXR^~dNlw2yE0H4unRV&%(w%fkPR;xxnuHFd#Z%RYv%AeW#476 zQgpK}LI+tRUtIk7WMpIn$MEl;Kl{y!2t*c*UFJlM2|u|=|DV}UQ`lKf125+0E)(g@ zy1;o%BSS@ zbGkDFTr6cUF+zp_fs)7c1$aK734II1JU3kNw^gEA$#3;VX=&*ri3CSyXC`|3x%v6Kye;<9K&>}`guz5MG&a5+$);%?8Bvjw zBSO93U)w4?z9-M6Dkv&$7q{^GTu<}NHrSYW^0<;-zkZD)jX((W>ZX7CbkeI=o;Eh) z!Bk8p`Da3%ygG^?h}=p{eC0gKw{6?D?c2kvMAi72-)t-m0t@sMjVP8&1phJW*yBKxp!Ep^CBAADOvvH@+nJey%LA(J zZpb0Hg@L}l+qZA)`jA|ew?MRxi(@J+Ru?5sv&gsiNe8%PFUJqtW54R^HWyZJ9u-KC zq^IYKa<1N3a`s<)Fvm$6IQI4H()!9ZB|eXBj`GAav`dTw6Iq33}^vnw`foS5Z4Qgd7hGtuDi7rKRLt1>YrH_78cjt3tmb={Oq)Q6coIX z#!$E3ucwSTYiT)xY|#GjP~Er-K>DJ`aRMPh7p2MjwzklAg$`q4;xoiJkreIhGG0{Z z>gmy`$7@A#H~~p0De`(sjjGC9wt508MPw^dGtlyPtA2>z(DNE7sO13v!J`|A~E4l0;46FctI8 zoe&=^$<=|o423g09q?5{udilAMYVF8G9=%JFm(*|11i+7U(YY50@$88bqY0)>S8p$ zLYQ4TNk34n13PYTa33>urvEnDP*lo?-xvIYoLM^o!2z8AEG|Or0lrJnm64R>oOq(X z0mzsat0~~r6~qB;?J!-zGp}823=NsjoINde_r=KL zCVL0>Q|i{xSL~(xq3Y-gK0d{sUtqjrTIZh>c;41l;DJf{CSt?wJb++?%k=cXT5B0u z*~k3_pt|z&8F=qz%e-LGPB-j`;o!|S6sDx4EIEXkKOxNS)|z9KC&=n3*7WwD99d*0 z#uxYL)2F8M&nZX)FE>uQ$j^N;6EnGf{m{MEhH;m!Zd)w7HmU*{RIJeY-1=4zDx?$u zvWNU&;W`ee{PN|t{KwGxZ~?+&BJl$tdVapa(vE4|hl6nyP-5LU_G5Du z^Ht->?A44;)NaUuz{{sjp$alIH4V?MjE!Y< zBb83NjOqj%|G#1d1rQ(te#UQ5xLmxbu)uU|ZFSYM$~RJFkDf4l>C2Y~<>X$0(ZLrS zJc!#v`@yqWRn&ho@sEp&Cus3ZDtYmhBXQ z&H#XQ#tzCXDne|iuVZ7@7cS(8?^D#q4c8$gAhbY`+$PP%%}qj(=lK9YfFcw{q(`;0 zUAqIRc6Jvp-gF-m{WvgibKVk5koA2GkqC3@#`e6lRQp z-4g21w?tX5qy(P{A#+hKxK<5e!9nK5&BysWLGC&paHtvFCBqljbO{3O<;$A0q6z_} zk)3l9O%qO+FZ1y5bVSQL4aodgj@zt#_(&xC-avyx3I%w<1)RLP>J9cFD{FFYZVuBV z5qvD?(uh#H1;PQg`RdDmy71@na)n|ueST)-v!S6Oq?)PsNx?T>nKeD-tGB)C=qPeV zwX+=cI6Wc$Mpntoo`C@_k5SQM{LC^kGRCdKqN1V_5;|+75V$+aZanuA=zjgcWFb}6t>uLYl;2n$Z0U%98!g#E$FidjM6MuqHKNG&?GKWZ z!6A5~vV4BN?X5z=IKn2%Qo+4@Jv}_i%gVGgH8r)hVP7ymaOOpaH8c73rMc6nt#Dnv zS{xa9#NPf(V+{Ak`nqH^kUvB1xQjR{t+~Ep)Q1X(4&_@_tB8uysx-Mu3yX-9;S6E# z;+FkL*{{l7&_Eto0awYC30n${E&3^4T>0Q?N!5Y4ovR zrj84`M12Niml@Tc3PhftKV5JHxnelj*nWR*pd(f}HxU+i6+KYpqqdHSh(OrcMnyQ8 z#$_kT>A%uy1qu<9>AyTqC6pNHuF1SqUQx02w|dJUMd6OV(2u@ivO!I+t<8;<-&14+ zkU#$42M(&F#@R@AgfvY3PP}ysn~91*O+#~i`Dgk&4u+FyXRs4M!b>HuAA2ajiT`AVzgtJ*X66Wy!Nc> z1t?0CQ)C39i2|YP>e*ftjvb!o)`5y9%K1h5w-S&|W3&;8`m6jZR%MkBdQEU8JT)zR zEHVEY7LDco6gN6AW|Wk4;hqKt6!z@VI!AX(o%W#v_nWU-YCQ;EV*B@FBUzq3tIRhU z)$kcr-Gs|)toHN%xdpTOfUwuS5&{CYnIirIJ=)J~?^Dl;hd0;~<&5yU?_j|n7W{f( zwvV16`^l4c;4FrR&o-FK=?}2yTJG70Y;yzg-c6x0J6pSK4?Z2mIYKcg0F$ykOnOV^ z+afhFR|q}+8?#oOulU;#)W{_Weq;Na7GTh)!llL84|8>{Yn?&hV{R(%Aan8u`0 z?mGFdPwxS}(692nd-kwI))T+;sKoW40!cx-O6Raz>)aciH*;#DqobKrmTTUHVz#RWL?W4OY!G*9%E#bSo8;3}#x`1p{efc;w% z_ntF7TAS}2p+RZxnQpjT$E3Qvy4vL+Baq-=W5cp-+aE+ekza);3P4>=EG)y=HpxME za!j+yT2fcA3&%VhKLy25%|NQl9nB`y9 zIr0q4bL8q?N+TdZ*S4$pZ~Ds6(UJ#2=wYhVo_0BU^d{^uKoRf6dv5>fKCbF`=@R4s z(X1EnXMvg(&dNQ(`FZP&yM(Wl>IcO@q1V7+8QF_@^}q%MU;-pS8Qqq zRL9O2fjL6qAqgL3em4~(4}suy{d&tbgmCxS-u)%`fx5AE318u>Wy{z^0>py^~1xwgrC3LRhdrwD!VoXD-GZma?Q5L3lBrW!frsk zwUd~FDk{i&M36P6GPiSw00j)2@3PgjzBLA9iKt9ie>C^L=Lzr=V5e_jKxMvrF=Nhs z42%nb07Y~qRIwm5>Q`ZZmwF9jLKQp1IswP_-&bq{OgO?}C4r?i>LE1Qcd zE6;k^o0~syQ;n+fFV4?*inz7lwGMjs)YfZ`L*Uy1F1URTfwYs7mF4p}lp$Nc^)xq^ zng9<~XWY%67!tjczKyj{qRs~#1+Mbb3p^18N{dZX{tr@g$p_mgkrF89i5?h4NL zF)``w$vb(j)uP-Dr(-t2>NPFrjvXSeKJ8E)+fHS`!@wLG?5S6azM;^HVbr~LXNc1=Fj$?b`U|bP zNY%eXhU5vp97WI4kI`z^$)kRL8<2Jz>+6N33%k+}w!to%6e=o}qA@Z4YqFJ`RQ
yec~N#>BwPs zd9VNaa^&Z#W^Q;m6~Vgb(!Gvbzyux7PvPWpy2snqTT7z;1RBHP!7V50^UVzv($X(& zLG;wAaLjs|M?6EaqS6^b<~IfG*!x}Vbz;3|6S)ud-4&)&-cUUE?)I+i9jaKrPMDOx zU*uK1PrA1pCg6Sho=#6Y=-(|E3;RAc28#(eY*5F!T%z zwX>}@RcrH#gn+=nTA)*eb*OR5w}`6^O`lPAt50FR0mG&yZt+|)&3Out$9c%`EG6cZIdvqWiS_H z_50l>2Qheh?Ez6R(_PaI+kdmg9=z$t-rl>qf}$nI)tLnk9(0Fk7N-CVkd97MTif@< z<0=V$BDF9W>xwf`WsoDh_TU ztT=FJuDKfT1|TyxR}>P`o@qeob=5oMV~4$Gn;>gTeSLjv>#PJ&vGrd=rnAKSR`(%y z?C#^{`w8a@PdNLz?xwQ%i^2z7J0x_LNKMdM{{CB_kDn})S|{kfK&izVDZ{6zhGhx{ zKUV2|5IerJ`w_n`5k?}nz?`AT7fD;$f3?5l976t437+H^z$8TeStyYxZt_jm?bG-e zeD^N#9UiDTP+nl8b3}!@YsM?sNGCyBx&eXB^ZS51)JG-D7493Tk}wEbI=Tz*?_UK# z&$`ECpnMk)c5oPX>dt|(T&{V0*;`E8#yLVr> zFa^e7!O{dJ^X1FWFaVgEL31?vT#e6ulAn(XC=aRv{>gRcjJS@SoDV~zZ83DRtMWtm zOH}6&rc(4v+3%;MRDvReA=rJ^hAJWgBJ=_De^&$BdN)(_`ms}ax!KEMg4O@@FAf&do7MUlp;w5A9<<}PTsM9(= zohBM^D5yFQ!z-@3xjccOj<`LF9P9IU-o|x;TqXgW)qlz*)L!VMJC(hS54JE-oJ#f`IB^28Fi$2YCxOu0Iy&Mt1@aN@cJC&ejo1VM+;Q(a6e#2ieEQux zcOct@R6>=6BxiQ|^tj7w6jngsmVXNCYj@ST$E$sN3|#{G3)xaaLIU9|?q8Mb>h9j4 zAnw2eg#$(I*-G!1MMWL`{nt_C&VDM)>2xq_I#>iM8FF@tg8P&7^jcV&!O#l`keYP1 zWas7zA3C%GYzvyeO=07>|7tfxGq`c2Xdna{fU^fLLv;OERgb{D^6lHruNsTWD)HyN z&>sLF2`)#+ywFgT&h^O$F9ih!vHLDbmEzPuoVa`Yw%bHw3``v`tiZnz5kU)$di#(v}Q;0t=FW!0ZfV;Od#uEGv^b&6%dnjPYn5wGP|C$Pj zu@c=nU>6!S0he-eE`TpZPQGvfI@-$G8Wi==u&`qfkJ6n?`+E5ABUBxF1_o^(K79SX z!pO)7wuPFJaq0K(M4ug;GU*_KzkK-umQUI1XWEk|H}!?6$jPDSgL3iu=TFbk2aO^k zB7*wd7l+Ez^Hp*2RYYGGmm=`pu>UN6)aW2@ngR>;8)Q^B^rr4^s8iV}dT{n}mlCH- z>RVc9W(kwE?DAzUWkb+&UPzrVGz{R6KvIkQcj2?{-MbeUNYX2H?BZqFHKZ&UV~CvE z`tns!d3XiGLft8JNFXps7U#u8o;RNEjTJL+yj=)Ye1_1m{6 z;^89TlB=KQ<+Xr(#?}`W_FDOMj>u~UXlJCCb>O!E5G^f7Rz;;9*kRpkefJK0Dy(Xq z4^hmL5F`&C)M8Qu;WaTkOV@sk3H0ye)Rd~v5`F$-M5*c7PB2&T z^zIOuGaxNonVIBmzVwu21lY8GeElkmKYS5bP__4|4Q&V|+JS;fk6|`2{8o6)R8pA; zX@M}w{5SUj8=1>A~oj%=i{y7N&rHr_^IA|># zLJsc`63_mO0DfI;S!D01n>RZ+j+{G}rN&PnOwZ0LHs6Gj(a^IlSN<>>-qG_^o?1lfhL<(MV@# z#er4_@Cbm?*M}Y;Jv}{eFkCU&d275XsiUa9Uq2iX^kM4<0<|bfyfi zOG-`##Nl>IOLJmZNMVfQYz#INgNmi|cX-;_4U@){QiH7tq8>!Ru^gx%>Fxk)x3x2p z?%#K4RPmFf4tnuVr$8bFKL#Hex|+beyAhOU(Ua8Ksm{dJkwHZp>bm@M99$E$Mc+Rk zO^GC+$Nt-lFoG_^h*eH=gpH6)hVmTvDl_p!o-vN%e;sS+$l{8DVnn|NCt{t;S$n8z zC`6&0-R{KA;Tjr>W+Yl}kd{X!}&>Eo3w$dfZ zPRz&u3n)f2YS*qE7`RAIfM|kyN-OIC-N&2O=>WIb(JYL}$ST87xUV3VNA^LRZE?r9 zcis$b9u8VsRDcNewo(dok(wnhUTE%nvS%^y{3#}Zk0 z!N2+%lsq==?ekGcI2ac%s{jH5fx3vvHZE(n_1<)Qo0pHZgSlWZlAhVHiQ@kkK6F@es)?PZ|{zq_*UFW zRKvIV`Sa3Au4^u&fofSsSu;b}R0!RmAw2qU#@G#riXJvHdem}rb72MsQ5WO=T?nSs z^sAmQg2C$WKKbB2DXGqP?~W=|0mc_(h4MAN`zjcyR)dsnA)eZPK{`nzJ-%*SS1(>y z@Nl*AeN_FATp_*kC+K#u@B5pek)C$QODQ>rHS$YuzB%F^z6GA=mF0;zKn-QmK*^!_(AC|lk(F?~XhIK8kYif9j{16c|?+~fPeAMm+;7Ta@ZpZE!i$dp0t zj#F8sCcv5hG>B^K@o~K!KeD1b5rZ*M^mzgmOiWBvR8$b1KPd>Y8^CQf3O9>CFL zla!KzFG9(49!f#2!sE_hzh50*c~76xQB%wNZ>|Hiex8`HiK03Py#oDP=+8pWnW&1& zNN=yKkWe^n)!RE#cI^WCIAO~`@7a2BHqu@x!* z)yQYpGPrEaD?IiSy;>d~9+*<>hE&)SLD<5{@%HUoz>K0;IxZa`fXlMxc2`z=y1QXf z+$Sa`BPYj1OM9mJh9BhrUiBDGXn40k#KBww+cyOj6?C(IwzJN9wCuv#1>Z7IGIBF& z=~3_5eB4R%**G%CFoZusKx3xb?Tm~GoN_1{kCKw$wPJ?xWJK+mI8oh>Y_ZqY)Fj59 zQHbY|y?sCD3jFl)g=-5W0wx;LAIKhrs5j1|Dn#PlAzm7F4_K0Z}cR4k5lFhpXu!y=bDbUwx`K9s*oI1Syk~kF=}gR0dI5p9qbDs z+BA*=|NcUpxO(+E{9|+d&*7akQmddr9A4T zKR35VL4bgj)kc?Q{or5)26N!RHRN}=%-S8xS@RmIKP>q-9gCEk;Uv2>1M0D+g+sp^>aOtGb678I}guLPfy4xLA!9B88Q!wn&Yr)M@AA| z!1kHLAwY6r!y$diA(+^=aEVGtw2zG372ZxYx8flmH)<{sZ{?er$O0My+`ma5?GPNEnauj*6vbP9)|yY z)`dSSa5&_C0LChSeoO3dY-fCxC%Tg_a?qaS7yN-1*?lI@sOjj|;HLf0TF14W%!94> z<3}6bd*_4jR$(lfvhoJ3dFW+vx^(GeEh_-xND&|~M36BUH5Gl9#D;7SKC+NYhXjhC z;o%|Md)1N4>txzz093@KI@@AoFXNx&J222uxbv`MZ@`lazz;_U(O(&BA!ma=k~tw` zaW9?vh`zzW(Q1Dyb8{a^%qXiT%Eb^3&`Rbak7fCYd|gU`fvN%gffz>JyMVsfq9RGmrX*zr%^k)Oc6nML5~$~3y&;;zUci-; zRl_dd53q*PLFVAW;cEZU!9i|VDkDif*hKaIJ^mmtzvcv>F!mH2D`!jWk6gdL;w453 zNuJouFDc2a9*;>5IQ?Xdk{o12=Tr zX*X}U2Hx1waFOC>=)6vjah}NQxqX|RD@GPM3J#4)4#tyXg6<$8u#w@Kfd#f5?l-LQ zAO24Ux;fo8a^po~27z`u>4sqK^aK*_ikLE+5lbF8;dF=uiRiCk=u>aC3**r*3#L{oTJ3<#h2eV4P7 z69oZ#^=K0?jl80w9dmzXpa)x6XehQlFIuNj6{8Ua)eo-3CGs^QFOAAGukg;@yKlGW z3%9}_a%JRA8R9d#O*Yp?w@fr5sbw6A`HK)hwE5R5FlQaYymfqB!_u2I$(I4*H#If_ zv2t;8!e-j^kN6HDaXU<`X}h{^nP}05f<@qBVOe-py^)`tO*zZ?(Og4=lrdZpAJi8W zB;r!C3_Xm5fE3Bw8z_A8_;DtXWnx=1)6<~sta&Hw(Y67Dx5K4NQB4yFt7W7rwiO;n}NO|)<6*#qrOTXIleemk2y|!?kHq;v}UaRxD=uJ znQEtRfV*2_vYA*FxH_B_~? zViY0nll)G_45{(gC@3(1sycV+5;q42+TXR$QtJnD&4bj0_tfa!k>8O=gxR@v?D#V} zOw>Vdy*SjfYA{)LI5vox^Cg#?I2iTFsrHU;lhdZMmrVNNU*viF>_P!vZ z4CdzK|7-E;Ucj7wn3 z$VtbMn{a3Ih*GPsNRd~Hfv9eO9u5KI$m(=J95%fgVrLA9QcbfAp%7t>5_~Vp3y=;w zhqd78x|ogNtHhTYA0Ob({{(;-G4`CN9MFl~3}1lp`MxV}@gM^-!s4GlA7}4t!@#QI zNmI$pE=$sM1hx+lYxBbuI#LoCldy^kR3E6<9J6Z1du3%!yv1*83P1&?nvFdCzu@hyc_WSjYP6P;Hr;r|oawz$K?8bqPh~E7cwOG7$e81*8|=zra4O&y zifH5uKzrTVqsPO`TV^pIaXv)EFoSrOD}WZKLo!{aqNj*NOE05WA=)I4Vr#_m5}b?Q;+xxlft#3H`n3wI5u!C07n;g zTTOut^h(z%aOl#Y`A4>o;VUs`6~|ujLVfS>LWavJ(}2yv4J8-kdsK$(sTAS-%>j4l zjU;ft0F!aCu_`WOgx+H7jPmjUJfeYMc=|L9+HvrC-=_}MKE2P|*Xk?(c5a@ifgPekb0xUn$-7;Dxieu05T>V#*AvW1d zqj+4*Qi8@MkN_^iO@T4|-@`*%;gUz)m=d7I4@i|JcMhH!R9$*XAVy`~@ zc3{U~B)#;NlZ842$~gepUjR8wfvG)5AFZ(u@B|$DK%#H1PJ|^_ZN;@u9pH?HSOI+# z1wAwgxGiTS;jk|@Llq&$vG3f~>5*{M=O~{Y0L~61enLfwhtVL9!h5?FE3A7C9V+m@ zf02&if%zL2r%k!^zk4~NfPhg#z?pW42h%b$KmWBEh3;ipZeBD1OfGoAiHl2#?|9zR zgG$m#&tP55$T%#N2;Kpvc3kLT^Cs*KwN$=@2lA{Bc-ExctMgAE>|Rabk3#VK`X>&4`k|- z+4|||nZqM>s@#IXuHU<|MIN+%i2el+7?H9CJZz}^)8WB{=_dFB{x$D?Ao@_Z`tS%E zwCk0@VGVWx4~m%~k|3$znow(1R&E3wpA5U5ix40$|N7}uJ?{=k>@?(v{BR$;7Jk8# ziGoN~h@AZyyN{CW6fAj!lbL1P7N_J)ZV#=ss8t2ml1LHypo ze;;ipZ!lXZHDPeMjrE5hVr<;g+xvJ;0=I(YUJQKy!mvg$JA3*6qb;8UisT9=k` zD4)5d%@KAzzRCxzKDKj=3H*<0gWRSk{}I}`upQ)vws)}g_IPQwhI6q?$KOM4R{X z=WO#1@yAQA3==`u=7vw_pBu)c;d|gZfnrE(UIBE=N>vE1O*104(xL)}1`jV0wkswb zoB}S$<9Dj`T;IYth1MWk@D)L;U?DGl{+tei2qWVo8OJVRe?QP~SZcs>T>rV5fBka( z*Wv&V^y@fCTc^*Qd1q6%nH!{?0nG~SeRx1a0gM;2J_ttilxRegws}hq4jmV&N1UFO zhsm(NH^%a=4SSCIp@0&2oX#r0{u+-00NOyCC{c%Z%r-xD${k1rrxDT%wk7rso_3_F zs*0zXj4YC|^C3n+gF#J$VikIpP+|*;kzKoXf$)%(l#GAr*%eSX{st2Q5TewU(LF;> zT8j+_eh!;THX50bsk^uI1jW79{qToFBoG#E#?D8~Z*RX)OzcO*+8eU$g{KI2u(HGL zIXFb*7pMYYen&p1vC6+EcA3!ATfh$bqk2m`g&meuK~KaWo{|Ix7i$4aWZ&hb`%-pF%E~rR zU*k@3o9k}`PK1$$*NI@9?d|PIw0MGpfdOK(ATu?Fiq%DP68a2F^4sKOWMCkgM?ddi zsZ(Wx`W_eg6DB56PlOSr!<(b2zp-|WKk5HL)n z+|{vKGCUH2m9+%wH15LYECWPph+wA?){Kn0AV~rNAOu0Dg6x%(lLPy~&&6%G6Q~}v zeSivc$@vKagE285p$oxb(rSgFFdJ z61!6HjE}>`i{%g|F|~Nw*|({wSMZF1uXt>b@;M7#4(MgYKONK8=TY>S0~$BM6Re^| zL#cy^iw+|#wm!ZY5E#m2qL4w*J2?w&{WRTJIID6)Vf$8APJw}7dAa7sRrt{J%1)d) zgI0^{V1{Arc{asqd*%_lRtY>9h@5Z&Vcqq_?_gWNpq8L3xNX}VRO4?+c!gQ_NJu!> zg)v|Y;rqaw;8AL~Ug|ss1i;oLVsG|C%F2~s^hVJS1bp6GklrjI!v$^o5_DZWm5+p| zQ}o+^oQ>~HuqgvG_WohwqCRZRCz6EXec4V7GyQh*GE1%oYTGM zHuKRqB!v_eKdu77Uu|-u057L~7I$*eHxhg2o|&Z=6vWnA4-F5aMKJ!(orX!*bKkk% zxdgRNA|K9=R*$x|F%Z(y(~IE*xqqKC^5Qr^J_!M3{kH|;00OYec9Qq8^Yz}!<3V8H zDn;0D!X^VfatD2wppp6v6FntSUWe}z(*v6&nvY7BsEPgHSe7x?b}RsRu&+)tu|d-8 z(Be?;O@IDONUFVDq=8`9kN1YvbVunTsvJvK^v_u?rZp_&4` zN?y#vUHZpB-1WiWhlg;1_}W-~sqZ`HS_UbWo{=%^c@O9v)5y}AjOgNEyU&EJsx=B2qh23 zFgRsoWENqDSLPr)E!K+y6GkNvIpZG=0(*dnygg*LtN$0m0c|KNJA2Q_h^tm>~?qkI;HzQX>rgGXN8aFb#+svrJ_mz z%w4vpR}I%gGP@Bd`h3JUmVKQ62WZ+N(ZUH;Es0w-fjB@DKpHQvZ2$ArC7tv-vL2sv z*Q4h4kQD8;jL?+YKViLs4%JjsyOLDb z800;d+^Gx3JYnXluPNlS=cS>xurGFf7;wXV9t*WZp)&4qLd$;MBF`Z~Idx*z9@1y>S zbFzWKyCx5N&Day&upXuQ-tiDVuo8CA%8vKZadcD1YUpU1R>R(w|4>>(! zLePc9l#8Es4>X3;07UL%vI{Xn?!$K6fY6Q`D4H3bs+Ebou~=G4iseJ{l=L(NVGzaK z!y9s<>>?mLzCc5Pf5RuPs*!v1^z`J?SRN9h4SzlX>z5Xt_N`NHQ@P)F#$L0LS~Gsi zmj*W{vWGcfw`{3=Sg?ql3BN_WH|%!E3b1zR#Nx|A6vj$|n@pOdYfde9*eOfLcsY~| zZRG@rK&qL5z+v{@GJ9@3I~SNuTz~+>K@(AbqUO-#XRb=)RIO8ge0+`!HQh-sg;W;& zo=Qyoa8)*GJ==s5;YwqW3Gnc1I#yY5H_$HLzAYF{a2{>=HF!#$W@TR_ND5=a6`;ts3!7vNlTU0gW$ z`&?*7+$}HlgLQ46xPMuEAAQd7Hf0od>>;S&q?{K3*Hr ztr~}4|5Nhoy5?V{xug3}rwHp-T(L-Uva-yzc^z@lH+bJX$FFVnvD+uMEh>EUp6rol zAt53|x-+k6Qg@rx%TZa^!5OeX`pl}mYANL?8UuNN$^b>?)x(jh0 znokEzZgpu$%2g6MF%gytJR^vp86#S?Am@p!SSTrnD89u+ASjlFI8G zzu9x=cC*KHeIsCKx%v07ZQC!%L3PsNs|6Brg3Xq|^xSDVR!zAMITtQKb9FrU*&h0Y zgsA+^9c61pTKZi6(V5U0HjsU=u)Ibq#pxzyW z&-XKkj6aha{=|j+S!A_l&FGJBV83n1D2Ejx+mH5Rw)yHq;1k`?X4vQy*k`gRqK7Do zypd^{X!=^2hvs}5r~&hzH2+=MKW?P!sdY`(DT`qvxEqcI?z3dYmu#-{#R&q?+hOIV zw{Sfmt~=J6S$53me`-g!S$ROkf9C zDe9V=t8b_s%-MJHr1Mwp1Z52kLdMnHf6NiX0Yu*ZAiwX~N{tAQxNFVd^=FA6`dOMA zbZ%N#!6_EsL{G%pFV2MliR~XIwqeau{YO*ES0FZqfqd@VI8g)7W}@A@FT!R{un`wQ zs`*i~aH)^Ke+axz>ufa7YiZDRr7kRWeeLifZcw<;ZMCtHjG3I~q6~S8LQ>iE*#L|* zRNHhmW!wwVtAe z=4OzhjJa;Bi53h@YhE`kymb+)CO8=gA4^G`%^bD|!6ulnv>F#JJ5) zd+(1|cx^f|h4d@vCLg(xH)3DEGjYHH5S-9Th(s6yydQbfs{4Gu5gDUNg~4Z<&;HR{ zTrNiZpPgNnQ9Eark8d217e(b(OS6 zJSh3aFG9~2CZI@!i0MmXm2`c}D>*+rYXMpR19OJvhXt#R1O|Dl5w zIqXhUeo0A|gKpx%d8^`Oo}brTFkL*-MYV^X!ne>VF#{%t4l$@dTJ?5t_vSi?@ZVqC z)NU@cPg%#pwfgwsWM^HSMB>LcZ)DnDeY+}4!A!UqSH47%t&00ww58+@EA^S4o{%a( zahgsWp9|&!*$3wP)ST z1S{?j^SoMiSq6K1Yl*yx6rd->SB?%`qh6$Z2i_MKty#MklzjnZ6eTI@E_e43h`v;} zlGY?t0#_2ZNVTNd3l{XA>FVaDyvZTBgQ%e@hk$;%;e8^i>Ei4CvI6f+Fq4g*Ef~Um zI+yu9bV?aSZ_(zgEcG3Z0fB*t=}GfDT}^xT>?tY-aHsAisld^t;onmi_nBq9*Y+;v zp*kL{jCJWcu|PT_UAjM2VZKO2NNR0u<>A2}gx&N=A@1mrBc$xzZ~r_M>vOrb_6c2 z4YL<19j%R1BF##3-OQC&W7YKXT zw~LZ)eLHKU`)AkrRyG@M7(HYY^fvIh*sf!`X%1NPz36Q{#AWCECncmg9>D`_V!08>X~v`?_nY zq&Spm3V>ZvUlSq@jNIawBOm$4X55J~7w56wYkUd>b>8AU{VDV{CsG9|@7V|=!+qYo zcP%Z|moLXZJ>RkV?Y&_l{JzVM543K{f(6fB0quorslEGZu99cP|8N27>cl3$yyYsJ z(Tnu}SB~mAJ^T(kxu5(i!fI-q`9l3omCeC)bz&;K;e7X&9U@T1L%%E*SwYYZRGDQb z4?c9r4JykC_$Hh@GhJQ9M0>}tb-W**D?`Jr=YU0IOHcl}*C@6M?1J(oQhOF_Tm%r( zzyC6f{`MJLEd=F3F$H#Wd3%A2F8=oK8+Ill%zopbmB~>SG-TL*%kGMsq&1V|Zsv0c- z%)xy)^ucGUtNqBb1%l;J{m$q*Up-yj_m9tBgBUK#IdS45C>CT!*n%ww=!{B<5K=2o zigwJ&pyz{s=ll!nP8=WD62-m}691%X+9_B!t+!E#PaQ-h#9@_>1!1)hehXs^k2Qc9 z0E!W5`;S|xA+nl1dkg~uiu+!8pg**ja94=4bcw zLE3@2W@07|3!*YyVimS%A-G`GsH>|7?NK&ATwMH}aLhhrOVLE4kX~>;D7XBon|>54 zR8L3e1yTTh7_grrsRIZl?q##!rASAgG;!NDT>nYHSAh<%S_R<`@_6ike{;5uZICJj zL*%~%jUth```|$~7PL4X5iG#uGdclic9|@!BuhcGJ|awYht<*`EOtnxS(@U-BKf`) z2DlS|$zkO0)JTE8A&zK^)p4qv`NN;cUpY3o+-%MHX; zwWM#KKkpv-+t}j@GLhvEV#UyP5LL^5yG|HnUV~`wQRH7wy-5z~_hGkV<;Yq&Y5vHJJ~MiAI1YQlHlCG6tAKX_XWNe z&@ntBc-AyRDFDdHXmWx7qI*g6tZqqW9fR{hUx8}W_I+r29gCjk9h-vOl{4=Cq{Kmz z*0>(P;UXx2=+iOb{{3$cb1ntUAJ~TNi`$69&ubPTQ3JVAe2^dAzc00MQ_d^%@#Ed} zGsM(=P5N99FEa8|-S65$d^GkrJM{U#e;8yg+4h!1}s zf5XsFEy*sQU_@2Q2M86WHkw%a*)+BxBL|yNfu}h{zX({m)SPUDi{lYCb{%@tODgKq z+rNh&2_^m#USPw(>09;;N|fK<`Hz6pXU>#({*sX2dgj$&9&PC^j_vFA#7RDl>v?G$ z5&YF}Qd9RNtgr62gThfg(u#9=D{#vASc+$lkV&w)^Gn8XWb4&lJW2kcX~)d%i;z%) zOk&W0xJqfD$_}dpMHQ7%n27=|+{hYbfB#bL!1>04uNF}j-z7f$oh8a&{`zaTUH+<) z`Cd*GYb-3em^>i21+y{txpbP_{=_sk<+;3XT3EgGjC_^*Xd_XT{WuS#4My<$$& ze*ODT4j4=E$-d%4o}1PgYT-ZHllJkwQhpU}NtE$Z)AcGs!`XhH7x)DtfjV_6P?dHl zA{^|v__OlDh%nf9o+!| z5jMw}GiO*e#H}-D(kr}MKOd8cYxfJ^su*-FM*FYv?;V_+s6#(fd^Q;G%A*|QTiiT>eQMoeY zlDsqx#?`A^c1ug2!M(HfRzP3P>!v<$PPo|~ zzB>VQj7$CNFUfo0P8IWq?tRWuwkdOf8HyAsy^dldTH8#+nP$l=C-F$FoD0<8zblF( ztE&ng8w{t~q*I04wa}Q#9{Ki&WTIeXZW;Pn7Y|9*on^5~r2afvgn<~kryk#wrb(or zkdE7(xpSx8;kz|k)nB%>$d0*HSGRQZ`rL#hfsBkw8xGlmBhRoIK|P22CUpDS+vn1z zuU>tIwk2<6hvSFWrwu~`AN5;jV{7{d?Cq}3Uq`y?%-Px?ZuC+AAv1`5aBQLk{l4DI zyl9(aA)R?GCdy-{@gHwrzKlBgkIp*p*9BG=3OK!xKw_0|5UEUqMDUYcGkzkBkM64N z^`1FqtPwi-dk~ocYx{lZ>G-_-tmnfO>xf1&?&mk#v#s~$?I-BNcbqrxPblN_PAq$I zIU%URM^*L{X+GF9u|>w|JN>gM1QA+3$2A62kSx<671U?osq}<9EtO96NK7Zk#lZ+` ziNL~jk_Q)f7d)g0LI(k(bC94WKRaQ{7U#o<4;`u;G9Jb+)k&jI4}5ko>8Hsy<@K&< zz1(}M8qY#R*+m3q%MU)EK3k8236oN$9T*|cw)!bewJ})GL&0l>kyWqr-Nc7;iSKzt zIHhX<(aHD2&2pmutLYC&b4m9}8Gd~J?1|6){6gpZ3ftTotc(`Q;-Td-YZkm}<|Z99 z?C77x9=y(+s3S+-z-tWp(JmG_HaZb#TaPl4M?ovb>;9!2`K@e7$T{fJ(58C)x+CqR z_l4Et@}*(yXdV*D%^PpE5*_@`E4K8QZ#*}|#s|%2Vxpt3?*S)`0imjW`XJIvu4<%b zR@uu?TF$elYHu=THyVKJ-tVG3RX1VdLL_B|hUc0!UjeE8K5Wwpk{_CJk)x4xfs+gk zlmLTn+&In0Pc1{6kbc^IMatmM?4XE_Pxfj_Ltg*6T%jlRblamP*$Bie!rGYD7MMCm z_w4kK{x2|2Y7MV_tdvnPD)5;FUpRiB@p5}+)j3X^hRUjxI-aM1h+kf66pI;D99t7k z%(}-DGA5nh@Xa97>dhw?;)+OXpm-34}>D{jMWvW;w_D$OXs@6sCP~szMmR zh;zr;5&BW~#djq`&)i!Wa0*u;3bVie?o%AZhUQ3^_I!9o#VSONG{4u9>4w|`A3(4T z*z{+{#r`8nM2^od`Aka~j0D|dR`rz^v|_Jx?zR zq<)9BAkdAvLaS7%bn@1Yrw>U5d_+=V8-f0W#~HiXvk}d46-gC&y9^HHXP~)|ms(BB zj(Sx`%1nbnW{1%S@42zlMH!DQuzpg4b*olIUbH4R!iQF zpU=Xj4*E5W0bH{d`JSpWU#9d&PgX3sfY9y_Z$CKtV*mS;fUB{Emf6BzMloPv>rPi$ z4XVHQQ1PIGrJWtD?=!{luB32nrVu-J5!6#)U*OP6}Q zh3$m6pQp?>>)Wg`V#rYc{y)*z(}rn0+xtQW>HMVNrdkSVc)Dndg?7i(16#Jq43vkl z3&J#Q+B=q8=c5z}zYwyiQ3!O{;0gQn+_AH#%Q4UFH(jNecG;;@BQ&lg+cjnQP55-s!n6F0v4_;G}7S*!{{;_;s0WoqD8%JM{l|>&g#X%hvbQ<6YF>oA$C=ZC<(ho0!=^^9tjq74%<3ZHG&K1j@%VL_*Q z==9yb{{H&Qm$)|dtY-`gB_n3d;15xERxNc;-M6n3i0>n7m9!u5fb-wYL3KyD*qIIA zmcb|E-$k(KZQa(aUtbpb<;sm4A87AWBXbV(uCd4SuhDeO{_4?FQbbE*zeOm?%XJF= z@m_VK$dm9NzXn|oh*HxsTm##?vj&~_etk$?d(=QDy(KLAQ`Wzc}=;=&f-?kzk}7mMLGWG zpHMNz9E;HJJZ!1#psUPpg!*;h<@QoY5S$r-lum-s|Ia^h2t$E7Z9%ulv!{k4e$d26 z|1X`VW9{-W@4H-6!w=BG4=$On^wJ~t+sZBag_SNem4R)=fweu?^38$xuI-_MqwacmNVZy!fC;dn7iqu_JUOr>nqQZj=d&H>$h5Sl?e|J`{KW(ld3(r3qqbt=K$k!zdG-L-Y0LFLL$NX=qJG{B&2o5TE*nOANAsO;y5z# zN1K$-f`L6`j6dwGGaxwxFkZuT+wbWFXIdcv%b_R~;(mT2!`p^_s-SA5N zzzeBLqOl4ksHsK%oEW9r5s=A>(kD@Cve_)kL)%!saoTEBkr)e2El*ZVKX(Wkaxy9&-sv$_xT zp79;nAKeVwG&dK~Ryk|aaLl8Z_LI5CtrkDcHKdqf@Do9q!rh}v{C7~kUZBEc&k&7R zjwRj|;uI7fzs87&dDSDzIuI(wI7?>qFWvV&q;Lrp{KtOr3h7#gtqZY+TN=<-@Pg znCyp<59zzmymGDiDS2{)(!hb6h||d9++XjpjOdC#`sJI*^er_sPputPKU90crf&i} z9nW+5i~TRbx&f8qs1rJia8pIz{{H7NU?trTr)6~iSwb@DLgS~l>(`wmt${0w1D}I) zgyRe9@he7W(ZdyErJ@qHZq>N$L0-t{jI`8gn<|m{tEjMORt5z05=c(JXk=k(dY^H; z!!r*^8AQr({u~rz`Ys${oLMY1L0Cgsr`Pq3jVJMZI4~&0#YEKhoVJ4&7S{BRtNQfy z>zdW8lc2WWy&Lt*{%3o8-Qy9e>USSMmJ>Yw2Hy5Sg^sybQ;?bR=VSK3C&Uw`sK}p> z7mO8|z_JSuJil?iJs&H|F~*{com1#;XrXzlF$lO66FF=iZ@1jqPuDQuy>JMTjB7V1F){J)33`YJU+{=65hon9yABMAFG74G#Xi`MZdkl&N`;KT<32 zZNbnPREQu+4Y|5xKBb1htH-8;N@u&Xr-F6%Y|%f3A`x}9sP*5c6X5T$+i-yGRa19t z`=NpYVF+x{l?|&_jl{nmy8tv_;Mu6m<1;79q}LIvy2-^tn*I7cd-`zFOMvL{P?fa zr(LwL-$rn@&wTY_PD;~Hjwk(BuH4q`z-2rMkui40tlQ+V!9?Ilgg(%q)xy`chICLw z5=n=u)VMT7QY1`A)U7yt0pm!3);@EbzxYho!tLliLME(Ck~5AOj*7O29Iw4H#U5^7 zTr`b@e_YID1V@!|Fv7QJQ9OB-gKpNrjJAjNJLcHFof6?KO(&ud()F{u94f zII3>1h7hAN=`+LzY$0C06o}&l;rd5a4j>` z-%l?84{_iI7*`>dm<~inS|gUB>n4A3yP|l$Ctwk8jubEH>azw6n(&Jkx*>$wPy?uv zF0vXoNYwhYIL3=7_js{H96l|)3lPRH!vCS z<4}dT)oa%#Z`-Chb>0+!6E^geM^X8nD6Z$6@|rkadUfJHaJ5U6+f)?{#Z_3LFx9KD)exxVyr*BcyV_?dte?&K z4o8WB-INfMWp?$fEqkP0;8rr5UnA!nsN z5|Vc>A44Zt8MItcxZr=uNnJAkBv?ETlyjVB6Udp%qjbf5Pw|B(WVXHg_4C~+9+27b z*H;;mH{}tr*yFeK(iJyO8XY{9`ii~EJ=XQ|^zdLlR&<3oT`xj7*`9D9NYEVnb$2T; z{SM~)`h5hg3QEph1;-5Q1acD&MlNf|mUH@5v&DG<0#fk%1Bkr$A+|6y!g}}^3>#LF zI8Y&OCY>liX+E=OS2qR$E2H|e(wbiq><8z}v~56l59?HNKj?v6&bKcaAXprw6`%I9 zng#e-!|}qo|KS4s^J`Dwr7Wr@+7GAad|hb6ugttg26=%M3xxtJC3Phw{CtcRds(OQ zjKUwIX6~ynYvxRNjlY3cYXJ1AQ)QE?Ia?II_0EY;AyLq*k*F%pB3t66(ivdDpJ+3A zH2DKhTNuN)cP~RstgR!Hlcz&Wxi@go!P=I4ZE$2@3$ug3SNKqKgJsj^gI*Pm(-v3h^Owa`eN>A%iZ_{u6m93WT87*XiRW#mg@FD2z#>U^O?- zs%ivyAQ4nIzL`*5_HEFSsdU9o8zN=O1u1vFYE6rX4wKLXm}z7xCha#T+LTH8M4g zC#H77KPRo^xpROge?IHEfwQdgf(PdpWfgjXO6eJ`-oM1U6Ce{_l}d8}VVezyWX_z} zJb`zSlf&!Wa6IxTqMicx{T%?TPtUJfM7PGLdpUO@v&Bk1HbB!tJ$4K;7@c8E`G}k_YtOMq^)*?#KHS2;N^TcbXup*V(7}R1q0OCVaWh9Bp9l4 z&7ggt^CA(jAV~n!SDKR~A(N!93HTeZ>zf>d7A*-`^qSK_A+YH~D?~>Ys%KnP#mi5m z>sSiXS1W46Pcfk>)^Oe0we>A)IEy2LXpzw$1NWxK+_z7kid(Gyv3tNn5#s@G0xGcq zz~|$h)!eVIFCg!Mnjw9%2400v0lnta6PWYD0C@Z#vLpIS%x@07=e!6R3}+Czv#?J8 z{+l<3AjK}<`VocA%f4groub`~XceO93zcy7fHMgM5>_2#fb47ly^hs`um=kX#!9GH z8QxY%Wgz0<4O!RzFc}*aU{wi;sN6ktO}J5-wQ=7{(QnZH;S@zL#$!4XCh^Bks1?ge zZuQ2<$q3lIb^Yk6mPFAY&>s8UVit!ybCq39lX)Ef^=;v6Se+GG zfP4U_=y7I&BeL;Z=ek6fr5tECDiqqVYNn*f#D&JbT_44NFsclXM3F%r`fDmzUKdYl zh5dY?{SO*QB9a&%zl-Le)eQPYt-VCkTG?UjDtAM2^Zs(eFeK_sHUs1cOaGyba?=S5 zWEg{rlrq9~hRNCpSb~azi<7hSzi;1S-a~cAJQX@maT~=BU%WVR!h`|eSJ1IXQ^bCy z3GQyo7!b9mXCPT|F#qCUWWYdV^CMoP{>G|(PtS!E@-2n* zuByN;1WuPogph&h3&K!@Nw?m}tkFx|m@7-D07tc7 zHigz8EQC<344F~@WcZBlfKx>u2N!||RaH|6fxydzo1n6*n!UEyHE{~0J*cujd>34^ zr<@$w7SIl#Hh@D`yhs!?8N)>3gW|lCEh+1nJV2d(2W?s!T6k`j|D4zXzX3Y9n_GXL zD)+^Q5X-LOFXtWWpmu@73n*>LeB=3Ya!J)Ue^?PBn>%2$AzA`4Dj? zpMHLE;}SnV{&VUHGu7;}_E&pI{hp20wN@JZB8@@vSaiY>CAVWI5^F|5S3`bDWp4hl zkKzO;J-}8YP9=ECR2MWaP@|F8w6cD_Rl;Xs9&#yK=WA}I*xT$ zuabNPgojU>bqUus;r3~+Lk&G!P!K7xjm^cA@cS?#QJ&!Lq6BRMy*&?&$UpB$5@H@Y z*Bom6W{TYPUZVWs?*|zB+A4ZL=wr6kv$-J21~{!caXrkP>Xeb8;#gT zkNScSW11ONQ=Qm{XiSdMoE+BDOFR<)~Hw#!Z`4E#+1iJ5kr>)~3@;R&(HdVquhGWfux6~TsH_m$L(o4iR`w60}z}|oz6{-~+v*o?S7hK%1wy8D^J|c;} zG4`bts_464tX+9IH7hF=EStW_XUk+xxTNaJ#cq<;ijp`umHx9ZAmBz>_|dRC5I$Li zz>n-$GQi=Xkcm&H2qQOjmXC9dok+G$(m~nCpL~K$b`z_JpzLMTp0s67HD)*-6zo$7 zB~cY$@53e+AXIh~)PGv&m;Y7?h3bsi!CK5rpU(O%lB=g_7q?Q*Rx&Eh%3#M&RD2vN zJS1VD8hh)_vgS=(8ITQaptEJ&T^G)u$E_d~XygA&CKXAAQK8VWV!Nz~YfL+K3`epm8~7G6zf8fPOkcneM5JYW%F?gEt`ngpd6 z(jrn?#<~fDyO4nsu+PHbgIkSTxeS89B)pOJz?oObj%A(d+HwGZMYf0{M)JnFShat6E63>%P zL4wVu{zE|3`Cc>w@Z{h#)IJ_)-LT?jcKFY_r%wkmJS4~rGV!4BHf>|$ZO(_UJ)WSN zu^*7>7ospV?Mt`xf4G!rY1I)l4&E(-&UK(UT@ zPPSI>$A%P;83vqd1d=fm>_YFZz+R?$KdOp1a1E>dX#T7q4!{IO%@#yDak1^udQ1#1|?LV#zz|i zGHh1z{1oC)pKo|#7!Z?r+r#8=~>jyLttE zS4mxMFh07sNjm)U@W}t9q_J8MqRJJ`J608ITwzcGHuVJSXM#vKS|6Ck$QS2_$#yMb^qG-HDOPC}RBq@8) z_%%_TnKpYI1s^My_g4@qGL$|6OmfsHDmeHbBfjgp#5$AWCsiYoR_h35?8(?Y%%sBTnS;wra&S{HN+!xKt0vezLS<~?wjH0=mvz~Q-C>x;_ERO za#^#(OG?@y>0I^;!Uz+CE8vY6ruu5pUnJx?(?}pj!G>VH6&H80(R=88owNPI|5Y|x zIpHTI5b{IPH}EC~TTA`xAd24o1ZoMvpD0E}!2bR-`S3MfOIa>o^$8XlHk^jfEo~>vYd84$rnOC77y}8 z`i}>bIf1&;&X_W8h*$K2eI_<-*qz$6+AChNW=1k$s4|X{urXs!WBmq94*LX&y5xKI zeD~@8kDURMUGZ<`-@Db*l%AQWoQKKq(_W%oW0vo1ZN|Abwx^n$qM~BCib+467aP7W zJ#ee%@CNtnPgzc{*u>K7Hyyab72|cb`DYKF`J0z72d|rfL0?jZ_W_H!%f7Z|ugHY% zDS{Wg!+XPI{o%u5V?f30pS4Q~8tP%MVmr`-%G< zMG>DBFP$+#1ogiZpO;$+G_91}Qg=+eIL9wxxy+||R0 z^h0UZe?GI}p3F=zJ~DK+7JL6a%Z z#yhOtYh@GV;E~#M{ECU_GCd`%;Sx;ziB7)&D~V~6CJVRpoA7o6D5FTU^7*BSYi5#p z1-tjK*^pU|k(8Irli|(?TrPXaY$0!w$PK+rCNCP4SqZaKTx4T!|79Bnj;Ct&t|M5A zz05n4ym?yQYFEn<4)7-V-Ty2Fx;j!L{tT2wLc}n?%YgukJw+m~yB^sO&deCR$;(}= z=I7Rr!Xz29_5aTA9+Bi^#yJ@qYuEjf80|WF-#U)U`7|hW4f8u*PYlNBw!X^ka_X~) z>_$)@_!(q{qH=C*Lz14SIBS82@m*hBJ1EIh(wYQS+b3nZq%}-vj_md-oQ6VXe)X17 zOQOI@yBWL+vxS@>6PaC3dTL31cCFJH`c*Gd;La*O3+S^-?Q_AuF;$Hr14e%ScT6O@ zRU3eF5$@sFCmbYiwZF!9cI^CheXO`~!cE)GGOf~ej{$QuyUo%ZBtk>Cu zC{pQlIM_~{^kKUd$=iP%QqgAXTVk6}jTMPLPF0byo-`?s4meVAGA*q7TMsfj_hukt z4&nL;!za++v7+!dhfNFhuQ4U6s*%zQCrwkcz+W>!zDPJvyq(}LBe?}T48~)-mu^>R zy(r)EI(%uX@#^2w-R9the~z%Y>{B3>@mKk!@0%765c`>)^iv{m_MzMnw?@amt6P-Q zch1&vlZ!d8F`WOtdfZb$T1?_2^HR>s$jH#m7hG7PKh-OgX;%JG2Fu^TysnQk0)F6{ z+Z)d)Z_#Sa?PI)6cAm;W@q=j*zK=QXH?ENtpBEUCtZlLw*V!-wEUC|Rbu?RlK{_IA zx*NBre|UBgZ|=-8aowR`Un|H-f8RBz;jfk8;O~u$8e?xGUK6`E@zAsE6?ePm>-GJv+D*%1;Bl$QjEPQkIQZY1jM{XCANcJl;T3J2b@$%A11C;& z60LuX3itBT6lo0|YOj2g{tk7VS4ps~@)djYEw^InZqRwu-SsSDP%USW!4A0rliBVM z=Zyx=6P1(gxBas^I{%xx&%%XbqK6kZuBVg-S3`Ro_|tN$;B+#4?nwY)K!2W{`^ec) z^GuNS$j)v>05zpd@8YNGz6;FE%@e9;k({G{q5{5rUgxxXzrB*etqVrwKZthJRyZL1 zH@yL9Dr%b3CMsx=h;+wb$771rgKj{xKl6Qgm60m8uk#|k6qW279n{vY{YG+d7a%uz zUCSK-64n~6VHdq`Qu5c(g+1iItN&lMs3rXsh)mRbi(qKo)-~ROLRlozePH?G-8&9- zM_KhjH)JLa0Hc9w4d}St@l;=$yR?ORKo)-W&??=6zU$%MMWWri)m4 zsH^kG0#q2HHuxmfp^=lwGi-I0aeNqT90h?yS9zGB;nukaQ>A~dmX49wcuk;(zBP){ zmJxvS)4?^^Q;3N$gj@6W|8u9r3HW5Xdv}(VSq8?hB^X)S*(`8xoMlr3G!ax7k#fk_ znNkDwRUT5K9Hai6mlJaeMoBc+42pnDvvY5!Ym#^IyZ7%QWW}VX>TZ7)folc01WahG zs}#3g`9%w$aOKnSH0vY%lw-0r>b2os@*b(+iNfFzq^ByUR*T!=9?|(CX#_|)n~4NoD)sG0}PPjQb=N}4%mPVu>Oea}BOJz%-s#q9LC z4n|Uhg>|qZ0R6B+O|U6Ed$yC5kd{niJrFE%-#?Hdapv-9p+Sg5WODUKe`EznI;-wW zlGk+3y}5RyuI1=kUFWZ`$DTavvtPrdjWy5DuOB z61osXJytG7foYCPS?Bk82oz;QW3*)E5B>lQzI~d{nmbihxHk`nXP%ooUB9yt>LigU zsCx1z>JHKK3FL$-AvMX9;b8O-wf^{#2`RJi@P!K-QL6I5$RMKJ-)?{^98|JMmZXU` z$=>xj3ica}1G`$QdfVvWzxK=RyA)k3LgFySj9gq?M-rl85t2GN7mmQ*i5u6=l5J#7 z9GwNKyPU-izoS92mE%z$J9tnW0-P;^eti6R7)VWpQSV_TQzI?lq~Ltzlb|`jNsu1u1R#K{Pw$h+uc^Duy9E9#kdvv zdGB+!_MD`%J(thhF)5(>{t5S@pYA^-XKAcZRF|uLCKD}Mcx&tP zK|dZ?go^s;)=jSr?XDQEH}v(dgp!i%jW;Jg|5yT`MrV`ACwX?ykeM$;VxBn}Sjn&9 z^Z}2=OY_*VzxWyWh)37NHzhzV_+yq_%@EKgk;{DW2>rXsb30p8H%-BppTaZ9P1U9e zdKX)s{#U_bk5V|}H=jpz6S@XQRRB0gFxHLCcYCH-WPBgZl+6A6yBgyL!3)9Ts<9Cs zSVVkNe~05!BgHwX;JtkLp4X!);%W6#SbUhG$JM+f!^Ahn>uJBwQq-#w!v=oN?(Sfy z85U=RBBCRB-2ACisdA^{_6gtx(i;?@Bx6&IATTu(e5I}Dyty}( z>RCqS4a^`%zUw($qkA)QBGil7#uRc1H9zA<@Y4MHz@=_{_img)14{D9bFDkls z>sIfmisMXVelhjDvet+ZA8|4g#>zmXbkWCh9T_N}9T|NZ}YnHvx0)A|gaU zfk=Pc;s2t8J~CPJi#MUF@KTfTIxQWjKUr^;w9c3@fBzPR3$r9mCi*1`we+)6JQ~KE znK6hd-{|#00@glusjjYMNhvevp8mk0(*mxyi*)|mX?F!Bd)CV{PZ)yWg(N}(+1l!kqjS$xyRk<(JN4yjqEj}c?U== z22MZ7`2dwbA_>mBy$5=&;e}3}F$2~7Lhb@Y5a#m!{m&4;s>@&DPfkmSUhg(WTG_~@ z)R6N#61HfpO`pCAq?jHlzX_H(W*=Z+*Hf-xWmQoj_UMWG@zxLvHZ}B~i+NoNzHUx8 z#g&ld@dDAD(hO#r?nQXRH0=gYIAG;vM?;6liuLHuJ$tZ!f6ovXV-pjXbpg2bjwd)G z-3FmVzGS6^xRfyT4`4TI8%Yc`bwIMBIeCH6s8L_Qrs<)AVp7`!Wbz|-@4}1>*|33r zmZMjnea_E0{aLJrk?zpAz+(g_Q>)`G<$K(<#4$1ebwRPoQlz&J$L9yKj=|M!+Lg4c z&?O7A#ZH{KaqCtfSv*+uST~R9ldzfD1oapmDF!@z=%(Z8S5zd-N`hoThlD!-%+kAH z-&+!sW_sX&QH-mj?*U)ObIu&RkyyK=M1mw4LLDKSf2(Q>8i(^9IYjcjwpmRbg5UMF zZ47s5l^&w}?1^{}w7fdT#{UW>&ygdi|MRHaZY%Ngf4Bg$vXLqWcv^y08qhIa13JNQ zzJGC7@7^+MZCWYQP$&Z_t|4&oC)heo*Wc|2;9fpl0!0QNSU4-*$wVSs?=^(Whn@kE zg-=?q{=W%q;K$UDjH2eYQ`nP zN#HL)cr`DfQwdF(QKKlvIPUL8SQWQK){a{-mM*{W!H7N7g?=^juU>v4xhp6b8GP24 z0*`J526VZ(k;P4!u>R9n01%!W^fcnC;F!@Jq!irgWYcb!p{7sL`I^VcL5}KfSfR$F znwmI>awR3xH}zh#G@pgYwu5sI2F^kZn-sw+proY#XZKwpW~&d8?Y$sGPaUOIxEM^6 zZhMdom(3!FcY;B!>n{!K1A``I-|{tu{6Kr69#P@EdBaUC#_qvQ$=ifGsa+pH%b~q@ z;f^>APt(%V({Y+Bh{pwrBaN-AoTOh9UoGB)o8O47a4@;rho2Q<*SK*=EQxr+XY^>^8nEl&8?1UZhT=Ju z`7cNdYAbx(w)E)9*ioRsVFmGAwV*{{9bMMBI`YL?tA)^Rgg!LO5n|Bl)v!oW53}Y7 zhhX9SN#~AMp8yfP1jh{kDU|@aXqC_HrSMhh8=ae8P7rUDu zU<8->p8~rWD6h7pkNMveD8`vdqjBwK&&CgAFD7qr%CBes_6|o%g2_K#)++K#Szf|b zojF5^fAFAf!#aLxZ4~=RAug(jIojX>wW&|b%LPX+lP%*2Y_n$B{CFAPn@Kf@JXVsk z_$Wcj>?hAOmug6gx@xn$()RX{!_J6pCP*+C4c7rb;MJ#)-$px4I`!BD-M%dVpDcC$ zWG9B*9ZXl3-_0iHN~noJ!E5yqt4n#@hy*Bha$>d-F`Wz%e2UIqYDPXglqijdq%a^H zV(Dp8*>s0meX<_Ri3;3n7c@y4b)4rdo;fqK%?O;>fI%ZF=LhoyV11Bj&YpeHMW6f; z&N!zgpZkF`I7$@c{hwPG@g4y}Uw{Mk; za@~%?3}H+0nPtHK-eH%ooigHO*;rrXR?rA;ZD{m6dbo0x3tFrO#kiZi)yx{t^-`Jc(T zw85H^=KRK9Rpl_{B#C0f$x97ZcxiL&Z%nu8FR-q^{rCYn*7qdF;0$%(|LaXm>)o4< z7*FBicNJOV9(EJ^At#iIv{G!ZNs~b1^8W2xG^$3GiTNt1SK+mczE@&^}wbv_)Cm9P-{;Z55x|sS9WIu1$~?fl(`#*}R|Weegd5&CEf|Keu;a z03SvTOJ@SQn9#TK9rtC^_`&@Qk_V2WLpJ#PDE!M!Oib>FquUP*JOzs(`_`Z_q8_5H zznZSmgkF?=!0l*1`Ni`G%yD%EAFCX@^?l?wd{#-3fDB-AUAu99&ITCEjAolb{MEG( z#|UaYF^9=bx=~k$ZvV4->_m7FN5mb=t;G|B9+ z&$8LKEZ4kI6uyvE2q~8pzX`@F8De&uiK?j*#S&)DhVAD8|1j@IiSs$PS>8X=r{c~X z(~%>E!R`bZ%0+~1`D%TwnzlkU#NzT_DknF0jXqHoHg!IMy4({E#dLi+;*PwZE+zuS6_h7Vso6TW z#fL;@WjzAVOWhR1J0sbXl9uL)D)pkD3-@?2-uF(vm5d7qMTObG<9~oj1@3nNwx-vi zfe1c}b1GIsjnGMxc|G~COp#SxjCQ&%G{q&N_)MNK_LDk(J| zNv$DK5wd(t`VkiVhi@Ok0R;t>Mt@>|MpVrsQWR|3-K6Xvd1NF#2I35G>fQ1zpSqXVk9@3s#yU{Ph66J72rbG)F&Qrx+qpZ!>nz2!0`gs#pP*(GjWK2v=9i5%M zpy$)5*3r?CoSS;5G<6bD)_i7kt!pZE%V_Pvp zEX@e-$EabTF-=UpCCx_$FTS7()cux(S&D9QLMDb|e`ST(Fm4MW=HuI9=Jy2_tlElTv?%lf=0{QKogD?6n zS;9R}OX%^csi{2j*8mA4mqgMbNOA;QHu_WmgQTQsc6L&a^R&9F@Bt4AX=8Z%H){0! z6Sju%i}(s@K2lP&Y|1OcU!sRwv258fQkP;yzKS&tvF5g#&YxC2GsdGErCxzv1yiEA zrA1v+6Zh0D#rn0~XAmzyj7H|AJwWf;5Ukq>1(5z;!=hqAQ5V(E(Ov6Mm24$RMnz^H zGNCm&QceFLmjLU4s&k@|Q2;J~P;G-wN~}drjyV^li81AE(b;%G>cxGNL*VaD9+Ycj zpV&`B17s>g8DS({fGIu07P0=vIOKjHfWOLI5MFTZ9L7O5^Xk8ntC?6>JgKT$#B%aq zo~B5(ME`(q!A}Zp*Dkkji@Ec4c&RXsnr=3^B7GK$ zB>B1Tax3Y;!OW!#6jSY-zaV-0_B-GMsA;HJUx6D)7I< z+rwsFypw5i_;u4{E`cJK#_$4MGI|C~+Yf(IU@<+tFn5D<*mhkOK5n$d#rJW0x>G*pjh6y^70Kp z2@VoEAd&Zr&D^#mCSD~XDrj1?A*!K|l0m=ugiH^3KmdkC0rE_LkTq%*E-{@OA2e~p zXgotsow@}bj`(rm!hitR&viK75|LYlj$%to?g?9iheb;TkMM;HbGcgf%j00(8x$Zs ziUTK1m{>r8=~v+H-!p9@muUhnL)lLBVBDmIVUdvn|LJ`OAVHlMJiAWVCI$ruU#+Vv z!2Fzej@bg=C!KwZljh{C8(Va=z7>){v&1*@q61PV|3ma+2Vn|E=CG-wZRF#;rZ{jk zvXepP!IA;mZqoal%ZMjDK4ejvjKo7;SFAHtIF4}M8CC=rN$#Crnfh(A`t>R#ZMS4GKVAE0#m@$B+CI4u(i>uxLW<*DpZ(B|Le`Bkzmv>%@&*6hMpEQt-EV4|IDs zF%S>3>TR_l(+GzxV4Re?q)KeVUMBsV5F=uOz_q=`3$depHTS(gI$F{~^W(>lDaEOu zAU(qBjh;|DL(M-j`1fowpaxXY6m0ZuIcsxswTo=)L_ohNRO!fdg6h=Y*I5*TBNa*= z=fhB%_Tj-DV6O8DqzG7o8p6M)`XGQh#$xr2aTdN=!F0q={PA>RihC zFj!*Jw0eN~%w`?{6^@&ib}fQjxO~?erivK_ZD?$6-jSJk4p@xYSXw>&ZqJGCPYzw# z-Snj$g3bfv0cV!<_T1hiPqP|AR&UD=GO^KE!~6P52H2*#QNC z@T^OAJP14WFs%ImBNZ6VgX+2w#q#j`hyW*h2e_URz#%Xa`*|^j+=J&AnA zw!e)EiTChSL;-(%zTVKFW%>!%IIP`o@BGrA6YI*&ENw6U6)VE9aV_exZ3YhNq8uSl z)HanU?Q8aw4g#SUDXvhEkb&RTKFi#*@Q{#xB2tw*bX(acxHaM;Qna>i6s;yby;sB@ z8X{OTV9%s}PCcb2{q*Tolp%|<(M7r&7SpYupxvH1T8Y&$OjXV)d6(I3VdNu4r@+w0 zrfvMbe;XT>IMW|LPAt}6B`7);EUeCf>%OL;#{|fMDL8J$!`o;*6HhPQLKQ&8%yc!dI8tuOs!5Zw%NAC} za!TUem-DA$>1FYe{hZdUDdI?L`sSoT>2D^tSJMC1<;e#GGCauXHYdG#9v)8_Dtzxx z)TvUUQjCZF9aO|%6I!i&yR}DDh2i}3Sey3=NWQxTegXAEzkUyCSHJ!OsV2p+^0K!H z_xom}EBY&|%;$>{rp|oSYoMy(UHxS)<33 zN7do|9f8`(%5kKhROQ>oSTg2ICk+waZ8futAzd9M05`}aNQ}T@>F81B&qU^( z7I5ItmS~NcZ>>6HdMdsRBCBP~3?5JRl`vD13mpdRMXqt4q1uq!5F0Uo3Ug1|$kb%1 z`L7|xVkctw*mS5p6A>R8-GuUf^eA(eR)&O_85}!gL@vZyhR*`>(#N9iRBiy!jzG$1d};XY*%c;s-|QnZIz7VUVHI$A@q__q0LJ^Tvpsj@$&|p);ZBJT@w?9O^;b*!5NjBglxMW;=beB4fe^DyGv!C2t_3PYT)R2(WqV3=Zxv^uv5G%t zo*1;#vtg%_iv5*Ko-&@;sT`+hx@UMq#Lshfu}K7&Ty5cP(j;h-u$x#%7190Jfa3z0 z8}6#F+EhRrij<9HFWC-@6Xholtb+^cdw6&K)$V#E9g-G*Lk@i55w^T?| zLyGnw4VCh|ZvB40=a1*P|M2beP498v*L7a!d7Q^_oXw^XSXmgf5J7eOlDX*KEFC>Z zH71Og;$HvbQxnnSGMlJ<7Ct;#b6OW1nm#v{Y20?ucuE43Em#R|XztK3RPEJ4P&zUi z-jO-lMFH4L0`qZHfw0oSAl(9W0=)Abs1@!S1~HbLi_bFU^6Jxhd8u~#@+$q9*hhe& zHJtZB1X00f`3Z{1`RZM$%<8W9ES^ z^m3qTP}^jfIaaY>QhESDf`4;8di02I?A&V(1HLnJ2HwH`m44(fW|RG#gkoUpfxH$J_BrtvV>ybQ}IaSA~l+J^MhQ{)-Gq2L=W;VEJ_SDIN4x<@p`d zyMqU>VqfuRJ{tN|dP%%Jx0s)jMCf8}w0N>jsp_~#RoW0Jj%FDB)P_{R2p7s~q&L{; z0l^a1un;c^QZLroQJlS&w6HUuRm@*ZF|DFL|g{2UN%^=4f4knh+pRyS?~ zS~qA4854KlKUE+>o~uM!kLip4{^FbSbM9Q`TZscSQZ5cQj%S@9Piq1DCRSjN1io$A zzkhFY^Vh*vXiT}~2r0P;YWyT)516|;X?Hbij}6R46~Uh+n&~VuU}&zRM@=IN>?+jg zO3PK6+uXEx!@`y0jV-)i{-aWn(!4q0XzQu;jWgdNekKNq|+Bt!UIFKJ=G^j5`*dgo4WtaC^6~$!UJ9l0`#{+}TGzNLM)sP)sIF zB{ihBG{0uKx59e`s6nf%t5K>|eY)b>k1YqOiHqfgaYk7gQ{A8Od1CdKEE+P7G2*lc z(S>oqkoXY!Xhe-%vOe4j+AYQfALtz13dqL&@K=S49uL|h*8s)X%h#_TR8=uX!Juki zoub=kuH>|K4kpdp&>4cncYlG;*JbIFY_;rXM-~RLb=t) za~)t62q9IPs4?X3ixVJ(;NV~!{T}94-OW96yXt}K14zPY%A+gY?lBER4DLb4Yix9_rl{628)9!q_QKK zmrhSDqvFc1ccx1RZP+G|crXyCQ<7_LcJ_Jli>k$$yEvL@R->Q9#g_egcm<(Zw0}DM z!>HI!Y0oA!l_2-*z!wcoKsA808uOhhRiKh$$4Nx)wM}$dWW*`8bri%@f(fuccx!%A zwM@y)n@g83H&KW_cLi4Bax%8jXK)%2Pi>s z=e`yeCn01|=f8jNGiA!gGdhx%Yco&fHN8-(U32*Oac7@R@@VrIt;x=9MaAQl(R$at zdpDwW0OGS_M8UB_K52oIsr$aLM^h`KuvUV&EY|6ez(C-g7Dzc{O7Zns7Ieh#-~Z8R z!Kwe{0!(DEI&I`!%~7$Wblh4}Bl>{$1xqDeaQpp59nM^+mabT1X+^e zl%sP@qMkQ25#33k0A*=EmuPLp-hyKncR*VI0b_eKrVUe$irGu!fX9l3kFSoBjjWvL zvs&MH)%LvSLVC9(E--!YzG1Q>`6MYT5iRw@UW=M*+VMrOc>xQVzcuQcQG$ZORh8~n zS%^-CNwC{zEC^q~NIO0zBnWx0AM&B4*sZ#_Pz_U!ci;amwAT^iPK$_qRyv;mRJN>r zxuIPbj3bH++-!jJUK<-5)9RqQ8twka=(RM(jJ_&t>ZI;TFDlkg&cFH*2|W(Q*DrT& z{PE*6orHOBJVCj@Iby$8#vVBvi{}T0Kn}{QPLuWNC}TT0{#*Ny6}*sGk(Du<-5uV zm~M~im0K^WX9dA9$ttS7u@mQPw5#zA#}^|)L-Tg+n(XKpDOuC?x0%thRD?E?>7#UV zv*fxC6KV4%r|mQzo%xmUVC#)xppaU|-QI9W2PCZDql9%+l51g2Fmkz)K!PcwpFUjZ z6Ox76vYR+hXwH-4iQ6VY7Tq;IsAg8;{upZVs~$8cnDaT=!=wG?VoFo&T%U8guJ>|r zb_V@@^XgSrdb+*7Do7-Eo&L|DfrUqX;+Wm8hH=7=XKOq{3>-yJnqe66Me3`{PMpqv zu+AJoKnjuqa+xGoCTTyuvUUv{(e#(z??56H8Q_114!Itzv~7AGL9yxC4wR89TD+gF z7mra@SC`RXy|1>&N%0g|U3>5P5R0f^yQ}nFEacjqpTX%$3sG%_M!|VMkT@X>6^u9| zQV5Iex-83L;J~&5eT{_26KGC~qq&ymr2h=DVbVKR(CymM-|ZY9)|W)n{y-n&wQG7$ zAAae=ft|E*yQ#+Sl{Oa-KYqcP#PTtv z$C;Kz5eS&yzJITjr<<}+&Y|)Y2exjPBBpid^jQfhrlhMnTbP!op_ic^E64*|uvo_z zY}#(0?A9+S;1BRmzkG4H@r=&ycH39Y4klZq(2uk+uT&ObAM6|-h|5$b6D z(#O!sD605*?z_n)omZOGrEp@T1Ylj_4h??#AOP>Yq7X(9tNB~pE^g>w=)!_P0?1HR z(EL?R^(2ky!4WKSX#tNPI;Uhg#6f}#>6#!wB{FPj4-SY>kEhllw3MIVkYoOZn9)vjMrHWJqX80jykT`dU(vFNeZI2Nz>)^ z%gI|UPBcwRlrn4``z0w#dG1F6cjAq2lbd?1i~zALt{M0FZ*gT6B5?8>7(r>Riu2!ktAi9*s ze>$1CF(C|LVBup#xEv`QdGQ{}$`MDTh8N0iF2*(f#W~HsiZvOqVLW(yt}!X=?)F{I zW)s3lrgkP9HifK%C#kyYwPT-}C@+EP`;VrJjpazf-1j)umuECOxNc>*L+pSXcPsAS z*QzWS_^5Jg{f`&5wKCJZjG2ScrTMeG!r&1F#@!tNogyzfDPE47Zm7{|3H5}>yQ!pr z>Q-GOum9Jp!+U03Z~PfDa5uBq z*SkjoOzV5x-r2W}aFPh|{rmEPyVurSmE|m`83ZQIh`)XuW$bcFYDvB4$>-}{m=zT= z8j6WuW?6OL3;q9mZ3Q2?B%xr)Q0G&Fb$}m$pJ?FJ)#^Hrc*gWxrkaj-R2M z8qAkYkMkf!OO9S*I)RZ*TJN309bKJ_Ou4xIyM z&SXf;v%Kj~ykJLVD49?)B-rWDP*Py- zd39yw%euOI4G=Tbo7enX! z*zVb;c}eX$Ms1RvoVEuo4#sk*Wx!X7tJD;p7AIupFAK=T*oDd(n%NKVR0jtKUV1R% z-^;Xe^Yb~H$LF4wXwDl5$a4|&!p4RnV^{3kFC8)!cI)Kl-eT*G69DJ~Oq$ zO>s+m3L&Ldf4ZyK zql>pkN9mJ_hA=6e+d{%ZEY~c4=8TGz4r#RH;-)NS zW9GEk=9jDc-qIdmJuTgAZCk(|TzVPe00jxTAB3$@u8H8G^fdKyL7SMyU=OL`6s*q{>jicS)tr(aW45WHTq=FA=BSiwUncQ z5tQgFS{=MyIz&LXxdx#GR-B}FPCmPoIZ@#_fHEAVK$aHdWgPH(;*VL4=hyXS0pOjU zIi?5qio9Qx$>d(JT!{rBoB+@n%qPBo7oEZb&n#`J+u=)k(@oWNLw?G^~6)F z;68C7K*Xx_>sRLZ0Fe-avA+pY+Ny;PgNOrz3g!=u>vA0JaGMRPFa&1fo04DU%8uyC z>4WVw;KfoVQ12b>3%EqB%QnxcOx!~wlg=bu%oz}mpt)OnaO?rOLah^JAE@i; zGw&Te%R-wDKMQO4g5UNgVtG!UgJid%bu!rdnwo4rJiQ`}ga;j!GZ{w8eIP6A+4&{i z5oMe@RasbQ%#2yUB8a0qLJsG>d&lQIg^vrQZ-waXlf@5+>DowwBP(+9K)e_?k&}aY<8Ys>9-VY_fSt|x7Fb1sy_J^2I}-#t*37qoX-_(Uu*3Pv`yC@_ z!EQ@T3??HZ&XED|FX%?G(smU1q0THRw1>1H;($p>;mvl4i^J{6?4TnnD=IqtsER3m zi8_rEa{S4;CNh)t14ls8*V5F4bZYdho)&T7paDbn!mAZ85OXfNkA8morUy^5sM!c; zSpcW`$%Rss4mzfAW@Z$64E2j?c3QB*!BOS^Bb|{I2=9KcY=IE*2j6ew4DEpOgk31x zGKMkeHNkKW@RI`+<^sW|_fT=KXa4>B%Yi-ls?I(!xq_Lh;RqC!JYfoTTpa_t@@phY zlB0}ABx8Ya-s;%*KO}KphKslu@S{707Wf(WBfiL?E8QZoRYYOmzyC?^-kA(Y#R?CI znIS@!{A{(wW4k1)DX2lOJ)V~KoXVC22(AbHnVQC*toZWsVAyPc!~jP$vl$d|Pvj6* z7;GuouSxHd^M?@1T>qhn<*lrkqpCnf+ign;DXz=^e8c73 zXBthg&KRM_rFLpIH5Kz<$SnE~U;bwz4RE}#Flc07p-JsZ9po{`(+%b!f^<-HS|DY% zoL7eX9#mJG>x`!yf|%=f6DJWaDr^Gr{$}5>m`y;2JVoL=t^u_RM~!N?r9@-TEp81l zdG>VuB-az4QfPj*AWrG9DqmDDXZa0U#XYB@=;VMd$zw))Ikz0b3CsjZ`IXr(+D_J& z83m<~d!3k$f}=}-XUrO`;C{}cwELpPV2^owq#5($7lUnLn09y2?ymSHGXIkMiesw2 z^T-2Z@vImN(4Uk<+osR?GG(>)WWtiLeXX7hmMJ$qM`NTgxPN~cfrJWlH{T@r{}$m}*DtAH& zKVS0=wk8KDh0Vr*X~Y~e6iJV;^q(>`1adw^7;LEC={jWUm|&M|rW#SeU)n2aw0@hI z8`4r@;VQ(9dOEIC)Es`b_`Xj)?ss<(vdm=1M zuwOPV=1DnPxVps$Pst)sVeLTL{rAg(;X>BU(gET;H;cV|SqzsTwabfNo+ri`6Yx%l zUofT6@~iUEpQ6zV;7=amPD}IOXcM*KWw{@~ z-il_bwE84{71 z<~=uC@AQ}_^~(Iq9w+S%3G6jNn4;E(eRVC(QqhrnmBYP4B~p25Nayt^&a~pAmZVz@ z=xVs7{%1%SR{QB&R}C9>nW)5=P7{9jZh5)gkCRF2=&I=k=Gp~?tEM=1?ycHGt z)=uE#(_Q|5|KAL|+=-E!r1|iQEE5x1MU-|_*?V94n79>nl95j7J=RjKm$-~%f;D<< zJbd^q2TT8IO9gJINz%a9+x!k>o_|v=Et`MWuJz4a(_8QKQ}JN8f)6E44;9Su;Lnf$ zzRM6Z)%>lidbZuZp_6Re2(@RH_&%M00DfVx;Z2@~@tsqKOM9PiO?ln0lB7S-vXj~T z%1*3YkU!ekL>?}nXpRXc$jk)U$VrAx``5w5^`HW)+cI|ifAYGe=Xy4>`tXVol^T@P z>yKZ0tH6^`m1n};e1o9H*rZWe=&iy`2#hWIn%b3RA78!NklcT1;+=l-GGFFoE;rQh zpLc_92^v>1mb5A>ktV1lR2qg!*RERMZF_BF>ez;TLo~#t z;g%AP$N&s=ybe=|l95RMb>7llGv+g{-3I!#^dJ#z~d zvf>G-Kfl1ld(R;IsZ$eb^^r9LDCHg)<>EJO=vA84vTf}B>4!x}%k@egLk7b`Q6N+f zUHc1a^5%^jx&5`BpvF+-LoP`(o!6P&0Oz>|v2*9&kNL#=77UUGc#PR-c+1p57V_*+ z7@Qb>jc?bBVHI7v#BV<`8|tjoKU!qhZ;kYA2(CeH4oa=-@`hKWw17TGd=jKTuA11m z*V2!wyfiSQ7REcn1J+TOWc0?aWeQn}nOl&- zox>tbbj_riR$OOK;}*KpRJTLon%v@gUe=I&i;16D<&+W6A`0Y>0=!XzasTZ+pXExk z980MvWTT|%VfLS*M9;+`aBKFUhnZR=QWVp+EzMg-A5>~DhsQYBu&2hr|H8Dav@BCD z(b}usaDiVz?N}8zMvONm_Lm$dPTcxWltG!!0^QXr3={I%LvW2q3@RoLGQ$U$ERIFY z(O5*mP30>HWXRiJ70r0j=DvKC#5hLw#{DxPlq=Mx}R)^nUy%cwnB!pTh<;bh2e|8)_Jn>ynWn*vKKCM-- z85@|fA|h3}@+~XHahjp3JiOsnwIM_vVsGvKQGMX`B)J97B@&Q{5WASw$oWJ<1(^H!b4NEv#i;dGjGw$fzQqL=%TN9jwgCwxF)_+P&8_$0 z8C8Acu)pk$dn(Ta+8}?)PXD0@3&fhy~{vMJuGI=I@l08#ua!tZ=JSD~L z=dGsL)~Bt%qmdoNxk9|4>rIkIku1}0s|CIBLHp- zoFSrSY4VW3O>d`%Pw6v=(uM<3IUA3>(w z@&Rg}qRU420)HAR0Od67xV1rRYY&GdrO%Ls zS_Ur0FF$*l3GXpl734F zm;$9A>ypO_MS+VxEI(oBnLZP{5Qm5L9;|a4EN01K@ejC!gG-k6Z^`qu8Va7M^> zIwuUQYj12IZp&l}b<30x2)5luZcpn051V024Cu9jD}DaWr}yt^u~IYhG+AT(jET~Z zR|$;bJT1IRDVik5bK%xO7~iO55Ak`51szrtU+ zS$(aq7e&21VsIKh*usV8=-HMo-SekCpLB7*&>jdjsj%z*4yOk~=aUD-{RbGJnqRaC zZ=0afke)naxaDv0^+U+f8Gs&5jwbVwr%hWheR>DDR;_l~@n`y2SXr$EQS>=`?wunJP$}UA z*PW>retvcVmYI?C?I=;<-(wZc$aGD??qDSd(o-lpl#sdi5;hdSOmfYnOoR?7Lk+bS z`;b;;?0*Edn@W)o1Hxo=J zBsa<(cg0;`%j&U?bO)%?+-eS7KL?S4VTv2<^wInM1%JD<{4#Zc;Zgm^Iq`=Zd9K(N z&tPi_0x23pFsEXHCJtz?sog*WmcdQ)pPW;h6k7AT;novHKi4B+>9$JlkQZq;w)KP|E!p>r%&||9QBexIs z<9HAU$Tc)T(TjAO2x znS`o_r-*X!sYhQ<#mWfGnKIq9XV3YMau^~X_-?Jk^|4c?G#AL}@oU6>|jF!bMrFVuBbWDbOg;+8%6?18H?Q&vf1~*ex3^AJtU|t#xVNu*K%|N=uGM3 zv}>0@eTOw@{D>~KGcdWqjEtk8a{_86n-b;Ic!bZTeWxI!u1R5qSuN5;n=K`X5Vf&_ z4(FJPk5`J*>!6hoCF$kedwH)JIVYx^4_L6^3VmBZUCs-70q8g4#&ivwf)bhUho!v@ zp6m#ru{9Ub&L{RWjt;4U9LW3{=8El0Ow|8#xNcm*Ezp5DPL&p&@GS?Ab}0N*gzC zMkQH|VxEB^ndk3@9iq$Q%p_c%2MuBlX=C%<^<+CFq|-;Wa2)c_t)b#|f({^Als! z4jdqytRWCW;IX#8hgvx@T=+Rg!^qJo1|Iy&9|*TADepd`;Bd;8Q-JS(C~KER=$4k-nSX;nnM1v z?5Pm&5r}czPtdos6UM%rIX2wFfff#&Uobb&+Mc27D-0YT)|jSMzNJPN`M?SagV!~m zll&&jU^0l-snRpg{o3<=TXi;Xf}sxPi!tQWnlSdTIeI9c1Hi{?hKKbfVp z@pnHU7m+Ts^4KD4b{O1S^?SwkbYhzO4ctoA1-XsbfKI&acHr)MJQ&wP1;DQ?KlxG&?B%z$H`!3 zl|i{oQ;eTbM$1n{0NWD6LjSz?o!&)8POc5ag?E4d{04K2j*e!g1Xy?Ct$Pq%x_2Gf zq)gir`a9UQijeryTmC=p)J*}pLb05%C9$YTh(Lla=D*Ma|_22f;Cs%L0MC`8f6h%FEym0}F`b zEume*yX}UrkIl*nd&8{WxK~;&Bm%6st)Rm^ zbB4#Z#v96b8U`kDbQ^mg1M)&g_<@BQP6E5FklW`Vh&;_;*2vX8r!sviUm9sR$o7GAa_!S|_)b zyA~Y6A2-r6~RdGKlBYb7catFGgv$-37o#7AE_XoXfr5FB&ve}d-(nS02W#f50f zMCV+?-X|HCz=IO7X|D?Zu4Z$^bwz;wU9#-+Ac$G9aA$6o zd7yPpnZ-Zi1t!yipn?zGyeDTD>ZO*6HseITL?3So+N+-zGj<+p7!MCy2*D(A6cK29 z;n+Sr+noNnXD@Cyq%Y%s+OFJtFe}%ECZ3Z}5un|`i2IB8ugf+V!A!IL`r_R?#b+zN zGrUT<`~AOIbBtWjt4-_89t@8kDtg|Evk;-bTaWM@}KP}yc7lWU)q^*>waiNqp&99O41ncwIL%Y#d5}o6YJcK z8aRuj1^8!jzT2lZHHqy!0&>ru3af8@9r8;uHKCyF*%kA4yW!)I7WO%Er>)#LedD9B zZYLh|Zg}>TdPwwMV2=DIZ7A(@(@;uQr#~6rOEbO*GPlxpgFXFbsR&s3{(b=kcRmM; zYXrQs@>h%uyhmwBF+OPPupb{DWgI&;wES9g5{d!J%6_sxqK58Sf=Adq&|nTNb`iKO zvfPqDTiZMUul9R2vLDQF#UzjP98eZTw8jV2A+S71rTfs;nKS1CqE36c$$`;G1w=YI zHjy&Y_O!0Z@F>x#*U!bJf9N@xekUdL@RYB9J@{WiKwxIrbCf&BC^-Q>8Uw!UZ(9~> zCMVtNN59f(?5?Kf=EgGKE@#=guJ|GdcKWK^M5hU_$Oal# zhAdi?eMm9H{GpLXYh*17Xg9+HAWXRemp^Er8VkM4gZpZ4ghK?YL9NeDFWN~3eu-~= z4m`qM2tbkOTA@u7SuaaXe;pm#9g4g2uJB@0q}S4f&EI>B@1c<#+Df zxOo$$&+^5Kf%Mep`Wf{v{PxT_1!)#&GmUW!;jZ4(ncaUE_r>p<-r)nskFWbe;Ojmb z$M6i@Qn@BDj-Mg;749JSmW=etTelW729j`>X?M#Dcq1`n8Jv+;BT9475C~8|pQ9bv zBpqRMm&ykQ3WFX=#+!%_jo2B`CAL6sYMSoe7-WA=@mgk-nczwAYFyi|QA_^2 zr~%Q#)x-l24>aD?NJSxoT-|@Av^#}a!8SQz+%%#iJz1kXexW;@L`NbaM%v~J2>}RQX)k%!kcx(?)9+=#tK<> zt`o5b(;s)YeFTkAyhHHUW3B^;hF-z%{pzCWI^-#|0SovttWAk9Vo~CM8u9|Dp*Rra z%^QFlUct^C7?@5cH^NsJito4orZmaOmn>uo&*u_{)(N!4Rf#!zoj2l}) z7z(t~y&)yynNL>22g504kg}h%3fG_>+#uP;vfw3gmUBQYMm0`%rnRf4FZK%eyv3>n#-$5e_6AV7e zg8svkByWbxt6%18;LWI}<<0a9{{O&NN)QXE4%U@t&KToM&|!r$qmpVKsEMb8h5ruk zkCGeO6fNpUJ!^@r2N8Ao`LP&DT zRqU^P3+mI2`4h}^dw*lc3;cnXfK*ZT!50JK3Z~y_^rBIWiC###1)R0q-0Qslxh+WI z9s}11bEIE4o_&~U;bDem$pv`EnB`bny z#zM-%&H*1X$Y$9S&HjKS-vPa@tR$Tx)U%T46OiRHZ#F7Q_Chu!xj`H}sC?hcB}gN9 zLoTqo{&@i#2Lsfz*ez4K=04&1>&`nCsmn-`REbw*?i_qW5@wdBx9v?KdG*py}+NgY-t27=Am4=G_=nS z#(Ke{uA%y5xWzDE5sUhbFlEqy0qMFiG2mri9%fHx3Q~7fd5SFGGxJhFF#O)OosHps zS3SK@a#jpgNZpxhE}F(jE=$dBBPI$2*jY4BcJH1$YgYH4RlEUr1UVfsaSQf#T{j;@ zs6YFTG1^kMEhc1SahV0aOiKVTlwmLSrkSAbgcu6d;>~)~Ep~!SkW-NljhwLh zldKqRnD9BS$5v7TvcRQAv>F)T=w#_g-GpXiM=2FJ{k&5&Re2?vD5t-wqOU)qvOv8eE5))wAb%>b3 zhz>T&sb9W-cedW%f+B;)fa6#RH!*SPRk7Zs|DT^9)@lU~s|$q)T3oPO+9D*fNo9$T z*fJ(V_G09RB_=5yI^b<1(8i#iXETd7^jM-SY%n*D@|iq&#LwvmuW0r51~x}vq?g+! zDUol_trabYkX=ZoJcbWNbBhbE*3FyqNI;AR7yqM9wNks@(%j^+^1O)~*vRrJc&3Ry z(s!1059uMEE1GnC$Bcn*tf;K)XubUhgQ`gc$M-r-17!r=qPz4pNPt0@VT=|mptvUY zrP6ja<`h(q&E&7MvYZ)pW1P$bQ9Vj;4E^^)lp*vK2%hWsFPA&}>Xog?FnA$ka9Lw| zfEllUGA}5o$E`spHb?-Z3JPji{6TW-*VD7%sXPfqBM$XM2m@^*2+-b0aYq3T|5W$T z0K93EI>7YA4Up3myf`pmH4%?zk5|F((2|K&9X7aF3-X;2ybm7QwHns`a{bTIMFF&x zxPJFJiui;l0N@ALb#W2V$j%ZS;TojPOP2Ke((leD83AV`qxl2;xtqb5gYR%jKEzGn zKDDCTL}vRhrYY{u$HOG`#{l0Uo{64(PxRK;mb|%ZVd#(MF(^n|LnE^JMnE=6dMR;n z={H53F~<+uXy~if)dvg(TyI zr}1HY0DtOU3)xLi@c(6b+Wh%Cj%nwwUq>&u+8=)GY>VhfnR#+4g<{0D*eUIV zrxAPg5$6*zhHhg}w2`!{B27B>^V=`9;aL&(gF49*RW>B7|739oGZzm2B`Aadl_`;e zqWg`-xs`7Po%N$#=1A;Rh=(*uD^wgOx4unN?=iWe6JACJR8p8HEWL7-S&n`y%CDd+ z!JXogQZHrk4GJcvNf`Tky|@@7q!7bTT>m{frUqn9^b7D+aDw z8SdW!09J4@?Q-kK1A7Gg2J2d`pOKi5aEqoc`KM^(d!;ek&Gw<<2Qf&ooGfI&ON$Sc zgGLZe8uTzBo?-DCP_0E*sR?ty$0bFm_y^&ua4Zn)?a50NV$i<=#SYmNziK= z&>Uk9*4x`d0p$7mDQai|*I-ksugb%`(E6D&HRab7#vo2FhdqZ=TLX#Re%;bB3=|d) zZcw|!JVhoS{a*iF_O*OeptgH>ayI80tyNMQ+7+}>_UqpMUGS)4HP&emk7&0A$r&ya zBhgOwR@;d1K@Q#gpgco-rv*xM0V;F0-t!}@=gA$+n_+R*7DySlJ{9sVVo=RJ8-s>N zXBYZ%x?%gsG#udZsv6}D&KU$HYDeOxBF!^!Uv93Gwd!mc?$u+s&q*hm6J?s&9E4|b zdAbW!0e04VqzXQzT?L_``AEGIzg+*0{PO7Vz}*PaBMR)SC-BXiw^95zESxjM{+-g@6r!(*Bz?kkS=kA4hL6F&a;fIsAP z1L;ImS%ANy24Ng)i=~SfJ6Nmsloh`wD6D(n?UA#|7C>>3%Bt{J zwD=Vn8%cp-)nC<&4oWEL6(z8i*<|BxN+Wn_o7DE>^aYeL6DLg)$93|sFN@!{ONx72 zA%Apw4`*KFjk$wEnu5Ux&`Z$mL~7h^${MgtGU7%L2d?_!5slW_ZI5eiTy_(6Dl7 zYT2w)kEkf7WCzGzuy??)ftTmTLcV9Tua>V^H=U#VE4s!p2nlgEl{XSUVk4v!@FY}hE6tL5vdZpI(K@~atm399PHMy!^BU$UGDHnlf)^S#+}sfGRLwH+ky0lVh2j( zv=bsNb)wA69QaZ#Oe~W3y}@b=_bOjn@xNREJ6uoa4fL5d?aGAu=mA9_P;9;yNcu6QgZ1fK4%a z93%!Qnar2~@97{PIqfm;|3T4UK1OkveY0(u8V8$##$+&4m1xK8Fvob^acmSEqv|c; zcKW?1=SpB=8c&eK@e!oMEf~i@Xlz$Mi3$P_2#7L#pVOBQ9SUOb{Gmvhc7{M#FbTOO z5J4on)JbmPC{VB(nK$DHw6^=(>wXp-%^-G0=Dr)SE=?^7q!qqjH)dYge`Nb81(;Ev z^I%0N5q4)wW(P)JP+Tqw?rW^Uy%RTCF#Q6M$mcTqnqmor;hVNSH~SS0AG)A{lm>W)tOrN5xeiIQy`Uou}o@ zTLn3XE=-83RqHF=ynDAlqKR@CX}ojOSg^(&iU1r|^K+eRF< zx4Fw8l~;M~#nhk?jxuw?C9fN2-P{?zymxsR=5Y-0;PXNhwKGhLd>rE48&$>9+6feV z`kMctqpm$rqO-E&Qtjs>)Dky}u2(H0)i|dDB7n8^?xFxuleKad`B>(y@S*_zmtx8l z_OK(fnd}Uf$_s2duw=66zXeI8mbyT8D>qL)YJm(%i&N~~)@&a_=C!UFdu%!f; zP)kEa95Xo)SE05Mv>;%ibB)LT?0x8n&Rciv$XoqwgmJa;b&aOps>xay=JN_ij?ire z_v@#<5l{Lddq-zf@EDRC0XQ7Tc4WIGxsvRXe$Y;69p^^mB7VU`pqGNx8ecEzu53HX zpE(R41=3;~0)dbtfC^s_2JW89D{=8Pr%oMpU@Wu=h=WNt2W=d=o$`iH&|25@wH#U@ zk;FKpyYIB{zq@qbP&oaVDF*eg(!SJYs5!0ze0X|nu=xDHnAil%5Z?YZngow zs4cw+xr);4%PG<)?xmNP%Q`+hPl{{3B^WJ+DQ%A=mDZ7z4j42@Y1d|sODcR8o^soa zhP=c+S#SX*njOwhp%$Uf%tyiW+U>bfXKT`vv#T0kF*q5gH+=Zc(Kv$HcWWj{FQp`$ z1aJb1C>EyuQI)}_zlN#eAO7sj{4PQm-TSI|i8uy;?aH>GmN|X;v?THXH}(JcYm7?< zdq}Prd>SJSI6KU#s|uHB6YH{>Y5?kXyR_7lBAcsMFNXzwAU_DjH~<#4L_N9fptg53 z4M46FWK1ny+@R#nykXL}b9_PgmUvrTzq)o{1@lKo(+qTTTLt7wLP;TqHiLZ)5=hgF zsY~=70l}gxT=;VBvpdl)`3c#D;`#OK*J#Rz;2Gtd;cu~%lgyf$(%Kq<@ym?OHp#In z6S&LG^y$*YmUj=UACpSP4xKn%zE(%rSD9QciA{HaJlwK{p{gOJ8 zRh|t3ve|a-yZX-tz9Es9RMm|^OmE93!qSblIEOOzw?n#BODRqRj)vQ|Z-*+HuIbN? zY7E7&jADjk7S~*^-#>r4HJVidtf5lgIQk&#aKCQ+#_*o1>Iqm7!5wIQq`6EZV)?SV zo6I4_c&=)}v}xdPUpNFzL?EI<3A=S`epT*l4y&yd7v~rfzv;m(gd^6m;{(q2`STM( zEMcv%UxHi)?F7H!g}GP{kilTFnge(vPv_AGMc;qS`SEt?YW66PyX#Kr^csK?H%4T| z$6pL>S;r7e^plY6am%Dzy=)oMsUW!?o*_1QKtkMa788Ia_>HSEwJ)_d7a2yHZd#@Y z(U2xZM`Nc2?qNPTHwf^Wo?B4yw*t;G9M_S3qbOsH6+B+#kRo|$q}!6zq5yK)&yUZV zGq~!bcVK(>@Nzkl`AZZ!WSwwDuq%Lg0$GL%m!ZYdsc{NK8pe>A7#mZ~RRocmbO;S? z0rw*3RLOnz=TOqttxG`$TZviUcm!e-WO%2K`hOCaY2)>&+Mz?n@#7RnSe6cV1q@`cjd>hx(a zJbrWCw|AOVHLhp}MDwdJdDCcvh?HV~*cG3vPAhFY;v&Ukms)iG30oJyNXVy;g4qTx zwiPOK`g0h<*afUUKzA=E=L?-A_)Ppw6TwOxz)%zbQ~c+rr`Gf}`r{(1sW}54jk$Rq zMhlz`Zuj@?*dZr~cC5yxx}zvLeihU$HlKPSaKVC21%4F!R6lrARM{su@bPKugSPbMxAj?GQ`f26OW>a@`*2@ zNK6+;dbAa%PQLy0X}etl;SYFyo1IgJCTp=pqoYX9AqcTvJ8Ed8>E3?G&@JSwP+9Da z)mI<~tJ8I3aUX|yxNu?nJmYW6ARVd42F{)9Gig%K`*HO9=#9F&Z}gtq=_&W5Da0lf zP!LLTD_yvT9v-mC^6W<+$gdDw(IyU@F(X}fbc<-nR20DaF|AwG*$Kh~gAf4e@c};F zG-oijw6TusUHpy3*QA`2_?@QML3)yVExZXVh71JcgkFVdRrc32Y;fhar}#MBg0oU{RSjn|hYDwM$5kcM72U(9SFv}w!f17^fNN0|AmO9;tskz-)Ah^EMk%~L>u&>-l z9p!W!0*G~t&N3_wj=wf$w1wKf$c(0tO>uEo1G3*d`!a;p$*C4}(Ms{S1G(PS_UTUR zdU)Cnq9qC2gvjAIK|lH$(pAE;)`als_upI!wEL{7rR8j_&cRybCF>q;n2W$4JsL;C z_&HR11X$>(9p-0C42It?CpNjC_-J^-HBxq650fpkXU;t1f32;jCKkPIg~YdRIL#co z9B3DTtq?ni(boyAwP}h>!OcPV_@LDf$#9?u@)$h7|8|>G*OQw5dyL4pz;c!kF~+6 zL6_abVfemb4@9cv%PU~_>*yBxZp z24NA?exyFCZnOFJqVuzx=X4zweFgW9OtWz6$h^1d4~m?c9*8_R0l+F4-UpfTy?Zp$ zYcRqQ9#T1^mXWH-3d~j48@3vY#JG|`^iHhZvkN`fUSnPoMp>G@gBR65w->@N?E(IK zgSuoigj{+*QiA-x6Z#9$QUlSGdok7#6I{V!epUZKInq=ipRAVXGpYAP@l;!y3ypK7 z&FFPtF@ioqaQC|Q0i-*Ic}h1r4hh8fMG)wY1dh%2&&*Fx?eclpt+q!N)Y9Lke7F3v z7#u(lI3JA671#F+?){~q;U_?6(bUrDtbABgg1{b(RO)GFCMzIf#gHekK#V?f6W_J1 zS_h%5CV`q&2%DzsP76s8AZ}k>=U1)NDU(=0B_VJpzjlzefrJLH6@!?4c!-PMmchMqVkW%#*B)fh?X5L4lXXQ z>7=|c4b`WyC$er=Wna~MMdw-&*k+L7uDON}w;l9s&8~LipGst9WEiL!P+NyEj#_B1lq!Vb}(2l@tber4qV0Mm1xK6J?oMb82e_xr*gWc zn5_>R_6JxVhf{9irp=qH357Azy50c&pk^uVTH}63u#C`utIgFU;_b8Wmu3PQp5gF@ zJocF{otuue{YuT)Z~ePWLC++SdrpDLL{ZG5;*5>u#hb^p5hfGZzPUW2WcZNc_PI^n zaR$38Ed+BQt*hQNr5pN!G4FQq%7Q+Gv6a&~>e99wa7se;WN*MAxDGri2pqA)Lx0Or z4#@7l1*=kn4~Hux2y4K91%jq;>b|J-9v(EVeR`Yn3l$WeL@K?sW^wz+292@j-B z8})3jRFAAAg%t!GQ|Rvri-%dgpA=Fi zL*>`n>D9?=Xe1>_Z0to#7LMmbU!(9>pyEmM=$M@J{_v?&ch2AFY=J04yuJYvm*NT>fW7yX`n zhkaC1yyokl$Vc)V#Kkk zmnZ4Bk=#KyPjZxP_!*+?d!wtoz4{VJEbQLvg@qxYgh9p9?PeCmX(C&puv~vJH2KGu zx{>&oP~qV{oTeG^K~Y7e554S?5|Bxwp0gOT!f(R4={Uhp^@B>knHVO9S{0aP8(*auoUuVGZEad|{dp6CYMCI!=y4N_ih?%e? zel^=qcn(E?IIbSnGx!+YHQT>UMq2Stv2i$YWvgl&2n2+r{kzoQg-S0=|3MGvK0jgg)k-Y<5mhcJfq z^2!G3kHOCv9bEPF>0Vc3*m{n~GDgl&;TV>e$6<<;R-@#PMqd9bz z1CCFW=xPkh9_J{8j~TiZJ>WW?g471B5t0|Zv2@+rV+`UIcnAv zALX#BxhXqH=|@AuBpiK$N+X*p~J_kYNl~ z%o!Vw#Fce5e)8nF+yeCmj9)ANtC0w6SVs&f(iZtmx;LOrgBDZU0Cp0Tmn@-xUj}~)j3ak; zC4LfBQgOOCFcBa5He^+-Wsyq_C-gmP>8$d&FlT?!gYOWezls#=ZTx(Jbx*E>1f{$$R_tjkwfI9CqRl)f8>3J_TJHD zw{Ne5701WpTy$}fOL1Qg_m9Q=;|CR$y|vxaOKX1*?A`kVy&1`zY%2e6Otq@7M>gPK zol7}&WCRI7TpYbmyX_ym8BFn|hnJ-k1EGF0u}iZ4W}<|CTdX@TN`;#Gk1)mg$|-H2 z`v-tiydcY(nE_!|sEm`LUfwo>A=!Me+wjS5-$ukOE#L)sp3{zUXZ31&#-&R$T&S%7 zvYZ% zz!Y3ydtV~_lHJ&+8KI2rq;RHB#Kj-zMk)*)$^dW1O#+9sPTL{2j%^W%kb%}9lmP*j z{#Rw}6|rfDRG_tDUWTS+{6iKWd@c%d{68660uhp%0NTvm;Cuj}Sv--#CjQ7XJePP3 z+!2nE+MyxfGZ6)XKu$XN4~LZ4JRQGH<#Bi$xzVXMp!PMovVDO{9Y*o>ot&cdE1^ty zij=5c%mJ!fEPL@Ew+lcXCKPkJn`w>EuI1X`-El{$NCsegfo^f}XMXanTZut%$22}1 z=7}6U=#oB$B$5m7XPR*I$Oa71H7Xm>?Iq9}bk%Blz(|P6|B-G^e#nvLWH}Bj?Mq!7 zA?^6_1$Y(nl&OZeXw<>jG)!vS6I@3$z5?e%SYyi!L_RcwR6a0VN7grpGmTYE96MlE z>ArUeQ0QM8?m=>vbJ!4WMwtWd z*8Aw~Y<_pcbh|{2bGY_v#q*V%tP``>Gcbm!tJr}cY)C%w=Yg-tC&Pd~`NV2%D6{5F zH$HOOByC;6ME(BvAqs*uF^FVD=qbDVr_Y`(+db$rMLYLiT-~*8cv`qxbG{XUzjyQf z9Ss11jRfsF2kXQN8!06usmPLcV^0g(lr|)lBt_GV zv}xZYDk>$upS$<{{r7wRnwci<=f1D|x{mWWj`KLlFJbiHZf0v~PU_|Bl1xEIRK0v) z2aIz}Pcw)I^+Fh;P||nMFpB+?5a!U*$cyQ&dSI+5iqt!_IYAn^SSR;DE$EC<%+|dA z23MQ-PdmIbEEo77=8z^mO`i1sya1Z;`GZl_S$k;1^e^w=T%Gh_CoN?f@}*oUXc!hO zM{|;$0LJ@!n)!zhl>WYhUJYFf3$~Y1HkY7k-870{1}F%GJ*SPZ#JJtsSbO<|ghb&F z0Hf{zsLb^7K^O4YZz0E>#HzI^tM?ly6s?-G3Im!xs|?DZTCizt+m`mKTS^3eBi}P& z`}Ui)wNBVewFsbnJ4w=n=Vp%Xtvd(fUy9chwq~2uafGO zQ_8%ZX}&m>02AJ}hNPEKR9_S;;XU0E+|B-AovaN48A*pPZFDyp&30;0ai~@9Y#_Nr0&IyLhIg3N5GV>ig2tV#AE@c*saq zL?wessc*>kQE6rRoHnoag9n3)?+qK>?qVR`xug0yhy|R1_03VtsIm4C4~$ZC1+*S5 z7|CZUqnuv9d`S*1Cc=8T*k8$PKvKbMHn`><;<(~nJ0gDw&G7ULr8}3p!RwCAx1X^> z;|nK+;1V9Y9b+v+-7iNp==D1zrV}&@CzU-hk{ z3+GnYT3i2sG&i_5>R-^iLo7-Og$DHxT9%h(ZNCxXv5a1+5+Eoh$&|f&nE}5qIr+)+ z=do@KKx-ykkot^7Vvfoa^kYb`-2o7xDR$1;(0O-ff0&R{RyNMk@|!@+7j>K1Vr_&N zVrx1S*$Djj3&=u!!<)yZv_~RS!m)lG+qp1E0m_?sGqkCg1-|^sLg08$I>{=#S0PL; z4g-#jI1R!4OZ2zv7hA-yu7GwRtOYd{^GL3yY_OY~8&b=#m9fosu5?53o#EDxP!TdY6}AYnX8WLMlpD1nQjNK|IYP!t*|pz9LHBnZ~=sk1&*v{N9aS z3IjMN>f=X`9ox*x=1yySC^RAH83j;P-O>OMLMSbs`{&U9q^*Cd z{T!1c@mQK5yK7HF4`gI;q2wq}XewNc%MxoGFbRRe>*Q8rU(CcpGOL%D?!ODt_+VVZ z!vr|FIz!f6@z)pFT>TvQz8}v46SKpNb8uP!9|h+pdiS-@Lqty)#|@b4!Ww$TcM@bT z1k=r^Ab?cN=Bk>S#kf0Xomm1}aj;fxSOdM`Gmsn3OM_Y6ZcV#CZCl@h&xN;Xy_el8 z*q(y+U^<}_)EwJYSdS+b%+TN6G$vtJBD{1%9~5gMa@Tx1<_mr&yzS0ZtQQ0#8$yjm ziwYY%yREa)h`sHM#D&U)4eu*TPH@7x5kF%Z#_Wpl=i=u^!N8YPI>lCP`>byyp11czdqi$h;X>kMtChX3eAS)+z|Brz&flTYj#&=TjT&(r| z`}(90cEagz)6-kgM!H=wtx>o}nT*Ojm)82c8IF#Z*?UAHOO4{jj|}dpDi3*BYAzDd z5(}73ND+rir%4%V7lo;wi6Wg-Lu& zZHECAveQV>e{?U;J0KtjFXf8#_u=vQuE^Jzx3e%W?{4@`39TI@wQQU}dYFRz){R+D zNgt8CbGPN|bToJ}b^FDeCkx}HgCl^FJvjPC^~znYu6~Wfgm9It>3xCG@iPdhiaa)w zC&Nso=>NUcp_GtBE%mVCT-ECRjwvTx!4)}8tmP$m6O?v&@^stG+jtO<&Fy{nkC95> zv<+<0uy8Qj>rZKG?JzYl(egV{c5oKqP#ow`-I@z`)?XLSq$;9zn6hH{>YI*(Y)rxZu%S}Ov z(6jJ$bdJ|Z={wO`Nuiws<#j-UOgD7rb{Q3qX#O&~XP{X`-W10woXg^gJK-s)H`z`% zwe5j4hrd$A1eLX!09*CJ#o5W!S1xQzo8S@+QgezkgR@u_YLJd zdt=ofpe|nMt@>_3c!f7P_Dluw$}_kiGIo-Xpd6 zVpn~Niox*VYD!8CElOs35$%MF7*MK|@kU{Rrl98hefGJF%=4=OH1rYC^xw>B>CJIE z4}PdRYAezx9~b4#YYxHX?XC69rwZm%&TyuOM=_84@?~Ad&0$E13CNzup(7A{yLZnZ z6OV2vBO^E{<%=X%xaKyX^u<@~f4R4Ev@8hmyMoE?SzcbBXxD(F)oZ1P1T8`& zq9y3R%nw^JpC^l)oT{RW1!)3eFLgU^9>MI%Wx!=2`jA-MHKTnl@e$+qY4_K6KVDke z`zCjX^alV1x_>3c* z(~aGBBvAdE~&Q=lMU=#w(J9Vm1?e&Yk^fZR<&OC&{FR|+Di=?Ai;fT zTIxtIIR(@JS@H((?SWW$txI9gOG`^3C&R)vSKUR~ES`N%dC(vRyDz{8%X))a!=C2X z|H2jqgx;>Lodi?q?jDK4As@dVV+Mw^pFqFnLCc}h)VFa0@FRuh(K~lglbP@Z*UEq4 zNdtCx>Tz*bea=3Ed|J3@QN{Wns$KTX2taY=lbib-auoIrD3#!>dw-srD_72>NGN@N z7P1gkiDgtzB&)yV87tSr&FwtOBR!`8492O@t2GL|TJmgAI$P4UtuR?s>|{*=(#zL< z#hZ>_4(kUW_q}FUQ8?w5vEhNb815r{uwA`>&->TGjX(*az*2P|l8${dio6hR*O{_6bl%C<=_A(8JplajbH9^4l0P>!~e^le(dT-KL7UpJB4c< zi4lXcB{~^n0;#8uy31L_juQ;OZnxp$v14ttN79(^!z5fAMdG|rRO2t_D6AXXyyV_- zd>0C>S>NIC`wtovL0>RNuK(C}1!9-w3MW__?4@Kkx5C-m16&3xn;IF789kaWBYeJm zVcT-DHg6(GfoLddCOS)E8S4j)0>Bo`?2U~x4u+)BXc50@6H#44gE>Bx%dy>gs<_S= zUkK2nEXNjw93tQEYpMEDy|Xr^;t6vgmEa!q-S-fm!q7LoDD0j%!A9`h>5ssxIsV!l z{23#L4(;2TWjl}&Nd(7;v}q=G%ZG%J!mQX-5oKpqju%m`HB{(xst;l`1CB_cW2pK$ zQC%QuHnIqsX_hB0gdybFx@ftfgk{*SKVMWN*P6BY1^Wftfr`v93ky|v0=%`WI1bj> z^neXOaP+*T@r(jzp~rAu)!n=a=wye+B?}d3edxrnp+n~rzsRD~Q(jDw4i$&OwTCVT zM*49Wk0p3bbDK262(u3fLKiH&Wo4RNG3LhPLdR65g{H7EU=?9?HzWnQ16ys^b{NDt zPVw}-cXs)F8dUEqbw0-yPqUWLtYC1#DVc$P$Rf|4#kebo%L)B0?kw-kaF@~c-=O{h zrSg_mzI$CJ8pwayB!|??-PLzhOf;JkEkty(#rbI-Xi;k{D z)`o=#zAqG7Fj6s(DkqpDe1JDf=0`t{b<5W+Goju}ShljA^B5QgB{^ZVWX+n+cihJt z@JdPlbNO2^Y6ABMk}Ry%WqDIGJu55qnN#`{Ei?N~(uu(wLch;llL(G_(MHIEUu_Tc z0rtVe3kIWjCO$}I>HytA)(_B)2oqyJfYQD=r6f0`c~oHY?km+}K4QW`X zWYA4v7Fh*tR5+VcBAsJ7KV-3nDJYm47%0viDJCGYk850yO{-DV*j7GaQS#7XNqw`6 zidsK>po8Bo)$yA6iHCl1+EeH=mlW}fT(gR^yZ`9;p~hSSi~31rJvXpU#K%u)o&gVp zFt&Nh>gI}or*k809&>{I_^@RDd>XlKy#7p3;qPk}KV#EjTPSDN>xqA3zP;KX!kIMQ z>#lvKdqrkcMdoYm32yFE&!E3?M-H5)ldH8v!tqWE4-6kROqKG{0`38yVtKjZ`N(f5PbWro?l=E16y%UPU?XJ-MlCATK7C}v<7ANXPZf|aX%51(%v_vN=`Y=ehSEpG_E#mlB3bq*re6^(JB}~%b8H-(!-yHC z)*d(R5g~|{O?dSif=aTT&6H74@F=-2SiEeRa5!$uGqBN85C;EU9z4@n2oo6i?o6@*(MIzdxlzRrym?>!Uy2y_RZ-+NE~t%R0Oa?Pp$) zu*~<#&fwHXr&|iA`~Eq8_vzDnYflcIWAUT@(Slh^%NOh}+7g`K(zmFjFuiYXKi_+C zsos7Ye>-$t{G-^#A-DFgygzcB1ik+8Px^bwYbcyd$1R5A-&f5g%BZY;6p|YUwn1R0ma%tZB>#Y^b#Bd9wgqj$sQBh71|V>6f_}t0GEj zi9)HvP!i{@SIwyHfg$^;mQyuzn4aEQ(`&uVZR;aKZHkKcxNTW~R9!`BCX!(&IOu(} zkLb~%LOJEwF_J4vqJCZhk8tf4Ayytl3ljdo?!@@2g zTEC68v&E>Pb4IRfWmjx7Bw?q*+;_WcIpb`$=UPN!sFIG^9(v`L&XJ-b36aoHs78ky zMyyfaLWQuSOYbiXwpjA*Wz-J41BMD2TL}Jy_D?#lSRvrRBbYx()G{^S+BN6M!0tsY z#|Hmqa;B~5(K5m=EQzr~Q&di1&KChfP9cN48b3*ev|~2}5nAk@tgX1kIl#;74%$w= zzOqbQ0G4u&WpS}S4vNwC3?8z|ir%pf0~2I!#L_#ycrXSG5OQ8icM|ymXMkUy*?B3h zFFvk8Qi`=+?W@ipK}~FPtCUW0&u> z7a*0MJ}kxc;+enk5~!)FQjRl-EMjRvZY3IIMP!#3gAP_}=W0f(N+*W#l&S56Ie?%L zO?jz*pW63UbAj}1VjaMSb@5y?x>rux%e5;D_DnrI&FkIn*$TN{l zaYd>--w<@gN_9tjWAov^->M`yTWTzWVBK?bbtHylj=_Adw?F61&p~a}(V548;ztbj zA8+tN2>+T<=%b{i<;VRY_q(ua`6;__<@Sc=!+yu8pwis(1tQ+qxWjS6mde>CjY1H* z>bBV?;I7UMBEK`JFdPija>4fD>)!1C^+OllI&j$QFbV);+(`HN*4Z+naOjExySYaL zG#?%RBjXlT08bv&3j?dc@ZPllDqpPDAaiQE6=xrHMtZ;s@pjYNt3WSp#8Z#{F%Ksh ztNtBiuAUgiS-ih)^J>d_duVHRPxt_G*g&-{p_o(&*kBQa!NByD{NwZRH=*MJ^jEDE z=hD{rBF$a@Z#Y~hN5^{t^OT@=ZT9BP&u~`bj}(IHwl{qFR)qE0S(jqA>*a#KIdot& zUG*+oDGniN=S3Av?mlT$1hNYA8e2{z8Q4>hy6L5szlcw&F_R%=_f8Pic*(0*3k&Bj zr@}49hoK=)7SQ(9#^q86?XSOnyXrh%tooo53_So979alK!dMv<^+aJ-l3TvA^d=IM z&dp9*?Hm>Dq3fFOmG5Qv?}@XOR1kC>DXXhflTR+3|8XLEzy|!om=b7}r;!0DBpc^= zc$$on>o{lqG=_bl|B8vYhp(8dpN3`fp_%k- ze@gXFV=-pgl872#)knl|KVAdQ*&i>T4>4V7m4UH?5XR6IE6haN#>Pv~w<&G3G^f_B zBq8WppxIDeU1E(|RxS<1QB<#U9Qv%Op&@#;r7e*S*F)IZ5}b38jYT3B@7NGO&R_P; z6G^qz`23kEo$dK6H1C;vl1#!EZYC(p3y#1Z#)oFtQm_*12=|ZqUbj{3h6W_0%`u1spXS1d&YrO9 z&~bKRZ1xAcxrM0RHd^xga2y1m{?6;nyXsqHp{pA}3IP^RY!_Qd@_4B8y}Rp_W417C zoR2nR@H8*c|oVxM4fv#@p?{Nq;<(oeC{9M-&=XY#E zBP{&&On5`ae#B_=<~t~gI~saI0#5}ib zPrlQ>S}L@LD5T#q)q)+u`zr8b3-aCdPd#W2H2dTC-_viuW*VfD7CAP>U)!4LUqJ%$ z#tb~|2vvs&Q^%a+{*`q0QDV${_1XNFU`d<-SvnpCf46i}I$8-iQo?QngsXeiGmC;x zGS)#q%}_<=Z2?Zmj;qIgXVKw__YkL3(enbHA|x6lan|Bvy&7-^2{nNyo8IFHV_914 zA4fcB$H)wi@CVV-{A*EpxnI5)Z!Dk1r+qs-)E$y}b14%7%|M|U9&P(gH?S1hl?59u z$zguEmKh!*(YC8@NW}oX$&)i|BFyf8QvD>)tB*Ue*asAsnN(lJ>gi6QHq sc#wT$c;qqK2KHb#9;}4H|NgksR9Y=3??aU2C=s8D<2{^<9sOhe4`JvAZ~y=R literal 0 HcmV?d00001 diff --git a/plugins/Generators_CAS/generators.irp.f b/plugins/Generators_CAS/generators.irp.f index f47341de..10fbfaee 100644 --- a/plugins/Generators_CAS/generators.irp.f +++ b/plugins/Generators_CAS/generators.irp.f @@ -9,14 +9,14 @@ BEGIN_PROVIDER [ integer, N_det_generators ] logical :: good call write_time(output_determinants) N_det_generators = 0 - do i=1,N_det + do i=1,N_det_ref do l=1,n_cas_bitmask good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) ) enddo if (good) then @@ -41,14 +41,14 @@ END_PROVIDER integer :: i, k, l, m logical :: good m=0 - do i=1,N_det + do i=1,N_det_ref do l=1,n_cas_bitmask good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) enddo if (good) then @@ -58,8 +58,8 @@ END_PROVIDER if (good) then m = m+1 do k=1,N_int - psi_det_generators(k,1,m) = psi_det(k,1,i) - psi_det_generators(k,2,m) = psi_det(k,2,i) + psi_det_generators(k,1,m) = psi_ref(k,1,i) + psi_det_generators(k,2,m) = psi_ref(k,2,i) enddo psi_coef_generators(m,:) = psi_coef(m,:) endif diff --git a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES index 801d2f51..3dc21fd0 100644 --- a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS +Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS MRPT_Utils diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 0540eed9..c1a277cf 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -629,6 +629,44 @@ END_PROVIDER call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int) END_PROVIDER + BEGIN_PROVIDER [ double precision, rho_mrpt, (N_det_non_ref, N_states) ] + implicit none + integer :: i, j, k + double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states) + double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states) + do i = 1, N_det_non_ref + do j = 1, N_det_ref + do k = 1, N_States + coef_array(j) = psi_ref_coef(j,k) + enddo + call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j)) + call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e) + print*,delta_e(:) + do k = 1, N_states + delta_e_Array(j,k) = delta_e(k) + enddo + enddo + do k = 1, N_states + do j = 1, N_det_Ref + coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k) + enddo + enddo + do k = 1, N_States + if(dabs(coef_mrpt(k)) .le.1.d-10)then + rho_mrpt(i,k) = 0.d0 + exit + endif + print*,k,psi_non_ref_coef(i,k) , coef_mrpt(k) + if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then + rho_mrpt(i,k) = 1.d0 + else + rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k) + endif + enddo + enddo + + END_PROVIDER + BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ] &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ] @@ -983,6 +1021,9 @@ double precision function get_dij_index(II, i, s, Nint) call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase get_dij_index = get_dij_index + else if(lambda_type == 3) then + call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) + get_dij_index = HIi * rho_mrpt(i, s) end if end function diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES index 7340c609..041b0136 100644 --- a/plugins/MRPT/NEEDED_CHILDREN_MODULES +++ b/plugins/MRPT/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MRPT_Utils Selectors_full Generators_full +MRPT_Utils Selectors_full Psiref_CAS Generators_CAS diff --git a/src/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg similarity index 100% rename from src/MRPT_Utils/EZFIO.cfg rename to plugins/MRPT_Utils/EZFIO.cfg diff --git a/src/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f similarity index 100% rename from src/MRPT_Utils/H_apply.irp.f rename to plugins/MRPT_Utils/H_apply.irp.f diff --git a/src/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES similarity index 100% rename from src/MRPT_Utils/NEEDED_CHILDREN_MODULES rename to plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES diff --git a/src/MRPT_Utils/README.rst b/plugins/MRPT_Utils/README.rst similarity index 100% rename from src/MRPT_Utils/README.rst rename to plugins/MRPT_Utils/README.rst diff --git a/src/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f similarity index 80% rename from src/MRPT_Utils/energies_cas.irp.f rename to plugins/MRPT_Utils/energies_cas.irp.f index 8f29717c..54e1a3f8 100644 --- a/src/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] integer :: i double precision :: energies(N_states) do i = 1, N_states - call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states,i) + call u0_H_dyall_u0(energies,psi_active,psi_ref_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) energy_cas_dyall(i) = energies(i) print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) enddo @@ -15,7 +15,7 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] integer :: i double precision :: energies(N_states) do i = 1, N_states - call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states,i) + call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_ref_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) energy_cas_dyall_no_exchange(i) = energies(i) print*, 'energy_cas_dyall(i)_no_exchange', energy_cas_dyall_no_exchange(i) enddo @@ -31,7 +31,7 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) use bitmasks integer :: iorb @@ -44,7 +44,7 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] spin_exc = ispin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -53,8 +53,8 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] enddo do state_target = 1,N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -72,7 +72,7 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb integer :: state_target @@ -84,7 +84,7 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] spin_exc = ispin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -93,8 +93,8 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] enddo do state_target = 1, N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -113,7 +113,7 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target @@ -130,7 +130,7 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) spin_exc_j = jspin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -139,10 +139,10 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) enddo do state_target = 1 , N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -163,7 +163,7 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target @@ -181,7 +181,7 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) spin_exc_j = jspin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -189,10 +189,10 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) enddo enddo call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -213,7 +213,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target double precision :: energies(n_states) @@ -229,7 +229,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 spin_exc_j = jspin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -238,14 +238,14 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) !if(orb_i == orb_j .and. ispin .ne. jspin)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) !else - ! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + ! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) ! one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) !endif enddo @@ -268,7 +268,7 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb @@ -291,7 +291,7 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a spin_exc_k = kspin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -301,12 +301,12 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -330,7 +330,7 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb @@ -353,7 +353,7 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a spin_exc_k = kspin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -362,12 +362,12 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a enddo do state_target = 1, N_states call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -391,7 +391,7 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb @@ -414,7 +414,7 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 spin_exc_k = kspin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -423,12 +423,12 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -452,7 +452,7 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb @@ -475,7 +475,7 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 spin_exc_k = kspin do i = 1, n_det do j = 1, n_states - psi_in_out_coef(i,j) = psi_coef(i,j) + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -484,12 +484,12 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -515,7 +515,7 @@ END_PROVIDER integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb,i_ok integer :: state_target @@ -543,8 +543,8 @@ END_PROVIDER enddo do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -552,10 +552,10 @@ END_PROVIDER call debug_det(psi_in_out,N_int) print*, 'pb, i_ok ne 0 !!!' endif - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) + coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) psi_in_out_coef(i,j) = coef * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo @@ -571,7 +571,7 @@ END_PROVIDER norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) endif enddo - do i = 1, N_det + do i = 1, N_det_ref do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) @@ -584,8 +584,8 @@ END_PROVIDER do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then -! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) +! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo @@ -616,7 +616,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: jorb,i_ok,aorb,orb_a integer :: state_target @@ -643,8 +643,8 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta do ispin = 1,2 do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_a,ispin,i_ok) if(i_ok.ne.1)then @@ -652,11 +652,11 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_ref_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo endif @@ -671,7 +671,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta endif enddo double precision :: norm_bis(N_states,2) - do i = 1, N_det + do i = 1, N_det_ref do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) @@ -684,7 +684,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo @@ -715,7 +715,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb,i_ok,aorb,orb_a integer :: state_target @@ -742,8 +742,8 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do ispin = 1,2 do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_a,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -751,11 +751,11 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_ref_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo endif @@ -770,7 +770,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State endif enddo double precision :: norm_bis(N_states,2) - do i = 1, N_det + do i = 1, N_det_ref do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) @@ -783,8 +783,8 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then -! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states,state_target) +! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo @@ -812,38 +812,38 @@ END_PROVIDER subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,N_states) + double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,N_states) double precision , intent(out) :: e_corr_from_1h1p_singles(N_states) integer :: i,vorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states),diag_elem(N_det),interact_psi0(N_det) + double precision :: norm_out(N_states),diag_elem(N_det_ref),interact_psi0(N_det_ref) double precision :: delta_e_inact_virt(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) double precision, allocatable :: delta_e_det(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states),H_matrix(N_det+1,N_det+1)) - allocate (eigenvectors(size(H_matrix,1),N_det+1)) - allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det)) - allocate (delta_e_det(N_det,N_det)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det_ref+1,N_det_ref+1)) + allocate (eigenvectors(size(H_matrix,1),N_det_ref+1)) + allocate (eigenvalues(N_det_ref+1),interact_cas(N_det_ref,N_det_ref)) + allocate (delta_e_det(N_det_ref,N_det_ref)) integer :: iorb,jorb,i_ok integer :: state_target double precision :: energies(n_states) double precision :: hij double precision :: energies_alpha_beta(N_states,2) - double precision :: lamda_pt2(N_det) + double precision :: lamda_pt2(N_det_ref) double precision :: accu(N_states),norm - double precision :: amplitudes_alpha_beta(N_det,2) - double precision :: delta_e_alpha_beta(N_det,2) + double precision :: amplitudes_alpha_beta(N_det_ref,2) + double precision :: delta_e_alpha_beta(N_det_ref,2) double precision :: coef_array(N_states) - double precision :: coef_perturb(N_det) - double precision :: coef_perturb_bis(N_det) + double precision :: coef_perturb(N_det_ref) + double precision :: coef_perturb_bis(N_det_ref) do vorb = 1,n_virt_orb orb_v = list_virt(vorb) @@ -856,8 +856,8 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from do ispin = 1,2 do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -866,11 +866,11 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from print*, 'pb, i_ok ne 0 !!!' endif interact_psi0(i) = 0.d0 - do j = 1 , N_det - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) - call get_delta_e_dyall(psi_det(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) + do j = 1 , N_det_ref + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,j),N_int,hij) + call get_delta_e_dyall(psi_ref(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) interact_cas(i,j) = hij - interact_psi0(i) += hij * psi_coef(j,1) + interact_psi0(i) += hij * psi_ref_coef(j,1) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -882,27 +882,27 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from do state_target = 1, N_states ! Building the Hamiltonian matrix H_matrix(1,1) = energy_cas_dyall(state_target) - do i = 1, N_det + do i = 1, N_det_ref ! interaction with psi0 - H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) - H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) + H_matrix(1,i+1) = interact_psi0(i)!* psi_ref_coef(i,state_target) + H_matrix(i+1,1) = interact_psi0(i)!* psi_ref_coef(i,state_target) ! diagonal elements H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) ! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) - do j = i+1, N_det + do j = i+1, N_det_ref call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) H_matrix(i+1,j+1) = hij !0.d0 ! H_matrix(j+1,i+1) = hij !0.d0 ! enddo enddo - call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) + call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det_ref+1) e_corr_from_1h1p_singles(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) - do i = 1, N_det + do i = 1, N_det_ref psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) coef_perturb(i) = 0.d0 - do j = 1, N_det - coef_perturb(i) += psi_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) + do j = 1, N_det_ref + coef_perturb(i) += psi_ref_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) enddo coef_perturb_bis(i) = interact_psi0(i) / (eigenvalues(1) - H_matrix(i+1,i+1)) if(dabs(interact_psi0(i)) .gt. 1.d-12)then @@ -913,22 +913,22 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from enddo if(dabs(eigenvalues(1) - energy_cas_dyall(state_target)).gt.1.d-10)then print*, '' - do i = 1, N_det+1 + do i = 1, N_det_ref+1 write(*,'(100(F16.10))') H_matrix(i,:) enddo accu = 0.d0 - do i = 1, N_det + do i = 1, N_det_ref accu(state_target) += psi_in_out_coef(i,state_target) * interact_psi0(i) enddo print*, '' print*, 'e corr diagonal ',accu(state_target) accu = 0.d0 - do i = 1, N_det + do i = 1, N_det_ref accu(state_target) += coef_perturb(i) * interact_psi0(i) enddo print*, 'e corr perturb ',accu(state_target) accu = 0.d0 - do i = 1, N_det + do i = 1, N_det_ref accu(state_target) += coef_perturb_bis(i) * interact_psi0(i) enddo print*, 'e corr perturb EN',accu(state_target) @@ -941,10 +941,10 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from write(*,'(100(F16.10,X))')coef_perturb_bis(:) endif integer :: k - do k = 1, N_det - do i = 1, N_det + do k = 1, N_det_ref + do i = 1, N_det_ref matrix_1h1p(i,i,state_target) += interact_cas(k,i) * interact_cas(k,i) * lamda_pt2(k) - do j = i+1, N_det + do j = i+1, N_det_ref matrix_1h1p(i,j,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) matrix_1h1p(j,i,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) enddo diff --git a/src/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f similarity index 100% rename from src/MRPT_Utils/excitations_cas.irp.f rename to plugins/MRPT_Utils/excitations_cas.irp.f diff --git a/plugins/MRPT_Utils/ezfio_interface.irp.f b/plugins/MRPT_Utils/ezfio_interface.irp.f new file mode 100644 index 00000000..ebe0bf52 --- /dev/null +++ b/plugins/MRPT_Utils/ezfio_interface.irp.f @@ -0,0 +1,42 @@ +! DO NOT MODIFY BY HAND +! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py +! from file /home/giner/qp_bis/quantum_package/src/MRPT_Utils/EZFIO.cfg + + +BEGIN_PROVIDER [ logical, do_third_order_1h1p ] + implicit none + BEGIN_DOC +! If true, compute the third order contribution for the 1h1p + END_DOC + + logical :: has + PROVIDE ezfio_filename + + call ezfio_has_mrpt_utils_do_third_order_1h1p(has) + if (has) then + call ezfio_get_mrpt_utils_do_third_order_1h1p(do_third_order_1h1p) + else + print *, 'mrpt_utils/do_third_order_1h1p not found in EZFIO file' + stop 1 + endif + +END_PROVIDER + +BEGIN_PROVIDER [ logical, pure_state_specific_mrpt2 ] + implicit none + BEGIN_DOC +! If true, diagonalize the dressed matrix for each state and do a state following of the initial states + END_DOC + + logical :: has + PROVIDE ezfio_filename + + call ezfio_has_mrpt_utils_pure_state_specific_mrpt2(has) + if (has) then + call ezfio_get_mrpt_utils_pure_state_specific_mrpt2(pure_state_specific_mrpt2) + else + print *, 'mrpt_utils/pure_state_specific_mrpt2 not found in EZFIO file' + stop 1 + endif + +END_PROVIDER diff --git a/src/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f similarity index 100% rename from src/MRPT_Utils/fock_like_operators.irp.f rename to plugins/MRPT_Utils/fock_like_operators.irp.f diff --git a/src/MRPT_Utils/give_2h2p.irp.f b/plugins/MRPT_Utils/give_2h2p.irp.f similarity index 100% rename from src/MRPT_Utils/give_2h2p.irp.f rename to plugins/MRPT_Utils/give_2h2p.irp.f diff --git a/src/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f similarity index 78% rename from src/MRPT_Utils/mrpt_dress.irp.f rename to plugins/MRPT_Utils/mrpt_dress.irp.f index 60bb2b69..f5e7bd40 100644 --- a/src/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -44,15 +44,15 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip integer :: N_miniList, leng double precision :: delta_e(N_states),hij_tmp integer :: index_i,index_j - double precision :: phase_array(N_det),phase + double precision :: phase_array(N_det_ref),phase integer :: exc(0:2,2,2),degree - leng = max(N_det_generators, N_det) + leng = max(N_det_ref, N_det_ref) allocate(miniList(Nint, 2, leng), idx_miniList(leng)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) - call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) + call create_minilist_find_previous(key_mask, psi_ref, miniList, i_generator-1, N_miniList, fullMatch, Nint) if(fullMatch) then return @@ -62,7 +62,7 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) if(N_tq > 0) then - call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint) + call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det_ref, N_minilist, Nint) end if @@ -79,18 +79,18 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip phase_array =0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) - call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) + call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha) double precision :: coef_array(N_states) do i_state = 1, N_states - coef_array(i_state) = psi_coef(index_i,i_state) + coef_array(i_state) = psi_ref_coef(index_i,i_state) enddo if(dabs(hialpha).le.1.d-10)then delta_e = 1.d+20 else - call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) + call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) endif hij_array(index_i) = hialpha - call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) + call get_excitation(psi_ref(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) ! phase_array(index_i) = phase do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) @@ -103,12 +103,12 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call omp_set_lock( psi_ref_bis_lock(index_i) ) do j = 1, idx_alpha(0) index_j = idx_alpha(j) -! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int) +! call get_excitation(psi_ref(1,1,index_i),psi_ref(1,1,index_i),exc,degree,phase,N_int) ! if(index_j.ne.index_i)then ! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then ! print*, phase_array(index_j) , phase_array(index_i) ,phase -! call debug_det(psi_det(1,1,index_i),N_int) -! call debug_det(psi_det(1,1,index_j),N_int) +! call debug_det(psi_ref(1,1,index_i),N_int) +! call debug_det(psi_ref(1,1,index_j),N_int) ! call debug_det(tq(1,1,i_alpha),N_int) ! stop ! endif @@ -126,14 +126,14 @@ end - BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ] - gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators) - gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators) - call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int) - call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int) + BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_ref,2) ] +&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_ref,2) ] +&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_ref,2) ] +&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_ref,2) ] + gen_det_sorted(:,:,:,1) = psi_ref(:,:,:N_det_ref) + gen_det_sorted(:,:,:,2) = psi_ref(:,:,:N_det_ref) + call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_ref, N_int) + call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_ref, N_int) END_PROVIDER @@ -159,7 +159,7 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N logical, external :: is_connected_to - integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) + integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_ref) integer,intent(in) :: N_miniList @@ -172,7 +172,7 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N cycle end if - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det_ref)) then N_tq += 1 do k=1,N_int tq(k,1,N_tq) = det_buffer(k,1,i) diff --git a/src/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f similarity index 72% rename from src/MRPT_Utils/mrpt_utils.irp.f rename to plugins/MRPT_Utils/mrpt_utils.irp.f index 8ac8e3e0..31013bb7 100644 --- a/src/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -1,5 +1,5 @@ - BEGIN_PROVIDER [ double precision, delta_ij, (N_det,N_det,N_states) ] + BEGIN_PROVIDER [ double precision, delta_ij, (N_det_ref,N_det_ref,N_states) ] &BEGIN_PROVIDER [ double precision, second_order_pt_new, (N_states) ] &BEGIN_PROVIDER [ double precision, second_order_pt_new_1h, (N_states) ] &BEGIN_PROVIDER [ double precision, second_order_pt_new_1p, (N_states) ] @@ -11,7 +11,7 @@ &BEGIN_PROVIDER [ double precision, second_order_pt_new_2h2p, (N_states) ] implicit none BEGIN_DOC - ! Dressing matrix in N_det basis + ! Dressing matrix in N_det_ref basis END_DOC integer :: i,j,m integer :: i_state @@ -21,17 +21,17 @@ delta_ij = 0.d0 - allocate (delta_ij_tmp(N_det,N_det,N_states)) + allocate (delta_ij_tmp(N_det_ref,N_det_ref,N_states)) ! 1h delta_ij_tmp = 0.d0 - call H_apply_mrpt_1h(delta_ij_tmp,N_det) + call H_apply_mrpt_1h(delta_ij_tmp,N_det_ref) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -41,12 +41,12 @@ ! 1p delta_ij_tmp = 0.d0 - call H_apply_mrpt_1p(delta_ij_tmp,N_det) + call H_apply_mrpt_1p(delta_ij_tmp,N_det_ref) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -56,15 +56,15 @@ ! 1h1p delta_ij_tmp = 0.d0 - call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) + call H_apply_mrpt_1h1p(delta_ij_tmp,N_det_ref) double precision :: e_corr_from_1h1p_singles(N_states) !call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) !call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -78,9 +78,9 @@ call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -91,12 +91,12 @@ ! 2h delta_ij_tmp = 0.d0 - call H_apply_mrpt_2h(delta_ij_tmp,N_det) + call H_apply_mrpt_2h(delta_ij_tmp,N_det_ref) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -106,12 +106,12 @@ ! 2p delta_ij_tmp = 0.d0 - call H_apply_mrpt_2p(delta_ij_tmp,N_det) + call H_apply_mrpt_2p(delta_ij_tmp,N_det_ref) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -122,12 +122,12 @@ ! 1h2p delta_ij_tmp = 0.d0 call give_1h2p_contrib(delta_ij_tmp) -!!!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) +!!!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det_ref) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -138,12 +138,12 @@ ! 2h1p delta_ij_tmp = 0.d0 call give_2h1p_contrib(delta_ij_tmp) -!!!! call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) + !!!!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det_ref) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -153,12 +153,12 @@ ! 2h2p delta_ij_tmp = 0.d0 -!!!!!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) +!!!!!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det_ref) accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo @@ -169,7 +169,7 @@ double precision :: contrib_2h2p(N_states) call give_2h2p(contrib_2h2p) do i_state = 1, N_states - do i = 1, N_det + do i = 1, N_det_ref delta_ij(i,i,i_state) += contrib_2h2p(i_state) enddo second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) @@ -180,10 +180,10 @@ ! total accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det + do i = 1, N_det_ref ! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) - do j = i_state, N_det - accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + do j = i_state, N_det_ref + accu(i_state) += delta_ij(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) enddo enddo second_order_pt_new(i_state) = accu(i_state) @@ -195,13 +195,15 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new, (N_det,N_det,N_states)] + BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new, (N_det_ref,N_det_ref,N_states)] implicit none integer :: i,j,i_state + double precision :: hij do i_state = 1, N_states - do i = 1,N_det - do j = 1,N_det - Hmatrix_dressed_pt2_new(j,i,i_state) = H_matrix_all_dets(j,i) + delta_ij(j,i,i_state) + do i = 1,N_det_ref + do j = 1,N_det_ref + call i_h_j(psi_ref(1,1,j),psi_ref(1,1,i),N_int,hij) + Hmatrix_dressed_pt2_new(j,i,i_state) = hij + delta_ij(j,i,i_state) enddo enddo enddo @@ -209,13 +211,15 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new_symmetrized, (N_det,N_det,N_states)] + BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new_symmetrized, (N_det_ref,N_det_ref,N_states)] implicit none integer :: i,j,i_state + double precision :: hij do i_state = 1, N_states - do i = 1,N_det - do j = i,N_det - Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = H_matrix_all_dets(j,i) & + do i = 1,N_det_ref + do j = i,N_det_ref + call i_h_j(psi_ref(1,1,j),psi_ref(1,1,i),N_int,hij) + Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = hij & + 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) ) Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) enddo @@ -224,7 +228,7 @@ END_PROVIDER END_PROVIDER BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ] - &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ] + &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det_ref,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ] BEGIN_DOC ! Eigenvectors/values of the CI matrix @@ -243,18 +247,18 @@ END_PROVIDER double precision, allocatable :: s2_eigvalues(:) double precision, allocatable :: e_array(:) integer, allocatable :: iorder(:) - double precision :: overlap(N_det) + double precision :: overlap(N_det_ref) double precision, allocatable :: psi_tmp(:) ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors - do j=1,min(N_states,N_det) - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j) + do j=1,min(N_states,N_det_ref) + do i=1,N_det_ref + CI_dressed_pt2_new_eigenvectors(i,j) = psi_ref_coef(i,j) enddo enddo - do j=min(N_states,N_det)+1,N_states_diag - do i=1,N_det + do j=min(N_states,N_det_ref)+1,N_states_diag + do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0 enddo enddo @@ -265,33 +269,33 @@ END_PROVIDER stop else if (diag_algorithm == "Lapack") then - allocate (eigenvectors(N_det,N_det)) - allocate (eigenvalues(N_det)) + allocate (eigenvectors(N_det_ref,N_det_ref)) + allocate (eigenvalues(N_det_ref)) if(pure_state_specific_mrpt2)then - allocate (hmatrix_tmp(N_det,N_det)) - allocate (iorder(N_det)) - allocate (psi_tmp(N_det)) + allocate (hmatrix_tmp(N_det_ref,N_det_ref)) + allocate (iorder(N_det_ref)) + allocate (psi_tmp(N_det_ref)) print*,'' print*,'***************************' do i_state = 1, N_states !! Big loop over states print*,'' print*,'Diagonalizing with the dressing for state',i_state - do i = 1, N_det - do j = 1, N_det + do i = 1, N_det_ref + do j = 1, N_det_ref hmatrix_tmp(j,i) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) enddo enddo call lapack_diag(eigenvalues,eigenvectors, & - Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det) + Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det_ref,N_det_ref) write(*,'(A86)')'Looking for the most overlapping state within all eigenvectors of the dressed matrix' print*,'' print*,'Calculating the overlap for ...' - do i = 1, N_det + do i = 1, N_det_ref overlap(i) = 0.d0 iorder(i) = i print*,'eigenvector',i - do j = 1, N_det - overlap(i)+= psi_coef(j,i_state) * eigenvectors(j,i) + do j = 1, N_det_ref + overlap(i)+= psi_ref_coef(j,i_state) * eigenvectors(j,i) enddo overlap(i) = -dabs(overlap(i)) print*,'energy = ',eigenvalues(i) + nuclear_repulsion @@ -305,26 +309,26 @@ END_PROVIDER print*,'with the overlap of ',dabs(overlap(1)) print*,'and an energy of ',eigenvalues(iorder(1)) + nuclear_repulsion print*,'Calculating the S^2 value ...' - do i=1,N_det + do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,i_state) = eigenvectors(i,iorder(1)) psi_tmp(i) = eigenvectors(i,iorder(1)) enddo CI_electronic_dressed_pt2_new_energy(i_state) = eigenvalues(iorder(1)) - call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2(i_state),psi_tmp,N_det,psi_det,N_int,1,N_det) + call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2(i_state),psi_tmp,N_det_ref,psi_det,N_int,1,N_det_ref) print*,'S^2 = ', CI_dressed_pt2_new_eigenvectors_s2(i_state) enddo else call lapack_diag(eigenvalues,eigenvectors, & - Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det) + Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det_ref,N_det_ref) CI_electronic_dressed_pt2_new_energy(:) = 0.d0 if (s2_eig) then i_state = 0 - allocate (s2_eigvalues(N_det)) - allocate(index_good_state_array(N_det),good_state_array(N_det)) + allocate (s2_eigvalues(N_det_ref)) + allocate(index_good_state_array(N_det_ref),good_state_array(N_det_ref)) good_state_array = .False. - call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& - N_det,size(eigenvectors,1)) - do j=1,N_det + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det_ref,psi_det,N_int,& + N_det_ref,size(eigenvectors,1)) + do j=1,N_det_ref ! Select at least n_states states with S^2 values closed to "expected_s2" print*, eigenvalues(j)+nuclear_repulsion, s2_eigvalues(j) if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then @@ -339,20 +343,20 @@ END_PROVIDER if (i_state /= 0) then ! Fill the first "i_state" states that have a correct S^2 value do j = 1, i_state - do i=1,N_det + do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) enddo CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j)) CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) enddo i_other_state = 0 - do j = 1, N_det + do j = 1, N_det_ref if(good_state_array(j))cycle i_other_state +=1 if(i_state+i_other_state.gt.n_states)then exit endif - do i=1,N_det + do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) enddo CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j) @@ -362,15 +366,15 @@ END_PROVIDER else print*,'' print*,'!!!!!!!! WARNING !!!!!!!!!' - print*,' Within the ',N_det,'determinants selected' + print*,' Within the ',N_det_ref,'determinants selected' print*,' and the ',N_states_diag,'states requested' print*,' We did not find any state with S^2 values close to ',expected_s2 print*,' We will then set the first N_states eigenvectors of the H matrix' print*,' as the CI_dressed_pt2_new_eigenvectors' print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' print*,'' - do j=1,min(N_states_diag,N_det) - do i=1,N_det + do j=1,min(N_states_diag,N_det_ref) + do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) @@ -380,11 +384,11 @@ END_PROVIDER deallocate(index_good_state_array,good_state_array) deallocate(s2_eigvalues) else - call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& - min(N_det,N_states_diag),size(eigenvectors,1)) + call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det_ref,psi_det,N_int,& + min(N_det_ref,N_states_diag),size(eigenvectors,1)) ! Select the "N_states_diag" states of lowest energy - do j=1,min(N_det,N_states) - do i=1,N_det + do j=1,min(N_det_ref,N_states) + do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) diff --git a/src/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f similarity index 98% rename from src/MRPT_Utils/new_way.irp.f rename to plugins/MRPT_Utils/new_way.irp.f index 3624b7d3..a4bbe93a 100644 --- a/src/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -38,8 +38,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,3) @@ -232,8 +232,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,3) @@ -413,8 +413,8 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer :: kspin,degree_scalar @@ -572,8 +572,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) integer :: accu_elec double precision :: get_mo_bielec_integral double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) integer :: istate double precision :: hja,delta_e_act_virt(N_states) integer :: kspin,degree_scalar @@ -715,8 +715,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2) diff --git a/src/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f similarity index 99% rename from src/MRPT_Utils/new_way_second_order_coef.irp.f rename to plugins/MRPT_Utils/new_way_second_order_coef.irp.f index 4c12dbe1..676e14e9 100644 --- a/src/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -44,8 +44,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) perturb_dets_phase(a,2,1) = -1000.d0 enddo - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate @@ -379,8 +379,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,6) diff --git a/src/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f similarity index 100% rename from src/MRPT_Utils/psi_active_prov.irp.f rename to plugins/MRPT_Utils/psi_active_prov.irp.f diff --git a/src/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f similarity index 99% rename from src/MRPT_Utils/second_order_new.irp.f rename to plugins/MRPT_Utils/second_order_new.irp.f index ba3b421b..2a61eece 100644 --- a/src/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -22,8 +22,8 @@ subroutine give_1h2p_new(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) double precision :: delta_e_inv(n_act_orb,2,N_states) double precision :: delta_e_inactive_virt(N_states) @@ -502,8 +502,8 @@ subroutine give_2h1p_new(matrix_2h1p) double precision :: delta_e_inv(n_act_orb,2,N_states) double precision :: fock_operator_local(n_act_orb,n_act_orb,2) double precision :: delta_e_inactive_virt(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,3) diff --git a/src/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f similarity index 99% rename from src/MRPT_Utils/second_order_new_2p.irp.f rename to plugins/MRPT_Utils/second_order_new_2p.irp.f index 11ae18da..d086b6c5 100644 --- a/src/MRPT_Utils/second_order_new_2p.irp.f +++ b/plugins/MRPT_Utils/second_order_new_2p.irp.f @@ -21,8 +21,8 @@ subroutine give_2p_new(matrix_2p) double precision :: active_int(n_act_orb,n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) double precision :: delta_e_inv(n_act_orb,n_act_orb,2,2,N_states) double precision :: delta_e_inactive_virt(N_states) diff --git a/src/MRPT_Utils/utils_bitmask.irp.f b/plugins/MRPT_Utils/utils_bitmask.irp.f similarity index 100% rename from src/MRPT_Utils/utils_bitmask.irp.f rename to plugins/MRPT_Utils/utils_bitmask.irp.f diff --git a/plugins/mrcepa0/NEEDED_CHILDREN_MODULES b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES index 8b6c5a18..fe8255d1 100644 --- a/plugins/mrcepa0/NEEDED_CHILDREN_MODULES +++ b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ +Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index c7714e8a..5dd1e4f3 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -343,7 +343,7 @@ class H_apply(object): """ self.data["size_max"] = "8192" self.data["initialization"] = """ - PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit +! PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit """ if self.do_double_exc == True: self.data["keys_work"] = """ @@ -370,7 +370,7 @@ class H_apply(object): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) - PROVIDE N_det_generators +! PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 @@ -478,7 +478,7 @@ class H_apply_zmq(H_apply): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) - PROVIDE N_det_generators +! PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 diff --git a/src/Determinants/H_apply_nozmq.template.f b/src/Determinants/H_apply_nozmq.template.f index 0c319fe3..5550d9d1 100644 --- a/src/Determinants/H_apply_nozmq.template.f +++ b/src/Determinants/H_apply_nozmq.template.f @@ -17,7 +17,7 @@ subroutine $subroutine($params_main) double precision, allocatable :: fock_diag_tmp(:,:) $initialization - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map !psi_det_generators psi_coef_generators nmax = mod( N_det_generators,nproc ) diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index 59544b79..3e4c1867 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -20,7 +20,7 @@ subroutine $subroutine($params_main) double precision, allocatable :: fock_diag_tmp(:,:) $initialization - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators +! PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators integer(ZMQ_PTR), external :: new_zmq_pair_socket integer(ZMQ_PTR) :: zmq_socket_pair From 38ccfc0cf1aabfa504049da09d51cbe6623ad56f Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 28 Nov 2016 14:51:12 +0100 Subject: [PATCH 69/76] Trying do really fo sin free multiple excitations --- plugins/Full_CI/H_apply.irp.f | 5 - plugins/MRCC_Utils/mrcc_utils.irp.f | 9 +- plugins/MRPT/print_1h2p.irp.f | 46 +-- plugins/MRPT_Utils/energies_cas.irp.f | 82 +++--- plugins/MRPT_Utils/mrpt_dress.irp.f | 21 +- plugins/MRPT_Utils/mrpt_utils.irp.f | 267 +++++++++--------- plugins/MRPT_Utils/psi_active_prov.irp.f | 44 ++- .../pt2_new.irp.f | 0 plugins/Perturbation/NEEDED_CHILDREN_MODULES | 2 +- plugins/Perturbation/pt2_equations.irp.f | 30 -- 10 files changed, 235 insertions(+), 271 deletions(-) rename plugins/{Perturbation => MRPT_Utils}/pt2_new.irp.f (100%) diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index 79599065..8977b7fd 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -12,11 +12,6 @@ s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s -s = H_apply("FCI_PT2_new") -s.set_perturbation("decontracted") -s.unset_openmp() -print s - s = H_apply("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index c1a277cf..92425eb0 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -635,34 +635,37 @@ END_PROVIDER double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states) double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states) do i = 1, N_det_non_ref + print*,'i',i do j = 1, N_det_ref do k = 1, N_States - coef_array(j) = psi_ref_coef(j,k) + coef_array(k) = psi_ref_coef(j,k) enddo call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j)) call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e) - print*,delta_e(:) +! write(*,'(A7,x,100(F16.10,x))')'delta_e',delta_e(:) do k = 1, N_states delta_e_Array(j,k) = delta_e(k) enddo enddo + coef_mrpt = 0.d0 do k = 1, N_states do j = 1, N_det_Ref coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k) enddo enddo + write(*,'(A7,X,100(F16.10,x))')'coef ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2) do k = 1, N_States if(dabs(coef_mrpt(k)) .le.1.d-10)then rho_mrpt(i,k) = 0.d0 exit endif - print*,k,psi_non_ref_coef(i,k) , coef_mrpt(k) if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then rho_mrpt(i,k) = 1.d0 else rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k) endif enddo + print*,'rho',rho_mrpt(i,:) enddo END_PROVIDER diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f index 747e2817..a3500e49 100644 --- a/plugins/MRPT/print_1h2p.irp.f +++ b/plugins/MRPT/print_1h2p.irp.f @@ -2,7 +2,7 @@ program print_1h2p implicit none read_wf = .True. touch read_wf - call routine_2 + call routine end subroutine routine_2 @@ -20,44 +20,20 @@ end subroutine routine implicit none double precision,allocatable :: matrix_1h2p(:,:,:) - allocate (matrix_1h2p(N_det,N_det,N_states)) + double precision :: accu(2) + allocate (matrix_1h2p(N_det_ref,N_det_ref,N_states)) integer :: i,j,istate - do i = 1, N_det - do j = 1, N_det - do istate = 1, N_states - matrix_1h2p(i,j,istate) = 0.d0 + accu = 0.d0 + matrix_1h2p = 0.d0 + call H_apply_mrpt_2p(matrix_1h2p,N_det_ref) + do istate = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(istate) += matrix_1h2p(i,j,istate) * psi_coef(i,istate) * psi_coef(j,istate) enddo enddo + print*,accu(istate) enddo - if(.False.)then - call give_1h2p_contrib(matrix_1h2p) - double precision :: accu - accu = 0.d0 - do i = 1, N_det - do j = 1, N_det - accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) - enddo - enddo - print*, 'second order ', accu - endif - - if(.True.)then - do i = 1, N_det - do j = 1, N_det - do istate = 1, N_states - matrix_1h2p(i,j,istate) = 0.d0 - enddo - enddo - enddo - call give_1h2p_new(matrix_1h2p) - accu = 0.d0 - do i = 1, N_det - do j = 1, N_det - accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) - enddo - enddo - endif - print*, 'third order ', accu deallocate (matrix_1h2p) end diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index 54e1a3f8..33baeb6a 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -31,7 +31,7 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) use bitmasks integer :: iorb @@ -42,7 +42,7 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] orb = list_act(iorb) hole_particle = 1 spin_exc = ispin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -54,8 +54,8 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] do state_target = 1,N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + one_creat(iorb,ispin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -72,7 +72,7 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb integer :: state_target @@ -82,7 +82,7 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] orb = list_act(iorb) hole_particle = -1 spin_exc = ispin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -94,8 +94,8 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] do state_target = 1, N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + one_anhil(iorb,ispin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -113,7 +113,7 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target @@ -128,7 +128,7 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = 1 spin_exc_j = jspin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -142,8 +142,8 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -163,7 +163,7 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target @@ -179,7 +179,7 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -192,8 +192,8 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -213,7 +213,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target double precision :: energies(n_states) @@ -227,7 +227,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -289,7 +289,7 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -306,8 +306,8 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -330,7 +330,7 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb @@ -351,7 +351,7 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -367,8 +367,8 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -391,7 +391,7 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb @@ -412,7 +412,7 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = 1 spin_exc_k = kspin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -428,8 +428,8 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -452,7 +452,7 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb @@ -473,7 +473,7 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det + do i = 1, n_det_ref do j = 1, n_states psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo @@ -489,8 +489,8 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -515,7 +515,7 @@ END_PROVIDER integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb,i_ok integer :: state_target @@ -541,7 +541,7 @@ END_PROVIDER do state_target =1 , N_states one_anhil_one_creat_inact_virt_norm(iorb,vorb,state_target,ispin) = 0.d0 enddo - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int psi_in_out(j,1,i) = psi_ref(j,1,i) psi_in_out(j,2,i) = psi_ref(j,2,i) @@ -616,7 +616,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: jorb,i_ok,aorb,orb_a integer :: state_target @@ -641,7 +641,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int psi_in_out(j,1,i) = psi_ref(j,1,i) psi_in_out(j,2,i) = psi_ref(j,2,i) @@ -715,7 +715,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb,i_ok,aorb,orb_a integer :: state_target @@ -740,7 +740,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int psi_in_out(j,1,i) = psi_ref(j,1,i) psi_in_out(j,2,i) = psi_ref(j,2,i) @@ -825,7 +825,7 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) double precision, allocatable :: delta_e_det(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det_ref+1,N_det_ref+1)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det_ref+1,N_det_ref+1)) allocate (eigenvectors(size(H_matrix,1),N_det_ref+1)) allocate (eigenvalues(N_det_ref+1),interact_cas(N_det_ref,N_det_ref)) allocate (delta_e_det(N_det_ref,N_det_ref)) @@ -854,7 +854,7 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from - fock_virt_total_spin_trace(orb_v,j) enddo do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int psi_in_out(j,1,i) = psi_ref(j,1,i) psi_in_out(j,2,i) = psi_ref(j,2,i) diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index f5e7bd40..eccdae0a 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -84,14 +84,21 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip do i_state = 1, N_states coef_array(i_state) = psi_ref_coef(index_i,i_state) enddo - if(dabs(hialpha).le.1.d-10)then + integer :: degree_scalar + + call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int) + if(dabs(hialpha).le.1.d-20)then delta_e = 1.d+20 else call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) endif + if(degree .ne. 2)then + do i_state = 1, N_states + delta_e(i_state) = 1.d+20 + enddo + endif hij_array(index_i) = hialpha call get_excitation(psi_ref(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) -! phase_array(index_i) = phase do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) enddo @@ -103,16 +110,6 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call omp_set_lock( psi_ref_bis_lock(index_i) ) do j = 1, idx_alpha(0) index_j = idx_alpha(j) -! call get_excitation(psi_ref(1,1,index_i),psi_ref(1,1,index_i),exc,degree,phase,N_int) -! if(index_j.ne.index_i)then -! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then -! print*, phase_array(index_j) , phase_array(index_i) ,phase -! call debug_det(psi_ref(1,1,index_i),N_int) -! call debug_det(psi_ref(1,1,index_j),N_int) -! call debug_det(tq(1,1,i_alpha),N_int) -! stop -! endif -! endif do i_state=1,N_states ! standard dressing first order delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 31013bb7..cb007199 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -39,155 +39,141 @@ enddo print*, '1h = ',accu - ! 1p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1p(i_state) = accu(i_state) - enddo - print*, '1p = ',accu +!! 1p +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_1p(delta_ij_tmp,N_det_ref) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det_ref +! do j = 1, N_det_ref +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +!enddo +!second_order_pt_new_1p(i_state) = accu(i_state) +!enddo +!print*, '1p = ',accu - ! 1h1p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1h1p(delta_ij_tmp,N_det_ref) - double precision :: e_corr_from_1h1p_singles(N_states) -!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) -!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p = ',accu +!! 1h1p +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_1h1p(delta_ij_tmp,N_det_ref) +!double precision :: e_corr_from_1h1p_singles(N_states) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det_ref +! do j = 1, N_det_ref +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +!enddo +!second_order_pt_new_1h1p(i_state) = accu(i_state) +!enddo +!print*, '1h1p = ',accu - ! 1h1p third order - if(do_third_order_1h1p)then - delta_ij_tmp = 0.d0 - call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p(3)',accu - endif +!! 1h1p third order +!if(do_third_order_1h1p)then +! delta_ij_tmp = 0.d0 +! call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) +! accu = 0.d0 +! do i_state = 1, N_states +! do i = 1, N_det_ref +! do j = 1, N_det_ref +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +! enddo +! second_order_pt_new_1h1p(i_state) = accu(i_state) +! enddo +! print*, '1h1p(3)',accu +!endif - ! 2h - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2h(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h(i_state) = accu(i_state) - enddo - print*, '2h = ',accu +!! 2h +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_2h(delta_ij_tmp,N_det_ref) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det_ref +! do j = 1, N_det_ref +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +!enddo +!second_order_pt_new_2h(i_state) = accu(i_state) +!enddo +!print*, '2h = ',accu - ! 2p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2p(i_state) = accu(i_state) - enddo - print*, '2p = ',accu +!! 2p +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_2p(delta_ij_tmp,N_det_ref) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det_ref +! do j = 1, N_det_ref +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +!enddo +!second_order_pt_new_2p(i_state) = accu(i_state) +!enddo +!print*, '2p = ',accu - ! 1h2p - delta_ij_tmp = 0.d0 - call give_1h2p_contrib(delta_ij_tmp) +!! 1h2p +!delta_ij_tmp = 0.d0 +!call give_1h2p_contrib(delta_ij_tmp) !!!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h2p(i_state) = accu(i_state) - enddo - print*, '1h2p = ',accu +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det_ref +! do j = 1, N_det_ref +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +!enddo +!second_order_pt_new_1h2p(i_state) = accu(i_state) +!enddo +!print*, '1h2p = ',accu - ! 2h1p - delta_ij_tmp = 0.d0 - call give_2h1p_contrib(delta_ij_tmp) - !!!!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h1p(i_state) = accu(i_state) - enddo - print*, '2h1p = ',accu +!! 2h1p +!delta_ij_tmp = 0.d0 +!call give_2h1p_contrib(delta_ij_tmp) +!!!!!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det_ref) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det_ref +! do j = 1, N_det_ref +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +!enddo +!second_order_pt_new_2h1p(i_state) = accu(i_state) +!enddo +!print*, '2h1p = ',accu - ! 2h2p - delta_ij_tmp = 0.d0 -!!!!!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h2p(i_state) = accu(i_state) - enddo - print*, '2h2p = ',accu +!! 2h2p - double precision :: contrib_2h2p(N_states) - call give_2h2p(contrib_2h2p) - do i_state = 1, N_states - do i = 1, N_det_ref - delta_ij(i,i,i_state) += contrib_2h2p(i_state) - enddo - second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) - enddo - print*, '2h2p = ',contrib_2h2p(1) +!double precision :: contrib_2h2p(N_states) +!call give_2h2p(contrib_2h2p) +!do i_state = 1, N_states +! do i = 1, N_det_ref +! delta_ij(i,i,i_state) += contrib_2h2p(i_state) +! enddo +!second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) +!enddo +!print*, '2h2p = ',contrib_2h2p(:) ! total - accu = 0.d0 + accu = 0.d0 do i_state = 1, N_states - do i = 1, N_det_ref -! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) - do j = i_state, N_det_ref - accu(i_state) += delta_ij(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + print*,'state ',i_state + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij(i,:,i_state) + do j = i , N_det_ref + accu(i_state) += delta_ij(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + enddo enddo - enddo - second_order_pt_new(i_state) = accu(i_state) - print*, 'total= ',accu(i_state) + second_order_pt_new(i_state) = accu(i_state) + print*, 'total= ',accu(i_state) enddo @@ -217,7 +203,7 @@ END_PROVIDER double precision :: hij do i_state = 1, N_states do i = 1,N_det_ref - do j = i,N_det_ref + do j = 1,N_det_ref call i_h_j(psi_ref(1,1,j),psi_ref(1,1,i),N_int,hij) Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = hij & + 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) ) @@ -284,9 +270,9 @@ END_PROVIDER do j = 1, N_det_ref hmatrix_tmp(j,i) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) enddo +! print*,i,hmatrix_tmp(i,i)+nuclear_repulsion enddo - call lapack_diag(eigenvalues,eigenvectors, & - Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det_ref,N_det_ref) + call lapack_diag(eigenvalues,eigenvectors,hmatrix_tmp,N_det_ref,N_det_ref) write(*,'(A86)')'Looking for the most overlapping state within all eigenvectors of the dressed matrix' print*,'' print*,'Calculating the overlap for ...' @@ -303,7 +289,10 @@ END_PROVIDER enddo print*,'' print*,'Sorting the eigenvectors per overlap' - call dsort(overlap,iorder,n_states) + call dsort(overlap,iorder,n_det_ref) + do j = 1, N_det_ref + print*,overlap(j),iorder(j) + enddo print*,'' print*,'The most overlapping state is the ',iorder(1) print*,'with the overlap of ',dabs(overlap(1)) diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 33cb5d5b..e3b0986a 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -180,7 +180,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) double precision :: delta_e_inactive(N_states) - integer :: i_hole_inact + integer :: i_hole_inact, list_holes_inact(n_inact_orb,2) call get_excitation_degree(det_1,det_2,degree,N_int) if(degree>2)then @@ -190,8 +190,13 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) delta_e_inactive = 0.d0 + integer :: n_holes_total + n_holes_total = 0 do i = 1, n_holes_spin(1) i_hole_inact = holes_list(i,1) + n_holes_total +=1 + list_holes_inact(n_holes_total,1) = i_hole_inact + list_holes_inact(n_holes_total,2) = 1 do i_state = 1, N_states delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) enddo @@ -199,6 +204,9 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) do i = 1, n_holes_spin(2) i_hole_inact = holes_list(i,2) + n_holes_total +=1 + list_holes_inact(n_holes_total,1) = i_hole_inact + list_holes_inact(n_holes_total,2) = 2 do i_state = 1, N_states delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) enddo @@ -370,15 +378,41 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo else if (n_holes_act == 1 .and. n_particles_act == 2) then + ! First find the particle that has been added from the inactive + ! + integer :: spin_hole_inact, spin_hole_part_act + spin_hole_inact = list_holes_inact(1,2) +! spin_hole_part_act = + if(jspin == spin_hole_inact )then + kspin = spin_hole_part_act + ispin = spin_hole_part_act + else + jspin = spin_hole_part_act + ispin = spin_hole_part_act + endif + ! by convention, you first make a movement in the cas ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) + i_hole_act = hole_list_practical(2,1) + jspin = spin_hole_inact ! first particle - jspin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) ! second particle - kspin = particle_list_practical(1,2) j_particle_act = particle_list_practical(2,2) + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 2)then + print*, '' + call debug_det(det_1,N_int) + call debug_det(det_2,N_int) + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + print*, s1,h1,p1 + print*, s2,h2,p2 + print*, '---' + print*, ispin, i_hole_act + print*, jspin, i_particle_act + print*, kspin, j_particle_act + pause + endif do i_state = 1, N_states delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) diff --git a/plugins/Perturbation/pt2_new.irp.f b/plugins/MRPT_Utils/pt2_new.irp.f similarity index 100% rename from plugins/Perturbation/pt2_new.irp.f rename to plugins/MRPT_Utils/pt2_new.irp.f diff --git a/plugins/Perturbation/NEEDED_CHILDREN_MODULES b/plugins/Perturbation/NEEDED_CHILDREN_MODULES index 25b89c5f..f7999340 100644 --- a/plugins/Perturbation/NEEDED_CHILDREN_MODULES +++ b/plugins/Perturbation/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Properties Hartree_Fock Davidson MRPT_Utils +Determinants Properties Hartree_Fock Davidson diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index b29e130f..5839c20c 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -46,36 +46,6 @@ subroutine pt2_epstein_nesbet ($arguments) end -subroutine pt2_decontracted ($arguments) - use bitmasks - implicit none - $declarations - - BEGIN_DOC - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem_fock, h - double precision :: i_H_psi_array(N_st) - double precision :: coef_pert - PROVIDE selection_criterion - - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) - call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert) - H_pert_diag = 0.d0 - - - c_pert(1) = coef_pert - e_2_pert(1) = coef_pert * i_H_psi_array(1) -! print*,coef_pert,i_H_psi_array(1) - -end - - - - subroutine pt2_epstein_nesbet_2x2 ($arguments) use bitmasks implicit none From a946fc615b5304a2e59b45e6180636b095b4bb3b Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 29 Nov 2016 16:48:24 +0100 Subject: [PATCH 70/76] Beginning to merge MRCC and MRPT --- plugins/MRCC_Utils/mrcc_utils.irp.f | 11 +- plugins/MRPT_Utils/H_apply.irp.f | 2 + plugins/MRPT_Utils/energies_cas.irp.f | 88 ++++-- plugins/MRPT_Utils/mrpt_dress.irp.f | 38 ++- plugins/MRPT_Utils/mrpt_utils.irp.f | 225 +++++++------ plugins/MRPT_Utils/psi_active_prov.irp.f | 385 ++++++++++++++++++++--- 6 files changed, 549 insertions(+), 200 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 92425eb0..9cf0330b 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -634,8 +634,11 @@ END_PROVIDER integer :: i, j, k double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states) double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states) + integer :: number_of_holes, number_of_particles,nh,np do i = 1, N_det_non_ref print*,'i',i + nh = number_of_holes(psi_non_ref(1,1,i)) + np = number_of_particles(psi_non_ref(1,1,i)) do j = 1, N_det_ref do k = 1, N_States coef_array(k) = psi_ref_coef(j,k) @@ -653,7 +656,9 @@ END_PROVIDER coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k) enddo enddo + write(*,'(A7,X,100(F16.10,x))')'coef ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2) + print*, nh,np do k = 1, N_States if(dabs(coef_mrpt(k)) .le.1.d-10)then rho_mrpt(i,k) = 0.d0 @@ -666,6 +671,7 @@ END_PROVIDER endif enddo print*,'rho',rho_mrpt(i,:) + write(33,*)i,rho_mrpt(i,:) enddo END_PROVIDER @@ -1011,7 +1017,7 @@ END_PROVIDER double precision function get_dij_index(II, i, s, Nint) integer, intent(in) :: II, i, s, Nint double precision, external :: get_dij - double precision :: HIi, phase + double precision :: HIi, phase,delta_e_final(N_states) if(lambda_type == 0) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) @@ -1026,7 +1032,8 @@ double precision function get_dij_index(II, i, s, Nint) get_dij_index = get_dij_index else if(lambda_type == 3) then call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) - get_dij_index = HIi * rho_mrpt(i, s) + call get_delta_e_dyall_fast(psi_ref(1,1,II),psi_non_ref(1,1,i),delta_e_final) + get_dij_index = HIi * rho_mrpt(i, s) / delta_e_final(s) end if end function diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f index 6f17ab05..56f8a0c7 100644 --- a/plugins/MRPT_Utils/H_apply.irp.f +++ b/plugins/MRPT_Utils/H_apply.irp.f @@ -23,6 +23,7 @@ print s s = H_apply("mrpt_1h") s.filter_only_1h() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -63,6 +64,7 @@ print s s = H_apply("mrpt_1h1p") s.filter_only_1h1p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index 33baeb6a..02ff8302 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -188,12 +188,14 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + do state_target = 1 , N_states + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + enddo enddo enddo enddo @@ -319,7 +321,7 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] +BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -336,45 +338,69 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a integer :: korb integer :: state_target double precision :: energies(n_states) + double precision :: norm_spins(2,2,N_states), energies_spins(2,2,N_states) + double precision :: thresh_norm + thresh_norm = 1.d-10 do iorb = 1,n_act_orb - do ispin = 1,2 orb_i = list_act(iorb) hole_particle_i = 1 - spin_exc_i = ispin do jorb = 1, n_act_orb - do jspin = 1,2 orb_j = list_act(jorb) hole_particle_j = 1 - spin_exc_j = jspin do korb = 1, n_act_orb - do kspin = 1,2 orb_k = list_act(korb) hole_particle_k = -1 - spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) + + ! loop on the spins + ! By definition, orb_i is the particle of spin ispin + ! a^+_{ispin , orb_i} + do ispin = 1, 2 + do jspin = 1, 2 + ! By definition, orb_j and orb_k are the couple of particle/hole of spin jspin + ! a^+_{jspin , orb_j} a_{jspin , orb_k} + ! norm_spins(ispin,jspin) :: norm of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > + ! energies_spins(ispin,jspin) :: Dyall energu of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) + enddo + enddo + do state_target = 1, N_states + ! hole :: hole_particle_k, jspin + call apply_exc_to_psi(orb_k,hole_particle_k,jspin, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call apply_exc_to_psi(orb_j,hole_particle_j,jspin, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call apply_exc_to_psi(orb_i,hole_particle_i,ispin, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + if(dabs(norm_out(state_target)).lt.thresh_norm)then + norm_spins(ispin,jspin,state_target) = 0.d0 + else + norm_spins(ispin,jspin,state_target) = 1.d0 + endif + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + energies_spins(ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + enddo enddo enddo + integer :: icount + ! averaging over all possible spin permutations with Heaviside norm do state_target = 1, N_states - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + icount = 0 + do jspin = 1, 2 + do ispin = 1, 2 + icount += 1 + two_creat_one_anhil(iorb,jorb,korb,state_target) = energies_spins(ispin,jspin,state_target) * norm_spins(ispin,jspin,state_target) + enddo + enddo + two_creat_one_anhil(iorb,jorb,korb,state_target) = two_creat_one_anhil(iorb,jorb,korb,state_target) / dble(icount) enddo - enddo enddo - enddo enddo - enddo enddo deallocate(psi_in_out,psi_in_out_coef) diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index eccdae0a..c50e4221 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -48,18 +48,18 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip integer :: exc(0:2,2,2),degree - leng = max(N_det_ref, N_det_ref) + leng = max(N_det_generators, N_det_generators) allocate(miniList(Nint, 2, leng), idx_miniList(leng)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) - call create_minilist_find_previous(key_mask, psi_ref, miniList, i_generator-1, N_miniList, fullMatch, Nint) + call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) if(fullMatch) then return end if - call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) + call find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) if(N_tq > 0) then call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det_ref, N_minilist, Nint) @@ -88,17 +88,28 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int) if(dabs(hialpha).le.1.d-20)then - delta_e = 1.d+20 - else - call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) - endif - if(degree .ne. 2)then do i_state = 1, N_states delta_e(i_state) = 1.d+20 enddo + else + call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) + do i_state = 1, N_states + if(isnan(delta_e(i_state)))then + print*, 'i_state',i_state + call debug_det(psi_ref(1,1,index_i),N_int) + call debug_det(tq(1,1,i_alpha),N_int) + print*, delta_e(:) + stop + endif + enddo endif +! if(degree_scalar .ne. 1)then +! do i_state = 1, N_states +! delta_e(i_state) = 1.d+20 +! enddo +! endif hij_array(index_i) = hialpha - call get_excitation(psi_ref(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) +! call get_excitation(psi_ref(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) enddo @@ -134,12 +145,12 @@ end END_PROVIDER -subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) +subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) use bitmasks implicit none - integer, intent(in) :: i_generator,n_selected, Nint + integer, intent(in) :: n_selected, Nint integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,m @@ -180,8 +191,3 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N end - - - - - diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index cb007199..39cf46db 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -39,127 +39,126 @@ enddo print*, '1h = ',accu -!! 1p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_1p(delta_ij_tmp,N_det_ref) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det_ref -! do j = 1, N_det_ref -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -!enddo -!second_order_pt_new_1p(i_state) = accu(i_state) -!enddo -!print*, '1p = ',accu + ! 1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1p(i_state) = accu(i_state) + enddo + print*, '1p = ',accu -!! 1h1p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_1h1p(delta_ij_tmp,N_det_ref) -!double precision :: e_corr_from_1h1p_singles(N_states) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det_ref -! do j = 1, N_det_ref -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -!enddo -!second_order_pt_new_1h1p(i_state) = accu(i_state) -!enddo -!print*, '1h1p = ',accu + ! 1h1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1h1p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p = ',accu -!! 1h1p third order -!if(do_third_order_1h1p)then -! delta_ij_tmp = 0.d0 -! call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) -! accu = 0.d0 -! do i_state = 1, N_states -! do i = 1, N_det_ref -! do j = 1, N_det_ref -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! enddo -! second_order_pt_new_1h1p(i_state) = accu(i_state) -! enddo -! print*, '1h1p(3)',accu -!endif + ! 1h1p third order + if(do_third_order_1h1p)then + delta_ij_tmp = 0.d0 + call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p(3)',accu + endif -!! 2h -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_2h(delta_ij_tmp,N_det_ref) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det_ref -! do j = 1, N_det_ref -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -!enddo -!second_order_pt_new_2h(i_state) = accu(i_state) -!enddo -!print*, '2h = ',accu + ! 2h + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2h(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h(i_state) = accu(i_state) + enddo + print*, '2h = ',accu -!! 2p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_2p(delta_ij_tmp,N_det_ref) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det_ref -! do j = 1, N_det_ref -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -!enddo -!second_order_pt_new_2p(i_state) = accu(i_state) -!enddo -!print*, '2p = ',accu + ! 2p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2p(i_state) = accu(i_state) + enddo + print*, '2p = ',accu -!! 1h2p -!delta_ij_tmp = 0.d0 -!call give_1h2p_contrib(delta_ij_tmp) -!!!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det_ref) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det_ref -! do j = 1, N_det_ref -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -!enddo -!second_order_pt_new_1h2p(i_state) = accu(i_state) -!enddo -!print*, '1h2p = ',accu + ! 1h2p + delta_ij_tmp = 0.d0 + call give_1h2p_contrib(delta_ij_tmp) + !!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h2p(i_state) = accu(i_state) + enddo + print*, '1h2p = ',accu -!! 2h1p -!delta_ij_tmp = 0.d0 -!call give_2h1p_contrib(delta_ij_tmp) -!!!!!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det_ref) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det_ref -! do j = 1, N_det_ref -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -!enddo -!second_order_pt_new_2h1p(i_state) = accu(i_state) -!enddo -!print*, '2h1p = ',accu + ! 2h1p + delta_ij_tmp = 0.d0 + call give_2h1p_contrib(delta_ij_tmp) + !!!!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h1p(i_state) = accu(i_state) + enddo + print*, '2h1p = ',accu -!! 2h2p + ! 2h2p -!double precision :: contrib_2h2p(N_states) -!call give_2h2p(contrib_2h2p) -!do i_state = 1, N_states -! do i = 1, N_det_ref -! delta_ij(i,i,i_state) += contrib_2h2p(i_state) -! enddo -!second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) -!enddo -!print*, '2h2p = ',contrib_2h2p(:) + double precision :: contrib_2h2p(N_states) + call give_2h2p(contrib_2h2p) + do i_state = 1, N_states + do i = 1, N_det_ref + delta_ij(i,i,i_state) += contrib_2h2p(i_state) + enddo + second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) + enddo + print*, '2h2p = ',contrib_2h2p(:) ! total diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index e3b0986a..55e8aefb 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -9,10 +9,10 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] integer :: i,j,k,l provide cas_bitmask !print*, 'psi_active ' - do i = 1, N_det + do i = 1, N_det_ref do j = 1, N_int - psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1)) - psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1)) + psi_active(j,1,i) = iand(psi_ref(j,1,i),cas_bitmask(j,1,1)) + psi_active(j,2,i) = iand(psi_ref(j,2,i),cas_bitmask(j,1,1)) enddo enddo END_PROVIDER @@ -184,7 +184,9 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) call get_excitation_degree(det_1,det_2,degree,N_int) if(degree>2)then - delta_e_final = -1.d+10 + do i_state = 1, N_States + delta_e_final(i_state) = -1.d+10 + enddo return endif @@ -198,7 +200,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) list_holes_inact(n_holes_total,1) = i_hole_inact list_holes_inact(n_holes_total,2) = 1 do i_state = 1, N_states - delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) + delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) enddo enddo @@ -223,14 +225,14 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) do i = 1, n_particles_spin(1) i_part_virt = particles_list(i,1) do i_state = 1, N_states - delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) + delta_e_virt(i_state) += fock_virt_total_spin_trace(i_part_virt,i_state) enddo enddo do i = 1, n_particles_spin(2) i_part_virt = particles_list(i,2) do i_state = 1, N_states - delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) + delta_e_virt(i_state) += fock_virt_total_spin_trace(i_part_virt,i_state) enddo enddo @@ -382,40 +384,27 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) ! integer :: spin_hole_inact, spin_hole_part_act spin_hole_inact = list_holes_inact(1,2) -! spin_hole_part_act = - if(jspin == spin_hole_inact )then - kspin = spin_hole_part_act - ispin = spin_hole_part_act - else - jspin = spin_hole_part_act - ispin = spin_hole_part_act - endif - ! by convention, you first make a movement in the cas - ! first hole + +! ! by convention, you first make a movement in the cas +! ! first hole i_hole_act = hole_list_practical(2,1) - jspin = spin_hole_inact - ! first particle - i_particle_act = particle_list_practical(2,1) - ! second particle - j_particle_act = particle_list_practical(2,2) - call get_excitation_degree(det_1,det_2,degree,N_int) - if(degree == 2)then - print*, '' - call debug_det(det_1,N_int) - call debug_det(det_2,N_int) - call get_excitation(det_1,det_2,exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - print*, s1,h1,p1 - print*, s2,h2,p2 - print*, '---' - print*, ispin, i_hole_act - print*, jspin, i_particle_act - print*, kspin, j_particle_act - pause + if(particle_list_practical(1,1) == spin_hole_inact)then +! ! first particle + i_particle_act = particle_list_practical(2,2) +! ! second particle + j_particle_act = particle_list_practical(1,2) + else if (particle_list_practical(1,2) == spin_hole_inact)then +! ! first particle + i_particle_act = particle_list_practical(1,2) +! ! second particle + j_particle_act = particle_list_practical(2,2) + else + print*, 'pb in n_holes_act == 1 .and. n_particles_act == 2 !!' + stop endif do i_state = 1, N_states - delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) + delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,i_state) enddo else if (n_holes_act == 3 .and. n_particles_act == 0) then @@ -464,7 +453,9 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo endif else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then - delta_e_act = -10000000.d0 + do i = 1, N_states + delta_e_act(i_state) = -10000000.d0 + enddo endif !print*, 'one_anhil_spin_trace' @@ -478,3 +469,321 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) end + +subroutine get_delta_e_dyall_fast(det_1,det_2,delta_e_final) + BEGIN_DOC + ! routine that returns the delta_e with the Moller Plesset and Dyall operators + ! + ! with det_1 being a determinant from the cas, and det_2 being a perturber + ! + ! Delta_e(det_1,det_2) = sum (hole) epsilon(hole) + sum(part) espilon(part) + delta_e(act) + ! + ! where hole is necessary in the inactive, part necessary in the virtuals + ! + ! and delta_e(act) is obtained from the contracted application of the excitation + ! + ! operator in the active space that lead from det_1 to det_2 + END_DOC + implicit none + use bitmasks + double precision, intent(out) :: delta_e_final(N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer :: i,j,k,l + integer :: i_state + + integer :: n_holes_spin(2) + integer :: n_holes + integer :: holes_list(N_int*bit_kind_size,2) + + + double precision :: delta_e_inactive(N_states) + integer :: i_hole_inact, list_holes_inact(n_inact_orb,2) + + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree>2)then + do i_state = 1, N_States + delta_e_final(i_state) = -1.d+10 + enddo + return + endif + + call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) + delta_e_inactive = 0.d0 + integer :: n_holes_total + n_holes_total = 0 + do i = 1, n_holes_spin(1) + i_hole_inact = holes_list(i,1) + n_holes_total +=1 + list_holes_inact(n_holes_total,1) = i_hole_inact + list_holes_inact(n_holes_total,2) = 1 + do i_state = 1, N_states + delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) + enddo + enddo + + do i = 1, n_holes_spin(2) + i_hole_inact = holes_list(i,2) + n_holes_total +=1 + list_holes_inact(n_holes_total,1) = i_hole_inact + list_holes_inact(n_holes_total,2) = 2 + do i_state = 1, N_states + delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) + enddo + enddo + + double precision :: delta_e_virt(N_states) + integer :: i_part_virt + integer :: n_particles_spin(2) + integer :: n_particles + integer :: particles_list(N_int*bit_kind_size,2) + + call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list) + delta_e_virt = 0.d0 + do i = 1, n_particles_spin(1) + i_part_virt = particles_list(i,1) + do i_state = 1, N_states + delta_e_virt(i_state) += fock_virt_total_spin_trace(i_part_virt,i_state) + enddo + enddo + + do i = 1, n_particles_spin(2) + i_part_virt = particles_list(i,2) + do i_state = 1, N_states + delta_e_virt(i_state) += fock_virt_total_spin_trace(i_part_virt,i_state) + enddo + enddo + + + integer :: n_holes_spin_act(2),n_particles_spin_act(2) + integer :: n_holes_act,n_particles_act + integer :: holes_active_list(2*n_act_orb,2) + integer :: holes_active_list_spin_traced(4*n_act_orb) + integer :: particles_active_list(2*n_act_orb,2) + integer :: particles_active_list_spin_traced(4*n_act_orb) + double precision :: delta_e_act(N_states) + delta_e_act = 0.d0 + call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & + n_holes_act,n_particles_act,holes_active_list,particles_active_list) + integer :: icount,icountbis + integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2)) + icount = 0 + icountbis = 0 + do i = 1, n_holes_spin_act(1) + icount += 1 + icountbis += 1 + hole_list_practical(1,icountbis) = 1 + hole_list_practical(2,icountbis) = holes_active_list(i,1) + holes_active_list_spin_traced(icount) = holes_active_list(i,1) + enddo + do i = 1, n_holes_spin_act(2) + icount += 1 + icountbis += 1 + hole_list_practical(1,icountbis) = 2 + hole_list_practical(2,icountbis) = holes_active_list(i,2) + holes_active_list_spin_traced(icount) = holes_active_list(i,2) + enddo + if(icount .ne. n_holes_act) then + print*,'' + print*, icount, n_holes_act + print * , 'pb in holes_active_list_spin_traced !!' + stop + endif + + icount = 0 + icountbis = 0 + do i = 1, n_particles_spin_act(1) + icount += 1 + icountbis += 1 + particle_list_practical(1,icountbis) = 1 + particle_list_practical(2,icountbis) = particles_active_list(i,1) + particles_active_list_spin_traced(icount) = particles_active_list(i,1) + enddo + do i = 1, n_particles_spin_act(2) + icount += 1 + icountbis += 1 + particle_list_practical(1,icountbis) = 2 + particle_list_practical(2,icountbis) = particles_active_list(i,2) + particles_active_list_spin_traced(icount) = particles_active_list(i,2) + enddo + if(icount .ne. n_particles_act) then + print*, icount, n_particles_act + print * , 'pb in particles_active_list_spin_traced !!' + stop + endif + + + integer :: i_hole_act, j_hole_act, k_hole_act + integer :: i_particle_act, j_particle_act, k_particle_act + + + integer :: ispin,jspin,kspin + if (n_holes_act == 0 .and. n_particles_act == 1) then + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 1)then + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + i_hole = list_inact_reverse(h1) + i_part = list_act_reverse(p1) + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state) + enddo + else if (degree == 2)then + do i_state = 1, N_states + delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state) + enddo + endif + + else if (n_holes_act == 1 .and. n_particles_act == 0) then + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 1)then + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + i_hole = list_act_reverse(h1) + i_part = list_virt_reverse(p1) + do i_state = 1, N_states + delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state) + enddo + else if (degree == 2)then + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) + enddo + endif + + else if (n_holes_act == 1 .and. n_particles_act == 1) then + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! first particle + jspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin,i_state) + enddo + + else if (n_holes_act == 2 .and. n_particles_act == 0) then + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + do i_state = 1, N_states + delta_e_act(i_state) += two_anhil(i_hole_act,j_hole_act,ispin,jspin,i_state) + enddo + + else if (n_holes_act == 0 .and. n_particles_act == 2) then + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + jspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + do i_state = 1, N_states + delta_e_act(i_state) += two_creat(i_particle_act,j_particle_act,ispin,jspin,i_state) + enddo + + else if (n_holes_act == 2 .and. n_particles_act == 1) then + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! second hole + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + ! first particle + kspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + do i_state = 1, N_states + delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) + enddo + + else if (n_holes_act == 1 .and. n_particles_act == 2) then + ! First find the particle that has been added from the inactive + ! + integer :: spin_hole_inact, spin_hole_part_act + spin_hole_inact = list_holes_inact(1,2) + +! ! by convention, you first make a movement in the cas +! ! first hole + i_hole_act = hole_list_practical(2,1) + if(particle_list_practical(1,1) == spin_hole_inact)then +! ! first particle + i_particle_act = particle_list_practical(2,2) +! ! second particle + j_particle_act = particle_list_practical(1,2) + else if (particle_list_practical(1,2) == spin_hole_inact)then +! ! first particle + i_particle_act = particle_list_practical(1,2) +! ! second particle + j_particle_act = particle_list_practical(2,2) + else + print*, 'pb in n_holes_act == 1 .and. n_particles_act == 2 !!' + stop + endif + + do i_state = 1, N_states + delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,i_state) + enddo + + else if (n_holes_act == 3 .and. n_particles_act == 0) then + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! second hole + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + ! third hole + kspin = hole_list_practical(1,3) + k_hole_act = hole_list_practical(2,3) + do i_state = 1, N_states + delta_e_act(i_state) += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin,i_state) + enddo + + else if (n_holes_act == 0 .and. n_particles_act == 3) then + ! first particle + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + ! second particle + jspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + ! second particle + kspin = particle_list_practical(1,3) + k_particle_act = particle_list_practical(2,3) + do i_state = 1, N_states + delta_e_act(i_state) += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin,i_state) + enddo + + else if (n_holes_act .eq. 0 .and. n_particles_act .eq.0)then + integer :: degree + integer(bit_kind) :: det_1_active(N_int,2) + integer :: h1,h2,p1,p2,s1,s2 + integer :: exc(0:2,2,2) + integer :: i_hole, i_part + double precision :: phase + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 1)then + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + i_hole = list_inact_reverse(h1) + i_part = list_virt_reverse(p1) + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) + enddo + endif + else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then + do i = 1, N_states + delta_e_act(i_state) = -10000000.d0 + enddo + endif + +!print*, 'one_anhil_spin_trace' +!print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2) + + + do i_state = 1, n_states + delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state) + enddo +!write(*,'(100(f16.10,X))'), delta_e_final(1) , delta_e_act(1) , delta_e_inactive(1) , delta_e_virt(1) + +end + + From eda249e631c50e058d429e6ac555fb406a949de0 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 5 Dec 2016 15:10:53 +0100 Subject: [PATCH 71/76] final version of MRPT, at least I hope --- plugins/MRPT/MRPT_Utils.main.irp.f | 6 +- plugins/MRPT/print_1h2p.irp.f | 10 +- plugins/MRPT_Utils/H_apply.irp.f | 6 + plugins/MRPT_Utils/energies_cas.irp.f | 188 +++++++++----- plugins/MRPT_Utils/mrpt_dress.irp.f | 64 +++-- plugins/MRPT_Utils/mrpt_utils.irp.f | 303 +++++++++++++---------- plugins/MRPT_Utils/new_way.irp.f | 140 +++++------ plugins/MRPT_Utils/psi_active_prov.irp.f | 88 +++---- 8 files changed, 485 insertions(+), 320 deletions(-) diff --git a/plugins/MRPT/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f index 72750f8c..e5d925a3 100644 --- a/plugins/MRPT/MRPT_Utils.main.irp.f +++ b/plugins/MRPT/MRPT_Utils.main.irp.f @@ -10,7 +10,7 @@ end subroutine routine_3 implicit none - integer :: i + integer :: i,j !provide fock_virt_total_spin_trace provide delta_ij @@ -23,6 +23,10 @@ subroutine routine_3 write(*,'(A12,X,I3,A3,XX,F16.09)') ' E+PT2 ', i,' = ', CI_energy(i)+second_order_pt_new(i) write(*,'(A12,X,I3,A3,XX,F16.09)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i) write(*,'(A12,X,I3,A3,XX,F16.09)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) + print*,'coef before and after' + do j = 1, N_det_ref + print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i) + enddo enddo end diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f index a3500e49..2739340b 100644 --- a/plugins/MRPT/print_1h2p.irp.f +++ b/plugins/MRPT/print_1h2p.irp.f @@ -2,16 +2,18 @@ program print_1h2p implicit none read_wf = .True. touch read_wf - call routine + call routine_2 end subroutine routine_2 implicit none - integer :: i,j + integer :: i,j,degree + double precision :: hij +!provide one_creat_virt do i =1, n_act_orb -!do i =1, 2 - write(*,'(I3,x,100(F16.10,X))')i,one_anhil_one_creat(i,:,:,:,1) + write(*,'(I3,x,100(F16.10,X))')i,one_creat(i,:,1) ! write(*,'(I3,x,100(F16.10,X))')i,one_anhil_one_creat(1,4,1,2,1) +! enddo diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f index 56f8a0c7..a7adc480 100644 --- a/plugins/MRPT_Utils/H_apply.irp.f +++ b/plugins/MRPT_Utils/H_apply.irp.f @@ -44,6 +44,7 @@ print s s = H_apply("mrpt_1p") s.filter_only_1p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -85,6 +86,7 @@ print s s = H_apply("mrpt_2p") s.filter_only_2p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -105,6 +107,7 @@ print s s = H_apply("mrpt_2h") s.filter_only_2h() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -126,6 +129,7 @@ print s s = H_apply("mrpt_1h2p") s.filter_only_1h2p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -146,6 +150,7 @@ print s s = H_apply("mrpt_2h1p") s.filter_only_2h1p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -166,6 +171,7 @@ print s s = H_apply("mrpt_2h2p") s.filter_only_2h2p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index 02ff8302..8f6a7eb6 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -321,8 +321,8 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,N_states)] - implicit none +BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] +implicit none integer :: i,j integer :: ispin,jspin,kspin integer :: orb_i, hole_particle_i,spin_exc_i @@ -332,80 +332,142 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target double precision :: energies(n_states) - double precision :: norm_spins(2,2,N_states), energies_spins(2,2,N_states) - double precision :: thresh_norm - thresh_norm = 1.d-10 do iorb = 1,n_act_orb + do ispin = 1,2 orb_i = list_act(iorb) hole_particle_i = 1 + spin_exc_i = ispin do jorb = 1, n_act_orb + do jspin = 1,2 orb_j = list_act(jorb) hole_particle_j = 1 + spin_exc_j = jspin do korb = 1, n_act_orb + do kspin = 1,2 orb_k = list_act(korb) hole_particle_k = -1 + spin_exc_k = kspin + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) + enddo + enddo - ! loop on the spins - ! By definition, orb_i is the particle of spin ispin - ! a^+_{ispin , orb_i} - do ispin = 1, 2 - do jspin = 1, 2 - ! By definition, orb_j and orb_k are the couple of particle/hole of spin jspin - ! a^+_{jspin , orb_j} a_{jspin , orb_k} - ! norm_spins(ispin,jspin) :: norm of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > - ! energies_spins(ispin,jspin) :: Dyall energu of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1, N_states - ! hole :: hole_particle_k, jspin - call apply_exc_to_psi(orb_k,hole_particle_k,jspin, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call apply_exc_to_psi(orb_j,hole_particle_j,jspin, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call apply_exc_to_psi(orb_i,hole_particle_i,ispin, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - if(dabs(norm_out(state_target)).lt.thresh_norm)then - norm_spins(ispin,jspin,state_target) = 0.d0 - else - norm_spins(ispin,jspin,state_target) = 1.d0 - endif - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - energies_spins(ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - enddo - enddo - enddo - integer :: icount - ! averaging over all possible spin permutations with Heaviside norm - do state_target = 1, N_states - icount = 0 - do jspin = 1, 2 - do ispin = 1, 2 - icount += 1 - two_creat_one_anhil(iorb,jorb,korb,state_target) = energies_spins(ispin,jspin,state_target) * norm_spins(ispin,jspin,state_target) - enddo - enddo - two_creat_one_anhil(iorb,jorb,korb,state_target) = two_creat_one_anhil(iorb,jorb,korb,state_target) / dble(icount) + do state_target = 1, N_states + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo + enddo enddo + enddo enddo + enddo enddo deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER +!BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,N_states)] +!implicit none +!integer :: i,j +!integer :: ispin,jspin,kspin +!integer :: orb_i, hole_particle_i,spin_exc_i +!integer :: orb_j, hole_particle_j,spin_exc_j +!integer :: orb_k, hole_particle_k,spin_exc_k +!double precision :: norm_out(N_states) +!integer(bit_kind), allocatable :: psi_in_out(:,:,:) +!double precision, allocatable :: psi_in_out_coef(:,:) +!use bitmasks +!allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + +!integer :: iorb,jorb +!integer :: korb +!integer :: state_target +!double precision :: energies(n_states) +!double precision :: norm_spins(2,2,N_states), energies_spins(2,2,N_states) +!double precision :: thresh_norm +!thresh_norm = 1.d-10 +!do iorb = 1,n_act_orb +! orb_i = list_act(iorb) +! hole_particle_i = 1 +! do jorb = 1, n_act_orb +! orb_j = list_act(jorb) +! hole_particle_j = 1 +! do korb = 1, n_act_orb +! orb_k = list_act(korb) +! hole_particle_k = -1 + +! ! loop on the spins +! ! By definition, orb_i is the particle of spin ispin +! ! a^+_{ispin , orb_i} +! do ispin = 1, 2 +! do jspin = 1, 2 +! ! By definition, orb_j and orb_k are the couple of particle/hole of spin jspin +! ! a^+_{jspin , orb_j} a_{jspin , orb_k} +! ! norm_spins(ispin,jspin) :: norm of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > +! ! energies_spins(ispin,jspin) :: Dyall energu of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > +! do i = 1, n_det_ref +! do j = 1, n_states +! psi_in_out_coef(i,j) = psi_ref_coef(i,j) +! enddo +! do j = 1, N_int +! psi_in_out(j,1,i) = psi_active(j,1,i) +! psi_in_out(j,2,i) = psi_active(j,2,i) +! enddo +! enddo +! do state_target = 1, N_states +! ! hole :: hole_particle_k, jspin +! call apply_exc_to_psi(orb_k,hole_particle_k,jspin, & +! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) +! call apply_exc_to_psi(orb_j,hole_particle_j,jspin, & +! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) +! call apply_exc_to_psi(orb_i,hole_particle_i,ispin, & +! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) +! if(dabs(norm_out(state_target)).lt.thresh_norm)then +! norm_spins(ispin,jspin,state_target) = 0.d0 +! else +! norm_spins(ispin,jspin,state_target) = 1.d0 +! endif +! call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) +! energies_spins(ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) +! enddo +! enddo +! enddo +! integer :: icount +! ! averaging over all possible spin permutations with Heaviside norm +! do state_target = 1, N_states +! icount = 0 +! do jspin = 1, 2 +! do ispin = 1, 2 +! icount += 1 +! two_creat_one_anhil(iorb,jorb,korb,state_target) = energies_spins(ispin,jspin,state_target) * norm_spins(ispin,jspin,state_target) +! enddo +! enddo +! two_creat_one_anhil(iorb,jorb,korb,state_target) = two_creat_one_anhil(iorb,jorb,korb,state_target) / dble(icount) +! enddo +! enddo +! enddo +!enddo +!deallocate(psi_in_out,psi_in_out_coef) + +!END_PROVIDER + BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j @@ -767,6 +829,9 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State norm_bis = 0.d0 do ispin = 1,2 do i = 1, n_det_ref +! if(orb_a == 6 .and. orb_v == 12)then +! print*, 'i ref = ',i +! endif do j = 1, N_int psi_in_out(j,1,i) = psi_ref(j,1,i) psi_in_out(j,2,i) = psi_ref(j,2,i) @@ -778,15 +843,25 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State enddo else call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) + if(orb_a == 6 .and. orb_v == 12)then + call debug_det(psi_ref(1,1,i),N_int) + call debug_det(psi_in_out(1,1,i),N_int) + print*, hij + endif do j = 1, n_states - double precision :: coef,contrib - coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_ref_coef(i,j)) * hij + double precision :: contrib + psi_in_out_coef(i,j) = psi_ref_coef(i,j) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) + !if(orb_a == 6 .and. orb_v == 12)then + ! print*, j,psi_ref_coef(i,j),psi_in_out_coef(i,j) + !endif enddo endif enddo do j = 1, N_states +! if(orb_a == 6 .and. orb_v == 12)then +! print*, 'norm',norm(j,ispin) +! endif if (dabs(norm(j,ispin)) .le. thresh_norm)then norm(j,ispin) = 0.d0 norm_no_inv(j,ispin) = norm(j,ispin) @@ -822,6 +897,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else +! one_creat_virt(aorb,vorb,state_target) = 0.5d0 * (one_anhil(aorb, 1,state_target) + one_anhil(aorb, 2,state_target) ) one_creat_virt(aorb,vorb,state_target) = 0.d0 endif ! print*, '********' diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index c50e4221..f241d35a 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -66,21 +66,47 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip end if + double precision :: coef_array(N_states) do i_alpha=1,N_tq +! do i = 1, N_det_ref +! do i_state = 1, N_states +! coef_array(i_state) = psi_ref_coef(i,i_state) +! enddo +! call i_H_j(psi_ref(1,1,i),tq(1,1,i_alpha),n_int,hialpha) +! if(dabs(hialpha).le.1.d-20)then +! do i_state = 1, N_states +! delta_e(i_state) = 1.d+20 +! enddo +! else +! call get_delta_e_dyall(psi_ref(1,1,i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) +! endif +! hij_array(i) = hialpha +! do i_state = 1,N_states +! delta_e_inv_array(i,i_state) = 1.d0/delta_e(i_state) +! enddo +! enddo +! do i = 1, N_det_ref +! do j = 1, N_det_ref +! do i_state = 1, N_states +! delta_ij_(i,j,i_state) += hij_array(i) * hij_array(j)* delta_e_inv_array(j,i_state) +! enddo +! enddo +! enddo +! cycle + + + + ! call get_excitation_degree_vector(psi_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_ref,idx_alpha) call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) do j=1,idx_alpha(0) idx_alpha(j) = idx_miniList(idx_alpha(j)) enddo -! double precision :: ihpsi0,coef_pert -! ihpsi0 = 0.d0 -! coef_pert = 0.d0 phase_array =0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha) - double precision :: coef_array(N_states) do i_state = 1, N_states coef_array(i_state) = psi_ref_coef(index_i,i_state) enddo @@ -91,25 +117,21 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip do i_state = 1, N_states delta_e(i_state) = 1.d+20 enddo - else + !else if(degree_scalar== 1)then + else call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) - do i_state = 1, N_states - if(isnan(delta_e(i_state)))then - print*, 'i_state',i_state - call debug_det(psi_ref(1,1,index_i),N_int) - call debug_det(tq(1,1,i_alpha),N_int) - print*, delta_e(:) - stop - endif - enddo + !if(dabs(delta_e(2)) .le. dabs(0.01d0))then + !print*, delta_e(2) + !call debug_det(psi_ref(1,1,index_i),N_int) + !call debug_det(tq(1,1,i_alpha),N_int) + !endif + + !else + !do i_state = 1, N_states + ! delta_e(i_state) = 1.d+20 + !enddo endif -! if(degree_scalar .ne. 1)then -! do i_state = 1, N_states -! delta_e(i_state) = 1.d+20 -! enddo -! endif hij_array(index_i) = hialpha -! call get_excitation(psi_ref(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) enddo @@ -122,7 +144,7 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip do j = 1, idx_alpha(0) index_j = idx_alpha(j) do i_state=1,N_states -! standard dressing first order + ! standard dressing first order delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) enddo enddo diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 39cf46db..09efc536 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -30,6 +30,7 @@ accu = 0.d0 do i_state = 1, N_states do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) do j = 1, N_det_ref accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) @@ -39,141 +40,174 @@ enddo print*, '1h = ',accu - ! 1p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1p(i_state) = accu(i_state) - enddo - print*, '1p = ',accu - - ! 1h1p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1h1p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p = ',accu - - ! 1h1p third order - if(do_third_order_1h1p)then - delta_ij_tmp = 0.d0 - call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + ! 1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p(3)',accu - endif - - ! 2h - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2h(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h(i_state) = accu(i_state) - enddo - print*, '2h = ',accu - - ! 2p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2p(i_state) = accu(i_state) - enddo - print*, '2p = ',accu - - ! 1h2p - delta_ij_tmp = 0.d0 - call give_1h2p_contrib(delta_ij_tmp) - !!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h2p(i_state) = accu(i_state) - enddo - print*, '1h2p = ',accu - - ! 2h1p - delta_ij_tmp = 0.d0 - call give_2h1p_contrib(delta_ij_tmp) - !!!!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det_ref) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h1p(i_state) = accu(i_state) - enddo - print*, '2h1p = ',accu - - ! 2h2p - - double precision :: contrib_2h2p(N_states) - call give_2h2p(contrib_2h2p) - do i_state = 1, N_states - do i = 1, N_det_ref - delta_ij(i,i,i_state) += contrib_2h2p(i_state) - enddo - second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) - enddo - print*, '2h2p = ',contrib_2h2p(:) - + second_order_pt_new_1p(i_state) = accu(i_state) + enddo + print*, '1p = ',accu + + ! 1h1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1h1p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p = ',accu + + ! 1h1p third order + if(do_third_order_1h1p)then + delta_ij_tmp = 0.d0 + call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p(3)',accu + endif + + ! 2h + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2h(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h(i_state) = accu(i_state) + enddo + print*, '2h = ',accu + + ! 2p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2p(i_state) = accu(i_state) + enddo + print*, '2p = ',accu + + ! 1h2p + delta_ij_tmp = 0.d0 + call give_1h2p_contrib(delta_ij_tmp) + !!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h2p(i_state) = accu(i_state) + enddo + print*, '1h2p = ',accu + + ! 2h1p + delta_ij_tmp = 0.d0 + call give_2h1p_contrib(delta_ij_tmp) + !!!!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det_ref) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + do j = 1, N_det_ref + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h1p(i_state) = accu(i_state) + enddo + print*, '2h1p = ',accu + + ! 2h2p + + double precision :: contrib_2h2p(N_states) + call give_2h2p(contrib_2h2p) + do i_state = 1, N_states + do i = 1, N_det_ref + delta_ij(i,i,i_state) += contrib_2h2p(i_state) + enddo + second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) + enddo + print*, '2h2p = ',contrib_2h2p(:) + ! total - accu = 0.d0 + accu = 0.d0 + print*, 'naked matrix' + double precision, allocatable :: hmatrix(:,:) + double precision:: hij,h00 + allocate(hmatrix(N_det_ref, N_det_ref)) + call i_h_j(psi_ref(1,1,1),psi_ref(1,1,1),N_int,h00) + do i = 1, N_det_ref + do j = 1, N_det_Ref + call i_h_j(psi_ref(1,1,i),psi_ref(1,1,j),N_int,hij) + hmatrix(i,j) = hij + enddo + print*, hmatrix(i,i), h00 + hmatrix(i,i) += - h00 + enddo + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')hmatrix(i,:) + enddo + print*, '' + print*, '' + print*, '' do i_state = 1, N_states print*,'state ',i_state do i = 1, N_det_ref write(*,'(1000(F16.10,x))')delta_ij(i,:,i_state) - do j = i , N_det_ref + do j = 1 , N_det_ref accu(i_state) += delta_ij(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + hmatrix(i,j) += delta_ij(j,i,i_state) enddo enddo second_order_pt_new(i_state) = accu(i_state) print*, 'total= ',accu(i_state) + + do i = 1, N_det_ref + write(*,'(1000(F16.10,x))')hmatrix(i,:) + enddo + enddo + deallocate(hmatrix) @@ -206,7 +240,7 @@ END_PROVIDER call i_h_j(psi_ref(1,1,j),psi_ref(1,1,i),N_int,hij) Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = hij & + 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) ) - Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) +! Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) enddo enddo enddo @@ -260,8 +294,8 @@ END_PROVIDER allocate (hmatrix_tmp(N_det_ref,N_det_ref)) allocate (iorder(N_det_ref)) allocate (psi_tmp(N_det_ref)) - print*,'' - print*,'***************************' + print*,'' + print*,'***************************' do i_state = 1, N_states !! Big loop over states print*,'' print*,'Diagonalizing with the dressing for state',i_state @@ -305,7 +339,26 @@ END_PROVIDER call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2(i_state),psi_tmp,N_det_ref,psi_det,N_int,1,N_det_ref) print*,'S^2 = ', CI_dressed_pt2_new_eigenvectors_s2(i_state) enddo + !else if(state_average)then + ! print*,'' + ! print*,'***************************' + ! print*,'' + ! print*,'Doing state average dressings' + ! allocate (hmatrix_tmp(N_det_ref,N_det_ref)) + ! hmatrix_tmp = 0.d0 + ! do i_state = 1, N_states !! Big loop over states + ! do i = 1, N_det_ref + ! do j = 1, N_det_ref + ! hmatrix_tmp(j,i) += Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) + ! enddo + ! enddo + ! enddo + + + ! deallocate(hmatrix_tmp) + else + call lapack_diag(eigenvalues,eigenvectors, & Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det_ref,N_det_ref) CI_electronic_dressed_pt2_new_energy(:) = 0.d0 diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index a4bbe93a..dc921551 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -1,7 +1,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) + double precision , intent(inout) :: matrix_2h1p(N_det_ref,N_det_ref,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb integer :: ispin,jspin @@ -22,8 +22,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -38,14 +38,14 @@ subroutine give_2h1p_contrib(matrix_2h1p) active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det,3) + integer :: index_orb_act_mono(N_det_ref,3) - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) @@ -53,8 +53,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) do a = 1, n_act_orb ! First active aorb = list_act(a) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -64,7 +64,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -81,7 +81,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & @@ -109,7 +109,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a @@ -150,7 +150,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) ! you determine the interaction between the excited determinant and the other parent | Jdet > ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,2) - active_int(borb,1) ) else @@ -195,7 +195,7 @@ end subroutine give_1h2p_contrib(matrix_1h2p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) + double precision , intent(inout) :: matrix_1h2p(N_det_ref,N_det_ref,*) integer :: i,v,r,a,b integer :: iorb, vorb, rorb, aorb, borb integer :: ispin,jspin @@ -216,8 +216,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -232,14 +232,14 @@ subroutine give_1h2p_contrib(matrix_1h2p) active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det,3) + integer :: index_orb_act_mono(N_det_ref,3) - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) @@ -247,8 +247,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) aorb = list_act(a) if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -258,7 +258,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -280,7 +280,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) & @@ -308,7 +308,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a @@ -350,7 +350,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,1) - active_int(borb,2) ) else @@ -396,7 +396,7 @@ end subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb,s,sorb integer :: ispin,jspin @@ -413,8 +413,8 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer :: kspin,degree_scalar @@ -422,13 +422,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) do r = 1, n_virt_orb ! First virtual @@ -443,13 +443,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -510,7 +510,7 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) do jdet = 1, idx(0) ! if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha aorb = (exc(1,2,1)) !!! a^{\dagger}_a @@ -522,24 +522,24 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) jspin = 2 endif - call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) if(degree_scalar .ne. 2)then print*, 'pb !!!' print*, degree_scalar - call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(psi_ref(1,1,idx(jdet)),N_int) call debug_det(det_tmp,N_int) stop endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) double precision :: hij_test hij_test = 0.d0 - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) do state_target = 1, N_states matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) enddo else hij_test = 0.d0 - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij_test) do state_target = 1, N_states matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) enddo @@ -556,7 +556,7 @@ end subroutine give_1p_sec_order_singles_contrib(matrix_1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1p(N_det,N_det,*) + double precision , intent(inout) :: matrix_1p(N_det_ref,N_det_ref,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb,s,sorb integer :: ispin,jspin @@ -572,8 +572,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) integer :: accu_elec double precision :: get_mo_bielec_integral double precision :: hij,phase - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) integer :: istate double precision :: hja,delta_e_act_virt(N_states) integer :: kspin,degree_scalar @@ -581,13 +581,13 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) do i = 1, n_act_orb ! First active iorb = list_act(i) do r = 1, n_virt_orb ! First virtual @@ -601,8 +601,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation active -- > virtual call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok) @@ -619,7 +619,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) enddo cycle endif - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -681,10 +681,10 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) enddo - do jdet = 1,N_det + do jdet = 1,N_det_ref double precision :: coef_array(N_states),hij_test - call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono) - call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) + call i_H_j(det_tmp,psi_ref(1,1,jdet),N_int,himono) + call get_delta_e_dyall(psi_ref(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) do state_target = 1, N_states ! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1) matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target) @@ -702,7 +702,7 @@ end subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb integer :: ispin,jspin @@ -715,8 +715,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2) @@ -730,8 +730,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -741,8 +741,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - fock_virt_total_spin_trace(rorb,j) enddo - do idet = 1, N_det - call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_double_alpha_beta(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations do ispin = 1, 2 @@ -752,8 +752,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) do b = 1, n_act_orb borb = list_act(b) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin)) integer :: i_ok,corb,dorb @@ -784,7 +784,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) pert_det(inint,2,a,b,ispin) = det_tmp(inint,2) enddo - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hidouble) do state_target = 1, N_states delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target) pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target) @@ -795,7 +795,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) enddo do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) integer :: c,d,state_target integer(bit_kind) :: det_tmp_bis(N_int,2) ! excitation from I --> J @@ -815,8 +815,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2) enddo double precision :: hjdouble_1,hjdouble_2 - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) do state_target = 1, N_states matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 ) enddo diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 55e8aefb..bd31dc1d 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -380,32 +380,46 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo else if (n_holes_act == 1 .and. n_particles_act == 2) then - ! First find the particle that has been added from the inactive - ! - integer :: spin_hole_inact, spin_hole_part_act - spin_hole_inact = list_holes_inact(1,2) - + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! first particle + kspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + ! first particle + jspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + do i_state = 1, N_states + delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,kspin,jspin,ispin,i_state) + enddo + + +! ! First find the particle that has been added from the inactive +! ! +! integer :: spin_hole_inact, spin_hole_part_act +! spin_hole_inact = list_holes_inact(1,2) +! ! ! by convention, you first make a movement in the cas ! ! first hole - i_hole_act = hole_list_practical(2,1) - if(particle_list_practical(1,1) == spin_hole_inact)then +! i_hole_act = hole_list_practical(2,1) +! if(particle_list_practical(1,1) == spin_hole_inact)then ! ! first particle - i_particle_act = particle_list_practical(2,2) +! i_particle_act = particle_list_practical(1,2) ! ! second particle - j_particle_act = particle_list_practical(1,2) - else if (particle_list_practical(1,2) == spin_hole_inact)then +! j_particle_act = particle_list_practical(2,2) +! else if (particle_list_practical(1,2) == spin_hole_inact)then ! ! first particle - i_particle_act = particle_list_practical(1,2) +! i_particle_act = particle_list_practical(2,2) ! ! second particle - j_particle_act = particle_list_practical(2,2) - else - print*, 'pb in n_holes_act == 1 .and. n_particles_act == 2 !!' - stop - endif +! j_particle_act = particle_list_practical(1,2) +! else +! print*, 'pb in n_holes_act == 1 .and. n_particles_act == 2 !!' +! stop +! endif - do i_state = 1, N_states - delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,i_state) - enddo +! do i_state = 1, N_states +! delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,i_state) +! enddo else if (n_holes_act == 3 .and. n_particles_act == 0) then ! first hole @@ -466,6 +480,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state) enddo !write(*,'(100(f16.10,X))'), delta_e_final(1) , delta_e_act(1) , delta_e_inactive(1) , delta_e_virt(1) +!write(*,'(100(f16.10,X))'), delta_e_final(2) , delta_e_act(2) , delta_e_inactive(2) , delta_e_virt(2) end @@ -697,31 +712,18 @@ subroutine get_delta_e_dyall_fast(det_1,det_2,delta_e_final) enddo else if (n_holes_act == 1 .and. n_particles_act == 2) then - ! First find the particle that has been added from the inactive - ! - integer :: spin_hole_inact, spin_hole_part_act - spin_hole_inact = list_holes_inact(1,2) - -! ! by convention, you first make a movement in the cas -! ! first hole - i_hole_act = hole_list_practical(2,1) - if(particle_list_practical(1,1) == spin_hole_inact)then -! ! first particle - i_particle_act = particle_list_practical(2,2) -! ! second particle - j_particle_act = particle_list_practical(1,2) - else if (particle_list_practical(1,2) == spin_hole_inact)then -! ! first particle - i_particle_act = particle_list_practical(1,2) -! ! second particle - j_particle_act = particle_list_practical(2,2) - else - print*, 'pb in n_holes_act == 1 .and. n_particles_act == 2 !!' - stop - endif + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! first particle + kspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + ! first particle + jspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) do i_state = 1, N_states - delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,i_state) + delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,kspin,jspin,ispin,i_state) enddo else if (n_holes_act == 3 .and. n_particles_act == 0) then @@ -782,7 +784,7 @@ subroutine get_delta_e_dyall_fast(det_1,det_2,delta_e_final) do i_state = 1, n_states delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state) enddo -!write(*,'(100(f16.10,X))'), delta_e_final(1) , delta_e_act(1) , delta_e_inactive(1) , delta_e_virt(1) +!write(*,'(100(f16.10,X))'), delta_e_final(2) , delta_e_act(2) , delta_e_inactive(2) , delta_e_virt(2) end From de209b3fa85b04f4498dac2df96b571b2ba9a48c Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 3 Feb 2017 11:51:22 +0100 Subject: [PATCH 72/76] pouet --- plugins/MRPT/MRPT_Utils.main.irp.f | 9 ++- plugins/MRPT/print_1h2p.irp.f | 18 +++-- plugins/MRPT_Utils/EZFIO.cfg | 13 ++++ plugins/MRPT_Utils/energies_cas.irp.f | 7 ++ plugins/MRPT_Utils/ezfio_interface.irp.f | 38 +++++++++++ plugins/MRPT_Utils/mrpt_dress.irp.f | 18 ++--- plugins/MRPT_Utils/mrpt_utils.irp.f | 76 +++++++++++++++++---- plugins/MRPT_Utils/new_way.irp.f | 60 ++++++++-------- plugins/MRPT_Utils/psi_active_prov.irp.f | 2 +- plugins/Psiref_CAS/psi_ref.irp.f | 11 +++ plugins/loc_cele/loc.f | 2 +- plugins/loc_cele/loc_cele.irp.f | 41 +++++++---- plugins/loc_cele/loc_exchange_int_act.irp.f | 9 +-- src/Integrals_Monoelec/pot_ao_ints.irp.f | 2 +- 14 files changed, 227 insertions(+), 79 deletions(-) diff --git a/plugins/MRPT/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f index e5d925a3..af3713c5 100644 --- a/plugins/MRPT/MRPT_Utils.main.irp.f +++ b/plugins/MRPT/MRPT_Utils.main.irp.f @@ -19,8 +19,8 @@ subroutine routine_3 do i = 1, N_States print*,'State',i write(*,'(A12,X,I3,A3,XX,F16.10)') ' PT2 ', i,' = ', second_order_pt_new(i) - write(*,'(A12,X,I3,A3,XX,F16.09)') ' E ', i,' = ', CI_energy(i) - write(*,'(A12,X,I3,A3,XX,F16.09)') ' E+PT2 ', i,' = ', CI_energy(i)+second_order_pt_new(i) + write(*,'(A12,X,I3,A3,XX,F16.09)') ' E ', i,' = ', psi_ref_average_value(i) + write(*,'(A12,X,I3,A3,XX,F16.09)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i) write(*,'(A12,X,I3,A3,XX,F16.09)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i) write(*,'(A12,X,I3,A3,XX,F16.09)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) print*,'coef before and after' @@ -28,6 +28,11 @@ subroutine routine_3 print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i) enddo enddo + if(save_heff_eigenvectors)then + call save_wavefunction_general(N_det_ref,N_states_diag_heff,psi_ref,N_det_ref,CI_dressed_pt2_new_eigenvectors) + endif +! print*, 'neutral = ',psi_ref_coef(1,1),CI_dressed_pt2_new_eigenvectors(1,1) +! print*, 'ionic = ',psi_ref_coef(3,1),CI_dressed_pt2_new_eigenvectors(3,1) end diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f index 2739340b..85ddcda8 100644 --- a/plugins/MRPT/print_1h2p.irp.f +++ b/plugins/MRPT/print_1h2p.irp.f @@ -9,11 +9,19 @@ subroutine routine_2 implicit none integer :: i,j,degree double precision :: hij -!provide one_creat_virt - do i =1, n_act_orb - write(*,'(I3,x,100(F16.10,X))')i,one_creat(i,:,1) -! write(*,'(I3,x,100(F16.10,X))')i,one_anhil_one_creat(1,4,1,2,1) -! + do i =1, n_core_inact_orb + write(*,'(I3,x,100(F16.10,X))')list_core_inact(i),fock_core_inactive_total_spin_trace(list_core_inact(i),1) + enddo + print*,'' + do i =1, n_virt_orb + write(*,'(I3,x,100(F16.10,X))')list_virt(i),fock_virt_total_spin_trace(list_virt(i),1) + enddo + stop + do i = 1, n_virt_orb + do j = 1, n_inact_orb + if(dabs(one_anhil_one_creat_inact_virt(j,i,1)) .lt. 1.d-10)cycle + write(*,'(I3,x,I3,X,100(F16.10,X))')list_virt(i),list_inact(j),one_anhil_one_creat_inact_virt(j,i,1) + enddo enddo diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg index 948aa735..db7b127a 100644 --- a/plugins/MRPT_Utils/EZFIO.cfg +++ b/plugins/MRPT_Utils/EZFIO.cfg @@ -5,6 +5,13 @@ interface: ezfio,provider,ocaml default: True +[save_heff_eigenvectors] +type: logical +doc: If true, you save the eigenvectors of the effective hamiltonian +interface: ezfio,provider,ocaml +default: False + + [pure_state_specific_mrpt2] type: logical doc: If true, diagonalize the dressed matrix for each state and do a state following of the initial states @@ -12,3 +19,9 @@ interface: ezfio,provider,ocaml default: True +[N_states_diag_heff] +type: States_number +doc: Number of eigenvectors obtained with the effective hamiltonian +interface: ezfio,provider,ocaml +default: 1 + diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index 8f6a7eb6..f8782bec 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -617,6 +617,9 @@ END_PROVIDER thresh_norm = 1.d-20 +!do i = 1, N_det_ref +! print*, psi_ref_coef(i,1) +!enddo do vorb = 1,n_virt_orb @@ -645,6 +648,10 @@ END_PROVIDER double precision :: coef,contrib coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) psi_in_out_coef(i,j) = coef * hij +! if(vorb == 1.and. iorb == 1)then +! if(vorb == 1.and. iorb == 3)then +! print*, i,hij,coef +! endif norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo enddo diff --git a/plugins/MRPT_Utils/ezfio_interface.irp.f b/plugins/MRPT_Utils/ezfio_interface.irp.f index ebe0bf52..91c7ea63 100644 --- a/plugins/MRPT_Utils/ezfio_interface.irp.f +++ b/plugins/MRPT_Utils/ezfio_interface.irp.f @@ -22,6 +22,44 @@ BEGIN_PROVIDER [ logical, do_third_order_1h1p ] END_PROVIDER +BEGIN_PROVIDER [ logical, save_heff_eigenvectors ] + implicit none + BEGIN_DOC +! If true, you save the eigenvectors of the effective hamiltonian + END_DOC + + logical :: has + PROVIDE ezfio_filename + + call ezfio_has_mrpt_utils_save_heff_eigenvectors(has) + if (has) then + call ezfio_get_mrpt_utils_save_heff_eigenvectors(save_heff_eigenvectors) + else + print *, 'mrpt_utils/save_heff_eigenvectors not found in EZFIO file' + stop 1 + endif + +END_PROVIDER + +BEGIN_PROVIDER [ integer, n_states_diag_heff ] + implicit none + BEGIN_DOC +! Number of eigenvectors obtained with the effective hamiltonian + END_DOC + + logical :: has + PROVIDE ezfio_filename + + call ezfio_has_mrpt_utils_n_states_diag_heff(has) + if (has) then + call ezfio_get_mrpt_utils_n_states_diag_heff(n_states_diag_heff) + else + print *, 'mrpt_utils/n_states_diag_heff not found in EZFIO file' + stop 1 + endif + +END_PROVIDER + BEGIN_PROVIDER [ logical, pure_state_specific_mrpt2 ] implicit none BEGIN_DOC diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index f241d35a..1fd8cb03 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -117,19 +117,15 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip do i_state = 1, N_states delta_e(i_state) = 1.d+20 enddo - !else if(degree_scalar== 1)then else call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) - !if(dabs(delta_e(2)) .le. dabs(0.01d0))then - !print*, delta_e(2) - !call debug_det(psi_ref(1,1,index_i),N_int) - !call debug_det(tq(1,1,i_alpha),N_int) - !endif - - !else - !do i_state = 1, N_states - ! delta_e(i_state) = 1.d+20 - !enddo + + ! !!!!!!!!!!!!! SHIFTED BK + ! double precision :: hjj + ! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj) + ! delta_e(1) = CI_electronic_energy(1) - hjj + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + endif hij_array(index_i) = hialpha do i_state = 1,N_states diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 09efc536..35940404 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -48,6 +48,8 @@ do i = 1, N_det_ref write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) do j = 1, N_det_ref +! print*, accu +! print*,delta_ij_tmp(j,i,i_state) , psi_ref_coef(i,i_state) , psi_ref_coef(j,i_state) accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo @@ -65,11 +67,41 @@ write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) do j = 1, N_det_ref accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo + double precision :: accu_diag,accu_non_diag + accu_diag = 0.d0 + accu_non_diag = 0.d0 + do i = 1, N_det_ref + accu_diag += delta_ij_tmp(i,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(i,i_state) + do j = 1, N_det_ref + if(i == j)cycle + accu_non_diag += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + enddo + enddo second_order_pt_new_1h1p(i_state) = accu(i_state) enddo + !double precision :: neutral, ionic + !neutral = 0.d0 + !do i = 1, 2 + ! do j = 1, N_det_ref + ! neutral += psi_ref_coef(j,1) * delta_ij_tmp(j,i,1) * psi_ref_coef(i,1) + ! enddo + !enddo + !do i = 3, 4 + ! do j = 1, N_det_ref + ! ionic += psi_ref_coef(j,1) * delta_ij_tmp(j,i,1) * psi_ref_coef(i,1) + ! enddo + !enddo + !neutral = delta_ij_tmp(1,1,1) * psi_ref_coef(1,1)**2 + delta_ij_tmp(2,2,1) * psi_ref_coef(2,1)**2 & + ! + delta_ij_tmp(1,2,1) * psi_ref_coef(1,1)* psi_ref_coef(2,1) + delta_ij_tmp(2,1,1) * psi_ref_coef(1,1)* psi_ref_coef(2,1) + !ionic = delta_ij_tmp(3,3,1) * psi_ref_coef(3,1)**2 + delta_ij_tmp(4,4,1) * psi_ref_coef(4,1)**2 & + ! + delta_ij_tmp(3,4,1) * psi_ref_coef(3,1)* psi_ref_coef(4,1) + delta_ij_tmp(4,3,1) * psi_ref_coef(3,1)* psi_ref_coef(4,1) + !neutral = delta_ij_tmp(1,1,1) + !ionic = delta_ij_tmp(3,3,1) + !print*, 'neutral = ',neutral + !print*, 'ionic = ',ionic print*, '1h1p = ',accu ! 1h1p third order @@ -167,6 +199,22 @@ second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) enddo print*, '2h2p = ',contrib_2h2p(:) + + !! 2h2p old fashion + !delta_ij_tmp = 0.d0 + !call H_apply_mrpt_2h2p(delta_ij_tmp,N_det_ref) + !accu = 0.d0 + !do i_state = 1, N_states + !do i = 1, N_det_ref + ! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + ! do j = 1, N_det_ref + ! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + ! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + ! enddo + !enddo + !second_order_pt_new_2h2p(i_state) = accu(i_state) + !enddo + !print*, '2h2p = ',accu ! total @@ -234,6 +282,8 @@ END_PROVIDER implicit none integer :: i,j,i_state double precision :: hij + double precision :: accu(N_states) + accu = 0.d0 do i_state = 1, N_states do i = 1,N_det_ref do j = 1,N_det_ref @@ -241,14 +291,16 @@ END_PROVIDER Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = hij & + 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) ) ! Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) + accu(i_State) += psi_ref_coef(i,i_State) * Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) * psi_ref_coef(j,i_State) enddo enddo enddo + print*, 'accu = ',accu + nuclear_repulsion END_PROVIDER - BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ] - &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det_ref,N_states_diag) ] - &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ] + BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag_heff) ] + &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det_ref,N_states_diag_heff) ] + &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag_heff) ] BEGIN_DOC ! Eigenvectors/values of the CI matrix END_DOC @@ -269,14 +321,14 @@ END_PROVIDER double precision :: overlap(N_det_ref) double precision, allocatable :: psi_tmp(:) - ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors + ! Guess values for the "N_states_diag_heff" states of the CI_dressed_pt2_new_eigenvectors do j=1,min(N_states,N_det_ref) do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,j) = psi_ref_coef(i,j) enddo enddo - do j=min(N_states,N_det_ref)+1,N_states_diag + do j=min(N_states,N_det_ref)+1,N_states_diag_heff do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0 enddo @@ -408,13 +460,13 @@ END_PROVIDER print*,'' print*,'!!!!!!!! WARNING !!!!!!!!!' print*,' Within the ',N_det_ref,'determinants selected' - print*,' and the ',N_states_diag,'states requested' + print*,' and the ',N_states_diag_heff,'states requested' print*,' We did not find any state with S^2 values close to ',expected_s2 print*,' We will then set the first N_states eigenvectors of the H matrix' print*,' as the CI_dressed_pt2_new_eigenvectors' print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' print*,'' - do j=1,min(N_states_diag,N_det_ref) + do j=1,min(N_states_diag_heff,N_det_ref) do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo @@ -426,8 +478,8 @@ END_PROVIDER deallocate(s2_eigvalues) else call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det_ref,psi_det,N_int,& - min(N_det_ref,N_states_diag),size(eigenvectors,1)) - ! Select the "N_states_diag" states of lowest energy + min(N_det_ref,N_states_diag_heff),size(eigenvectors,1)) + ! Select the "N_states_diag_heff" states of lowest energy do j=1,min(N_det_ref,N_states) do i=1,N_det_ref CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) @@ -444,7 +496,7 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] +BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag_heff) ] implicit none BEGIN_DOC ! N_states lowest eigenvalues of the CI matrix @@ -453,7 +505,7 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] integer :: j character*(8) :: st call write_time(output_determinants) - do j=1,N_states_diag + do j=1,N_states_diag_heff CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion write(st,'(I4)') j call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st)) diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index dc921551..3cfa7154 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -499,9 +499,9 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) do r = 1, n_virt_orb ! First virtual rorb = list_virt(r) do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do state_target = 1, N_states - coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) - enddo + !do state_target = 1, N_states + ! coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) + !enddo do inint = 1, N_int det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) @@ -509,34 +509,34 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) enddo do jdet = 1, idx(0) ! - if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - aorb = (exc(1,2,1)) !!! a^{\dagger}_a - borb = (exc(1,1,1)) !!! a_{b} - jspin = 1 - else - aorb = (exc(1,2,2)) !!! a^{\dagger}_a - borb = (exc(1,1,2)) !!! a_{b} - jspin = 2 - endif - - call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) - if(degree_scalar .ne. 2)then - print*, 'pb !!!' - print*, degree_scalar - call debug_det(psi_ref(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - stop - endif - call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) double precision :: hij_test - hij_test = 0.d0 - call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) - do state_target = 1, N_states - matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) - enddo + if(idx(jdet).ne.idet)then + ! call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) + ! if (exc(0,1,1) == 1) then + ! ! Mono alpha + ! aorb = (exc(1,2,1)) !!! a^{\dagger}_a + ! borb = (exc(1,1,1)) !!! a_{b} + ! jspin = 1 + ! else + ! aorb = (exc(1,2,2)) !!! a^{\dagger}_a + ! borb = (exc(1,1,2)) !!! a_{b} + ! jspin = 2 + ! endif + ! + ! call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + ! if(degree_scalar .ne. 2)then + ! print*, 'pb !!!' + ! print*, degree_scalar + ! call debug_det(psi_ref(1,1,idx(jdet)),N_int) + ! call debug_det(det_tmp,N_int) + ! stop + ! endif + ! call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + ! hij_test = 0.d0 + ! call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) + ! do state_target = 1, N_states + ! matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) + ! enddo else hij_test = 0.d0 call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij_test) diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index bd31dc1d..95f7479e 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -468,7 +468,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) endif else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then do i = 1, N_states - delta_e_act(i_state) = -10000000.d0 + delta_e_act(i_state) = -1.d12 enddo endif diff --git a/plugins/Psiref_CAS/psi_ref.irp.f b/plugins/Psiref_CAS/psi_ref.irp.f index d3b6c28f..0729a540 100644 --- a/plugins/Psiref_CAS/psi_ref.irp.f +++ b/plugins/Psiref_CAS/psi_ref.irp.f @@ -67,3 +67,14 @@ END_PROVIDER END_PROVIDER + + BEGIN_PROVIDER [double precision, electronic_psi_ref_average_value, (N_states)] +&BEGIN_PROVIDER [double precision, psi_ref_average_value, (N_states)] + implicit none + integer :: i,j + call u_0_H_u_0(electronic_psi_ref_average_value,psi_ref_coef,N_det_ref,psi_ref,N_int,N_states,psi_det_size) + do i = 1, N_states + psi_ref_average_value(i) = electronic_psi_ref_average_value(i) + nuclear_repulsion + enddo + +END_PROVIDER diff --git a/plugins/loc_cele/loc.f b/plugins/loc_cele/loc.f index edc3aa7a..ed8b9a76 100644 --- a/plugins/loc_cele/loc.f +++ b/plugins/loc_cele/loc.f @@ -18,7 +18,7 @@ C zprt=.true. niter=1000000 - conv=1.d-8 + conv=1.d-10 C niter=1000000 C conv=1.d-6 diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index 2d47c633..2dda522e 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -101,10 +101,27 @@ cmoref = 0.d0 irot = 0 - irot(1,1) = 11 - irot(2,1) = 12 - cmoref(15,1,1) = 1.d0 ! - cmoref(14,2,1) = 1.d0 ! + irot(1,1) = 5 + irot(2,1) = 6 + cmoref(6,1,1) = 1d0 + cmoref(26,2,1) = 1d0 + +! !!! H2O +! irot(1,1) = 4 +! irot(2,1) = 5 +! irot(3,1) = 6 +! irot(4,1) = 7 +! ! O pz +! cmoref(5,1,1) = 1.55362d0 +! cmoref(6,1,1) = 1.07578d0 + +! cmoref(5,2,1) = 1.55362d0 +! cmoref(6,2,1) = -1.07578d0 +! ! O px - pz +! ! H1 +! cmoref(16,3,1) = 1.d0 +! ! H1 +! cmoref(21,4,1) = 1.d0 ! ESATRIENE with 3 bonding and anti bonding orbitals ! First bonding orbital for esa @@ -150,19 +167,19 @@ ! ESATRIENE with 1 central bonding and anti bonding orbitals ! AND 4 radical orbitals ! First radical orbital - cmoref(7,1,1) = 1.d0 ! +! cmoref(7,1,1) = 1.d0 ! ! Second radical orbital - cmoref(26,2,1) = 1.d0 ! +! cmoref(26,2,1) = 1.d0 ! ! First bonding orbital - cmoref(45,3,1) = 1.d0 ! - cmoref(64,3,1) = 1.d0 ! +! cmoref(45,3,1) = 1.d0 ! +! cmoref(64,3,1) = 1.d0 ! ! Third radical orbital for esa - cmoref(83,4,1) = 1.d0 ! +! cmoref(83,4,1) = 1.d0 ! ! Fourth radical orbital for esa - cmoref(102,5,1) = 1.d0 ! +! cmoref(102,5,1) = 1.d0 ! ! First anti bonding orbital - cmoref(45,6,1) = 1.d0 ! - cmoref(64,6,1) =-1.d0 ! +! cmoref(45,6,1) = 1.d0 ! +! cmoref(64,6,1) =-1.d0 ! do i = 1, nrot(1) diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f index f332dd5d..c4dcf75c 100644 --- a/plugins/loc_cele/loc_exchange_int_act.irp.f +++ b/plugins/loc_cele/loc_exchange_int_act.irp.f @@ -19,16 +19,17 @@ program loc_int do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + if(list_core_inact_check(jorb) == .False.)then + exchange_int(jorb) = 0.d0 + else + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + endif enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' diff --git a/src/Integrals_Monoelec/pot_ao_ints.irp.f b/src/Integrals_Monoelec/pot_ao_ints.irp.f index 7116d2c7..aef8a060 100644 --- a/src/Integrals_Monoelec/pot_ao_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_ints.irp.f @@ -185,7 +185,7 @@ include 'Utils/constants.include.F' enddo const_factor = dist*rho const = p * dist_integral - if(const_factor > 80.d0)then + if(const_factor > 1000.d0)then NAI_pol_mult = 0.d0 return endif From 4e0c71df10ccf6653fbc802692e6bba4f663965f Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 6 Feb 2017 21:28:01 +0100 Subject: [PATCH 73/76] density based mrpt2 --- plugins/MRPT/print_1h2p.irp.f | 7 +- plugins/MRPT_Utils/density_matrix_based.irp.f | 193 +++++++++++++++++ plugins/MRPT_Utils/energies_cas.irp.f | 28 ++- plugins/MRPT_Utils/excitations_cas.irp.f | 9 +- plugins/MRPT_Utils/mrpt_dress.irp.f | 17 +- plugins/MRPT_Utils/mrpt_utils.irp.f | 64 +++--- plugins/MRPT_Utils/new_way.irp.f | 5 +- plugins/MRPT_Utils/psi_active_prov.irp.f | 1 + src/Determinants/density_matrix.irp.f | 51 +++++ src/Determinants/two_body_dm_map.irp.f | 199 ++++-------------- 10 files changed, 367 insertions(+), 207 deletions(-) create mode 100644 plugins/MRPT_Utils/density_matrix_based.irp.f diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f index 85ddcda8..b9f6575b 100644 --- a/plugins/MRPT/print_1h2p.irp.f +++ b/plugins/MRPT/print_1h2p.irp.f @@ -2,7 +2,7 @@ program print_1h2p implicit none read_wf = .True. touch read_wf - call routine_2 + call routine end subroutine routine_2 @@ -35,7 +35,8 @@ subroutine routine integer :: i,j,istate accu = 0.d0 matrix_1h2p = 0.d0 - call H_apply_mrpt_2p(matrix_1h2p,N_det_ref) +!call H_apply_mrpt_1h2p(matrix_1h2p,N_det_ref) + call give_1h2p_contrib(matrix_1h2p) do istate = 1, N_states do i = 1, N_det do j = 1, N_det @@ -44,6 +45,8 @@ subroutine routine enddo print*,accu(istate) enddo + call contrib_1h2p_dm_based(accu) + print*,accu(:) deallocate (matrix_1h2p) end diff --git a/plugins/MRPT_Utils/density_matrix_based.irp.f b/plugins/MRPT_Utils/density_matrix_based.irp.f new file mode 100644 index 00000000..ac135807 --- /dev/null +++ b/plugins/MRPT_Utils/density_matrix_based.irp.f @@ -0,0 +1,193 @@ +subroutine contrib_1h2p_dm_based(accu) + implicit none + integer :: i_i,i_r,i_v,i_a,i_b + integer :: i,r,v,a,b + integer :: ispin,jspin + integer :: istate + double precision, intent(out) :: accu(N_states) + double precision :: active_int(n_act_orb,2) + double precision :: delta_e(n_act_orb,2,N_states) + double precision :: get_mo_bielec_integral + accu = 0.d0 +!do i_i = 1, 1 + do i_i = 1, n_inact_orb + i = list_inact(i_i) +! do i_r = 1, 1 + do i_r = 1, n_virt_orb + r = list_virt(i_r) +! do i_v = 1, 1 + do i_v = 1, n_virt_orb + v = list_virt(i_v) + do i_a = 1, n_act_orb + a = list_act(i_a) + active_int(i_a,1) = get_mo_bielec_integral(i,a,r,v,mo_integrals_map) ! direct + active_int(i_a,2) = get_mo_bielec_integral(i,a,v,r,mo_integrals_map) ! exchange + do istate = 1, N_states + do jspin=1, 2 + delta_e(i_a,jspin,istate) = one_anhil(i_a,jspin,istate) & + - fock_virt_total_spin_trace(r,istate) & + - fock_virt_total_spin_trace(v,istate) & + + fock_core_inactive_total_spin_trace(i,istate) + delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) + enddo + enddo + enddo + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb +! do i_b = i_a, i_a + b = list_act(i_b) + do ispin = 1, 2 ! spin of (i --> r) + do jspin = 1, 2 ! spin of (a --> v) + if(ispin == jspin .and. r.le.v)cycle ! condition not to double count + do istate = 1, N_states + if(ispin == jspin)then + accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_mo_spin_index(a,b,istate,ispin) & + * (active_int(i_b,1) - active_int(i_b,2)) & + * delta_e(i_a,jspin,istate) + else + accu(istate) += active_int(i_a,1) * one_body_dm_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & + * active_int(i_b,1) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + +end + +subroutine contrib_2h1p_dm_based(accu) + implicit none + integer :: i_i,i_j,i_v,i_a,i_b + integer :: i,j,v,a,b + integer :: ispin,jspin + integer :: istate + double precision, intent(out) :: accu(N_states) + double precision :: active_int(n_act_orb,2) + double precision :: delta_e(n_act_orb,2,N_states) + double precision :: get_mo_bielec_integral + accu = 0.d0 + do i_i = 1, n_inact_orb + i = list_inact(i_i) + do i_j = 1, n_inact_orb + j = list_inact(i_j) + do i_v = 1, n_virt_orb + v = list_virt(i_v) + do i_a = 1, n_act_orb + a = list_act(i_a) + active_int(i_a,1) = get_mo_bielec_integral(i,j,v,a,mo_integrals_map) ! direct + active_int(i_a,2) = get_mo_bielec_integral(i,j,a,v,mo_integrals_map) ! exchange + do istate = 1, N_states + do jspin=1, 2 +! delta_e(i_a,jspin,istate) = +! + delta_e(i_a,jspin,istate) = one_creat(i_a,jspin,istate) - fock_virt_total_spin_trace(v,istate) & + + fock_core_inactive_total_spin_trace(i,istate) & + + fock_core_inactive_total_spin_trace(j,istate) + delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) + enddo + enddo + enddo + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb +! do i_b = i_a, i_a + b = list_act(i_b) + do ispin = 1, 2 ! spin of (i --> v) + do jspin = 1, 2 ! spin of (j --> a) + if(ispin == jspin .and. i.le.j)cycle ! condition not to double count + do istate = 1, N_states + if(ispin == jspin)then + accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) & + * (active_int(i_b,1) - active_int(i_b,2)) & + * delta_e(i_a,jspin,istate) + else + accu(istate) += active_int(i_a,1) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & + * active_int(i_b,1) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + +end + + +subroutine contrib_2p_dm_based(accu) + implicit none + integer :: i_r,i_v,i_a,i_b,i_c,i_d + integer :: r,v,a,b,c,d + integer :: ispin,jspin + integer :: istate + double precision, intent(out) :: accu(N_states) + double precision :: active_int(n_act_orb,n_act_orb,2) + double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) + double precision :: get_mo_bielec_integral + accu = 0.d0 + do i_r = 1, n_virt_orb + r = list_virt(i_r) + do i_v = 1, n_virt_orb + v = list_virt(i_v) + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb + b = list_act(i_b) + active_int(i_a,i_b,1) = get_mo_bielec_integral(a,b,r,v,mo_integrals_map) ! direct + active_int(i_a,i_b,2) = get_mo_bielec_integral(a,b,v,r,mo_integrals_map) ! direct + do istate = 1, N_states + do jspin=1, 2 ! spin of i_a + do ispin = 1, 2 ! spin of i_b + delta_e(i_a,i_b,jspin,ispin,istate) = two_anhil(i_a,i_b,jspin,ispin,istate) & + - fock_virt_total_spin_trace(r,istate) & + - fock_virt_total_spin_trace(v,istate) + delta_e(i_a,i_b,jspin,ispin,istate) = 1.d0/delta_e(i_a,i_b,jspin,ispin,istate) + enddo + enddo + enddo + enddo + enddo + ! diagonal terms + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb + b = list_act(i_b) + do ispin = 1, 2 ! spin of (a --> r) + do jspin = 1, 2 ! spin of (b --> v) + if(ispin == jspin .and. r.le.v)cycle ! condition not to double count + if(ispin == jspin .and. a.le.b)cycle ! condition not to double count + do istate = 1, N_states + if(ispin == jspin)then + double precision :: contrib_spin + if(ispin == 1)then + contrib_spin = two_body_dm_aa_diag_act(i_a,i_b) + else + contrib_spin = two_body_dm_bb_diag_act(i_a,i_b) + endif + accu(istate) += (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) * contrib_spin & + * (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) & + * delta_e(i_a,i_b,ispin,jspin,istate) + else + accu(istate) += 0.5d0 * active_int(i_a,i_b,1) * two_body_dm_ab_diag_act(i_a,i_b) * delta_e(i_a,i_b,ispin,jspin,istate) & + * active_int(i_a,i_b,1) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + +end + diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index f8782bec..563b4bdf 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -648,10 +648,11 @@ END_PROVIDER double precision :: coef,contrib coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) psi_in_out_coef(i,j) = coef * hij -! if(vorb == 1.and. iorb == 1)then -! if(vorb == 1.and. iorb == 3)then -! print*, i,hij,coef -! endif + if(orb_i == 5 .and. orb_v == 20)then +! if(orb_i == 2 .and. orb_v == 6 )then + print*, i, ispin + print*, coef * hij,coef,hij + endif norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo enddo @@ -664,6 +665,10 @@ END_PROVIDER norm_no_inv(j,ispin) = norm(j,ispin) one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 1.d0 / norm(j,ispin) norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) + if(orb_i == 5 .and. orb_v == 20)then +! if(orb_i == 2 .and. orb_v == 6 )then + print*,ispin ,norm(j,ispin) + endif endif enddo do i = 1, N_det_ref @@ -679,21 +684,32 @@ END_PROVIDER do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then -! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) + if(orb_i == 5 .and. orb_v == 20)then +! if(orb_i == 2 .and. orb_v == 6 )then + print*, ispin, energy_cas_dyall_no_exchange(1) , energies_alpha_beta(state_target, ispin) + print*, ispin, energy_cas_dyall_no_exchange(1) - energies_alpha_beta(state_target, ispin) + endif endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then -! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall(state_target) - & one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.d0 endif + if(dabs(dabs(one_anhil_one_creat_inact_virt(iorb,vorb,state_target)) - 1.30584271462d0) < 1.d-11)then + print*, orb_i,orb_v + print*, energy_cas_dyall_no_exchange(1) - energies_alpha_beta(state_target,1) / norm_bis(state_target,1) + print*, energy_cas_dyall_no_exchange(1) - energies_alpha_beta(state_target,2) / norm_bis(state_target,2) + print*, fock_core_inactive_total_spin_trace(orb_i,1) + print*, fock_virt_total_spin_trace(orb_v,1) + print*, one_anhil_one_creat_inact_virt(iorb,vorb,state_target) + endif enddo enddo enddo diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 6028d4fa..768abe8c 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -774,6 +774,7 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) case (0) hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint) +! hij = 0.d0 end select end @@ -798,7 +799,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! alpha - alpha do i = 1, elec_num_tab_local(1) iorb = occ(i,1) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) do j = i+1, elec_num_tab_local(1) jorb = occ(j,1) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -808,7 +809,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! beta - beta do i = 1, elec_num_tab_local(2) iorb = occ(i,2) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) do j = i+1, elec_num_tab_local(2) jorb = occ(j,2) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -826,6 +827,8 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) enddo +! return + ! alpha - core-act do i = 1, elec_num_tab_local(1) iorb = occ(i,1) @@ -833,6 +836,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) +! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(1) enddo enddo @@ -843,6 +847,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) +! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(2) enddo enddo diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index 1fd8cb03..91bb7a54 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -113,19 +113,20 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip integer :: degree_scalar call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int) +! if(degree_scalar == 2)then +! hialpha = 0.d0 +! endif if(dabs(hialpha).le.1.d-20)then do i_state = 1, N_states delta_e(i_state) = 1.d+20 enddo else call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) - - ! !!!!!!!!!!!!! SHIFTED BK - ! double precision :: hjj - ! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj) - ! delta_e(1) = CI_electronic_energy(1) - hjj - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - +! !!!!!!!!!!!!! SHIFTED BK +! double precision :: hjj +! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj) +! delta_e(1) = CI_electronic_energy(1) - hjj +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! endif hij_array(index_i) = hialpha do i_state = 1,N_states @@ -139,6 +140,8 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call omp_set_lock( psi_ref_bis_lock(index_i) ) do j = 1, idx_alpha(0) index_j = idx_alpha(j) + !!!!!!!!!!!!!!!!!! WARNING TEST + if(index_j .ne. index_i)cycle do i_state=1,N_states ! standard dressing first order delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 35940404..cc62295f 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -104,23 +104,23 @@ !print*, 'ionic = ',ionic print*, '1h1p = ',accu - ! 1h1p third order - if(do_third_order_1h1p)then - delta_ij_tmp = 0.d0 - call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det_ref - write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) - do j = 1, N_det_ref - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p(3)',accu - endif + !! 1h1p third order + !if(do_third_order_1h1p)then + ! delta_ij_tmp = 0.d0 + ! call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) + ! accu = 0.d0 + ! do i_state = 1, N_states + ! do i = 1, N_det_ref + ! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) + ! do j = 1, N_det_ref + ! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) + ! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + ! enddo + ! enddo + ! second_order_pt_new_1h1p(i_state) = accu(i_state) + ! enddo + ! print*, '1h1p(3)',accu + !endif ! 2h delta_ij_tmp = 0.d0 @@ -200,21 +200,21 @@ enddo print*, '2h2p = ',contrib_2h2p(:) - !! 2h2p old fashion - !delta_ij_tmp = 0.d0 - !call H_apply_mrpt_2h2p(delta_ij_tmp,N_det_ref) - !accu = 0.d0 - !do i_state = 1, N_states - !do i = 1, N_det_ref - ! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) - ! do j = 1, N_det_ref - ! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) - ! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - ! enddo - !enddo - !second_order_pt_new_2h2p(i_state) = accu(i_state) - !enddo - !print*, '2h2p = ',accu +! ! 2h2p old fashion +! delta_ij_tmp = 0.d0 +! call H_apply_mrpt_2h2p(delta_ij_tmp,N_det_ref) +! accu = 0.d0 +! do i_state = 1, N_states +! do i = 1, N_det_ref +! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state) +! do j = 1, N_det_ref +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +! enddo +! second_order_pt_new_2h2p(i_state) = accu(i_state) +! enddo +! print*, '2h2p = ',accu ! total diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index 3cfa7154..a007e761 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -129,6 +129,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) integer :: kspin do jdet = 1, idx(0) if(idx(jdet).ne.idet)then +! cycle ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator ! are connected by the presence of the perturbers determinants |det_tmp> aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} @@ -213,16 +214,18 @@ subroutine give_1h2p_contrib(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase !matrix_1h2p = 0.d0 - elec_num_tab_local = 0 do inint = 1, N_int elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo +!do i = 1, 1 ! First inactive do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) +! do v = 1, 1 do v = 1, n_virt_orb ! First virtual vorb = list_virt(v) +! do r = 1, 1 do r = 1, n_virt_orb ! Second virtual rorb = list_virt(r) ! take all the integral you will need for i,j,r fixed diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 95f7479e..9d0d1fc6 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -14,6 +14,7 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] psi_active(j,1,i) = iand(psi_ref(j,1,i),cas_bitmask(j,1,1)) psi_active(j,2,i) = iand(psi_ref(j,2,i),cas_bitmask(j,1,1)) enddo + call debug_det(psi_active(1,1,i),N_int) enddo END_PROVIDER diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 118bbdf7..6bafa287 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -15,6 +15,57 @@ enddo END_PROVIDER + BEGIN_PROVIDER [ double precision, one_body_dm_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] + implicit none + integer :: i,j,ispin,istate + ispin = 1 + do istate = 1, N_states + do j = 1, mo_tot_num + do i = 1, mo_tot_num + one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_alpha(i,j,istate) + enddo + enddo + enddo + + ispin = 2 + do istate = 1, N_states + do j = 1, mo_tot_num + do i = 1, mo_tot_num + one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_beta(i,j,istate) + enddo + enddo + enddo + + END_PROVIDER + + + BEGIN_PROVIDER [ double precision, one_body_dm_dagger_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] + implicit none + integer :: i,j,ispin,istate + ispin = 1 + do istate = 1, N_states + do j = 1, mo_tot_num + one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_alpha(j,j,istate) + do i = j+1, mo_tot_num + one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) + one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) + enddo + enddo + enddo + + ispin = 2 + do istate = 1, N_states + do j = 1, mo_tot_num + one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_beta(j,j,istate) + do i = j+1, mo_tot_num + one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) + one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) + enddo + enddo + enddo + + END_PROVIDER + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ] &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ] implicit none diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f index aa8f630b..bb1a341e 100644 --- a/src/Determinants/two_body_dm_map.irp.f +++ b/src/Determinants/two_body_dm_map.irp.f @@ -194,6 +194,8 @@ subroutine add_values_to_two_body_dm_map(mask_ijkl) end BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_act, (n_act_orb, n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_aa_diag_act, (n_act_orb, n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_bb_diag_act, (n_act_orb, n_act_orb)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_inact, (n_inact_orb_allocate, n_inact_orb_allocate)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_core, (n_core_orb_allocate, n_core_orb_allocate)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_all, (mo_tot_num, mo_tot_num)] @@ -234,6 +236,8 @@ end two_body_dm_ab_diag_all = 0.d0 two_body_dm_ab_diag_act = 0.d0 + two_body_dm_aa_diag_act = 0.d0 + two_body_dm_bb_diag_act = 0.d0 two_body_dm_ab_diag_core = 0.d0 two_body_dm_ab_diag_inact = 0.d0 two_body_dm_diag_core_a_act_b = 0.d0 @@ -269,8 +273,20 @@ end two_body_dm_ab_diag_act(k,m) += 0.5d0 * contrib two_body_dm_ab_diag_act(m,k) += 0.5d0 * contrib enddo + do l = 1, n_occ_ab_act(2) + m = list_act_reverse(occ_act(l,2)) + two_body_dm_bb_diag_act(k,m) += 0.5d0 * contrib + two_body_dm_bb_diag_act(m,k) += 0.5d0 * contrib + enddo + enddo + do j = 1,n_occ_ab_act(1) + k = list_act_reverse(occ_act(j,1)) + do l = 1, n_occ_ab_act(1) + m = list_act_reverse(occ_act(l,1)) + two_body_dm_aa_diag_act(k,m) += 0.5d0 * contrib + two_body_dm_aa_diag_act(m,k) += 0.5d0 * contrib + enddo enddo - ! CORE PART of the diagonal part of the two body dm do j = 1, N_int key_tmp_core(j,1) = psi_det(j,1,i) @@ -325,6 +341,8 @@ end END_PROVIDER BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_aa_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_bb_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_core_act, (n_core_orb_allocate,n_act_orb,n_act_orb)] implicit none use bitmasks @@ -394,14 +412,22 @@ END_PROVIDER call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ - if(s1==s2)cycle ! Only the alpha/beta two body density matrix ! * c_I * c_J h1 = list_act_reverse(h1) h2 = list_act_reverse(h2) p1 = list_act_reverse(p1) p2 = list_act_reverse(p2) - call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) - + if(s1==s2)then + if(s1==1)then + call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) +! call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,p2,h2,p1) + else + call insert_into_two_body_dm_big_array( two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) +! call insert_into_two_body_dm_big_array( two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,p2,h2,p1) + endif + else ! alpha/beta two body density matrix + call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) + endif else if(degree==1)then! case of the SINGLE EXCITATIONS *************************************************** print*,'h1 = ',h1 h1 = list_act_reverse(h1) @@ -417,6 +443,12 @@ END_PROVIDER ! * c_I * c_J call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) enddo + do k = 1, n_occ_ab(1) + m = list_act_reverse(occ(k,1)) + ! * c_I * c_J + call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) +! call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,m,p1,m) + enddo ! core <-> active part of the extra diagonal two body dm do k = 1, n_occ_ab_core(2) @@ -432,6 +464,12 @@ END_PROVIDER ! * c_I * c_J call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) enddo + do k = 1, n_occ_ab(2) + m = list_act_reverse(occ(k,2)) + ! * c_I * c_J + call insert_into_two_body_dm_big_array(two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) +! call insert_into_two_body_dm_big_array(two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,m,p1,m) + enddo ! core <-> active part of the extra diagonal two body dm do k = 1, n_occ_ab_core(1) @@ -464,156 +502,3 @@ subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contr end - -double precision function compute_extra_diag_two_body_dm_ab(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the alpha/bet two body density at r1, r2 - END_DOC - double precision :: r1(3), r2(3) - double precision :: compute_extra_diag_two_body_dm_ab_act,compute_extra_diag_two_body_dm_ab_core_act - compute_extra_diag_two_body_dm_ab = compute_extra_diag_two_body_dm_ab_act(r1,r2)+compute_extra_diag_two_body_dm_ab_core_act(r1,r2) -end - -double precision function compute_extra_diag_two_body_dm_ab_act(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the two body density at r1, r2 -! involving ONLY THE ACTIVE PART, which means that the four index of the excitations -! involved in the two body density matrix are ACTIVE - END_DOC - PROVIDE n_act_orb - double precision, intent(in) :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) - double precision :: contrib - double precision :: contrib_tmp -!print*,'n_act_orb = ',n_act_orb - compute_extra_diag_two_body_dm_ab_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_r1) - call give_all_act_mos_at_r(r2,mos_array_r2) - do l = 1, n_act_orb ! p2 - do k = 1, n_act_orb ! h2 - do j = 1, n_act_orb ! p1 - do i = 1,n_act_orb ! h1 - contrib_tmp = mos_array_r1(i) * mos_array_r1(j) * mos_array_r2(k) * mos_array_r2(l) - compute_extra_diag_two_body_dm_ab_act += two_body_dm_ab_big_array_act(i,j,k,l) * contrib_tmp - enddo - enddo - enddo - enddo - -end - -double precision function compute_extra_diag_two_body_dm_ab_core_act(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the two body density at r1, r2 -! involving ONLY THE ACTIVE PART, which means that the four index of the excitations -! involved in the two body density matrix are ACTIVE - END_DOC - double precision, intent(in) :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) - double precision :: mos_array_core_r1(n_core_orb),mos_array_core_r2(n_core_orb) - double precision :: contrib_core_1,contrib_core_2 - double precision :: contrib_act_1,contrib_act_2 - double precision :: contrib_tmp - compute_extra_diag_two_body_dm_ab_core_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_act_r1) - call give_all_act_mos_at_r(r2,mos_array_act_r2) - call give_all_core_mos_at_r(r1,mos_array_core_r1) - call give_all_core_mos_at_r(r2,mos_array_core_r2) - do i = 1, n_act_orb ! h1 - do j = 1, n_act_orb ! p1 - contrib_act_1 = mos_array_act_r1(i) * mos_array_act_r1(j) - contrib_act_2 = mos_array_act_r2(i) * mos_array_act_r2(j) - do k = 1,n_core_orb ! h2 - contrib_core_1 = mos_array_core_r1(k) * mos_array_core_r1(k) - contrib_core_2 = mos_array_core_r2(k) * mos_array_core_r2(k) - contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_core_2 + contrib_act_2 * contrib_core_1) - compute_extra_diag_two_body_dm_ab_core_act += two_body_dm_ab_big_array_core_act(k,i,j) * contrib_tmp - enddo - enddo - enddo - -end - -double precision function compute_diag_two_body_dm_ab_core(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_core_orb_allocate),mos_array_r2(n_core_orb_allocate) - double precision :: contrib,contrib_tmp - compute_diag_two_body_dm_ab_core = 0.d0 - call give_all_core_mos_at_r(r1,mos_array_r1) - call give_all_core_mos_at_r(r2,mos_array_r2) - do l = 1, n_core_orb ! - contrib = mos_array_r2(l)*mos_array_r2(l) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_core_orb ! - contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - compute_diag_two_body_dm_ab_core += two_body_dm_ab_diag_core(k,l) * contrib_tmp - enddo - enddo - -end - - -double precision function compute_diag_two_body_dm_ab_act(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) - double precision :: contrib,contrib_tmp - compute_diag_two_body_dm_ab_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_r1) - call give_all_act_mos_at_r(r2,mos_array_r2) - do l = 1, n_act_orb ! - contrib = mos_array_r2(l)*mos_array_r2(l) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_act_orb ! - contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - compute_diag_two_body_dm_ab_act += two_body_dm_ab_diag_act(k,l) * contrib_tmp - enddo - enddo -end - -double precision function compute_diag_two_body_dm_ab_core_act(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_core_r1(n_core_orb_allocate),mos_array_core_r2(n_core_orb_allocate) - double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) - double precision :: contrib_core_1,contrib_core_2 - double precision :: contrib_act_1,contrib_act_2 - double precision :: contrib_tmp - compute_diag_two_body_dm_ab_core_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_act_r1) - call give_all_act_mos_at_r(r2,mos_array_act_r2) - call give_all_core_mos_at_r(r1,mos_array_core_r1) - call give_all_core_mos_at_r(r2,mos_array_core_r2) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_act_orb ! - contrib_act_1 = mos_array_act_r1(k) * mos_array_act_r1(k) - contrib_act_2 = mos_array_act_r2(k) * mos_array_act_r2(k) - contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_act_2 + contrib_act_2 * contrib_act_1) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do l = 1, n_core_orb ! - contrib_core_1 = mos_array_core_r1(l) * mos_array_core_r1(l) - contrib_core_2 = mos_array_core_r2(l) * mos_array_core_r2(l) - compute_diag_two_body_dm_ab_core_act += two_body_dm_diag_core_act(l,k) * contrib_tmp - enddo - enddo -end - -double precision function compute_diag_two_body_dm_ab(r1,r2) - implicit none - double precision,intent(in) :: r1(3),r2(3) - double precision :: compute_diag_two_body_dm_ab_act,compute_diag_two_body_dm_ab_core - double precision :: compute_diag_two_body_dm_ab_core_act - compute_diag_two_body_dm_ab = compute_diag_two_body_dm_ab_act(r1,r2)+compute_diag_two_body_dm_ab_core(r1,r2) & - + compute_diag_two_body_dm_ab_core_act(r1,r2) -end From a72b890b92eb65e179779d84b2332226d10ab0dd Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 16 Mar 2017 21:21:27 +0100 Subject: [PATCH 74/76] debugging FOBOCI --- config/gfortran.cfg | 4 +- plugins/FCIdump/NEEDED_CHILDREN_MODULES | 2 +- plugins/FCIdump/fcidump.irp.f | 48 ++++--- plugins/FOBOCI/NEEDED_CHILDREN_MODULES | 2 +- plugins/FOBOCI/all_singles.irp.f | 1 + plugins/FOBOCI/create_1h_or_1p.irp.f | 133 +++++++++++++----- plugins/FOBOCI/density_matrix.irp.f | 5 + plugins/FOBOCI/dress_simple.irp.f | 7 +- plugins/FOBOCI/fobo_scf.irp.f | 6 +- .../foboci_lmct_mlct_threshold_old.irp.f | 7 +- plugins/FOBOCI/routines_foboci.irp.f | 110 +++++++++++++-- plugins/MRPT/MRPT_Utils.main.irp.f | 10 +- plugins/MRPT/print_1h2p.irp.f | 8 +- plugins/MRPT_Utils/energies_cas.irp.f | 98 +++++++++---- plugins/MRPT_Utils/excitations_cas.irp.f | 55 +++++++- plugins/MRPT_Utils/fock_like_operators.irp.f | 2 +- plugins/MRPT_Utils/mrpt_dress.irp.f | 8 +- plugins/MRPT_Utils/psi_active_prov.irp.f | 3 +- plugins/loc_cele/loc_cele.irp.f | 10 +- src/Determinants/H_apply.irp.f | 76 ++++++++++ src/Determinants/density_matrix.irp.f | 1 - src/Determinants/truncate_wf.irp.f | 46 +++++- 22 files changed, 514 insertions(+), 128 deletions(-) diff --git a/config/gfortran.cfg b/config/gfortran.cfg index c0aa875f..60e32235 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -35,14 +35,14 @@ OPENMP : 1 ; Append OpenMP flags # -ffast-math and the Fortran-specific # -fno-protect-parens and -fstack-arrays. [OPT] -FCFLAGS : -Ofast +FCFLAGS : # Profiling flags ################# # [PROFILE] FC : -p -g -FCFLAGS : -Ofast +FCFLAGS : # Debugging flags ################# diff --git a/plugins/FCIdump/NEEDED_CHILDREN_MODULES b/plugins/FCIdump/NEEDED_CHILDREN_MODULES index 34de8ddb..8d60d3c7 100644 --- a/plugins/FCIdump/NEEDED_CHILDREN_MODULES +++ b/plugins/FCIdump/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Davidson +Determinants Davidson core_integrals diff --git a/plugins/FCIdump/fcidump.irp.f b/plugins/FCIdump/fcidump.irp.f index f93c1128..8d334fc5 100644 --- a/plugins/FCIdump/fcidump.irp.f +++ b/plugins/FCIdump/fcidump.irp.f @@ -1,21 +1,25 @@ program fcidump implicit none + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + output=trim(ezfio_filename)//'.FCIDUMP' + i_unit_output = getUnitAndOpen(output,'w') integer :: i,j,k,l - integer :: ii(8), jj(8), kk(8),ll(8) + integer :: i1,j1,k1,l1 + integer :: i2,j2,k2,l2 integer*8 :: m character*(2), allocatable :: A(:) - print *, '&FCI NORB=', mo_tot_num, ', NELEC=', elec_num, & + write(i_unit_output,*) '&FCI NORB=', n_act_orb, ', NELEC=', elec_num-n_core_orb*2, & ', MS2=', (elec_alpha_num-elec_beta_num), ',' - allocate (A(mo_tot_num)) + allocate (A(n_act_orb)) A = '1,' - print *, 'ORBSYM=', (A(i), i=1,mo_tot_num) - print *,'ISYM=0,' - print *,'/' + write(i_unit_output,*) 'ORBSYM=', (A(i), i=1,n_act_orb) + write(i_unit_output,*) 'ISYM=0,' + write(i_unit_output,*) '/' deallocate(A) - integer*8 :: i8, k1 integer(key_kind), allocatable :: keys(:) double precision, allocatable :: values(:) integer(cache_map_size_kind) :: n_elements, n_elements_max @@ -23,14 +27,18 @@ program fcidump double precision :: get_mo_bielec_integral, integral - do l=1,mo_tot_num - do k=1,mo_tot_num - do j=l,mo_tot_num - do i=k,mo_tot_num - if (i>=j) then - integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + do l=1,n_act_orb + l1 = list_act(l) + do k=1,n_act_orb + k1 = list_act(k) + do j=l,n_act_orb + j1 = list_act(j) + do i=k,n_act_orb + i1 = list_act(i) + if (i1>=j1) then + integral = get_mo_bielec_integral(i1,j1,k1,l1,mo_integrals_map) if (dabs(integral) > mo_integrals_threshold) then - print *, integral, i,k,j,l + write(i_unit_output,*) integral, i,k,j,l endif end if enddo @@ -38,13 +46,15 @@ program fcidump enddo enddo - do j=1,mo_tot_num - do i=j,mo_tot_num - integral = mo_mono_elec_integral(i,j) + do j=1,n_act_orb + j1 = list_act(j) + do i=j,n_act_orb + i1 = list_act(i) + integral = mo_mono_elec_integral(i1,j1) + core_fock_operator(i1,j1) if (dabs(integral) > mo_integrals_threshold) then - print *, integral, i,j,0,0 + write(i_unit_output,*) integral, i,j,0,0 endif enddo enddo - print *, 0.d0, 0, 0, 0, 0 + write(i_unit_output,*) core_energy, 0, 0, 0, 0 end diff --git a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES index 16fce081..25d61c69 100644 --- a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES +++ b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD +Perturbation Selectors_no_sorted SCF_density Davidson CISD diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index 65d81e07..7c321b72 100644 --- a/plugins/FOBOCI/all_singles.irp.f +++ b/plugins/FOBOCI/all_singles.irp.f @@ -48,6 +48,7 @@ subroutine all_single(e_pt2) print*,'-----------------------' print*,'i = ',i call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st) + call make_s2_eigenfunction_first_order call diagonalize_CI print*,'N_det = ',N_det print*,'E = ',CI_energy(1) diff --git a/plugins/FOBOCI/create_1h_or_1p.irp.f b/plugins/FOBOCI/create_1h_or_1p.irp.f index 41ec7b6c..c5205903 100644 --- a/plugins/FOBOCI/create_1h_or_1p.irp.f +++ b/plugins/FOBOCI/create_1h_or_1p.irp.f @@ -29,21 +29,13 @@ subroutine create_restart_and_1h(i_hole) enddo enddo enddo + integer :: N_det_old N_det_old = N_det - N_det += n_new_det - allocate (new_det(N_int,2,n_new_det)) - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i = 1, N_det_old - do k = 1, N_int - psi_det(k,1,i) = old_psi_det(k,1,i) - psi_det(k,2,i) = old_psi_det(k,2,i) - enddo - enddo + + logical, allocatable :: duplicate(:) + allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det)) n_new_det = 0 do j = 1, n_act_orb @@ -58,19 +50,56 @@ subroutine create_restart_and_1h(i_hole) if(i_ok .ne. 1)cycle n_new_det +=1 do k = 1, N_int - psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) - psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) + new_det(k,1,n_new_det) = key_tmp(k,1) + new_det(k,2,n_new_det) = key_tmp(k,2) enddo - psi_coef(n_det_old+n_new_det,:) = 0.d0 enddo enddo enddo - SOFT_TOUCH N_det psi_det psi_coef - logical :: found_duplicates - if(n_act_orb.gt.1)then - call remove_duplicates_in_psi_det(found_duplicates) + integer :: i_test + duplicate = .False. + do i = 1, n_new_det + if(duplicate(i))cycle + do j = i+1, n_new_det + i_test = 0 + do ispin =1 ,2 + do k = 1, N_int + i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j))) + enddo + enddo + if(i_test.eq.0)then + duplicate(j) = .True. + endif + enddo + enddo + + integer :: n_new_det_unique + n_new_det_unique = 0 + print*, 'uniq det' + do i = 1, n_new_det + if(.not.duplicate(i))then + n_new_det_unique += 1 endif + enddo + print*, n_new_det_unique + N_det += n_new_det_unique + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, n_new_det_unique + do ispin = 1, 2 + do k = 1, N_int + psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i) + enddo + enddo + psi_coef(N_det_old+i,:) = 0.d0 + enddo + + + SOFT_TOUCH N_det psi_det psi_coef + deallocate (new_det,duplicate) end subroutine create_restart_and_1p(i_particle) @@ -107,18 +136,8 @@ subroutine create_restart_and_1p(i_particle) integer :: N_det_old N_det_old = N_det - N_det += n_new_det - allocate (new_det(N_int,2,n_new_det)) - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i = 1, N_det_old - do k = 1, N_int - psi_det(k,1,i) = old_psi_det(k,1,i) - psi_det(k,2,i) = old_psi_det(k,2,i) - enddo - enddo + logical, allocatable :: duplicate(:) + allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det)) n_new_det = 0 do j = 1, n_act_orb @@ -133,17 +152,59 @@ subroutine create_restart_and_1p(i_particle) if(i_ok .ne. 1)cycle n_new_det +=1 do k = 1, N_int - psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) - psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) + new_det(k,1,n_new_det) = key_tmp(k,1) + new_Det(k,2,n_new_det) = key_tmp(k,2) enddo - psi_coef(n_det_old+n_new_det,:) = 0.d0 enddo enddo enddo + integer :: i_test + duplicate = .False. + do i = 1, n_new_det + if(duplicate(i))cycle + call debug_det(new_det(1,1,i),N_int) + do j = i+1, n_new_det + i_test = 0 + call debug_det(new_det(1,1,j),N_int) + do ispin =1 ,2 + do k = 1, N_int + i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j))) + enddo + enddo + if(i_test.eq.0)then + duplicate(j) = .True. + endif + enddo + enddo + + integer :: n_new_det_unique + n_new_det_unique = 0 + print*, 'uniq det' + do i = 1, n_new_det + if(.not.duplicate(i))then + n_new_det_unique += 1 + endif + enddo + print*, n_new_det_unique + + N_det += n_new_det_unique + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, n_new_det_unique + do ispin = 1, 2 + do k = 1, N_int + psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i) + enddo + enddo + psi_coef(N_det_old+i,:) = 0.d0 + enddo + SOFT_TOUCH N_det psi_det psi_coef - logical :: found_duplicates - call remove_duplicates_in_psi_det(found_duplicates) + deallocate (new_det,duplicate) + end subroutine create_restart_1h_1p(i_hole,i_part) diff --git a/plugins/FOBOCI/density_matrix.irp.f b/plugins/FOBOCI/density_matrix.irp.f index aaf80c4f..42138c00 100644 --- a/plugins/FOBOCI/density_matrix.irp.f +++ b/plugins/FOBOCI/density_matrix.irp.f @@ -32,6 +32,11 @@ psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart norm_generators_restart += psi_coef_generators_restart(i,1)**2 enddo + double precision :: inv_norm + inv_norm = 1.d0/dsqrt(norm_generators_restart) + do i = 1, N_det_generators_restart + psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_norm + enddo one_body_dm_mo_alpha_generators_restart = 0.d0 diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index dd1ed221..fabbd834 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -175,6 +175,10 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener endif do j = 1, Ndet_generators call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix + if(i==j)then + call debug_det(psi_det_generators_input(1,1,i),N_int) + print*, hij + endif dressed_H_matrix(i,j) = hij enddo enddo @@ -234,6 +238,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do i = 1, N_states i_state(i) = i E_ref(i) = eigvalues(i) + print*, 'E_ref(i)',E_ref(i) enddo endif do i = 1,N_states @@ -287,7 +292,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener accu += eigvectors(j,i) * psi_coef_ref(j,k) enddo print*,'accu = ',accu - if(dabs(accu).ge.0.72d0)then + if(dabs(accu).ge.0.60d0)then i_good_state(0) +=1 i_good_state(i_good_state(0)) = i endif diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 8a709154..8be36b8a 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -15,8 +15,6 @@ end subroutine run_prepare implicit none -! no_oa_or_av_opt = .False. -! touch no_oa_or_av_opt call damping_SCF call diag_inactive_virt_and_update_mos end @@ -28,7 +26,7 @@ subroutine routine_fobo_scf print*,'' character*(64) :: label label = "Natural" - do i = 1, 5 + do i = 1, 1 print*,'*******************************************************************************' print*,'*******************************************************************************' print*,'FOBO-SCF Iteration ',i @@ -54,7 +52,7 @@ subroutine routine_fobo_scf endif call FOBOCI_lmct_mlct_old_thr(i) call save_osoci_natural_mos - call damping_SCF +! call damping_SCF call diag_inactive_virt_and_update_mos call clear_mo_map call provide_properties diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index 46ca9662..3d8dfb08 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -55,6 +55,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) call create_restart_and_1h(i_hole_osoci) call set_generators_to_psi_det print*,'Passed set generators' + integer :: m + do m = 1, N_det_generators + call debug_det(psi_det_generators(1,1,m),N_int) + enddo call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) double precision :: e_pt2 @@ -82,7 +86,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) call all_single(e_pt2) - call make_s2_eigenfunction_first_order +! call make_s2_eigenfunction_first_order threshold_davidson = 1.d-6 soft_touch threshold_davidson davidson_criterion call diagonalize_ci @@ -541,7 +545,6 @@ subroutine FOBOCI_lmct_mlct_old_thr_restart(iter) call print_generators_bitmasks_holes ! Impose that only the active part can be reached call set_bitmask_hole_as_input(unpaired_bitmask) -!!! call all_single_h_core call create_restart_and_1p(i_particl_osoci) !!! ! Update the generators call set_generators_to_psi_det diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index 7d194a54..26ce3b12 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -13,6 +13,8 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) integer :: n_good_hole logical,allocatable :: is_a_ref_det(:) allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) + double precision, allocatable :: local_norm(:) + allocate(local_norm(N_states)) n_one_hole = 0 n_one_hole_one_p = 0 @@ -30,7 +32,6 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) do k = 1, N_states inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) enddo -! cycle endif ! Find all the determinants present in the reference wave function @@ -59,10 +60,8 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) enddo endif enddo -!do k = 1, N_det -! call debug_det(psi_det(1,1,k),N_int) -! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1) -!enddo + + print*,'' print*,'n_good_hole = ',n_good_hole do k = 1,N_states @@ -72,27 +71,37 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) enddo print*,'' enddo - norm = 0.d0 - ! Set the wave function to the intermediate normalization + ! Set the wave function to the intermediate normalization do k = 1, N_states do i = 1, N_det psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) enddo enddo + + + norm = 0.d0 do k = 1,N_states print*,'state ',k do i = 1, N_det -!! print*,'psi_coef(i_ref) = ',psi_coef(i,1) if (is_a_ref_det(i))then print*,'i,psi_coef_ref = ',psi_coef(i,k) - cycle endif norm(k) += psi_coef(i,k) * psi_coef(i,k) enddo print*,'norm = ',norm(k) enddo + do k =1, N_states + local_norm(k) = 1.d0 / dsqrt(norm(k)) + enddo + do k = 1,N_states + do i = 1, N_det + psi_coef(i,k) = psi_coef(i,k) * local_norm(k) + enddo + enddo + deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) + deallocate(local_norm) soft_touch psi_coef end @@ -117,6 +126,8 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) integer :: i_count allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) allocate(index_one_hole_two_p(n_det)) + double precision, allocatable :: local_norm(:) + allocate(local_norm(N_states)) n_one_hole = 0 n_one_hole_one_p = 0 @@ -185,20 +196,29 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) enddo enddo - do k = 1, N_states + + norm = 0.d0 + do k = 1,N_states print*,'state ',k do i = 1, N_det -!! print*,'i = ',i, psi_coef(i,1) if (is_a_ref_det(i))then print*,'i,psi_coef_ref = ',psi_coef(i,k) - cycle endif norm(k) += psi_coef(i,k) * psi_coef(i,k) enddo - print*,'norm = ',norm + print*,'norm = ',norm(k) + enddo + do k =1, N_states + local_norm(k) = 1.d0 / dsqrt(norm(k)) + enddo + do k = 1,N_states + do i = 1, N_det + psi_coef(i,k) = psi_coef(i,k) * local_norm(k) + enddo enddo soft_touch psi_coef deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) + deallocate(local_norm) end @@ -210,12 +230,60 @@ subroutine update_density_matrix_osoci END_DOC integer :: i,j integer :: iorb,jorb + ! active <--> inactive block do i = 1, mo_tot_num do j = 1, mo_tot_num - one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) - one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) + one_body_dm_mo_alpha_osoci(i,j) += one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j) + one_body_dm_mo_beta_osoci(i,j) += one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j) enddo enddo +!do i = 1, n_act_orb +! iorb = list_act(i) +! do j = 1, n_inact_orb +! jorb = list_inact(j) +! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb) +! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb) +! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) +! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) +! enddo +!enddo + +!! active <--> virt block +!do i = 1, n_act_orb +! iorb = list_act(i) +! do j = 1, n_virt_orb +! jorb = list_virt(j) +! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb) +! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb) +! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) +! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) +! enddo +!enddo + +!! virt <--> virt block +!do j = 1, n_virt_orb +! jorb = list_virt(j) +! one_body_dm_mo_alpha_osoci(jorb,jorb)+= one_body_dm_mo_alpha_average(jorb,jorb) +! one_body_dm_mo_beta_osoci(jorb,jorb) += one_body_dm_mo_beta_average(jorb,jorb) +!enddo + +!! inact <--> inact block +!do j = 1, n_inact_orb +! jorb = list_inact(j) +! one_body_dm_mo_alpha_osoci(jorb,jorb) -= one_body_dm_mo_alpha_average(jorb,jorb) +! one_body_dm_mo_beta_osoci(jorb,jorb) -= one_body_dm_mo_beta_average(jorb,jorb) +!enddo + double precision :: accu_alpha, accu_beta + accu_alpha = 0.d0 + accu_beta = 0.d0 + do i = 1, mo_tot_num + accu_alpha += one_body_dm_mo_alpha_osoci(i,i) + accu_beta += one_body_dm_mo_beta_osoci(i,i) +! write(*,'(I3,X,100(F16.10,X))') i,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_beta_osoci(i,i),one_body_dm_mo_alpha_osoci(i,i)+one_body_dm_mo_beta_osoci(i,i) + enddo + print*, 'accu_alpha/beta',accu_alpha,accu_beta + + end @@ -263,6 +331,12 @@ subroutine initialize_density_matrix_osoci implicit none one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart + integer :: i + print*, '8*********************' + print*, 'initialize_density_matrix_osoci' + do i = 1, mo_tot_num + print*,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_alpha_generators_restart(i,i) + enddo end subroutine rescale_density_matrix_osoci(norm) @@ -438,6 +512,10 @@ subroutine save_osoci_natural_mos endif enddo enddo + print*, 'test' + print*, 'test' + print*, 'test' + print*, 'test' do i = 1, mo_tot_num do j = i+1, mo_tot_num if(dabs(tmp(i,j)).le.threshold_fobo_dm)then @@ -445,7 +523,9 @@ subroutine save_osoci_natural_mos tmp(j,i) = 0.d0 endif enddo + print*, tmp(i,i) enddo + label = "Natural" diff --git a/plugins/MRPT/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f index af3713c5..ab7a0ccb 100644 --- a/plugins/MRPT/MRPT_Utils.main.irp.f +++ b/plugins/MRPT/MRPT_Utils.main.irp.f @@ -18,11 +18,11 @@ subroutine routine_3 print *, 'N_states = ', N_states do i = 1, N_States print*,'State',i - write(*,'(A12,X,I3,A3,XX,F16.10)') ' PT2 ', i,' = ', second_order_pt_new(i) - write(*,'(A12,X,I3,A3,XX,F16.09)') ' E ', i,' = ', psi_ref_average_value(i) - write(*,'(A12,X,I3,A3,XX,F16.09)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i) - write(*,'(A12,X,I3,A3,XX,F16.09)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i) - write(*,'(A12,X,I3,A3,XX,F16.09)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) + write(*,'(A12,X,I3,A3,XX,F20.16)') ' PT2 ', i,' = ', second_order_pt_new(i) + write(*,'(A12,X,I3,A3,XX,F22.16)') ' E ', i,' = ', psi_ref_average_value(i) + write(*,'(A12,X,I3,A3,XX,F22.16)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i) + write(*,'(A12,X,I3,A3,XX,F22.16)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i) + write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) print*,'coef before and after' do j = 1, N_det_ref print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i) diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f index b9f6575b..f20f12b6 100644 --- a/plugins/MRPT/print_1h2p.irp.f +++ b/plugins/MRPT/print_1h2p.irp.f @@ -5,6 +5,12 @@ program print_1h2p call routine end +subroutine routine + implicit none + provide one_anhil_one_creat_inact_virt + +end + subroutine routine_2 implicit none integer :: i,j,degree @@ -27,7 +33,7 @@ subroutine routine_2 end -subroutine routine +subroutine routine_3 implicit none double precision,allocatable :: matrix_1h2p(:,:,:) double precision :: accu(2) diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index 563b4bdf..f7e48e4f 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -22,6 +22,40 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] END_PROVIDER +BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange_bis, (N_states)] + implicit none + integer :: i,j + double precision :: energies(N_states) + integer(bit_kind), allocatable :: psi_in_ref(:,:,:) + allocate (psi_in_ref(N_int,2,n_det_ref)) + integer(bit_kind), allocatable :: psi_in_active(:,:,:) + allocate (psi_in_active(N_int,2,n_det_ref)) + double precision, allocatable :: psi_ref_coef_in(:, :) + allocate(psi_ref_coef_in(N_det_ref, N_states)) + + do i = 1, N_det_ref + do j = 1, N_int + psi_in_ref(j,1,i) = psi_ref(j,1,i) + psi_in_ref(j,2,i) = psi_ref(j,2,i) + + psi_in_active(j,1,i) = psi_active(j,1,i) + psi_in_active(j,2,i) = psi_active(j,2,i) + enddo + do j = 1, N_states + psi_ref_coef_in(i,j) = psi_ref_coef(i,j) + enddo + enddo + do i = 1, N_states + call u0_H_dyall_u0_no_exchange_bis(energies,psi_in_ref,psi_ref_coef_in,n_det_ref,n_det_ref,n_det_ref,N_states,i) + energy_cas_dyall_no_exchange_bis(i) = energies(i) + print*, 'energy_cas_dyall(i)_no_exchange_bis', energy_cas_dyall_no_exchange_bis(i) + enddo + deallocate (psi_in_ref) + deallocate (psi_in_active) + deallocate(psi_ref_coef_in) +END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] implicit none @@ -604,6 +638,8 @@ END_PROVIDER double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + integer(bit_kind), allocatable :: psi_in_active(:,:,:) + allocate (psi_in_active(N_int,2,n_det_ref)) integer :: iorb,jorb,i_ok integer :: state_target @@ -614,6 +650,9 @@ END_PROVIDER double precision :: thresh_norm + integer :: other_spin(2) + other_spin(1) = 2 + other_spin(2) = 1 thresh_norm = 1.d-20 @@ -644,14 +683,14 @@ END_PROVIDER print*, 'pb, i_ok ne 0 !!!' endif call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) + integer :: exc(0:2,2,2) + double precision :: phase + call get_mono_excitation(psi_in_out(1,1,i),psi_ref(1,1,i),exc,phase,N_int) do j = 1, n_states - double precision :: coef,contrib - coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) - psi_in_out_coef(i,j) = coef * hij - if(orb_i == 5 .and. orb_v == 20)then -! if(orb_i == 2 .and. orb_v == 6 )then + psi_in_out_coef(i,j) = psi_ref_coef(i,j)* hij * phase +! if(orb_i == 5 .and. orb_v == 20)then + if(orb_i == 2 .and. orb_v == 6 )then print*, i, ispin - print*, coef * hij,coef,hij endif norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo @@ -663,22 +702,31 @@ END_PROVIDER one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 0.d0 else norm_no_inv(j,ispin) = norm(j,ispin) - one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 1.d0 / norm(j,ispin) +! one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 1.d0 / norm(j,ispin) norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) - if(orb_i == 5 .and. orb_v == 20)then -! if(orb_i == 2 .and. orb_v == 6 )then +! if(orb_i == 5 .and. orb_v == 20)then + if(orb_i == 2 .and. orb_v == 6 )then print*,ispin ,norm(j,ispin) endif endif enddo + integer :: iorb_annil,hole_particle,spin_exc,orb + double precision :: norm_out_bis(N_states) do i = 1, N_det_ref do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo + enddo + + do i = 1, N_det_ref do j = 1, N_int + ! psi_in_out(j,1,i) = iand(psi_in_out(j,1,i),cas_bitmask(j,1,1)) + ! psi_in_out(j,2,i) = iand(psi_in_out(j,2,i),cas_bitmask(j,1,1)) psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) + ! psi_in_out(j,1,i) = psi_ref(j,1,i) + ! psi_in_out(j,2,i) = psi_ref(j,2,i) enddo enddo do state_target = 1, N_states @@ -686,29 +734,35 @@ END_PROVIDER if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) - if(orb_i == 5 .and. orb_v == 20)then -! if(orb_i == 2 .and. orb_v == 6 )then - print*, ispin, energy_cas_dyall_no_exchange(1) , energies_alpha_beta(state_target, ispin) - print*, ispin, energy_cas_dyall_no_exchange(1) - energies_alpha_beta(state_target, ispin) - endif endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & - ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & +! 0.5d0 * (energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2)) + ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.d0 endif if(dabs(dabs(one_anhil_one_creat_inact_virt(iorb,vorb,state_target)) - 1.30584271462d0) < 1.d-11)then +! if(dabs(dabs(one_anhil_one_creat_inact_virt(iorb,vorb,state_target)) - 1.29269686324d0) < 1.d-11)then + print*, '' print*, orb_i,orb_v - print*, energy_cas_dyall_no_exchange(1) - energies_alpha_beta(state_target,1) / norm_bis(state_target,1) - print*, energy_cas_dyall_no_exchange(1) - energies_alpha_beta(state_target,2) / norm_bis(state_target,2) + print*, energy_cas_dyall_no_exchange(1) - energies_alpha_beta(state_target,1) !/ norm_bis(state_target,1) + print*, energy_cas_dyall_no_exchange(1) - energies_alpha_beta(state_target,2) !/ norm_bis(state_target,2) print*, fock_core_inactive_total_spin_trace(orb_i,1) print*, fock_virt_total_spin_trace(orb_v,1) print*, one_anhil_one_creat_inact_virt(iorb,vorb,state_target) + print*, '' + endif + if(dabs(one_anhil_one_creat_inact_virt(iorb,vorb,state_target)) .gt. 1.d-10)then + write(*,'(F11.8)'), one_anhil_one_creat_inact_virt(iorb,vorb,state_target) +! if(dabs(one_anhil_one_creat_inact_virt(iorb,vorb,state_target)) .lt. 1.d-2)then +! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.d0 +! print*, orb_i,orb_v +! endif endif enddo enddo @@ -852,9 +906,6 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State norm_bis = 0.d0 do ispin = 1,2 do i = 1, n_det_ref -! if(orb_a == 6 .and. orb_v == 12)then -! print*, 'i ref = ',i -! endif do j = 1, N_int psi_in_out(j,1,i) = psi_ref(j,1,i) psi_in_out(j,2,i) = psi_ref(j,2,i) @@ -866,11 +917,6 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State enddo else call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) - if(orb_a == 6 .and. orb_v == 12)then - call debug_det(psi_ref(1,1,i),N_int) - call debug_det(psi_in_out(1,1,i),N_int) - print*, hij - endif do j = 1, n_states double precision :: contrib psi_in_out_coef(i,j) = psi_ref_coef(i,j) * hij @@ -907,7 +953,6 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then -! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif @@ -915,7 +960,6 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then -! one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall(state_target) - & one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 768abe8c..4042d90b 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -25,6 +25,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & integer :: det_tmp(N_int), det_tmp_bis(N_int) double precision :: phase double precision :: norm_factor +! print*, orb,hole_particle,spin_exc elec_num_tab_local = 0 do i = 1, ndet @@ -36,6 +37,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & exit endif enddo +! print*, elec_num_tab_local(1),elec_num_tab_local(2) if(hole_particle == 1)then do i = 1, ndet call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) @@ -675,6 +677,7 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) integer :: n_occ_ab(2) logical :: has_mipi(Nint*bit_kind_size) double precision :: mipi(Nint*bit_kind_size) + double precision :: diag_H_mat_elem PROVIDE mo_bielec_integrals_in_map mo_integrals_map ASSERT (Nint > 0) @@ -771,9 +774,11 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) endif hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) +! hij = phase*(hij + mo_mono_elec_integral(m,p) ) case (0) hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint) +! hij = diag_H_mat_elem(key_i,Nint) ! hij = 0.d0 end select end @@ -799,7 +804,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! alpha - alpha do i = 1, elec_num_tab_local(1) iorb = occ(i,1) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) do j = i+1, elec_num_tab_local(1) jorb = occ(j,1) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -809,7 +814,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! beta - beta do i = 1, elec_num_tab_local(2) iorb = occ(i,2) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) do j = i+1, elec_num_tab_local(2) jorb = occ(j,2) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -835,7 +840,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) +! core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) ! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(1) enddo enddo @@ -846,7 +851,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) +! core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) ! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(2) enddo enddo @@ -884,3 +889,45 @@ subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in energies(state_target) = accu deallocate(psi_coef_tmp) end + + + +!subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_active,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) +subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) + use bitmasks + implicit none + integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target +!integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in),psi_in_active(N_int,2,dim_psi_in) + integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in) + double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in) + double precision, intent(out) :: energies(N_states_in) + + integer :: i,j + double precision :: hij,accu + energies = 0.d0 + accu = 0.d0 + double precision, allocatable :: psi_coef_tmp(:) + allocate(psi_coef_tmp(ndet)) + + do i = 1, ndet + psi_coef_tmp(i) = psi_in_coef(i,state_target) + enddo + + double precision :: hij_bis,diag_H_mat_elem + do i = 1, ndet + if(psi_coef_tmp(i)==0.d0)cycle + do j = i+1, ndet + if(psi_coef_tmp(j)==0.d0)cycle +! call i_H_j_dyall_no_exchange(psi_in_active(1,1,i),psi_in_active(1,1,j),N_int,hij) + call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) + accu += 2.d0 * psi_coef_tmp(i) * psi_coef_tmp(j) * hij + enddo + enddo + do i = 1, N_det + if(psi_coef_tmp(i)==0.d0)cycle + accu += psi_coef_tmp(i) * psi_coef_tmp(i) * diag_H_mat_elem(psi_in(1,1,i),N_int) + enddo + energies(state_target) = accu + deallocate(psi_coef_tmp) +end + diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index d4ce0661..f16aba26 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -197,7 +197,7 @@ k_inact_core_orb = list_core_inact(k) coulomb = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map) exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map) - accu += 2.d0 * coulomb - exchange + accu += 2.d0 * coulomb - exchange enddo fock_operator_active_from_core_inact(iorb,jorb) = accu enddo diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index 91bb7a54..9699a1df 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -122,7 +122,7 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip enddo else call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) -! !!!!!!!!!!!!! SHIFTED BK + !!!!!!!!!!!!! SHIFTED BK ! double precision :: hjj ! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj) ! delta_e(1) = CI_electronic_energy(1) - hjj @@ -141,7 +141,11 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip do j = 1, idx_alpha(0) index_j = idx_alpha(j) !!!!!!!!!!!!!!!!!! WARNING TEST - if(index_j .ne. index_i)cycle + !!!!!!!!!!!!!!!!!! WARNING TEST +! if(index_j .ne. index_i)cycle + !!!!!!!!!!!!!!!!!! WARNING TEST + !!!!!!!!!!!!!!!!!! WARNING TEST + !!!!!!!!!!!!!!!!!! WARNING TEST do i_state=1,N_states ! standard dressing first order delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 9d0d1fc6..ec6bbe50 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -14,7 +14,7 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] psi_active(j,1,i) = iand(psi_ref(j,1,i),cas_bitmask(j,1,1)) psi_active(j,2,i) = iand(psi_ref(j,2,i),cas_bitmask(j,1,1)) enddo - call debug_det(psi_active(1,1,i),N_int) +! call debug_det(psi_active(1,1,i),N_int) enddo END_PROVIDER @@ -330,6 +330,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) i_part = list_virt_reverse(p1) do i_state = 1, N_states delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state) +! delta_e_act += 1.d12 enddo else if (degree == 2)then do i_state = 1, N_states diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index 2dda522e..67e74f08 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -101,10 +101,12 @@ cmoref = 0.d0 irot = 0 - irot(1,1) = 5 - irot(2,1) = 6 - cmoref(6,1,1) = 1d0 - cmoref(26,2,1) = 1d0 + irot(1,1) = 14 + irot(2,1) = 15 +! cmoref(6,1,1) = 1.d0 +! cmoref(26,2,1) = 1.d0 + cmoref(36,1,1) = 1.d0 + cmoref(56,2,1) = 1.d0 ! !!! H2O ! irot(1,1) = 4 diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 411fe703..53e31647 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -195,6 +195,7 @@ subroutine copy_H_apply_buffer_to_wf !call remove_duplicates_in_psi_det(found_duplicates) end + subroutine remove_duplicates_in_psi_det(found_duplicates) implicit none logical, intent(out) :: found_duplicates @@ -270,6 +271,81 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) deallocate (duplicate,bit_tmp) end +subroutine remove_duplicates_in_psi_det_new(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(:) + + allocate (duplicate(N_det), bit_tmp(N_det)) + + do i=1,N_det + integer, external :: det_search_key + !$DIR FORCEINLINE + bit_tmp(i) = det_search_key(psi_det_sorted_bit(1,1,i),N_int) + duplicate(i) = .False. + enddo + + 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 += 1 + if (j > N_det) then + exit + else + cycle + endif + endif + duplicate(j) = .True. + do k=1,N_int + if ( (psi_det_sorted_bit(k,1,i) /= psi_det_sorted_bit(k,1,j) ) & + .or. (psi_det_sorted_bit(k,2,i) /= psi_det_sorted_bit(k,2,j) ) ) then + duplicate(j) = .False. + exit + endif + enddo + j += 1 + if (j > N_det) then + exit + endif + enddo + enddo + + found_duplicates = .False. + do i=1,N_det + if (duplicate(i)) then + found_duplicates = .True. + exit + endif + enddo + + 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 (:,:,i) + psi_coef(k,:) = psi_coef_sorted_bit(i,:) + else + psi_det(:,:,k) = 0_bit_kind + psi_coef(k,:) = 0.d0 + endif + enddo + N_det = k + call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') + SOFT_TOUCH N_det psi_det psi_coef + endif + deallocate (duplicate,bit_tmp) +end + subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) use bitmasks diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 6bafa287..56590d9c 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -134,7 +134,6 @@ END_PROVIDER !$OMP END CRITICAL deallocate(tmp_a,tmp_b) !$OMP END PARALLEL - END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f index aba16fa7..49b5e70a 100644 --- a/src/Determinants/truncate_wf.irp.f +++ b/src/Determinants/truncate_wf.irp.f @@ -1,8 +1,52 @@ program s2_eig_restart implicit none read_wf = .True. - call routine + call routine_2 end + +subroutine routine_2 + implicit none + integer :: i,j,k,l + use bitmasks + integer :: n_det_restart,degree + integer(bit_kind),allocatable :: psi_det_tmp(:,:,:) + double precision ,allocatable :: psi_coef_tmp(:,:),accu(:) + integer, allocatable :: index_restart(:) + allocate(index_restart(N_det)) + print*, 'How many Slater determinants would ou like ?' + read(5,*)N_det_restart + do i = 1, N_det_restart + index_restart(i) = i + enddo + allocate (psi_det_tmp(N_int,2,N_det_restart),psi_coef_tmp(N_det_restart,N_states),accu(N_states)) + accu = 0.d0 + do i = 1, N_det_restart + do j = 1, N_int + psi_det_tmp(j,1,i) = psi_det(j,1,index_restart(i)) + psi_det_tmp(j,2,i) = psi_det(j,2,index_restart(i)) + enddo + do j = 1,N_states + psi_coef_tmp(i,j) = psi_coef(index_restart(i),j) + accu(j) += psi_coef_tmp(i,j) * psi_coef_tmp(i,j) + enddo + enddo + do j = 1, N_states + accu(j) = 1.d0/dsqrt(accu(j)) + enddo + do j = 1,N_states + do i = 1, N_det_restart + psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) + enddo + enddo + call save_wavefunction_general(N_det_restart,N_states,psi_det_tmp,N_det_restart,psi_coef_tmp) + + deallocate (psi_det_tmp,psi_coef_tmp,accu,index_restart) + + + +end + + subroutine routine implicit none call make_s2_eigenfunction From 8885297493b6c8548b2882453487e1bb46cd579c Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 16 Mar 2017 21:21:45 +0100 Subject: [PATCH 75/76] Added SCF_density --- plugins/SCF_density/.gitignore | 25 + plugins/SCF_density/EZFIO.cfg | 35 ++ plugins/SCF_density/Fock_matrix.irp.f | 437 ++++++++++++++++++ .../SCF_density/HF_density_matrix_ao.irp.f | 66 +++ plugins/SCF_density/NEEDED_CHILDREN_MODULES | 1 + plugins/SCF_density/README.rst | 175 +++++++ plugins/SCF_density/damping_SCF.irp.f | 132 ++++++ plugins/SCF_density/diagonalize_fock.irp.f | 124 +++++ plugins/SCF_density/huckel.irp.f | 32 ++ 9 files changed, 1027 insertions(+) create mode 100644 plugins/SCF_density/.gitignore create mode 100644 plugins/SCF_density/EZFIO.cfg create mode 100644 plugins/SCF_density/Fock_matrix.irp.f create mode 100644 plugins/SCF_density/HF_density_matrix_ao.irp.f create mode 100644 plugins/SCF_density/NEEDED_CHILDREN_MODULES create mode 100644 plugins/SCF_density/README.rst create mode 100644 plugins/SCF_density/damping_SCF.irp.f create mode 100644 plugins/SCF_density/diagonalize_fock.irp.f create mode 100644 plugins/SCF_density/huckel.irp.f diff --git a/plugins/SCF_density/.gitignore b/plugins/SCF_density/.gitignore new file mode 100644 index 00000000..9f1c0929 --- /dev/null +++ b/plugins/SCF_density/.gitignore @@ -0,0 +1,25 @@ +# Automatically created by $QP_ROOT/scripts/module/module_handler.py +.ninja_deps +.ninja_log +AO_Basis +Bitmask +Electrons +Ezfio_files +Huckel_guess +IRPF90_man +IRPF90_temp +Integrals_Bielec +Integrals_Monoelec +MOGuess +MO_Basis +Makefile +Makefile.depend +Nuclei +Pseudo +SCF +Utils +ZMQ +ezfio_interface.irp.f +irpf90.make +irpf90_entities +tags \ No newline at end of file diff --git a/plugins/SCF_density/EZFIO.cfg b/plugins/SCF_density/EZFIO.cfg new file mode 100644 index 00000000..2fa29cf0 --- /dev/null +++ b/plugins/SCF_density/EZFIO.cfg @@ -0,0 +1,35 @@ +[thresh_scf] +type: Threshold +doc: Threshold on the convergence of the Hartree Fock energy +interface: ezfio,provider,ocaml +default: 1.e-10 + +[n_it_scf_max] +type: Strictly_positive_int +doc: Maximum number of SCF iterations +interface: ezfio,provider,ocaml +default: 200 + +[level_shift] +type: Positive_float +doc: Energy shift on the virtual MOs to improve SCF convergence +interface: ezfio,provider,ocaml +default: 0.5 + +[mo_guess_type] +type: MO_guess +doc: Initial MO guess. Can be [ Huckel | HCore ] +interface: ezfio,provider,ocaml +default: Huckel + +[energy] +type: double precision +doc: Calculated HF energy +interface: ezfio + +[no_oa_or_av_opt] +type: logical +doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure +interface: ezfio,provider,ocaml +default: False + diff --git a/plugins/SCF_density/Fock_matrix.irp.f b/plugins/SCF_density/Fock_matrix.irp.f new file mode 100644 index 00000000..af9255c8 --- /dev/null +++ b/plugins/SCF_density/Fock_matrix.irp.f @@ -0,0 +1,437 @@ + BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis. + ! For open shells, the ROHF Fock Matrix is + ! + ! | F-K | F + K/2 | F | + ! |---------------------------------| + ! | F + K/2 | F | F - K/2 | + ! |---------------------------------| + ! | F | F - K/2 | F + K | + ! + ! F = 1/2 (Fa + Fb) + ! + ! K = Fb - Fa + ! + END_DOC + integer :: i,j,n + if (elec_alpha_num == elec_beta_num) then + Fock_matrix_mo = Fock_matrix_alpha_mo + else + + do j=1,elec_beta_num + ! F-K + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F+K/2 + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F + do i=elec_alpha_num+1, mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + enddo + + do j=elec_beta_num+1,elec_alpha_num + ! F+K/2 + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + ! F-K/2 + do i=elec_alpha_num+1, mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + enddo + + do j=elec_alpha_num+1, mo_tot_num + ! F + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + ! F-K/2 + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F+K + do i=elec_alpha_num+1,mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) & + + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + enddo + + endif + + do i = 1, mo_tot_num + Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) + enddo +END_PROVIDER + + + + BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ] +&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ] + implicit none + BEGIN_DOC + ! Alpha Fock matrix in AO basis set + END_DOC + + integer :: i,j + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num + Fock_matrix_alpha_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) + Fock_matrix_beta_ao (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ] +&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ] + use map_module + implicit none + BEGIN_DOC + ! Alpha Fock matrix in AO basis set + END_DOC + + integer :: i,j,k,l,k1,r,s + integer :: i0,j0,k0,l0 + integer*8 :: p,q + double precision :: integral, c0, c1, c2 + double precision :: ao_bielec_integral, local_threshold + double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:) + double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp + + ao_bi_elec_integral_alpha = 0.d0 + ao_bi_elec_integral_beta = 0.d0 + if (do_direct_integrals) then + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, & + !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, & + !$OMP local_threshold)& + !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& + !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, & + !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) + + allocate(keys(1), values(1)) + allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & + ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) + ao_bi_elec_integral_alpha_tmp = 0.d0 + ao_bi_elec_integral_beta_tmp = 0.d0 + + q = ao_num*ao_num*ao_num*ao_num + !$OMP DO SCHEDULE(dynamic) + do p=1_8,q + call bielec_integrals_index_reverse(kk,ii,ll,jj,p) + if ( (kk(1)>ao_num).or. & + (ii(1)>ao_num).or. & + (jj(1)>ao_num).or. & + (ll(1)>ao_num) ) then + cycle + endif + k = kk(1) + i = ii(1) + l = ll(1) + j = jj(1) + + if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) & + < ao_integrals_threshold) then + cycle + endif + local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) + if (local_threshold < ao_integrals_threshold) then + cycle + endif + i0 = i + j0 = j + k0 = k + l0 = l + values(1) = 0.d0 + local_threshold = ao_integrals_threshold/local_threshold + do k2=1,8 + if (kk(k2)==0) then + cycle + endif + i = ii(k2) + j = jj(k2) + k = kk(k2) + l = ll(k2) + c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l) + c1 = HF_density_matrix_ao_alpha(k,i) + c2 = HF_density_matrix_ao_beta(k,i) + if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then + cycle + endif + if (values(1) == 0.d0) then + values(1) = ao_bielec_integral(k0,l0,i0,j0) + endif + integral = c0 * values(1) + ao_bi_elec_integral_alpha_tmp(i,j) += integral + ao_bi_elec_integral_beta_tmp (i,j) += integral + integral = values(1) + ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral + ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp + !$OMP END CRITICAL + !$OMP CRITICAL + ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp + !$OMP END CRITICAL + deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) + !$OMP END PARALLEL + else + PROVIDE ao_bielec_integrals_in_map + + integer(omp_lock_kind) :: lck(ao_num) + integer*8 :: i8 + integer :: ii(8), jj(8), kk(8), ll(8), k2 + integer(cache_map_size_kind) :: n_elements_max, n_elements + integer(key_kind), allocatable :: keys(:) + double precision, allocatable :: values(:) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, & + !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)& + !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& + !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) + + call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max) + allocate(keys(n_elements_max), values(n_elements_max)) + allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & + ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) + ao_bi_elec_integral_alpha_tmp = 0.d0 + ao_bi_elec_integral_beta_tmp = 0.d0 + + !$OMP DO SCHEDULE(dynamic) + !DIR$ NOVECTOR + do i8=0_8,ao_integrals_map%map_size + n_elements = n_elements_max + call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) + do k1=1,n_elements + call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1)) + + do k2=1,8 + if (kk(k2)==0) then + cycle + endif + i = ii(k2) + j = jj(k2) + k = kk(k2) + l = ll(k2) + integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1) + ao_bi_elec_integral_alpha_tmp(i,j) += integral + ao_bi_elec_integral_beta_tmp (i,j) += integral + integral = values(k1) + ao_bi_elec_integral_alpha_tmp(l,j) -= HF_density_matrix_ao_alpha(k,i) * integral + ao_bi_elec_integral_beta_tmp (l,j) -= HF_density_matrix_ao_beta (k,i) * integral + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp + !$OMP END CRITICAL + !$OMP CRITICAL + ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp + !$OMP END CRITICAL + deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) + !$OMP END PARALLEL + + endif + +END_PROVIDER + + + + + + +BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis + END_DOC + double precision, allocatable :: T(:,:) + allocate ( T(ao_num_align,mo_tot_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), & + mo_coef, size(mo_coef,1), & + 0.d0, T, ao_num_align) + call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & + 1.d0, mo_coef,size(mo_coef,1), & + T, size(T,1), & + 0.d0, Fock_matrix_alpha_mo, mo_tot_num_align) + deallocate(T) +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis + END_DOC + double precision, allocatable :: T(:,:) + allocate ( T(ao_num_align,mo_tot_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), & + mo_coef, size(mo_coef,1), & + 0.d0, T, ao_num_align) + call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & + 1.d0, mo_coef,size(mo_coef,1), & + T, size(T,1), & + 0.d0, Fock_matrix_beta_mo, mo_tot_num_align) + deallocate(T) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, HF_energy ] + implicit none + BEGIN_DOC + ! Hartree-Fock energy + END_DOC + HF_energy = nuclear_repulsion + + integer :: i,j + do j=1,ao_num + do i=1,ao_num + HF_energy += 0.5d0 * ( & + (ao_mono_elec_integral(i,j) + Fock_matrix_alpha_ao(i,j) ) * HF_density_matrix_ao_alpha(i,j) +& + (ao_mono_elec_integral(i,j) + Fock_matrix_beta_ao (i,j) ) * HF_density_matrix_ao_beta (i,j) ) + enddo + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] + implicit none + BEGIN_DOC + ! Fock matrix in AO basis set + END_DOC + + if ( (elec_alpha_num == elec_beta_num).and. & + (level_shift == 0.) ) & + then + integer :: i,j + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num_align + Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) + enddo + enddo + else + double precision, allocatable :: T(:,:), M(:,:) + integer :: ierr + ! F_ao = S C F_mo C^t S + allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) + if (ierr /=0 ) then + print *, irp_here, ' : allocation failed' + endif + +! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) +! -> M(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & + ao_overlap, size(ao_overlap,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num) +! -> T(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & + M, size(M,1), & + Fock_matrix_mo, size(Fock_matrix_mo,1), & + 0.d0, & + T, size(T,1)) + +! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) +! -> M(ao_num,ao_num) + call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & + T, size(T,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) +! -> Fock_matrix_ao(ao_num,ao_num) + call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & + M, size(M,1), & + ao_overlap, size(ao_overlap,1), & + 0.d0, & + Fock_matrix_ao, size(Fock_matrix_ao,1)) + + + deallocate(T) + endif +END_PROVIDER + +subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO) + implicit none + integer, intent(in) :: LDFMO ! size(FMO,1) + integer, intent(in) :: LDFAO ! size(FAO,1) + double precision, intent(in) :: FMO(LDFMO,*) + double precision, intent(out) :: FAO(LDFAO,*) + + double precision, allocatable :: T(:,:), M(:,:) + integer :: ierr + ! F_ao = S C F_mo C^t S + allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) + if (ierr /=0 ) then + print *, irp_here, ' : allocation failed' + endif + +! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) +! -> M(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & + ao_overlap, size(ao_overlap,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num) +! -> T(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & + M, size(M,1), & + FMO, size(FMO,1), & + 0.d0, & + T, size(T,1)) + +! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) +! -> M(ao_num,ao_num) + call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & + T, size(T,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) +! -> Fock_matrix_ao(ao_num,ao_num) + call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & + M, size(M,1), & + ao_overlap, size(ao_overlap,1), & + 0.d0, & + FAO, size(FAO,1)) + deallocate(T,M) +end + diff --git a/plugins/SCF_density/HF_density_matrix_ao.irp.f b/plugins/SCF_density/HF_density_matrix_ao.irp.f new file mode 100644 index 00000000..a9d601c7 --- /dev/null +++ b/plugins/SCF_density/HF_density_matrix_ao.irp.f @@ -0,0 +1,66 @@ +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 x Alpha density matrix in the AO basis x S^-1 + END_DOC + +! call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & +! mo_coef, size(mo_coef,1), & +! mo_coef, size(mo_coef,1), 0.d0, & +! HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1)) + integer :: i,j,k,l + double precision :: test_alpha + HF_density_matrix_ao_alpha = 0.d0 + do i = 1, mo_tot_num + do j = 1, mo_tot_num + if(dabs(mo_general_density_alpha(i,j)).le.1.d-10)cycle + do k = 1, ao_num + do l = 1, ao_num + HF_density_matrix_ao_alpha(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_alpha(i,j) + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 Beta density matrix in the AO basis x S^-1 + END_DOC + +! call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, & +! mo_coef, size(mo_coef,1), & +! mo_coef, size(mo_coef,1), 0.d0, & +! HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1)) + integer :: i,j,k,l + double precision :: test_beta + HF_density_matrix_ao_beta = 0.d0 + do i = 1, mo_tot_num + do j = 1, mo_tot_num + do k = 1, ao_num + do l = 1, ao_num + HF_density_matrix_ao_beta(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_beta(i,j) + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 Density matrix in the AO basis S^-1 + END_DOC + ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1)) + if (elec_alpha_num== elec_beta_num) then + HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha + else + ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1)) + HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta + endif + +END_PROVIDER + diff --git a/plugins/SCF_density/NEEDED_CHILDREN_MODULES b/plugins/SCF_density/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..a52d6e8e --- /dev/null +++ b/plugins/SCF_density/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Integrals_Bielec MOGuess Bitmask diff --git a/plugins/SCF_density/README.rst b/plugins/SCF_density/README.rst new file mode 100644 index 00000000..0699bf28 --- /dev/null +++ b/plugins/SCF_density/README.rst @@ -0,0 +1,175 @@ +=================== +SCF_density Module +=================== + +From the 140 molecules of the G2 set, only LiO, ONa don't converge well. + +Needed Modules +============== + +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + +.. image:: tree_dependency.png + +* `Integrals_Bielec `_ +* `MOGuess `_ + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Integrals_Bielec `_ +* `MOGuess `_ +* `Bitmask `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`ao_bi_elec_integral_alpha `_ + Alpha Fock matrix in AO basis set + + +`ao_bi_elec_integral_beta `_ + Alpha Fock matrix in AO basis set + + +`create_guess `_ + Create an MO guess if no MOs are present in the EZFIO directory + + +`damping_scf `_ + Undocumented + + +`diagonal_fock_matrix_mo `_ + Diagonal Fock matrix in the MO basis + + +`diagonal_fock_matrix_mo_sum `_ + diagonal element of the fock matrix calculated as the sum over all the interactions + with all the electrons in the RHF determinant + diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij + + +`eigenvectors_fock_matrix_mo `_ + Diagonal Fock matrix in the MO basis + + +`fock_matrix_alpha_ao `_ + Alpha Fock matrix in AO basis set + + +`fock_matrix_alpha_mo `_ + Fock matrix on the MO basis + + +`fock_matrix_ao `_ + Fock matrix in AO basis set + + +`fock_matrix_beta_ao `_ + Alpha Fock matrix in AO basis set + + +`fock_matrix_beta_mo `_ + Fock matrix on the MO basis + + +`fock_matrix_diag_mo `_ + Fock matrix on the MO basis. + For open shells, the ROHF Fock Matrix is + .br + | F-K | F + K/2 | F | + |---------------------------------| + | F + K/2 | F | F - K/2 | + |---------------------------------| + | F | F - K/2 | F + K | + .br + F = 1/2 (Fa + Fb) + .br + K = Fb - Fa + .br + + +`fock_matrix_mo `_ + Fock matrix on the MO basis. + For open shells, the ROHF Fock Matrix is + .br + | F-K | F + K/2 | F | + |---------------------------------| + | F + K/2 | F | F - K/2 | + |---------------------------------| + | F | F - K/2 | F + K | + .br + F = 1/2 (Fa + Fb) + .br + K = Fb - Fa + .br + + +`fock_mo_to_ao `_ + Undocumented + + +`guess `_ + Undocumented + + +`hf_density_matrix_ao `_ + S^-1 Density matrix in the AO basis S^-1 + + +`hf_density_matrix_ao_alpha `_ + S^-1 x Alpha density matrix in the AO basis x S^-1 + + +`hf_density_matrix_ao_beta `_ + S^-1 Beta density matrix in the AO basis x S^-1 + + +`hf_energy `_ + Hartree-Fock energy + + +`huckel_guess `_ + Build the MOs using the extended Huckel model + + +`level_shift `_ + Energy shift on the virtual MOs to improve SCF convergence + + +`mo_guess_type `_ + Initial MO guess. Can be [ Huckel | HCore ] + + +`n_it_scf_max `_ + Maximum number of SCF iterations + + +`no_oa_or_av_opt `_ + If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure + + +`run `_ + Run SCF calculation + + +`scf `_ + Produce `Hartree_Fock` MO orbital + output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ + output: hartree_fock.energy + optional: mo_basis.mo_coef + + +`thresh_scf `_ + Threshold on the convergence of the Hartree Fock energy + diff --git a/plugins/SCF_density/damping_SCF.irp.f b/plugins/SCF_density/damping_SCF.irp.f new file mode 100644 index 00000000..aa6f02b0 --- /dev/null +++ b/plugins/SCF_density/damping_SCF.irp.f @@ -0,0 +1,132 @@ +subroutine damping_SCF + implicit none + double precision :: E + double precision, allocatable :: D_alpha(:,:), D_beta(:,:) + double precision :: E_new + double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:) + double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:) + double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min + + integer :: i,j,k + logical :: saving + character :: save_char + + allocate( & + D_alpha( ao_num_align, ao_num ), & + D_beta( ao_num_align, ao_num ), & + F_new( ao_num_align, ao_num ), & + D_new_alpha( ao_num_align, ao_num ), & + D_new_beta( ao_num_align, ao_num ), & + delta_alpha( ao_num_align, ao_num ), & + delta_beta( ao_num_align, ao_num )) + + do j=1,ao_num + do i=1,ao_num + D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j) + D_beta (i,j) = HF_density_matrix_ao_beta (i,j) + enddo + enddo + + + call write_time(output_hartree_fock) + + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + '====','================','================','================', '====' + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + ' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save' + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + '====','================','================','================', '====' + + E = HF_energy + 1.d0 + E_min = HF_energy + delta_D = 0.d0 + do k=1,n_it_scf_max + + delta_E = HF_energy - E + E = HF_energy + + if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then + exit + endif + + saving = E < E_min + if (saving) then + call save_mos + save_char = 'X' + E_min = E + else + save_char = ' ' + endif + + write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') & + k, E, delta_E, delta_D, save_char + + D_alpha = HF_density_matrix_ao_alpha + D_beta = HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + + D_new_alpha = HF_density_matrix_ao_alpha + D_new_beta = HF_density_matrix_ao_beta + F_new = Fock_matrix_ao + E_new = HF_energy + + delta_alpha = D_new_alpha - D_alpha + delta_beta = D_new_beta - D_beta + + lambda = .5d0 + E_half = 0.d0 + do while (E_half > E) + HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha + HF_density_matrix_ao_beta = D_beta + lambda * delta_beta + TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + E_half = HF_energy + if ((E_half > E).and.(E_new < E)) then + lambda = 1.d0 + exit + else if ((E_half > E).and.(lambda > 5.d-4)) then + lambda = 0.5d0 * lambda + E_new = E_half + else + exit + endif + enddo + + a = (E_new + E - 2.d0*E_half)*2.d0 + b = -E_new - 3.d0*E + 4.d0*E_half + lambda = -lambda*b/(a+1.d-16) + D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha + D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta + delta_E = HF_energy - E + do j=1,ao_num + do i=1,ao_num + delta_D = delta_D + & + (D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + & + (D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j)) + enddo + enddo + delta_D = dsqrt(delta_D/dble(ao_num)**2) + HF_density_matrix_ao_alpha = D_alpha + HF_density_matrix_ao_beta = D_beta + TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + + + enddo + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' + write(output_hartree_fock,*) + + if(.not.no_oa_or_av_opt)then + call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) + endif + + call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') + call ezfio_set_hartree_fock_energy(E_min) + + call write_time(output_hartree_fock) + + deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta) +end diff --git a/plugins/SCF_density/diagonalize_fock.irp.f b/plugins/SCF_density/diagonalize_fock.irp.f new file mode 100644 index 00000000..2983abeb --- /dev/null +++ b/plugins/SCF_density/diagonalize_fock.irp.f @@ -0,0 +1,124 @@ + BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ] +&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Diagonal Fock matrix in the MO basis + END_DOC + + integer :: i,j + integer :: liwork, lwork, n, info + integer, allocatable :: iwork(:) + double precision, allocatable :: work(:), F(:,:), S(:,:) + + + allocate( F(mo_tot_num_align,mo_tot_num) ) + do j=1,mo_tot_num + do i=1,mo_tot_num + F(i,j) = Fock_matrix_mo(i,j) + enddo + enddo +! print*, no_oa_or_av_opt + if(no_oa_or_av_opt)then + integer :: iorb,jorb + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_inact_orb + jorb = list_inact(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + do j = 1, n_virt_orb + jorb = list_virt(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + do j = 1, n_core_orb + jorb = list_core(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + enddo +! do i = 1, n_act_orb +! iorb = list_act(i) +! write(*,'(100(F16.10,X))')F(iorb,:) +! enddo + endif + + + + + ! Insert level shift here + do i = elec_beta_num+1, elec_alpha_num + F(i,i) += 0.5d0*level_shift + enddo + + do i = elec_alpha_num+1, mo_tot_num + F(i,i) += level_shift + enddo + + n = mo_tot_num + lwork = 1+6*n + 2*n*n + liwork = 3 + 5*n + + allocate(work(lwork), iwork(liwork) ) + + lwork = -1 + liwork = -1 + + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + lwork = int(work(1)) + liwork = iwork(1) + deallocate(work,iwork) + allocate(work(lwork), iwork(liwork) ) + + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + + call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, & + mo_coef, size(mo_coef,1), F, size(F,1), & + 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) + deallocate(work, iwork, F) + + +! endif + +END_PROVIDER + +BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] + implicit none + BEGIN_DOC + ! diagonal element of the fock matrix calculated as the sum over all the interactions + ! with all the electrons in the RHF determinant + ! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij + END_DOC + integer :: i,j + double precision :: accu + do j = 1,elec_alpha_num + accu = 0.d0 + do i = 1, elec_alpha_num + accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) + enddo + diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) + enddo + do j = elec_alpha_num+1,mo_tot_num + accu = 0.d0 + do i = 1, elec_alpha_num + accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) + enddo + diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) + enddo + +END_PROVIDER diff --git a/plugins/SCF_density/huckel.irp.f b/plugins/SCF_density/huckel.irp.f new file mode 100644 index 00000000..103de83a --- /dev/null +++ b/plugins/SCF_density/huckel.irp.f @@ -0,0 +1,32 @@ +subroutine huckel_guess + implicit none + BEGIN_DOC +! Build the MOs using the extended Huckel model + END_DOC + integer :: i,j + double precision :: accu + double precision :: c + character*(64) :: label + + label = "Guess" + call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, & + size(mo_mono_elec_integral,1), & + size(mo_mono_elec_integral,2),label,1) + TOUCH mo_coef + + c = 0.5d0 * 1.75d0 + + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num + Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral_diag(i) + & + ao_mono_elec_integral_diag(j)) + enddo + Fock_matrix_ao(j,j) = Fock_matrix_alpha_ao(j,j) + enddo + TOUCH Fock_matrix_ao + mo_coef = eigenvectors_fock_matrix_mo + SOFT_TOUCH mo_coef + call save_mos + +end From c5cc7e4d47c2489859fbec4f5dca588883a6442b Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 17 Mar 2017 11:40:48 +0100 Subject: [PATCH 76/76] New version of FOBOCI --- plugins/FOBOCI/density_matrix.irp.f | 1 + plugins/FOBOCI/fobo_scf.irp.f | 7 +++++-- .../FOBOCI/foboci_lmct_mlct_threshold_old.irp.f | 1 + plugins/FOBOCI/generators_restart_save.irp.f | 15 +++++++++++++++ plugins/FOBOCI/routines_foboci.irp.f | 4 ++++ 5 files changed, 26 insertions(+), 2 deletions(-) diff --git a/plugins/FOBOCI/density_matrix.irp.f b/plugins/FOBOCI/density_matrix.irp.f index 42138c00..5a06d5d7 100644 --- a/plugins/FOBOCI/density_matrix.irp.f +++ b/plugins/FOBOCI/density_matrix.irp.f @@ -17,6 +17,7 @@ integer :: degree_respect_to_HF_l,index_ref_generators_restart double precision :: inv_coef_ref_generators_restart integer :: i + print*, 'providing the one_body_dm_mo_alpha_generators_restart' do i = 1, N_det_generators_restart ! Find the reference determinant for intermediate normalization diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 8be36b8a..3860493c 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -26,7 +26,8 @@ subroutine routine_fobo_scf print*,'' character*(64) :: label label = "Natural" - do i = 1, 1 + do i = 1, 10 + call initialize_mo_coef_begin_iteration print*,'*******************************************************************************' print*,'*******************************************************************************' print*,'FOBO-SCF Iteration ',i @@ -52,8 +53,10 @@ subroutine routine_fobo_scf endif call FOBOCI_lmct_mlct_old_thr(i) call save_osoci_natural_mos -! call damping_SCF + call damping_SCF call diag_inactive_virt_and_update_mos + call reorder_active_orb + call save_mos call clear_mo_map call provide_properties enddo diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index 3d8dfb08..5b549fc3 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -40,6 +40,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) logical :: lmct double precision, allocatable :: psi_singles_coef(:,:) logical :: exit_loop + call update_generators_restart_coef allocate( zero_bitmask(N_int,2) ) do i = 1, n_inact_orb lmct = .True. diff --git a/plugins/FOBOCI/generators_restart_save.irp.f b/plugins/FOBOCI/generators_restart_save.irp.f index eba9f0ad..669c899d 100644 --- a/plugins/FOBOCI/generators_restart_save.irp.f +++ b/plugins/FOBOCI/generators_restart_save.irp.f @@ -74,3 +74,18 @@ END_PROVIDER &BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ] END_PROVIDER + +subroutine update_generators_restart_coef + implicit none + call set_generators_to_generators_restart + call set_psi_det_to_generators + call diagonalize_CI + integer :: i,j,k,l + do i = 1, N_det_generators_restart + do j = 1, N_states + psi_coef_generators_restart(i,j) = psi_coef(i,j) + enddo + enddo + soft_touch psi_coef_generators_restart + provide one_body_dm_mo_alpha_generators_restart +end diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index 26ce3b12..cda7dd75 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -329,6 +329,10 @@ end subroutine initialize_density_matrix_osoci implicit none + call set_generators_to_generators_restart + call set_psi_det_to_generators + call diagonalize_CI + one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart integer :: i