mirror of
https://github.com/LCPQ/quantum_package
synced 2024-08-24 21:41:46 +02:00
commit
4f501c0a98
4
configure
vendored
4
configure
vendored
@ -33,8 +33,8 @@ import sys
|
|||||||
from os.path import join
|
from os.path import join
|
||||||
|
|
||||||
if not any(i in ["--production", "--development"] for i in sys.argv):
|
if not any(i in ["--production", "--development"] for i in sys.argv):
|
||||||
print __doc__
|
sys.argv += ["--development"]
|
||||||
sys.exit()
|
|
||||||
if len(sys.argv) != 3:
|
if len(sys.argv) != 3:
|
||||||
print __doc__
|
print __doc__
|
||||||
sys.exit()
|
sys.exit()
|
||||||
|
@ -100,26 +100,21 @@ let run ?o b c d m p xyz_file =
|
|||||||
match Hashtbl.find basis_table key with
|
match Hashtbl.find basis_table key with
|
||||||
| Some in_channel ->
|
| Some in_channel ->
|
||||||
in_channel
|
in_channel
|
||||||
| None ->
|
| None ->
|
||||||
begin
|
let msg =
|
||||||
Printf.printf "%s is not defined in basis %s.\nEnter alternate basis : %!"
|
Printf.sprintf "%s is not defined in basis %s.%!"
|
||||||
(Element.to_long_string element) b ;
|
(Element.to_long_string element) b ;
|
||||||
let bas =
|
in
|
||||||
match In_channel.input_line stdin with
|
failwith msg
|
||||||
| Some line -> String.strip line |> String.lowercase
|
|
||||||
| None -> failwith "Aborted"
|
|
||||||
in
|
|
||||||
let new_channel = In_channel.create
|
|
||||||
(Qpackage.root ^ "/data/basis/" ^ bas)
|
|
||||||
in
|
|
||||||
Hashtbl.add_exn basis_table ~key:key ~data:new_channel;
|
|
||||||
new_channel
|
|
||||||
end
|
|
||||||
in
|
in
|
||||||
|
|
||||||
let temp_filename =
|
let temp_filename =
|
||||||
Filename.temp_file "qp_create_" ".basis"
|
Filename.temp_file "qp_create_" ".basis"
|
||||||
in
|
in
|
||||||
|
let () =
|
||||||
|
Sys.remove temp_filename
|
||||||
|
in
|
||||||
|
|
||||||
let rec build_basis = function
|
let rec build_basis = function
|
||||||
| [] -> ()
|
| [] -> ()
|
||||||
| elem_and_basis_name :: rest ->
|
| elem_and_basis_name :: rest ->
|
||||||
@ -130,10 +125,10 @@ let run ?o b c d m p xyz_file =
|
|||||||
let command =
|
let command =
|
||||||
if (p) then
|
if (p) then
|
||||||
Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename
|
Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename
|
||||||
^ "\" \"" ^ basis ^"\" pseudo"
|
^ "." ^ basis ^ "\" \"" ^ basis ^"\" pseudo"
|
||||||
else
|
else
|
||||||
Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename
|
Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename
|
||||||
^ "\" \"" ^ basis ^"\""
|
^ "." ^ basis ^ "\" \"" ^ basis ^"\""
|
||||||
in
|
in
|
||||||
begin
|
begin
|
||||||
let filename =
|
let filename =
|
||||||
@ -163,8 +158,8 @@ let run ?o b c d m p xyz_file =
|
|||||||
Element.to_string elem
|
Element.to_string elem
|
||||||
in
|
in
|
||||||
let command =
|
let command =
|
||||||
Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename ^
|
Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename
|
||||||
"\" \"" ^ basis ^ "\" " ^ key
|
^ "." ^ basis ^ "\" \"" ^ basis ^ "\" "
|
||||||
in
|
in
|
||||||
begin
|
begin
|
||||||
let filename =
|
let filename =
|
||||||
@ -232,11 +227,15 @@ let run ?o b c d m p xyz_file =
|
|||||||
(* Write Basis set *)
|
(* Write Basis set *)
|
||||||
let basis =
|
let basis =
|
||||||
|
|
||||||
let nmax = Nucl_number.get_max () in
|
let nmax =
|
||||||
|
Nucl_number.get_max ()
|
||||||
|
in
|
||||||
let rec do_work (accu:(Atom.t*Nucl_number.t) list) (n:int) = function
|
let rec do_work (accu:(Atom.t*Nucl_number.t) list) (n:int) = function
|
||||||
| [] -> accu
|
| [] -> accu
|
||||||
| e::tail ->
|
| e::tail ->
|
||||||
let new_accu = (e,(Nucl_number.of_int ~max:nmax n))::accu in
|
let new_accu =
|
||||||
|
(e,(Nucl_number.of_int ~max:nmax n))::accu
|
||||||
|
in
|
||||||
do_work new_accu (n+1) tail
|
do_work new_accu (n+1) tail
|
||||||
in
|
in
|
||||||
let result = do_work [] 1 nuclei
|
let result = do_work [] 1 nuclei
|
||||||
@ -250,15 +249,8 @@ let run ?o b c d m p xyz_file =
|
|||||||
in
|
in
|
||||||
Basis.read_element (basis_channel x.Atom.element) i e
|
Basis.read_element (basis_channel x.Atom.element) i e
|
||||||
with
|
with
|
||||||
| End_of_file ->
|
| End_of_file -> failwith
|
||||||
begin
|
("Element "^(Element.to_string x.Atom.element)^" not found in basis set.")
|
||||||
let alt_channel = basis_channel x.Atom.element in
|
|
||||||
try
|
|
||||||
Basis.read_element alt_channel i x.Atom.element
|
|
||||||
with
|
|
||||||
End_of_file -> failwith
|
|
||||||
("Element "^(Element.to_string x.Atom.element)^" not found")
|
|
||||||
end
|
|
||||||
)
|
)
|
||||||
|> List.concat
|
|> List.concat
|
||||||
in
|
in
|
||||||
|
@ -6,5 +6,9 @@ from perturbation import perturbations
|
|||||||
s = H_apply("mp2")
|
s = H_apply("mp2")
|
||||||
s.set_perturbation("Moller_plesset")
|
s.set_perturbation("Moller_plesset")
|
||||||
print s
|
print s
|
||||||
|
|
||||||
|
s = H_apply("mp2_selection")
|
||||||
|
s.set_selection_pt2("Moller_plesset")
|
||||||
|
print s
|
||||||
END_SHELL
|
END_SHELL
|
||||||
|
|
||||||
|
31
plugins/MP2/mp2_wf.irp.f
Normal file
31
plugins/MP2/mp2_wf.irp.f
Normal file
@ -0,0 +1,31 @@
|
|||||||
|
program mp2_wf
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Save the MP2 wave function
|
||||||
|
END_DOC
|
||||||
|
integer :: i,k
|
||||||
|
|
||||||
|
|
||||||
|
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
|
||||||
|
integer :: N_st, iter
|
||||||
|
N_st = N_states
|
||||||
|
allocate (pt2(N_st), norm_pert(N_st), H_pert_diag(N_st))
|
||||||
|
|
||||||
|
pt2 = 1.d0
|
||||||
|
selection_criterion = 1.e-12
|
||||||
|
selection_criterion_min = 1.e-12
|
||||||
|
TOUCH selection_criterion_min selection_criterion selection_criterion_factor
|
||||||
|
call H_apply_mp2_selection(pt2, norm_pert, H_pert_diag, N_st)
|
||||||
|
psi_det = psi_det_sorted
|
||||||
|
psi_coef = psi_coef_sorted
|
||||||
|
touch N_det psi_det psi_coef
|
||||||
|
print*,'N_det = ',N_det
|
||||||
|
print*,'-----'
|
||||||
|
print *, 'PT2 = ', pt2(1)
|
||||||
|
print *, 'E = ', HF_energy
|
||||||
|
print *, 'E_before +PT2 = ', HF_energy+pt2(1)
|
||||||
|
N_det = min(N_det,N_det_max)
|
||||||
|
call save_wavefunction
|
||||||
|
call ezfio_set_mp2_energy(HF_energy+pt2(1))
|
||||||
|
deallocate(pt2,norm_pert,H_pert_diag)
|
||||||
|
end
|
@ -26,10 +26,18 @@ subroutine pt2_moller_plesset(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_s
|
|||||||
ASSERT (Nint == N_int)
|
ASSERT (Nint == N_int)
|
||||||
ASSERT (Nint > 0)
|
ASSERT (Nint > 0)
|
||||||
call get_excitation(ref_bitmask,det_pert,exc,degree,phase,Nint)
|
call get_excitation(ref_bitmask,det_pert,exc,degree,phase,Nint)
|
||||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
if (degree == 2) then
|
||||||
delta_e = Fock_matrix_diag_mo(h1) + Fock_matrix_diag_mo(h2) - &
|
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||||
(Fock_matrix_diag_mo(p1) + Fock_matrix_diag_mo(p2))
|
delta_e = Fock_matrix_diag_mo(h1) + Fock_matrix_diag_mo(h2) - &
|
||||||
delta_e = 1.d0/delta_e
|
(Fock_matrix_diag_mo(p1) + Fock_matrix_diag_mo(p2))
|
||||||
|
delta_e = 1.d0/delta_e
|
||||||
|
else if (degree == 1) then
|
||||||
|
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||||
|
delta_e = Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1)
|
||||||
|
delta_e = 1.d0/delta_e
|
||||||
|
else
|
||||||
|
delta_e = 0.d0
|
||||||
|
endif
|
||||||
|
|
||||||
call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det,psi_selectors_size,n_st,i_H_psi_array)
|
call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det,psi_selectors_size,n_st,i_H_psi_array)
|
||||||
h = diag_H_mat_elem(det_pert,Nint)
|
h = diag_H_mat_elem(det_pert,Nint)
|
||||||
|
@ -60,7 +60,7 @@ class H_apply(object):
|
|||||||
s["omp_master"] = "!$OMP MASTER"
|
s["omp_master"] = "!$OMP MASTER"
|
||||||
s["omp_end_master"] = "!$OMP END MASTER"
|
s["omp_end_master"] = "!$OMP END MASTER"
|
||||||
s["omp_barrier"] = "!$OMP BARRIER"
|
s["omp_barrier"] = "!$OMP BARRIER"
|
||||||
s["omp_do"] = "!$OMP DO SCHEDULE (static)"
|
s["omp_do"] = "!$OMP DO SCHEDULE (static,1)"
|
||||||
s["omp_enddo"] = "!$OMP ENDDO NOWAIT"
|
s["omp_enddo"] = "!$OMP ENDDO NOWAIT"
|
||||||
|
|
||||||
d = { True : '.True.', False : '.False.'}
|
d = { True : '.True.', False : '.False.'}
|
||||||
@ -201,7 +201,7 @@ class H_apply(object):
|
|||||||
"""
|
"""
|
||||||
self.data["size_max"] = "256"
|
self.data["size_max"] = "256"
|
||||||
self.data["initialization"] = """
|
self.data["initialization"] = """
|
||||||
PROVIDE CI_electronic_energy 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
|
||||||
"""
|
"""
|
||||||
self.data["keys_work"] = """
|
self.data["keys_work"] = """
|
||||||
call perturb_buffer_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, &
|
call perturb_buffer_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, &
|
||||||
@ -219,7 +219,7 @@ class H_apply(object):
|
|||||||
double precision, intent(inout):: norm_pert(N_st)
|
double precision, intent(inout):: norm_pert(N_st)
|
||||||
double precision, intent(inout):: H_pert_diag(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)
|
double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st)
|
||||||
PROVIDE CI_electronic_energy N_det_generators
|
PROVIDE N_det_generators
|
||||||
do k=1,N_st
|
do k=1,N_st
|
||||||
pt2(k) = 0.d0
|
pt2(k) = 0.d0
|
||||||
norm_pert(k) = 0.d0
|
norm_pert(k) = 0.d0
|
||||||
|
@ -8,6 +8,8 @@
|
|||||||
# Prints in stdout the name of a temporary file containing the basis set.
|
# Prints in stdout the name of a temporary file containing the basis set.
|
||||||
#
|
#
|
||||||
|
|
||||||
|
#DEBUG:
|
||||||
|
#echo $0 $@ 1>&2
|
||||||
|
|
||||||
if [[ -z ${QP_ROOT} ]]
|
if [[ -z ${QP_ROOT} ]]
|
||||||
then
|
then
|
||||||
|
@ -10,6 +10,9 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl
|
|||||||
integer :: highest, p1,p2,sp,ni,i,mi,nt,ns
|
integer :: highest, p1,p2,sp,ni,i,mi,nt,ns
|
||||||
|
|
||||||
integer(bit_kind), intent(in) :: key_prev(N_int, 2, *)
|
integer(bit_kind), intent(in) :: key_prev(N_int, 2, *)
|
||||||
|
PROVIDE N_int
|
||||||
|
PROVIDE N_det
|
||||||
|
|
||||||
$declarations
|
$declarations
|
||||||
|
|
||||||
|
|
||||||
@ -183,10 +186,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
|
|||||||
particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1))
|
particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1))
|
||||||
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
|
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
|
||||||
enddo
|
enddo
|
||||||
call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int)
|
call bitstring_to_list_ab(particle,occ_particle,N_elec_in_key_part_1,N_int)
|
||||||
call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int)
|
call bitstring_to_list_ab(hole,occ_hole,N_elec_in_key_hole_1,N_int)
|
||||||
call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int)
|
|
||||||
call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int)
|
|
||||||
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), &
|
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), &
|
||||||
ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num))
|
ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num))
|
||||||
|
|
||||||
@ -249,10 +250,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
|
|||||||
particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2))
|
particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2))
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int)
|
call bitstring_to_list_ab(particle_tmp,occ_particle_tmp,N_elec_in_key_part_2,N_int)
|
||||||
call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int)
|
call bitstring_to_list_ab(hole_tmp,occ_hole_tmp,N_elec_in_key_hole_2,N_int)
|
||||||
call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int)
|
|
||||||
call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int)
|
|
||||||
|
|
||||||
! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin)
|
! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin)
|
||||||
hole_save = hole
|
hole_save = hole
|
||||||
@ -444,10 +443,8 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $pa
|
|||||||
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
|
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int)
|
call bitstring_to_list_ab(particle,occ_particle,N_elec_in_key_part_1,N_int)
|
||||||
call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int)
|
call bitstring_to_list_ab(hole,occ_hole,N_elec_in_key_hole_1,N_int)
|
||||||
call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int)
|
|
||||||
call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int)
|
|
||||||
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2))
|
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2))
|
||||||
|
|
||||||
do ispin=1,2
|
do ispin=1,2
|
||||||
|
@ -71,7 +71,6 @@
|
|||||||
one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b
|
one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b
|
||||||
!$OMP END CRITICAL
|
!$OMP END CRITICAL
|
||||||
deallocate(tmp_a,tmp_b)
|
deallocate(tmp_a,tmp_b)
|
||||||
!$OMP BARRIER
|
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
endif
|
endif
|
||||||
@ -157,7 +156,6 @@ END_PROVIDER
|
|||||||
one_body_single_double_dm_mo_beta = one_body_single_double_dm_mo_beta + tmp_b
|
one_body_single_double_dm_mo_beta = one_body_single_double_dm_mo_beta + tmp_b
|
||||||
!$OMP END CRITICAL
|
!$OMP END CRITICAL
|
||||||
deallocate(tmp_a,tmp_b)
|
deallocate(tmp_a,tmp_b)
|
||||||
!$OMP BARRIER
|
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -132,7 +132,7 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx)
|
|||||||
popcnt(xor( key1(1,2,i), key2(1,2)))
|
popcnt(xor( key1(1,2,i), key2(1,2)))
|
||||||
if (degree_x2 > 4) then
|
if (degree_x2 > 4) then
|
||||||
cycle
|
cycle
|
||||||
else if(degree_x2 .ne. 0)then
|
else if(degree_x2 /= 0)then
|
||||||
idx(l) = i
|
idx(l) = i
|
||||||
l = l+1
|
l = l+1
|
||||||
endif
|
endif
|
||||||
@ -148,7 +148,7 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx)
|
|||||||
popcnt(xor( key1(2,2,i), key2(2,2)))
|
popcnt(xor( key1(2,2,i), key2(2,2)))
|
||||||
if (degree_x2 > 4) then
|
if (degree_x2 > 4) then
|
||||||
cycle
|
cycle
|
||||||
else if(degree_x2 .ne. 0)then
|
else if(degree_x2 /= 0)then
|
||||||
idx(l) = i
|
idx(l) = i
|
||||||
l = l+1
|
l = l+1
|
||||||
endif
|
endif
|
||||||
@ -166,7 +166,7 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx)
|
|||||||
popcnt(xor( key1(3,2,i), key2(3,2)))
|
popcnt(xor( key1(3,2,i), key2(3,2)))
|
||||||
if (degree_x2 > 4) then
|
if (degree_x2 > 4) then
|
||||||
cycle
|
cycle
|
||||||
else if(degree_x2 .ne. 0)then
|
else if(degree_x2 /= 0)then
|
||||||
idx(l) = i
|
idx(l) = i
|
||||||
l = l+1
|
l = l+1
|
||||||
endif
|
endif
|
||||||
@ -175,23 +175,28 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx)
|
|||||||
else
|
else
|
||||||
|
|
||||||
!DIR$ LOOP COUNT (1000)
|
!DIR$ LOOP COUNT (1000)
|
||||||
do i=1,sze
|
outer: do i=1,sze
|
||||||
degree_x2 = 0
|
degree_x2 = 0
|
||||||
!DEC$ LOOP COUNT MIN(4)
|
!DEC$ LOOP COUNT MIN(4)
|
||||||
do m=1,Nint
|
do m=1,Nint
|
||||||
degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +&
|
if ( key1(m,1,i) /= key2(m,1)) then
|
||||||
popcnt(xor( key1(m,2,i), key2(m,2)))
|
degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1)))
|
||||||
if (degree_x2 > 4) then
|
if (degree_x2 > 4) then
|
||||||
exit
|
cycle outer
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
if ( key1(m,2,i) /= key2(m,2)) then
|
||||||
|
degree_x2 = degree_x2+ popcnt(xor( key1(m,2,i), key2(m,2)))
|
||||||
|
if (degree_x2 > 4) then
|
||||||
|
cycle outer
|
||||||
|
endif
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
if (degree_x2 > 4) then
|
if(degree_x2 /= 0)then
|
||||||
cycle
|
|
||||||
else if(degree_x2 .ne. 0)then
|
|
||||||
idx(l) = i
|
idx(l) = i
|
||||||
l = l+1
|
l = l+1
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo outer
|
||||||
|
|
||||||
endif
|
endif
|
||||||
idx(0) = l-1
|
idx(0) = l-1
|
||||||
|
@ -349,6 +349,80 @@ subroutine get_mono_excitation(det1,det2,exc,phase,Nint)
|
|||||||
enddo
|
enddo
|
||||||
end
|
end
|
||||||
|
|
||||||
|
subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Gives the inidices(+1) of the bits set to 1 in the bit string
|
||||||
|
! For alpha/beta determinants
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: Nint
|
||||||
|
integer(bit_kind), intent(in) :: string(Nint,2)
|
||||||
|
integer, intent(out) :: list(Nint*bit_kind_size,2)
|
||||||
|
integer, intent(out) :: n_elements(2)
|
||||||
|
|
||||||
|
integer :: i, j, ishift
|
||||||
|
integer(bit_kind) :: l
|
||||||
|
|
||||||
|
n_elements(1) = 0
|
||||||
|
n_elements(2) = 0
|
||||||
|
ishift = 1
|
||||||
|
do i=1,Nint
|
||||||
|
l = string(i,1)
|
||||||
|
do while (l /= 0_bit_kind)
|
||||||
|
j = trailz(l)
|
||||||
|
n_elements(1) = n_elements(1)+1
|
||||||
|
l = ibclr(l,j)
|
||||||
|
list(n_elements(1),1) = ishift+j
|
||||||
|
enddo
|
||||||
|
l = string(i,2)
|
||||||
|
do while (l /= 0_bit_kind)
|
||||||
|
j = trailz(l)
|
||||||
|
n_elements(2) = n_elements(2)+1
|
||||||
|
l = ibclr(l,j)
|
||||||
|
list(n_elements(2),2) = ishift+j
|
||||||
|
enddo
|
||||||
|
ishift = ishift + bit_kind_size
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine bitstring_to_list_ab_old( string, list, n_elements, Nint)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Gives the inidices(+1) of the bits set to 1 in the bit string
|
||||||
|
! For alpha/beta determinants
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: Nint
|
||||||
|
integer(bit_kind), intent(in) :: string(Nint,2)
|
||||||
|
integer, intent(out) :: list(Nint*bit_kind_size,2)
|
||||||
|
integer, intent(out) :: n_elements(2)
|
||||||
|
|
||||||
|
integer :: i, ishift
|
||||||
|
integer(bit_kind) :: l
|
||||||
|
|
||||||
|
n_elements(1) = 0
|
||||||
|
n_elements(2) = 0
|
||||||
|
ishift = 2
|
||||||
|
do i=1,Nint
|
||||||
|
l = string(i,1)
|
||||||
|
do while (l /= 0_bit_kind)
|
||||||
|
n_elements(1) = n_elements(1)+1
|
||||||
|
list(n_elements(1),1) = ishift+popcnt(l-1_bit_kind) - popcnt(l)
|
||||||
|
l = iand(l,l-1_bit_kind)
|
||||||
|
enddo
|
||||||
|
l = string(i,2)
|
||||||
|
do while (l /= 0_bit_kind)
|
||||||
|
n_elements(2) = n_elements(2)+1
|
||||||
|
list(n_elements(2),2) = ishift+popcnt(l-1_bit_kind) - popcnt(l)
|
||||||
|
l = iand(l,l-1_bit_kind)
|
||||||
|
enddo
|
||||||
|
ishift = ishift + bit_kind_size
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -370,7 +444,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
|||||||
integer :: i,j,k
|
integer :: i,j,k
|
||||||
integer :: occ(Nint*bit_kind_size,2)
|
integer :: occ(Nint*bit_kind_size,2)
|
||||||
double precision :: diag_H_mat_elem, phase,phase_2
|
double precision :: diag_H_mat_elem, phase,phase_2
|
||||||
integer :: n_occ_alpha, n_occ_beta
|
integer :: n_occ_ab(2)
|
||||||
logical :: has_mipi(Nint*bit_kind_size)
|
logical :: has_mipi(Nint*bit_kind_size)
|
||||||
double precision :: mipi(Nint*bit_kind_size), miip(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
|
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
|
||||||
@ -422,8 +496,8 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
|||||||
endif
|
endif
|
||||||
case (1)
|
case (1)
|
||||||
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
||||||
call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint)
|
!DIR$ FORCEINLINE
|
||||||
call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint)
|
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||||
has_mipi = .False.
|
has_mipi = .False.
|
||||||
if (exc(0,1,1) == 1) then
|
if (exc(0,1,1) == 1) then
|
||||||
! Mono alpha
|
! Mono alpha
|
||||||
@ -506,7 +580,7 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
|
|||||||
integer :: i,j,k
|
integer :: i,j,k
|
||||||
integer :: occ(Nint*bit_kind_size,2)
|
integer :: occ(Nint*bit_kind_size,2)
|
||||||
double precision :: diag_H_mat_elem
|
double precision :: diag_H_mat_elem
|
||||||
integer :: n_occ_alpha, n_occ_beta
|
integer :: n_occ_ab(2)
|
||||||
logical :: has_mipi(Nint*bit_kind_size)
|
logical :: has_mipi(Nint*bit_kind_size)
|
||||||
double precision :: mipi(Nint*bit_kind_size), miip(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
|
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
|
||||||
@ -558,8 +632,8 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
|
|||||||
endif
|
endif
|
||||||
case (1)
|
case (1)
|
||||||
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
||||||
call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint)
|
!DIR$ FORCEINLINE
|
||||||
call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint)
|
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||||
has_mipi = .False.
|
has_mipi = .False.
|
||||||
if (exc(0,1,1) == 1) then
|
if (exc(0,1,1) == 1) then
|
||||||
! Mono alpha
|
! Mono alpha
|
||||||
@ -642,7 +716,7 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
|
|||||||
integer :: i,j,k
|
integer :: i,j,k
|
||||||
integer :: occ(Nint*bit_kind_size,2)
|
integer :: occ(Nint*bit_kind_size,2)
|
||||||
double precision :: diag_H_mat_elem, phase,phase_2
|
double precision :: diag_H_mat_elem, phase,phase_2
|
||||||
integer :: n_occ_alpha, n_occ_beta
|
integer :: n_occ_ab(2)
|
||||||
logical :: has_mipi(Nint*bit_kind_size)
|
logical :: has_mipi(Nint*bit_kind_size)
|
||||||
double precision :: mipi(Nint*bit_kind_size), miip(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
|
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
|
||||||
@ -696,8 +770,8 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
|
|||||||
endif
|
endif
|
||||||
case (1)
|
case (1)
|
||||||
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
||||||
call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint)
|
!DIR$ FORCEINLINE
|
||||||
call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint)
|
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||||
has_mipi = .False.
|
has_mipi = .False.
|
||||||
if (exc(0,1,1) == 1) then
|
if (exc(0,1,1) == 1) then
|
||||||
! Mono alpha
|
! Mono alpha
|
||||||
@ -1229,15 +1303,15 @@ double precision function diag_H_mat_elem(det_in,Nint)
|
|||||||
endif
|
endif
|
||||||
|
|
||||||
!call debug_det(det_in,Nint)
|
!call debug_det(det_in,Nint)
|
||||||
integer :: tmp
|
integer :: tmp(2)
|
||||||
call bitstring_to_list(particle(1,1), occ_particle(1,1), tmp, Nint)
|
!DIR$ FORCEINLINE
|
||||||
ASSERT (tmp == nexc(1))
|
call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
|
||||||
call bitstring_to_list(particle(1,2), occ_particle(1,2), tmp, Nint)
|
ASSERT (tmp(1) == nexc(1))
|
||||||
ASSERT (tmp == nexc(2))
|
ASSERT (tmp(2) == nexc(2))
|
||||||
call bitstring_to_list(hole(1,1), occ_hole(1,1), tmp, Nint)
|
!DIR$ FORCEINLINE
|
||||||
ASSERT (tmp == nexc(1))
|
call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
|
||||||
call bitstring_to_list(hole(1,2), occ_hole(1,2), tmp, Nint)
|
ASSERT (tmp(1) == nexc(1))
|
||||||
ASSERT (tmp == nexc(2))
|
ASSERT (tmp(2) == nexc(2))
|
||||||
|
|
||||||
det_tmp = ref_bitmask
|
det_tmp = ref_bitmask
|
||||||
do ispin=1,2
|
do ispin=1,2
|
||||||
@ -1266,6 +1340,7 @@ subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb)
|
|||||||
integer :: occ(Nint*bit_kind_size,2)
|
integer :: occ(Nint*bit_kind_size,2)
|
||||||
integer :: other_spin
|
integer :: other_spin
|
||||||
integer :: k,l,i
|
integer :: k,l,i
|
||||||
|
integer :: tmp(2)
|
||||||
|
|
||||||
ASSERT (iorb > 0)
|
ASSERT (iorb > 0)
|
||||||
ASSERT (ispin > 0)
|
ASSERT (ispin > 0)
|
||||||
@ -1279,19 +1354,19 @@ subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb)
|
|||||||
other_spin = iand(ispin,1)+1
|
other_spin = iand(ispin,1)+1
|
||||||
|
|
||||||
!DIR$ FORCEINLINE
|
!DIR$ FORCEINLINE
|
||||||
call get_occ_from_key(key,occ,Nint)
|
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||||
na -= 1
|
na = na-1
|
||||||
|
|
||||||
hjj -= mo_mono_elec_integral(iorb,iorb)
|
hjj = hjj - mo_mono_elec_integral(iorb,iorb)
|
||||||
|
|
||||||
! Same spin
|
! Same spin
|
||||||
do i=1,na
|
do i=1,na
|
||||||
hjj -= mo_bielec_integral_jj_anti(occ(i,ispin),iorb)
|
hjj = hjj - mo_bielec_integral_jj_anti(occ(i,ispin),iorb)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! Opposite spin
|
! Opposite spin
|
||||||
do i=1,nb
|
do i=1,nb
|
||||||
hjj -= mo_bielec_integral_jj(occ(i,other_spin),iorb)
|
hjj = hjj - mo_bielec_integral_jj(occ(i,other_spin),iorb)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
end
|
end
|
||||||
@ -1317,13 +1392,11 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb)
|
|||||||
ASSERT (ispin < 3)
|
ASSERT (ispin < 3)
|
||||||
ASSERT (Nint > 0)
|
ASSERT (Nint > 0)
|
||||||
|
|
||||||
integer :: tmp
|
integer :: tmp(2)
|
||||||
!DIR$ FORCEINLINE
|
!DIR$ FORCEINLINE
|
||||||
call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint)
|
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||||
ASSERT (tmp == elec_alpha_num)
|
ASSERT (tmp(1) == elec_alpha_num)
|
||||||
!DIR$ FORCEINLINE
|
ASSERT (tmp(2) == elec_beta_num)
|
||||||
call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint)
|
|
||||||
ASSERT (tmp == elec_beta_num)
|
|
||||||
|
|
||||||
k = ishft(iorb-1,-bit_kind_shift)+1
|
k = ishft(iorb-1,-bit_kind_shift)+1
|
||||||
ASSERT (k > 0)
|
ASSERT (k > 0)
|
||||||
@ -1331,18 +1404,18 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb)
|
|||||||
key(k,ispin) = ibset(key(k,ispin),l)
|
key(k,ispin) = ibset(key(k,ispin),l)
|
||||||
other_spin = iand(ispin,1)+1
|
other_spin = iand(ispin,1)+1
|
||||||
|
|
||||||
hjj += mo_mono_elec_integral(iorb,iorb)
|
hjj = hjj + mo_mono_elec_integral(iorb,iorb)
|
||||||
|
|
||||||
! Same spin
|
! Same spin
|
||||||
do i=1,na
|
do i=1,na
|
||||||
hjj += mo_bielec_integral_jj_anti(occ(i,ispin),iorb)
|
hjj = hjj + mo_bielec_integral_jj_anti(occ(i,ispin),iorb)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! Opposite spin
|
! Opposite spin
|
||||||
do i=1,nb
|
do i=1,nb
|
||||||
hjj += mo_bielec_integral_jj(occ(i,other_spin),iorb)
|
hjj = hjj + mo_bielec_integral_jj(occ(i,other_spin),iorb)
|
||||||
enddo
|
enddo
|
||||||
na += 1
|
na = na+1
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine get_occ_from_key(key,occ,Nint)
|
subroutine get_occ_from_key(key,occ,Nint)
|
||||||
@ -1354,10 +1427,10 @@ subroutine get_occ_from_key(key,occ,Nint)
|
|||||||
integer(bit_kind), intent(in) :: key(Nint,2)
|
integer(bit_kind), intent(in) :: key(Nint,2)
|
||||||
integer , intent(in) :: Nint
|
integer , intent(in) :: Nint
|
||||||
integer , intent(out) :: occ(Nint*bit_kind_size,2)
|
integer , intent(out) :: occ(Nint*bit_kind_size,2)
|
||||||
integer :: tmp
|
integer :: tmp(2)
|
||||||
|
|
||||||
call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint)
|
!DIR$ FORCEINLINE
|
||||||
call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint)
|
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user