LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2025-04-25 17:54:44 +02:00
Code Releases Activity

Merge branch 'dev-stable' of https://github.com/QuantumPackage/qp2 into dev-stable

Browse Source
This commit is contained in:
joguenzl 2025-03-17 16:00:19 +01:00
commit f3f3f3f135
91 changed files with 4630 additions and 2863 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
bin/qp_convert_output_to_ezfio
View File

@ -44,6 +44,7 @@ def write_ezfio(res, filename):
res.clean_uncontractions()
ezfio.set_file(filename)
ezfio.set_ezfio_files_ezfio_convention(20250211)
# _
# |_ | _ _ _|_ ._ _ ._ _
@ -154,8 +155,7 @@ def write_ezfio(res, filename):
prim_num_max = ezfio.get_ao_basis_ao_prim_num_max()
for i in range(len(res.basis)):
coefficient[
i] += [0. for j in range(len(coefficient[i]), prim_num_max)]
coefficient[i] += [0. for j in range(len(coefficient[i]), prim_num_max)]
exponent[i] += [0. for j in range(len(exponent[i]), prim_num_max)]
coefficient = reduce(lambda x, y: x + y, coefficient, [])
@ -173,6 +173,7 @@ def write_ezfio(res, filename):
# ~#~#~#~#~ #
ezfio.set_ao_basis_ao_coef(coef)
ezfio.set_basis_ao_normalized(True)
ezfio.set_ao_basis_ao_expo(expo)
ezfio.set_ao_basis_ao_basis("Read by resultsFile")

2
etc/openmp.rc
View File

@ -1 +1 @@
export OMP_NESTED=True
#export OMP_NESTED=True

2
external/ezfio vendored

@ -1 +1 @@
Subproject commit dba01c4fe0ff7b84c5ecfb1c7c77ec68781311b3
Subproject commit d02132ea79217c16fd24242e8f8b8a6c3ff68091

2
external/irpf90 vendored

@ -1 +1 @@
Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6
Subproject commit 43160c60d88d9f61fb97cc0b35477c8eb0df862b

35
ocaml/Angmom.ml
View File

@ -2,6 +2,7 @@ open Qptypes
open Sexplib.Std
type t = S|P|D|F|G|H|I|J|K|L [@@deriving sexp]
type st = t [@@deriving sexp]
let to_string = function
| S -> "S"
@ -70,13 +71,11 @@ let of_l i =
| x -> raise (Failure ("Angmom should be S|P|D|F|G|H|I|J|K|L"))
type st = t
module Xyz = struct
type t = { x: Positive_int.t ;
y: Positive_int.t ;
z: Positive_int.t } [@@deriving sexp]
type state_type = Null | X | Y | Z
(** Builds an XYZ triplet from a string.
@ -147,8 +146,8 @@ module Xyz = struct
in Positive_int.of_int (x+y+z)
(** Returns a list of XYZ powers for a given symmetry *)
let of_symmetry sym =
(** Returns a list of XYZ powers for a given angular momentum *)
let of_angmom sym =
let l = Positive_int.to_int (to_l sym) in
let create_z xyz =
{ x=xyz.x ;
@ -179,7 +178,31 @@ module Xyz = struct
|> List.rev
(** Returns the symmetry corresponding to the XYZ triplet *)
(** Returns the angular momentum corresponding to the XYZ triplet *)
let to_symmetry sym = of_l (get_l sym)
end
module Spd = struct
type t = { l: st; m: int } [@@deriving sexp]
let to_string { l ; m } =
(to_string l) ^ " " ^ (if m > 0 then "+" else "") ^ (string_of_int m)
let of_string s = match String_ext.lsplit2 ~on:' ' s with
| Some (l, m) -> { l=of_string l ; m=int_of_string m }
| _ -> failwith ("Invalid Spd: "^s)
(** Returns the l quantum number from a XYZ powers triplet *)
let get_l { l ; _ } = to_l l
(** Returns a list of XYZ powers for a given angular momentum *)
let of_angmom sym =
let l = Positive_int.to_int (to_l sym) in
Array.init (2*l+1) (fun i -> { l=sym ; m=i-l })
|> Array.to_list
(** Returns the angular momentum corresponding to the XYZ triplet *)
let to_symmetry sym = of_l (get_l sym)
end

25
ocaml/Angmom.mli
View File

@ -28,9 +28,30 @@ module Xyz :
val get_l : t -> Qptypes.Positive_int.t
(** Returns a list of XYZ powers for a given symmetry *)
val of_symmetry : st -> t list
val of_angmom : st -> t list
(** Returns the symmetry corresponding to the XYZ powers *)
val to_symmetry : t -> st
end
end
module Spd :
sig
type t = { l: st; m: int } [@@deriving sexp]
(** The string format contains the l and m quantum numbers *)
val of_string : string -> t
val to_string : t -> string
(** Returns the quantum number l *)
val get_l : t -> Qptypes.Positive_int.t
(** Returns a list of XYZ powers for a given symmetry *)
val of_angmom : st -> t list
(** Returns the symmetry corresponding to the XYZ powers *)
val to_symmetry : t -> st
end

4
ocaml/Long_basis.ml
View File

@ -10,7 +10,7 @@ let of_basis b =
| (g,n)::tail ->
begin
let new_accu =
Angmom.Xyz.of_symmetry g.Gto.sym
Angmom.Xyz.of_angmom g.Gto.sym
|> List.rev_map (fun x-> (x,g,n))
in
do_work (new_accu@accu) tail
@ -25,7 +25,7 @@ let to_basis b =
| [] -> List.rev accu
| (s,g,n)::tail ->
let first_sym =
Angmom.Xyz.of_symmetry g.Gto.sym
Angmom.Xyz.of_angmom g.Gto.sym
|> List.hd
in
let new_accu =

3
ocaml/qp_create_ezfio.ml
View File

@ -131,6 +131,7 @@ let run ?o b au c d m p cart xyz_file =
let key =
Element.to_string elem.Atom.element
in
if not (Hashtbl.mem basis_table key) then
Hashtbl.add basis_table key new_channel
) nuclei
end
@ -265,6 +266,8 @@ let run ?o b au c d m p cart xyz_file =
let write_file () =
(* Create EZFIO *)
Ezfio.set_file ezfio_file;
Ezfio.set_ezfio_files_ezfio_convention 20250211;
Ezfio.set_basis_ao_normalized true ;
(* Write Pseudo *)
let pseudo =

12
plugins/local/basis_correction/print_routine.irp.f
View File

@ -22,7 +22,10 @@ subroutine print_basis_correction
print*, '****************************************'
print*, '****************************************'
print*, 'mu_of_r_potential = ',mu_of_r_potential
if(mu_of_r_potential.EQ."hf".or.mu_of_r_potential.EQ."hf_old".or.mu_of_r_potential.EQ."hf_sparse")then
if(mu_of_r_potential.EQ."hf".or. &
mu_of_r_potential.EQ."hf_old".or.&
mu_of_r_potential.EQ."hf_sparse".or.&
mu_of_r_potential.EQ."proj")then
print*, ''
print*,'Using a HF-like two-body density to define mu(r)'
print*,'This assumes that HF is a qualitative representation of the wave function '
@ -38,7 +41,9 @@ subroutine print_basis_correction
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate)
enddo
else if(mu_of_r_potential.EQ."cas_full".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then
else if(mu_of_r_potential.EQ."cas_full".or. &
mu_of_r_potential.EQ."cas_truncated".or. &
mu_of_r_potential.EQ."pure_act") then
print*, ''
print*,'Using a CAS-like two-body density to define mu(r)'
print*,'This assumes that the CAS is a qualitative representation of the wave function '
@ -74,7 +79,8 @@ subroutine print_basis_correction
print*,''
print*,'**************'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' Average mu(r) , state ',istate,' = ',mu_average_prov(istate)
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' Average mu(r) [rho ], state ',istate,' = ',mu_average_prov(istate)
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' Average mu(r) [rho^2], state ',istate,' = ',mu_average_prov2(istate)
enddo
end

1
plugins/local/basis_correction/print_su_pbe_ot.irp.f
View File

@ -18,6 +18,7 @@ end
subroutine print_su_pbe_ot
implicit none
integer :: istate
print*,'Two flavours of PBE functionals :'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate)
enddo

4
plugins/local/extra_basis_int/ao_overlap.irp.f
View File

@ -4,7 +4,7 @@
BEGIN_PROVIDER [double precision, ao_extra_overlap , (ao_extra_num, ao_extra_num)]
BEGIN_DOC
! Overlap between atomic basis functions:
! Overlap between atomic basis functions belonging to the EXTRA BASIS
!
! :math:`\int \chi_i(r) \chi_j(r) dr`
END_DOC
@ -71,6 +71,8 @@ END_PROVIDER
BEGIN_DOC
! Overlap between atomic basis functions:
!
! first index belongs to the REGULAR AO basis, second to the EXTRA basis
!
! <AO_i|AO_j extra basis>
END_DOC

10
plugins/local/extra_basis_int/coul_1s.irp.f
View File

@ -11,6 +11,11 @@ double precision function coul_full_ao_pq_r_1s(p,q,R,R_p,R_q)
double precision, intent(in) :: R(3),R_p(3),R_q(3)
integer, intent(in) :: p,q
double precision :: coef,dist,P_pq(3),coefaos
if(.not.ao_extra_only_1s)then
print*,'You are using a function assuming that the extra basis is fitted on 1s functions'
print*,'But this is not the case apparently ... stopping'
stop
endif
coefaos= ao_extra_coef_normalized(p,1) * ao_extra_coef_normalized(q,1)
coef = inv_pi_gamma_pq_3_2_ao_extra(p,q) * E_pq_ao_extra(p,q)
P_pq = ao_extra_expo(p,1) * R_p + ao_extra_expo(q,1) * R_q
@ -40,6 +45,11 @@ double precision function coul_pq_r_1s(p,q,R,R_p,R_q)
double precision, intent(in) :: R(3),R_p(3),R_q(3)
integer, intent(in) :: p,q
double precision :: dist,P_pq(3)
if(.not.ao_extra_only_1s)then
print*,'You are using a function assuming that the extra basis is fitted on 1s functions'
print*,'But this is not the case apparently ... stopping'
stop
endif
P_pq = ao_extra_expo(p,1) * R_p + ao_extra_expo(q,1) * R_q
P_pq = P_pq * inv_gamma_pq_ao_extra(q,p)
dist = (P_pq(1)-R(1)) * (P_pq(1)-R(1))

56
plugins/local/extra_basis_int/extra_basis_int.irp.f
View File

@ -11,18 +11,30 @@ program extra_basis_int
! call routine_pot_ne
! call routine_test_pot_ne_extra_mixed
! call routine_test_coul_1s
call print_v_ne_extra_basis
call print_v_ne_basis
! call print_v_ne_extra_basis
! call print_v_ne_basis
! call test_v_ne_a_extra_basis
! call print_v_ee_mixed_direct
call print_v_ee_mixed_exchange
end
subroutine test_v_ne_a_extra_basis
implicit none
integer :: i,j
do i = 1, ao_extra_num
write(*,'(100(F16.10,X))')pot_vne_A_extra_basis(1:ao_extra_num,i)
enddo
end
subroutine test_overlap
implicit none
integer :: i,j
do i = 1, ao_extra_num
do j = 1, ao_extra_num
write(33,*)ao_extra_overlap(j,i)
enddo
do i = 1, ao_num
! do j = 1, ao_num
write(33,'(100(F16.10,X))')ao_extra_overlap_mixed(i,1:ao_extra_num)
! enddo
enddo
end
@ -189,3 +201,35 @@ subroutine print_v_ne_basis
print*,'accu = ',accu
end
subroutine print_v_ee_mixed_direct
implicit none
integer :: i,j,k,l
double precision :: ao_two_e_integral_mixed_direct
do i = 1, ao_num
do j = 1, ao_num
do k = 1, ao_extra_num
do l = 1, ao_extra_num
write(34,*)ao_two_e_integral_mixed_direct(i, j, k, l)
enddo
enddo
enddo
enddo
end
subroutine print_v_ee_mixed_exchange
implicit none
integer :: i,j,k,l
double precision :: ao_two_e_integral_mixed_exchange
do i = 1, ao_num
do j = 1, ao_extra_num
do k = 1, ao_num
do l = 1, ao_extra_num
write(34,*)ao_two_e_integral_mixed_exchange(i, j, k, l)
enddo
enddo
enddo
enddo
end

50
plugins/local/extra_basis_int/pot_ao_ints.irp.f
View File

@ -1,3 +1,53 @@
BEGIN_PROVIDER [ double precision, pot_vne_A_extra_basis, (ao_extra_num,ao_extra_num)]
implicit none
BEGIN_DOC
!
! Computes the following integral :
! $\sum_{R in the USUAL nuclei} -Z <chi_i|1/|r-R||chi_j>$
!
! where $\chi_i(r)$ AND $\chi_j(r)$ belongs to the EXTRA basis
END_DOC
integer :: mu,nu
double precision :: v_nucl_extra_ao
pot_vne_A_extra_basis = 0.d0
do mu = 1, ao_extra_num
do nu = 1, ao_extra_num
pot_vne_A_extra_basis(nu,mu)= v_nucl_extra_ao(mu,nu)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, pot_vne_extra_basis, (ao_num,ao_num)]
implicit none
BEGIN_DOC
!
! Computes the following integral :
! $\sum_{R in EXTRA nuclei} -Z <chi_i|1/|r-R||chi_j>$
!
!
! where $\chi_i(r)$ AND $\chi_j(r)$ belongs to the USUAL basis
END_DOC
integer :: mu,nu,k_nucl
double precision :: mu_in, R_nucl(3),charge_nucl, integral
double precision :: NAI_pol_mult_erf_ao
mu_in = 10.d0**10
pot_vne_extra_basis = 0.d0
do mu = 1, ao_num
do nu = 1, ao_num
do k_nucl = 1, extra_nucl_num
R_nucl(1:3) = extra_nucl_coord_transp(1:3,k_nucl)
charge_nucl = extra_nucl_charge(k_nucl)
integral = NAI_pol_mult_erf_ao(mu, nu, mu_in, R_nucl)
pot_vne_extra_basis(nu,mu) += -integral * charge_nucl
enddo
enddo
enddo
END_PROVIDER
double precision function NAI_pol_mult_erf_ao_extra(i_ao, j_ao, mu_in, C_center)

36
plugins/local/extra_basis_int/ref_extra_basis.irp.f
View File

@ -6,7 +6,9 @@ program pouet
! call routine_pot_ne_extra
! call ref_pot_ne_mixed
! call ref_pot_ne
call ref_pot_ne_extra_mixed
! call ref_pot_ne_extra_mixed
! call ref_v_ee_mixed_direct
call ref_v_ee_mixed_exchange
end
@ -113,3 +115,35 @@ subroutine ref_pot_ne_extra_mixed
enddo
enddo
end
subroutine ref_v_ee_mixed_direct
implicit none
integer :: i,j,k,l
double precision :: ao_two_e_integral
do i = 1, 15
do j = 1, 15
do k = 16, ao_num
do l = 16, ao_num
write(33,*)ao_two_e_integral(i, j, k, l)
enddo
enddo
enddo
enddo
end
subroutine ref_v_ee_mixed_exchange
implicit none
integer :: i,j,k,l
double precision :: ao_two_e_integral
do i = 1, 15
do j = 16, ao_num
do k = 1, 15
do l = 16, ao_num
write(33,*)ao_two_e_integral(i, j, k, l)
enddo
enddo
enddo
enddo
end

145
plugins/local/extra_basis_int/two_e_int.irp.f Normal file
View File

@ -0,0 +1,145 @@
double precision function ao_two_e_integral_mixed_direct(i, j, k, l)
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2)
! A A B B
!
! where i,j belong to the REGULAR AO basis (system A) and k,l to the EXTRA basis (system B)
END_DOC
implicit none
include 'utils/constants.include.F'
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
integer :: iorder_p(3), iorder_q(3)
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: integral
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
double precision :: general_primitive_integral
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_extra_nucl(k)
num_l = ao_extra_nucl(l)
ao_two_e_integral_mixed_direct = 0.d0
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_extra_power(k,p)
L_power(p) = ao_extra_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = extra_nucl_coord(num_k,p)
L_center(p) = extra_nucl_coord(num_l,p)
enddo
double precision :: coef1, coef2, coef3, coef4
double precision :: p_inv,q_inv
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
do r = 1, ao_extra_prim_num(k)
coef3 = coef2*ao_extra_coef_normalized_ordered_transp(r,k)
do s = 1, ao_extra_prim_num(l)
coef4 = coef3*ao_extra_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_extra_expo_ordered_transp(r,k),ao_extra_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_two_e_integral_mixed_direct = ao_two_e_integral_mixed_direct + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
end
double precision function ao_two_e_integral_mixed_exchange(i, j, k, l)
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2)
! A B A B
!
! where i,k belong to the REGULAR AO basis (system A) and j,l to the EXTRA basis (system B)
END_DOC
implicit none
include 'utils/constants.include.F'
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
integer :: iorder_p(3), iorder_q(3)
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: integral
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
double precision :: general_primitive_integral
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_extra_nucl(j)
num_k = ao_nucl(k)
num_l = ao_extra_nucl(l)
ao_two_e_integral_mixed_exchange = 0.d0
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_extra_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_extra_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = extra_nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = extra_nucl_coord(num_l,p)
enddo
double precision :: coef1, coef2, coef3, coef4
double precision :: p_inv,q_inv
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_extra_prim_num(j)
coef2 = coef1*ao_extra_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_extra_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_extra_prim_num(l)
coef4 = coef3*ao_extra_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_extra_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_two_e_integral_mixed_exchange = ao_two_e_integral_mixed_exchange + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
end

35
plugins/local/extra_basis_int/v_mixed_extra.irp.f
View File

@ -1,3 +1,6 @@
!!! TODO:: optimize when "ao_extra_only_1s" is True
double precision function v_extra_nucl_extra_ao(i_ao,j_ao)
implicit none
BEGIN_DOC
@ -6,9 +9,9 @@ double precision function v_extra_nucl_extra_ao(i_ao,j_ao)
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) v_ne^{extra}(r)$.
!
!
! where BOTH $\chi_i(r)$ AND $\chi_j(r)$ belongs to the EXTRA basis
! where BOTH $\chi_i(r)$ AND $\chi_j(r)$ belongs to the EXTRA basis (system B)
!
! and v_ne^{extra}(r) is the Coulomb potential coming from the EXTRA nuclei
! and v_ne^{extra}(r) is the Coulomb potential coming from the EXTRA nuclei (system B)
END_DOC
integer, intent(in) ::i_ao,j_ao
double precision :: mu_in,charge,coord(3)
@ -23,6 +26,30 @@ double precision function v_extra_nucl_extra_ao(i_ao,j_ao)
enddo
end
double precision function v_extra_nucl_ao(i_ao,j_ao)
implicit none
BEGIN_DOC
!
! Computes the following integral :
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) v_ne(r)$.
!
!
! where BOTH $\chi_i(r)$ AND $\chi_j(r)$ belongs to the REGULAR basis (system A)
!
! and v_ne(r) is the Coulomb potential coming from the EXTRA nuclei (system B)
END_DOC
integer, intent(in) ::i_ao,j_ao
integer :: i
double precision :: mu_in, coord(3),charge, integral
double precision :: NAI_pol_mult_erf_ao
mu_in = 1.d+10
do i = 1, extra_nucl_num
coord(1:3) = extra_nucl_coord_transp(1:3,i)
charge = extra_nucl_charge(i)
v_extra_nucl_ao += -NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, coord) * charge
enddo
end
double precision function v_nucl_extra_ao(i_ao,j_ao)
implicit none
@ -32,9 +59,9 @@ double precision function v_nucl_extra_ao(i_ao,j_ao)
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) v_ne(r)$.
!
!
! where BOTH $\chi_i(r)$ AND $\chi_j(r)$ belongs to the EXTRA basis
! where BOTH $\chi_i(r)$ AND $\chi_j(r)$ belongs to the EXTRA basis (system B)
!
! and v_ne(r) is the Coulomb potential coming from the REGULAR nuclei
! and v_ne(r) is the Coulomb potential coming from the REGULAR nuclei (system A)
END_DOC
integer, intent(in) ::i_ao,j_ao
double precision :: mu_in,charge,coord(3)

1
plugins/local/tuto_plugins/tuto_I/traces_one_e.irp.f
View File

@ -30,6 +30,7 @@ BEGIN_PROVIDER [ double precision, trace_ao_one_e_ints]
! have the same number of functions
END_DOC
integer :: i,j
double precision :: accu
double precision, allocatable :: inv_overlap_times_integrals(:,:) ! = h S^{-1}
allocate(inv_overlap_times_integrals(ao_num,ao_num))
! routine that computes the product of two matrices, you can check it with

1
scripts/qp_cipsi_rsh Symbolic link
View File

@ -0,0 +1 @@
/home/scemama/qp2/plugins/qp_plugins_lct/stable/rsdft_cipsi/qp_cipsi_rsh

1
scripts/qp_cipsi_rsh_mu_of_r Symbolic link
View File

@ -0,0 +1 @@
/home/scemama/qp2/plugins/qp_plugins_lct/stable/rsdft_cipsi/qp_cipsi_rsh_mu_of_r

12
scripts/qp_exc_energy.py
View File

@ -157,11 +157,15 @@ A = np.array( [ [ data[-1][1], 1. ],
B = np.array( [ [ data[-1][0] ],
[ data[-2][0] ] ] )
E0 = np.linalg.solve(A,B)[1]
E0 = E0[0]
A = np.array( [ [ data[-1][4], 1. ],
[ data[-2][4], 1. ] ] )
B = np.array( [ [ data[-1][3] ],
[ data[-2][3] ] ] )
E1 = np.linalg.solve(A,B)[1]
E1 = E1[0]
average_2 = (E1-E0)*to_eV
A = np.array( [ [ data[-1][1], 1. ],
@ -170,14 +174,18 @@ A = np.array( [ [ data[-1][1], 1. ],
B = np.array( [ [ data[-1][0] ],
[ data[-2][0] ],
[ data[-3][0] ] ] )
E0 = np.linalg.lstsq(A,B,rcond=None)[0][1]
E0 = np.linalg.lstsq(A,B,rcond=None)[0]
E0 = E0[0][0]
A = np.array( [ [ data[-1][4], 1. ],
[ data[-2][4], 1. ],
[ data[-3][4], 1. ] ] )
B = np.array( [ [ data[-1][3] ],
[ data[-2][3] ],
[ data[-3][3] ] ] )
E1 = np.linalg.lstsq(A,B,rcond=None)[0][1]
E1 = np.linalg.lstsq(A,B,rcond=None)[0]
E1 = E1[0][0]
average_3 = (E1-E0)*to_eV
exc = ((data[-1][3] + data[-1][4]) - (data[-1][0] + data[-1][1])) * to_eV

151
scripts/qp_geom_opt.py Executable file
View File

@ -0,0 +1,151 @@
#!/usr/bin/env python
# -*- coding: utf-8 -*-
"""
Usage:
qp_geom_opt [-s state] [-r executable] [-f] [-t tolerance] <EZFIO_FILE>
Options:
-s --state=<state> Excited state to optimize
-f --scf Perform an SCF after each geomety change
-r --qp_run=executable Excited state to optimize
-t --tol=tolerance Convergence criterion on the energy
"""
try:
from docopt import docopt
from module_handler import ModuleHandler, get_dict_child
from module_handler import get_l_module_descendant
from qp_path import QP_SRC, QP_PLUGINS, QP_DATA, QP_ROOT
except ImportError:
print("Please check if you have sourced the ${QP_ROOT}/quantum_package.rc")
print("(`source ${QP_ROOT}/quantum_package.rc`)")
print(sys.exit(1))
import numpy as np
import subprocess
from scipy.optimize import minimize
from ezfio import ezfio
import sys
def set_unbuffered_output():
"""Ensure sys.stdout is unbuffered or line-buffered in a portable way."""
if hasattr(sys.stdout, "reconfigure"): # Python 3.7+
sys.stdout.reconfigure(line_buffering=True)
else:
sys.stdout = open(sys.stdout.fileno(), mode='w', buffering=1)
set_unbuffered_output()
def get_energy(file, state, arguments):
"""Compute the energy of the given state by calling Quantum Package."""
if not arguments["--qp_run"]:
raise ValueError("--qp_run option missing")
if arguments["--scf"]:
executable = "scf"
else:
executable = "save_ortho_mos"
result = subprocess.run(f"qp_run {executable} {file} > {file}.energy.out",
shell=True, capture_output=True, text=True, check=True
)
executable = arguments["--qp_run"]
result = subprocess.run( f"qp_run {executable} {file} > {file}.energy.out",
shell=True)
energy = None
with open(f"{file}.energy.out", 'r') as f:
for line in f:
if "Energy of state" in line and f"{state}" in line:
energy = float(line.split()[-1]) # Extracts the energy value
return energy
raise ValueError("Energy not found in Quantum Package output. Update script {sys.argv[0]}")
def set_coordinates(coord):
"""Update the nuclear coordinates in EZFIO."""
ezfio.set_nuclei_nucl_coord(coord)
def get_coordinates():
"""Retrieve the current nuclear coordinates from EZFIO."""
return np.array(ezfio.get_nuclei_nucl_coord())
memo_energy = {}
def energy_function(coord, file, state, arguments):
"""Wrapper for the energy calculation, ensuring coordinates are updated."""
h = np.array_str(coord)
if h in memo_energy:
return memo_energy[h]
set_coordinates(coord)
energy = get_energy(file, state, arguments)
memo_energy[h] = energy
label = ezfio.get_nuclei_nucl_label()
num_atoms = len(label)
coord = coord.reshape(3, num_atoms).T # Reshape into (num_atoms, 3)
coord_angstrom = coord * 0.529177 # Convert atomic units to angstroms
print(num_atoms)
print(f"Energy: {energy:15.10f}")
for i, (x, y, z) in enumerate(coord_angstrom):
print(f"{label[i]:3s} {x:15.8f} {y:15.8f} {z:15.8f}") # Replace 'X' with actual atomic symbols
return energy
def optimize_geometry(file, state, arguments):
"""Perform geometry optimization using SciPy's minimize function."""
x0 = get_coordinates().flatten()
if arguments["--tol"]:
tolerance = float(tol=arguments["--tol"])
else:
tolerance = 1.e-3
result = minimize(energy_function, x0, args=(file, state, arguments),
method='Powell',
tol=tolerance,
options={'xtol': tolerance, 'ftol': tolerance})
# result = minimize(energy_function, x0, args=(file, state, arguments),
# method='BFGS',
# jac=None,
# tol=tolerance,
# options={'eps': 1.e-3})
if result.success:
print("Optimization successful!")
print("Final energy:", result.fun)
print("Optimized coordinates:", result.x)
else:
print("Optimization failed:", result.message)
set_coordinates(result.x) # Store the optimized geometry
return result
def main(arguments):
if arguments["--state"]:
state=arguments["--state"]
else:
state=1
ezfio_filename = arguments["<EZFIO_FILE>"]
ezfio.set_file(ezfio_filename)
optimize_geometry(ezfio_filename, state, arguments)
if __name__ == "__main__":
ARG = docopt(__doc__)
main(ARG)

21
scripts/qp_import_trexio.py
View File

@ -84,6 +84,7 @@ def write_ezfio(trexio_filename, filename):
ezfio.set_file(filename)
ezfio.set_trexio_trexio_file(trexio_filename)
ezfio.set_ezfio_files_ezfio_convention(20250211)
print("Nuclei\t\t...\t", end=' ')
@ -274,12 +275,11 @@ def write_ezfio(trexio_filename, filename):
if basis_type.lower() == "gaussian" and not cartesian:
try:
import trexio_tools
fd, tmp = tempfile.mkstemp()
os.close(fd)
tmp = "cartesian_"+trexio_filename
retcode = subprocess.call(["trexio", "convert-to", "-t", "cartesian", "-o", tmp, trexio_filename])
trexio_file_cart = trexio.File(tmp,mode='r',back_end=trexio.TREXIO_AUTO)
cartesian = trexio.read_ao_cartesian(trexio_file_cart)
os.unlink(tmp)
ezfio.set_trexio_trexio_file(tmp)
except:
pass
@ -319,8 +319,8 @@ def write_ezfio(trexio_filename, filename):
power_x.append(x)
power_y.append(y)
power_z.append(z)
coefficient.append(coef[i])
exponent.append(expo[i])
coefficient.append(list(coef[i]))
exponent.append(list(expo[i]))
num_prim.append(num_prim0[i])
assert (len(coefficient) == ao_num)
@ -330,15 +330,15 @@ def write_ezfio(trexio_filename, filename):
prim_num_max = max( [ len(x) for x in coefficient ] )
ao_normalization = trexio.read_ao_normalization(trexio_file_cart)
for i, coef in enumerate(coefficient):
for j in range(len(coef)):
coef[j] *= ao_normalization[i]
for i in range(ao_num):
coefficient[i] += [0. for j in range(len(coefficient[i]), prim_num_max)]
exponent [i] += [0. for j in range(len(exponent[i]), prim_num_max)]
ao_normalization = trexio.read_ao_normalization(trexio_file_cart)
for i in range(ao_num):
for j in range(prim_num_max):
coefficient[i][j] *= ao_normalization[i]
coefficient = reduce(lambda x, y: x + y, coefficient, [])
exponent = reduce(lambda x, y: x + y, exponent , [])
@ -349,6 +349,7 @@ def write_ezfio(trexio_filename, filename):
coef.append(coefficient[j])
expo.append(exponent[j])
ezfio.set_ao_basis_ao_coef(coef)
ezfio.set_ao_basis_ao_expo(expo)

102
src/ao_basis/aos.irp.f
View File

@ -20,7 +20,35 @@ BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ]
ao_shell(k) = i
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_sphe_num ]
implicit none
BEGIN_DOC
! Number of spherical AOs
END_DOC
integer :: n, i
ao_sphe_num=0
do i=1,shell_num
n = shell_ang_mom(i)
ao_sphe_num += 2*n+1
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_sphe_shell, (ao_sphe_num) ]
implicit none
BEGIN_DOC
! Index of the shell to which the AO corresponds
END_DOC
integer :: i, j, k, n
k=0
do i=1,shell_num
n = shell_ang_mom(i)
do j=-n,n
k = k+1
ao_sphe_shell(k) = i
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_first_of_shell, (shell_num) ]
@ -53,44 +81,96 @@ END_PROVIDER
C_A(3) = 0.d0
ao_coef_normalized = 0.d0
do i=1,ao_num
if (primitives_normalized) then
if (ezfio_convention >= 20250211) then
! Same primitive normalization factors for all AOs of the same shell, or read from trexio file
do i=1,ao_num
k=1
do while (k<=prim_num .and. shell_index(k) /= ao_shell(i))
k = k+1
end do
do j=1,ao_prim_num(i)
ao_coef_normalized(i,j) = ao_coef(i,j)*prim_normalization_factor(k+j-1)
enddo
enddo
else
! GAMESS convention for primitive factors
do i=1,ao_num
powA(1) = ao_power(i,1)
powA(2) = ao_power(i,2)
powA(3) = ao_power(i,3)
! Normalization of the primitives
if (primitives_normalized) then
do j=1,ao_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j), &
powA,powA,overlap_x,overlap_y,overlap_z,norm,nz)
ao_coef_normalized(i,j) = ao_coef(i,j)/dsqrt(norm)
enddo
enddo
endif
else
do i=1,ao_num
do j=1,ao_prim_num(i)
ao_coef_normalized(i,j) = ao_coef(i,j)
enddo
enddo
endif
! Normalization of the contracted basis functions
norm = 0.d0
double precision, allocatable :: self_overlap(:)
allocate(self_overlap(ao_num))
do i=1,ao_num
powA(1) = ao_power(i,1)
powA(2) = ao_power(i,2)
powA(3) = ao_power(i,3)
self_overlap(i) = 0.d0
do j=1,ao_prim_num(i)
do k=1,ao_prim_num(i)
do k=1,j-1
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
norm = norm+c*ao_coef_normalized(i,j)*ao_coef_normalized(i,k)
self_overlap(i) = self_overlap(i) + 2.d0*c*ao_coef_normalized(i,j)*ao_coef_normalized(i,k)
enddo
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j),powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
self_overlap(i) = self_overlap(i) +c*ao_coef_normalized(i,j)*ao_coef_normalized(i,j)
enddo
enddo
ao_coef_normalization_factor(i) = 1.d0/dsqrt(norm)
if (ao_normalized) then
do i=1,ao_num
ao_coef_normalization_factor(i) = 1.d0/dsqrt(self_overlap(i))
enddo
else
do i=1,ao_num
ao_coef_normalization_factor(i) = 1.d0
enddo
endif
do i=1,ao_num
do j=1,ao_prim_num(i)
ao_coef_normalized(i,j) = ao_coef_normalized(i,j) * ao_coef_normalization_factor(i)
enddo
else
ao_coef_normalization_factor(i) = 1.d0
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_sphe_coef_normalization_factor, (ao_sphe_num) ]
implicit none
BEGIN_DOC
! Normalization factor in spherical AO basis
END_DOC
ao_sphe_coef_normalization_factor(:) = 1.d0
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_normalized_ordered, (ao_num,ao_prim_num_max) ]

120
src/ao_basis/spherical_to_cartesian.irp.f
View File

@ -4,7 +4,8 @@
! First index is the index of the cartesian AO, obtained by ao_power_index
! Second index is the index of the spherical AO
BEGIN_PROVIDER [ double precision, cart_to_sphe_0, (1,1) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_0, (1,1) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_0, (1) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=0
@ -12,10 +13,12 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_0, (1,1) ]
cart_to_sphe_0 = 0.d0
cart_to_sphe_0 ( 1, 1) = 1.0d0
cart_to_sphe_norm_0 (1) = 1.d0
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_1, (3,3) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_1, (3,3) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_1, (3) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=1
@ -25,10 +28,14 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_1, (3,3) ]
cart_to_sphe_1 ( 3, 1) = 1.0d0
cart_to_sphe_1 ( 1, 2) = 1.0d0
cart_to_sphe_1 ( 2, 3) = 1.0d0
cart_to_sphe_norm_1 (1) = 1.d0
cart_to_sphe_norm_1 (2) = 1.d0
cart_to_sphe_norm_1 (3) = 1.d0
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_2, (6,5) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_2, (6,5) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_2, (6) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=2
@ -43,10 +50,14 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_2, (6,5) ]
cart_to_sphe_2 ( 1, 4) = 0.86602540378443864676d0
cart_to_sphe_2 ( 4, 4) = -0.86602540378443864676d0
cart_to_sphe_2 ( 2, 5) = 1.0d0
cart_to_sphe_norm_2 = (/ 1.0d0, 1.7320508075688772d0, 1.7320508075688772d0, 1.0d0, &
1.7320508075688772d0, 1.0d0 /)
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_3, (10,7) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_3, (10,7) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_3, (10) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=3
@ -69,10 +80,15 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_3, (10,7) ]
cart_to_sphe_3 ( 4, 6) = -1.0606601717798212866d0
cart_to_sphe_3 ( 2, 7) = 1.0606601717798212866d0
cart_to_sphe_3 ( 7, 7) = -0.790569415042094833d0
cart_to_sphe_norm_3 = (/ 1.0d0, 2.23606797749979d0, 2.23606797749979d0, &
2.23606797749979d0, 3.872983346207417d0, 2.23606797749979d0, 1.0d0, 2.23606797749979d0, &
2.23606797749979d0, 1.d00 /)
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_4, (15,9) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_4, (15,9) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_4, (15) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=4
@ -107,10 +123,18 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_4, (15,9) ]
cart_to_sphe_4 (11, 8) = 0.73950997288745200532d0
cart_to_sphe_4 ( 2, 9) = 1.1180339887498948482d0
cart_to_sphe_4 ( 7, 9) = -1.1180339887498948482d0
cart_to_sphe_norm_4 = (/ 1.0d0, 2.6457513110645907d0, 2.6457513110645907d0, &
3.4156502553198664d0, 5.916079783099616d0, 3.415650255319866d0, &
2.6457513110645907d0, 5.916079783099616d0, 5.916079783099616d0, &
2.6457513110645907d0, 1.0d0, 2.6457513110645907d0, 3.415650255319866d0, &
2.6457513110645907d0, 1.d00 /)
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_5, (21,11) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_5, (21,11) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_5, (21) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=5
@ -163,10 +187,18 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_5, (21,11) ]
cart_to_sphe_5 ( 2,11) = 1.169267933366856683d0
cart_to_sphe_5 ( 7,11) = -1.5309310892394863114d0
cart_to_sphe_5 (16,11) = 0.7015607600201140098d0
cart_to_sphe_norm_5 = (/ 1.0d0, 3.0d0, 3.0d0, 4.58257569495584d0, &
7.937253933193773d0, 4.58257569495584d0, 4.58257569495584d0, &
10.246950765959598d0, 10.246950765959598d0, 4.582575694955841d0, 3.0d0, &
7.937253933193773d0, 10.246950765959598d0, 7.937253933193773d0, 3.0d0, 1.0d0, &
3.0d0, 4.58257569495584d0, 4.582575694955841d0, 3.0d0, 1.d00 /)
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_6, (28,13) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_6, (28,13) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_6, (28) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=6
@ -243,10 +275,22 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_6, (28,13) ]
cart_to_sphe_6 ( 2,13) = 1.2151388809514737933d0
cart_to_sphe_6 ( 7,13) = -1.9764235376052370825d0
cart_to_sphe_6 (16,13) = 1.2151388809514737933d0
cart_to_sphe_norm_6 = (/ 1.0d0, 3.3166247903554003d0, 3.3166247903554003d0, &
5.744562646538029d0, 9.949874371066201d0, 5.744562646538029d0, &
6.797058187186571d0, 15.198684153570666d0, 15.198684153570664d0, &
6.797058187186572d0, 5.744562646538029d0, 15.198684153570666d0, &
19.621416870348583d0, 15.198684153570666d0, 5.744562646538029d0, &
3.3166247903554003d0, 9.949874371066201d0, 15.198684153570664d0, &
15.198684153570666d0, 9.9498743710662d0, 3.3166247903554003d0, 1.0d0, &
3.3166247903554003d0, 5.744562646538029d0, 6.797058187186572d0, &
5.744562646538029d0, 3.3166247903554003d0, 1.d00 /)
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_7, (36,15) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_7, (36,15) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_7, (36) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=7
@ -355,10 +399,25 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_7, (36,15) ]
cart_to_sphe_7 ( 7,15) = -2.4456993503903949804d0
cart_to_sphe_7 (16,15) = 1.96875d0
cart_to_sphe_7 (29,15) = -0.64725984928774934788d0
cart_to_sphe_norm_7 = (/ 1.0d0, 3.6055512754639896d0, 3.605551275463989d0, &
6.904105059069327d0, 11.958260743101398d0, 6.904105059069326d0, &
9.26282894152753d0, 20.712315177207984d0, 20.71231517720798d0, &
9.26282894152753d0, 9.26282894152753d0, 24.507141816213494d0, &
31.63858403911275d0, 24.507141816213494d0, 9.262828941527529d0, &
6.904105059069327d0, 20.712315177207984d0, 31.63858403911275d0, &
31.63858403911275d0, 20.71231517720798d0, 6.904105059069327d0, &
3.6055512754639896d0, 11.958260743101398d0, 20.71231517720798d0, &
24.507141816213494d0, 20.71231517720798d0, 11.958260743101398d0, &
3.6055512754639896d0, 1.0d0, 3.605551275463989d0, 6.904105059069326d0, &
9.26282894152753d0, 9.262828941527529d0, 6.904105059069327d0, &
3.6055512754639896d0, 1.d00 /)
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_8, (45,17) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_8, (45,17) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_8, (45) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=8
@ -506,10 +565,28 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_8, (45,17) ]
cart_to_sphe_8 ( 7,17) = -2.9348392204684739765d0
cart_to_sphe_8 (16,17) = 2.9348392204684739765d0
cart_to_sphe_8 (29,17) = -1.2945196985754986958d0
cart_to_sphe_norm_8 = (/ 1.0d0, 3.872983346207417d0, 3.872983346207417d0, &
8.062257748298551d0, 13.964240043768942d0, 8.06225774829855d0, &
11.958260743101398d0, 26.739483914241877d0, 26.739483914241877d0, &
11.958260743101398d0, 13.55939315961975d0, 35.874782229304195d0, &
46.31414470763765d0, 35.874782229304195d0, 13.55939315961975d0, &
11.958260743101398d0, 35.874782229304195d0, 54.79963503528103d0, &
54.79963503528103d0, 35.874782229304195d0, 11.958260743101398d0, &
8.062257748298551d0, 26.739483914241877d0, 46.31414470763765d0, &
54.79963503528103d0, 46.314144707637645d0, 26.739483914241877d0, &
8.06225774829855d0, 3.872983346207417d0, 13.964240043768942d0, &
26.739483914241877d0, 35.874782229304195d0, 35.874782229304195d0, &
26.739483914241877d0, 13.96424004376894d0, 3.8729833462074166d0, 1.0d0, &
3.872983346207417d0, 8.06225774829855d0, 11.958260743101398d0, &
13.55939315961975d0, 11.958260743101398d0, 8.06225774829855d0, &
3.8729833462074166d0, 1.d0 /)
END_PROVIDER
BEGIN_PROVIDER [ double precision, cart_to_sphe_9, (55,19) ]
BEGIN_PROVIDER [ double precision, cart_to_sphe_9, (55,19) ]
&BEGIN_PROVIDER [ double precision, cart_to_sphe_norm_9, (55) ]
implicit none
BEGIN_DOC
! Spherical -> Cartesian Transformation matrix for l=9
@ -703,5 +780,28 @@ BEGIN_PROVIDER [ double precision, cart_to_sphe_9, (55,19) ]
cart_to_sphe_9 (16,19) = 4.1179360680974030877d0
cart_to_sphe_9 (29,19) = -2.3781845426185916576d0
cart_to_sphe_9 (46,19) = 0.60904939217552380708d0
cart_to_sphe_norm_9 = (/ 1.0d0, 4.1231056256176615d0, 4.1231056256176615d0, &
9.219544457292889d0, 15.968719422671313d0, 9.219544457292889d0, &
14.86606874731851d0, 33.24154027718933d0, 33.24154027718933d0, &
14.866068747318508d0, 18.635603405463275d0, 49.30517214248421d0, &
63.652703529910404d0, 49.30517214248421d0, 18.635603405463275d0, &
18.635603405463275d0, 55.90681021638982d0, 85.39906322671229d0, &
85.39906322671229d0, 55.90681021638983d0, 18.635603405463275d0, &
14.86606874731851d0, 49.30517214248421d0, 85.39906322671229d0, &
101.04553429023969d0, 85.3990632267123d0, 49.30517214248421d0, &
14.866068747318508d0, 9.219544457292889d0, 33.24154027718933d0, &
63.652703529910404d0, 85.39906322671229d0, 85.3990632267123d0, &
63.65270352991039d0, 33.24154027718933d0, 9.219544457292887d0, &
4.1231056256176615d0, 15.968719422671313d0, 33.24154027718933d0, &
49.30517214248421d0, 55.90681021638983d0, 49.30517214248421d0, &
33.24154027718933d0, 15.968719422671313d0, 4.1231056256176615d0, 1.0d0, &
4.1231056256176615d0, 9.219544457292889d0, 14.866068747318508d0, &
18.635603405463275d0, 18.635603405463275d0, 14.866068747318508d0, &
9.219544457292887d0, 4.1231056256176615d0, 1.d0 /)
END_PROVIDER

5
src/ao_extra_basis/README.rst
View File

@ -5,7 +5,9 @@ extra_basis
Plugin to handle an extra basis, which is attached to the extra_nuclei.
It is essentially a duplication of all important quantities (coefficients, exponents and so on) of the usual |AO| basis.
An interesting feature is the possibility to fit any basis made at most with "p" functions onto a purely "s" basis.
Check in the directory "tuto" for a simple example of how to create a fictious system "B" attached independently to a system "A"
Another interesting feature is the possibility to fit any basis made at most with "p" functions onto a purely "s" basis.
This is done with the various scripts here:
- qp_fit_1s_basis : script that creates an |EZFIO| folder corresponding to an .xyz file and a basis fitted with only "s" functions
@ -13,3 +15,4 @@ This is done with the various scripts here:
Ex:
qp_add_extra_fit_system LiH.ezfio/ h2o.xyz # takes the EZFIO folder "LiH.ezfio" and creates all necessary additional basis and nuclei based on h2o.xyz, but only with 1s functions.

1
src/ao_extra_basis/fit_1s_basis.irp.f
View File

@ -31,6 +31,7 @@ program fit_1s_basis
call ezfio_set_extra_nuclei_extra_nucl_label(new_nucl_label_1s)
!
call ezfio_set_ao_extra_basis_ao_extra_num(n_func_tot)
call ezfio_set_ao_extra_basis_ao_extra_only_1s(.True.)
call ezfio_set_ao_extra_basis_ao_extra_center(ao_extra_center)
call ezfio_set_ao_extra_basis_ao_extra_nucl(new_ao_nucl_1s)
call ezfio_set_ao_extra_basis_ao_extra_prim_num(new_ao_prim_num_1s)

2
src/ao_extra_basis/qp_copy_extra_basis
View File

@ -58,7 +58,7 @@ do
done
i=primitives_normalized
newfile=primitives_normalized_extra
cp ${EZFIO_extra}/ao_basis/$i ${EZFIO_target}/ao_extra_basis/$newfile
cp ${EZFIO_extra}/basis/$i ${EZFIO_target}/ao_extra_basis/$newfile
echo "COPYING ALL DATA FROM "$EZFIO_extra"/aux_quantities/ to "${EZFIO_target}"/ao_extra_basis/"
i=data_one_e_dm_tot_ao.gz

3
src/ao_extra_basis/tuto/He_A.xyz Normal file
View File

@ -0,0 +1,3 @@
1
He atom "A"
He 0. 0. 0.

26
src/ao_extra_basis/tuto/example_copy.sh Executable file
View File

@ -0,0 +1,26 @@
source ~/qp2/quantum_package.rc
## Example of how to generate an additional h2o molecule, stored as a extra basis/nuclei etc .. to an He
sys_B=h2o.xyz
basis_B=sto-3g
output_B=${sys_B%.xyz}_${basis_B}
sys_A=He_A.xyz
basis_A=cc-pvtz
output_A=${sys_A%.xyz}_${basis_A}_extra_${output_B}
# we create the system "B" that will be attached as an "extra system" to the syste "A"
qp create_ezfio -b $basis_B $sys_B -o ${output_B}
# we perform an HF calculation to obtain the AO density matrix
qp run scf
# we save the density matrix in the EZFIO
qp run save_one_e_dm
# we create the system "A"
qp create_ezfio -b $basis_A $sys_A -o ${output_A}
# We perform an SCF calculation
qp run scf
# we copy the system "B" information as extra nuclei/basis etc in the EZFIO of system "A"
qp_copy_extra_basis ${output_B} ${output_A}
# we execute an example of progra that prints a lot of useful integrals/information on the A-B interaction
qp run test_extra_basis | tee ${output_A}.test_extra_basis

7
src/ao_extra_basis/tuto/h2o.xyz Normal file
View File

@ -0,0 +1,7 @@
3
O 0.000000 -0.399441 3.000000
H 0.761232 0.199721 3.000000
H -0.761232 0.199721 3.000000

16
src/ao_one_e_ints/ao_one_e_ints.irp.f
View File

@ -45,3 +45,19 @@ BEGIN_PROVIDER [ double precision, ao_one_e_integrals_imag,(ao_num,ao_num)]
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_sphe_one_e_integrals,(ao_sphe_num,ao_sphe_num)]
&BEGIN_PROVIDER [ double precision, ao_sphe_one_e_integrals_diag,(ao_sphe_num)]
implicit none
integer :: i,j,n,l
BEGIN_DOC
! One-electron Hamiltonian in the spherical |AO| basis.
END_DOC
ao_sphe_one_e_integrals = ao_sphe_integrals_n_e + ao_sphe_kinetic_integrals
do j = 1, ao_num
ao_sphe_one_e_integrals_diag(j) = ao_sphe_one_e_integrals(j,j)
enddo
END_PROVIDER

84
src/ao_one_e_ints/ao_ortho_canonical.irp.f
View File

@ -1,35 +1,42 @@
BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_coef, (ao_num,ao_num)]
&BEGIN_PROVIDER [ integer, ao_cart_to_sphe_num ]
&BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_normalization, (ao_num)]
implicit none
BEGIN_DOC
! Coefficients to go from cartesian to spherical coordinates in the current
! basis set
!
! S_cart^-1 <cart|sphe>
END_DOC
integer :: i
integer, external :: ao_power_index
integer :: ibegin,j,k
integer :: prev
integer :: prev, ao_sphe_count
prev = 0
ao_cart_to_sphe_coef(:,:) = 0.d0
ao_cart_to_sphe_normalization(:) = 1.d0
! Assume order provided by ao_power_index
i = 1
ao_cart_to_sphe_num = 0
ao_sphe_count = 0
do while (i <= ao_num)
select case ( ao_l(i) )
case (0)
ao_cart_to_sphe_num += 1
ao_cart_to_sphe_coef(i,ao_cart_to_sphe_num) = 1.d0
ao_sphe_count += 1
ao_cart_to_sphe_coef(i,ao_sphe_count) = 1.d0
ao_cart_to_sphe_normalization(i) = 1.d0
i += 1
BEGIN_TEMPLATE
case ($SHELL)
if (ao_power(i,1) == $SHELL) then
do k=1,size(cart_to_sphe_$SHELL,2)
do j=1,size(cart_to_sphe_$SHELL,1)
ao_cart_to_sphe_coef(i+j-1,ao_cart_to_sphe_num+k) = cart_to_sphe_$SHELL(j,k)
ao_cart_to_sphe_coef(i+j-1,ao_sphe_count+k) = cart_to_sphe_$SHELL(j,k)
enddo
enddo
do j=1,size(cart_to_sphe_$SHELL,1)
ao_cart_to_sphe_normalization(i+j-1) = cart_to_sphe_norm_$SHELL(j)
enddo
i += size(cart_to_sphe_$SHELL,1)
ao_cart_to_sphe_num += size(cart_to_sphe_$SHELL,2)
ao_sphe_count += size(cart_to_sphe_$SHELL,2)
endif
SUBST [ SHELL ]
1;;
@ -47,39 +54,37 @@
end select
enddo
if (ao_sphe_count /= ao_sphe_num) then
call qp_bug(irp_here, ao_sphe_count, "ao_sphe_count /= ao_sphe_num")
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_overlap, (ao_cart_to_sphe_num,ao_cart_to_sphe_num) ]
implicit none
BEGIN_DOC
! |AO| overlap matrix in the spherical basis set
END_DOC
double precision, allocatable :: S(:,:)
allocate (S(ao_cart_to_sphe_num,ao_num))
call dgemm('T','N',ao_cart_to_sphe_num,ao_num,ao_num, 1.d0, &
ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1), &
ao_overlap,size(ao_overlap,1), 0.d0, &
S, size(S,1))
call dgemm('N','N',ao_cart_to_sphe_num,ao_cart_to_sphe_num,ao_num, 1.d0, &
S, size(S,1), &
ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1), 0.d0, &
ao_cart_to_sphe_overlap,size(ao_cart_to_sphe_overlap,1))
deallocate(S)
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_inv, (ao_cart_to_sphe_num,ao_num) ]
BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_inv, (ao_sphe_num,ao_num) ]
implicit none
BEGIN_DOC
! Inverse of :c:data:`ao_cart_to_sphe_coef`
END_DOC
call get_pseudo_inverse(ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1),&
ao_num,ao_cart_to_sphe_num, &
ao_cart_to_sphe_inv, size(ao_cart_to_sphe_inv,1), lin_dep_cutoff)
! Normalize
integer :: m,k
double precision, allocatable :: S(:,:), R(:,:), Rinv(:,:), Sinv(:,:)
k = size(ao_cart_to_sphe_coef,1)
m = size(ao_cart_to_sphe_coef,2)
allocate(S(k,k), R(k,m), Rinv(m,k), Sinv(k,k))
R(:,:) = ao_cart_to_sphe_coef(:,:)
call dgemm('N','T', m, m, k, 1.d0, R, k, R, k, 0.d0, S, m)
call get_pseudo_inverse(S, k, k, m, Sinv, k, 1.d-20)
call dgemm('T','T', m, m, k, 1.d0, R, k, Sinv, k, 0.d0, Rinv, m)
integer :: i
do i=1,ao_num
ao_cart_to_sphe_inv(:,i) = Rinv(:,i) !/ ao_cart_to_sphe_normalization(i)
enddo
END_PROVIDER
@ -120,17 +125,17 @@ END_PROVIDER
double precision, allocatable :: S(:,:)
allocate(S(ao_cart_to_sphe_num,ao_cart_to_sphe_num))
allocate(S(ao_sphe_num,ao_sphe_num))
S = 0.d0
do i=1,ao_cart_to_sphe_num
do i=1,ao_sphe_num
S(i,i) = 1.d0
enddo
ao_ortho_canonical_num = ao_cart_to_sphe_num
call ortho_canonical(ao_cart_to_sphe_overlap, size(ao_cart_to_sphe_overlap,1), &
ao_cart_to_sphe_num, S, size(S,1), ao_ortho_canonical_num, lin_dep_cutoff)
ao_ortho_canonical_num = ao_sphe_num
call ortho_canonical(ao_sphe_overlap, size(ao_sphe_overlap,1), &
ao_sphe_num, S, size(S,1), ao_ortho_canonical_num, lin_dep_cutoff)
call dgemm('N','N', ao_num, ao_ortho_canonical_num, ao_cart_to_sphe_num, 1.d0, &
call dgemm('N','N', ao_num, ao_ortho_canonical_num, ao_sphe_num, 1.d0, &
ao_cart_to_sphe_coef, size(ao_cart_to_sphe_coef,1), &
S, size(S,1), &
0.d0, ao_ortho_canonical_coef, size(ao_ortho_canonical_coef,1))
@ -167,3 +172,4 @@ BEGIN_PROVIDER [double precision, ao_ortho_canonical_overlap, (ao_ortho_canonica
enddo
enddo
END_PROVIDER

23
src/ao_one_e_ints/ao_overlap.irp.f
View File

@ -308,3 +308,26 @@ BEGIN_PROVIDER [ double precision, S_half, (ao_num,ao_num) ]
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_sphe_overlap, (ao_sphe_num,ao_sphe_num) ]
implicit none
BEGIN_DOC
! |AO| overlap matrix in the spherical basis set
END_DOC
double precision, allocatable :: tmp(:,:)
allocate (tmp(ao_sphe_num,ao_num))
call dgemm('T','N',ao_sphe_num,ao_num,ao_num, 1.d0, &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), &
ao_overlap,size(ao_overlap,1), 0.d0, &
tmp, size(tmp,1))
call dgemm('N','N',ao_sphe_num,ao_sphe_num,ao_num, 1.d0, &
tmp, size(tmp,1), &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), 0.d0, &
ao_sphe_overlap,size(ao_sphe_overlap,1))
deallocate(tmp)
END_PROVIDER

22
src/ao_one_e_ints/kin_ao_ints.irp.f
View File

@ -190,3 +190,25 @@ BEGIN_PROVIDER [double precision, ao_kinetic_integrals_imag, (ao_num,ao_num)]
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_sphe_kinetic_integrals, (ao_sphe_num,ao_sphe_num) ]
implicit none
BEGIN_DOC
! |AO| kinetic inntegrals matrix in the spherical basis set
END_DOC
double precision, allocatable :: tmp(:,:)
allocate (tmp(ao_sphe_num,ao_num))
call dgemm('T','N',ao_sphe_num,ao_num,ao_num, 1.d0, &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), &
ao_kinetic_integrals,size(ao_kinetic_integrals,1), 0.d0, &
tmp, size(tmp,1))
call dgemm('N','N',ao_sphe_num,ao_sphe_num,ao_num, 1.d0, &
tmp, size(tmp,1), &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), 0.d0, &
ao_sphe_kinetic_integrals,size(ao_sphe_kinetic_integrals,1))
deallocate(tmp)
END_PROVIDER

22
src/ao_one_e_ints/pot_ao_ints.irp.f
View File

@ -609,3 +609,25 @@ double precision function V_r(n,alpha)
end
BEGIN_PROVIDER [ double precision, ao_sphe_integrals_n_e, (ao_sphe_num,ao_sphe_num) ]
implicit none
BEGIN_DOC
! |AO| VneVne inntegrals matrix in the spherical basis set
END_DOC
double precision, allocatable :: tmp(:,:)
allocate (tmp(ao_sphe_num,ao_num))
call dgemm('T','N',ao_sphe_num,ao_num,ao_num, 1.d0, &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), &
ao_integrals_n_e,size(ao_integrals_n_e,1), 0.d0, &
tmp, size(tmp,1))
call dgemm('N','N',ao_sphe_num,ao_sphe_num,ao_num, 1.d0, &
tmp, size(tmp,1), &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), 0.d0, &
ao_sphe_integrals_n_e,size(ao_sphe_integrals_n_e,1))
deallocate(tmp)
END_PROVIDER

64
src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f
View File

@ -296,3 +296,67 @@ END_PROVIDER
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_sphe_pseudo_integrals_local, (ao_sphe_num,ao_sphe_num) ]
implicit none
BEGIN_DOC
! |AO| pseudo_integrals_local matrix in the spherical basis set
END_DOC
double precision, allocatable :: tmp(:,:)
allocate (tmp(ao_sphe_num,ao_num))
call dgemm('T','N',ao_sphe_num,ao_num,ao_num, 1.d0, &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), &
ao_pseudo_integrals_local,size(ao_pseudo_integrals_local,1), 0.d0, &
tmp, size(tmp,1))
call dgemm('N','N',ao_sphe_num,ao_sphe_num,ao_num, 1.d0, &
tmp, size(tmp,1), &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), 0.d0, &
ao_sphe_pseudo_integrals_local,size(ao_sphe_pseudo_integrals_local,1))
deallocate(tmp)
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_sphe_pseudo_integrals_non_local, (ao_sphe_num,ao_sphe_num) ]
implicit none
BEGIN_DOC
! |AO| pseudo_integrals_non_local matrix in the spherical basis set
END_DOC
double precision, allocatable :: tmp(:,:)
allocate (tmp(ao_sphe_num,ao_num))
call dgemm('T','N',ao_sphe_num,ao_num,ao_num, 1.d0, &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), &
ao_pseudo_integrals_non_local,size(ao_pseudo_integrals_non_local,1), 0.d0, &
tmp, size(tmp,1))
call dgemm('N','N',ao_sphe_num,ao_sphe_num,ao_num, 1.d0, &
tmp, size(tmp,1), &
ao_cart_to_sphe_inv,size(ao_cart_to_sphe_inv,1), 0.d0, &
ao_sphe_pseudo_integrals_non_local,size(ao_sphe_pseudo_integrals_non_local,1))
deallocate(tmp)
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_sphe_pseudo_integrals, (ao_sphe_num,ao_sphe_num)]
implicit none
BEGIN_DOC
! Pseudo-potential integrals in the |AO| basis set.
END_DOC
ao_sphe_pseudo_integrals = 0.d0
if (do_pseudo) then
if (pseudo_klocmax > 0) then
ao_sphe_pseudo_integrals += ao_sphe_pseudo_integrals_local
endif
if (pseudo_kmax > 0) then
ao_sphe_pseudo_integrals += ao_sphe_pseudo_integrals_non_local
endif
endif
END_PROVIDER

1
src/ao_two_e_ints/NEED
View File

@ -2,5 +2,4 @@ hamiltonian
ao_one_e_ints
pseudo
bitmask
zmq
ao_basis

10
src/ao_two_e_ints/cholesky.irp.f
View File

@ -178,7 +178,7 @@ END_PROVIDER
rank_max = np
! Avoid too large arrays when there are many electrons
if (elec_num > 10) then
rank_max = min(np,20*elec_num*elec_num)
rank_max = min(np,25*elec_num*elec_num)
endif
call mmap_create_d('', (/ ndim8, rank_max /), .False., .True., map)
@ -194,14 +194,11 @@ END_PROVIDER
+ (np+1)*memory_of_double(block_size) ! Ltmp_p(np,block_size) + Ltmp_q(nq,block_size)
! call check_mem(mem)
! 5.
do while ( (Dmax > tau).and.(np > 0) )
! a.
i = i+1
block_size = max(N,24)
! Determine nq so that Delta fits in memory
@ -308,6 +305,8 @@ END_PROVIDER
Qmax = max(Qmax, D(Dset(q)))
enddo
if (Qmax <= Dmin) exit
! g.
iblock = 0
@ -466,10 +465,11 @@ END_PROVIDER
endif
! Reverse order of Cholesky vectors to increase precision in dot products
!$OMP PARALLEL DO PRIVATE(k,j)
do k=1,rank
do j=1,ao_num
cholesky_ao(1:ao_num,j,k) = L((j-1_8)*ao_num+1_8:1_8*j*ao_num,k)
cholesky_ao(1:ao_num,j,k) = L((j-1_8)*ao_num+1_8:1_8*j*ao_num,rank-k+1)
enddo
enddo
!$OMP END PARALLEL DO

194
src/ao_two_e_ints/integrals_erf_in_map_slave.irp.f
View File

@ -1,194 +0,0 @@
subroutine ao_two_e_integrals_erf_in_map_slave_tcp(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_two_e_integrals_erf_in_map_slave(0,i)
end
subroutine ao_two_e_integrals_erf_in_map_slave_inproc(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_two_e_integrals_erf_in_map_slave(1,i)
end
subroutine ao_two_e_integrals_erf_in_map_slave(thread,iproc)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Computes a buffer of integrals
END_DOC
integer, intent(in) :: thread, iproc
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer :: worker_id, task_id
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
character*(64) :: state
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
integer, external :: connect_to_taskserver
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
return
endif
zmq_socket_push = new_zmq_push_socket(thread)
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
do
integer, external :: get_task_from_taskserver
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) == -1) then
exit
endif
if (task_id == 0) exit
read(task,*) j, l
integer, external :: task_done_to_taskserver
call compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value)
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then
stop 'Unable to send task_done'
endif
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
enddo
integer, external :: disconnect_from_taskserver
if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
continue
endif
deallocate( buffer_i, buffer_value )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
end
subroutine ao_two_e_integrals_erf_in_map_collector(zmq_socket_pull)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Collects results from the AO integral calculation
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
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*8 :: control, accu, sze
integer :: task_id, more
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
sze = ao_num*ao_num
allocate ( buffer_i(sze), buffer_value(sze) )
accu = 0_8
more = 1
do while (more == 1)
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then
if (n_integrals > sze) then
deallocate (buffer_value, buffer_i)
sze = n_integrals
allocate (buffer_value(sze), buffer_i(sze))
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, rc, key_kind, n_integrals
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
IRP_IF ZMQ_PUSH
IRP_ELSE
rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
if (rc /= 4) then
print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
stop 'error'
endif
IRP_ENDIF
call insert_into_ao_integrals_erf_map(n_integrals,buffer_i,buffer_value)
accu += n_integrals
if (task_id /= 0) then
integer, external :: zmq_delete_task
if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) == -1) then
stop 'Unable to delete task'
endif
endif
endif
enddo
deallocate( buffer_i, buffer_value )
integer (map_size_kind) :: get_ao_erf_map_size
control = get_ao_erf_map_size(ao_integrals_erf_map)
if (control /= accu) then
print *, ''
print *, irp_here
print *, 'Control : ', control
print *, 'Accu : ', accu
print *, 'Some integrals were lost during the parallel computation.'
print *, 'Try to reduce the number of threads.'
stop
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
end

244
src/ao_two_e_ints/integrals_in_map_slave.irp.f
View File

@ -1,244 +0,0 @@
subroutine ao_two_e_integrals_in_map_slave_tcp(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_two_e_integrals_in_map_slave(0,i)
end
subroutine ao_two_e_integrals_in_map_slave_inproc(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_two_e_integrals_in_map_slave(1,i)
end
subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
use f77_zmq
use map_module
implicit none
BEGIN_DOC
! Push integrals in the push socket
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
integer, intent(in) :: n_integrals
integer(key_kind), intent(in) :: buffer_i(*)
real(integral_kind), intent(in) :: buffer_value(*)
integer, intent(in) :: task_id
integer :: rc
rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)
if (rc /= 4) then
print *, irp_here, ': f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)
if (rc /= key_kind*n_integrals) then
print *, irp_here, ': f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, ZMQ_SNDMORE)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, ': f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
if (rc /= 4) then
print *, irp_here, ': f77_zmq_send( zmq_socket_push, task_id, 4, 0)'
stop 'error'
endif
IRP_IF ZMQ_PUSH
IRP_ELSE
integer :: idummy
rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0)
if (rc /= 4) then
print *, irp_here, ': f77_zmq_send( zmq_socket_push, idummy, 4, 0)'
stop 'error'
endif
IRP_ENDIF
end
subroutine ao_two_e_integrals_in_map_slave(thread,iproc)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Computes a buffer of integrals
END_DOC
integer, intent(in) :: thread, iproc
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer :: worker_id, task_id
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
character*(64) :: state
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
integer, external :: connect_to_taskserver
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
return
endif
zmq_socket_push = new_zmq_push_socket(thread)
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
do
integer, external :: get_task_from_taskserver
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) == -1) then
exit
endif
if (task_id == 0) exit
call sscanf_dd(task, j, l)
integer, external :: task_done_to_taskserver
call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then
stop 'Unable to send task_done'
endif
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
enddo
integer, external :: disconnect_from_taskserver
if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
continue
endif
deallocate( buffer_i, buffer_value )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
end
subroutine ao_two_e_integrals_in_map_collector(zmq_socket_pull)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Collects results from the AO integral calculation
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
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*8 :: control, accu, sze
integer :: task_id, more
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
sze = ao_num*ao_num
allocate ( buffer_i(sze), buffer_value(sze) )
accu = 0_8
more = 1
do while (more == 1)
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then
if (n_integrals > sze) then
deallocate (buffer_value, buffer_i)
sze = n_integrals
allocate (buffer_value(sze), buffer_i(sze))
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, rc, key_kind, n_integrals
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
IRP_IF ZMQ_PUSH
IRP_ELSE
rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
if (rc /= 4) then
print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
stop 'error'
endif
IRP_ENDIF
call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value)
accu += n_integrals
if (task_id /= 0) then
integer, external :: zmq_delete_task
if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) == -1) then
stop 'Unable to delete task'
endif
endif
endif
enddo
deallocate( buffer_i, buffer_value )
integer (map_size_kind) :: get_ao_map_size
control = get_ao_map_size(ao_integrals_map)
if (control /= accu) then
print *, ''
print *, irp_here
print *, 'Control : ', control
print *, 'Accu : ', accu
print *, 'Some integrals were lost during the parallel computation.'
print *, 'Try to reduce the number of threads.'
stop
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
end

51
src/ao_two_e_ints/providers_ao_erf.irp.f
View File

@ -1,7 +1,5 @@
BEGIN_PROVIDER [ logical, ao_two_e_integrals_erf_in_map ]
implicit none
use f77_zmq
use map_module
BEGIN_DOC
! Map of Atomic integrals
@ -15,17 +13,16 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_erf_in_map ]
! For integrals file
integer(key_kind),allocatable :: buffer_i(:)
integer,parameter :: size_buffer = 1024*64
integer :: size_buffer
real(integral_kind),allocatable :: buffer_value(:)
integer :: n_integrals, rc
integer :: kk, m, j1, i1, lmax
character*(64) :: fmt
integral = ao_two_e_integral_erf(1,1,1,1)
double precision :: map_mb
PROVIDE read_ao_two_e_integrals_erf io_ao_two_e_integrals_erf
PROVIDE read_ao_two_e_integrals_erf io_ao_two_e_integrals_erf ao_integrals_erf_map
if (read_ao_two_e_integrals_erf) then
print*,'Reading the AO ERF integrals'
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map)
@ -39,37 +36,27 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_erf_in_map ]
call wall_time(wall_1)
call cpu_time(cpu_1)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_integrals_erf')
if (.True.) then
! Avoid openMP
integral = ao_two_e_integral_erf(1,1,1,1)
endif
character(len=:), allocatable :: task
allocate(character(len=ao_num*12) :: task)
write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
size_buffer = ao_num*ao_num
!$OMP PARALLEL DEFAULT(shared) private(j,l) &
!$OMP PRIVATE(buffer_i, buffer_value, n_integrals)
allocate(buffer_i(size_buffer), buffer_value(size_buffer))
n_integrals = 0
!$OMP DO COLLAPSE(1) SCHEDULE(dynamic)
do l=1,ao_num
write(task,fmt) (i,l, i=1,l)
integer, external :: add_task_to_taskserver
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
stop 'Unable to add task to server'
endif
do j=1,l
call compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value)
call insert_into_ao_integrals_erf_map(n_integrals,buffer_i,buffer_value)
enddo
deallocate(task)
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
PROVIDE nproc
!$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call ao_two_e_integrals_erf_in_map_collector(zmq_socket_pull)
else
call ao_two_e_integrals_erf_in_map_slave_inproc(i)
endif
enddo
!$OMP END DO
deallocate(buffer_i, buffer_value)
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_integrals_erf')
print*, 'Sorting the map'

53
src/ao_two_e_ints/two_e_integrals.irp.f
View File

@ -54,6 +54,7 @@ double precision function ao_two_e_integral(i, j, k, l)
else if (use_only_lr) then
ao_two_e_integral = ao_two_e_integral_erf(i, j, k, l)
return
else if (do_schwartz_accel(i,j,k,l)) then
@ -397,7 +398,6 @@ end
BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
implicit none
use f77_zmq
use map_module
BEGIN_DOC
! Map of Atomic integrals
@ -411,7 +411,7 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
! For integrals file
integer(key_kind),allocatable :: buffer_i(:)
integer,parameter :: size_buffer = 1024*64
integer :: size_buffer
real(integral_kind),allocatable :: buffer_value(:)
integer :: n_integrals, rc
@ -419,13 +419,15 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
character*(64) :: fmt
double precision :: map_mb
PROVIDE read_ao_two_e_integrals io_ao_two_e_integrals
PROVIDE read_ao_two_e_integrals io_ao_two_e_integrals ao_integrals_map
if (read_ao_two_e_integrals) then
print*,'Reading the AO integrals'
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
print*, 'AO integrals provided'
ao_two_e_integrals_in_map = .True.
else
return
endif
print*, 'Providing the AO integrals'
call wall_time(wall_0)
@ -437,39 +439,22 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
integral = ao_two_e_integral(1,1,1,1)
endif
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_integrals')
character(len=:), allocatable :: task
allocate(character(len=ao_num*12) :: task)
write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
size_buffer = ao_num*ao_num
!$OMP PARALLEL DEFAULT(shared) private(j,l) &
!$OMP PRIVATE(buffer_i, buffer_value, n_integrals)
allocate(buffer_i(size_buffer), buffer_value(size_buffer))
n_integrals = 0
!$OMP DO COLLAPSE(1) SCHEDULE(dynamic)
do l=1,ao_num
write(task,fmt) (i,l, i=1,l)
integer, external :: add_task_to_taskserver
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
stop 'Unable to add task to server'
endif
do j=1,l
call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value)
enddo
deallocate(task)
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
PROVIDE nproc
!$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call ao_two_e_integrals_in_map_collector(zmq_socket_pull)
else
call ao_two_e_integrals_in_map_slave_inproc(i)
endif
enddo
!$OMP END DO
deallocate(buffer_i, buffer_value)
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_integrals')
print*, 'Sorting the map'
call map_sort(ao_integrals_map)
call cpu_time(cpu_2)
@ -491,8 +476,6 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals('Read')
endif
endif
END_PROVIDER
! ---

1
src/basis/EZFIO.cfg
View File

@ -84,4 +84,3 @@ type: logical
doc: If true, normalize the basis functions
interface: ezfio, provider, ocaml
default: false

69
src/basis/basis.irp.f
View File

@ -1,72 +1,3 @@
BEGIN_PROVIDER [ double precision, shell_normalization_factor , (shell_num) ]
implicit none
BEGIN_DOC
! Number of primitives per |AO|
END_DOC
logical :: has
PROVIDE ezfio_filename
if (.not.ao_normalized) then
shell_normalization_factor = 1.d0
return
endif
if (mpi_master) then
if (size(shell_normalization_factor) == 0) return
call ezfio_has_basis_shell_normalization_factor(has)
if (has) then
write(6,'(A)') '.. >>>>> [ IO READ: shell_normalization_factor ] <<<<< ..'
call ezfio_get_basis_shell_normalization_factor(shell_normalization_factor)
else
double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
integer :: l, powA(3), nz
integer :: i,j,k
nz=100
C_A(1) = 0.d0
C_A(2) = 0.d0
C_A(3) = 0.d0
do i=1,shell_num
powA(1) = shell_ang_mom(i)
powA(2) = 0
powA(3) = 0
norm = 0.d0
do k=1, prim_num
if (shell_index(k) /= i) cycle
do j=1, prim_num
if (shell_index(j) /= i) cycle
call overlap_gaussian_xyz(C_A,C_A,prim_expo(j),prim_expo(k), &
powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
norm = norm+c*prim_coef(j)*prim_coef(k) * prim_normalization_factor(j) * prim_normalization_factor(k)
enddo
enddo
shell_normalization_factor(i) = 1.d0/dsqrt(norm)
enddo
endif
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST( shell_normalization_factor, (shell_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read shell_normalization_factor with MPI'
endif
IRP_ENDIF
call write_time(6)
END_PROVIDER
BEGIN_PROVIDER [ double precision, prim_normalization_factor , (prim_num) ]
implicit none
BEGIN_DOC

37
src/bitmask/bitmasks_routines.irp.f
View File

@ -283,33 +283,16 @@ subroutine print_det_one_dimension(string,Nint)
end
logical function is_integer_in_string(bite,string,Nint)
logical function is_integer_in_string(orb,bitmask,Nint)
use bitmasks
implicit none
integer, intent(in) :: bite,Nint
integer(bit_kind), intent(in) :: string(Nint)
integer(bit_kind) :: string_bite(Nint)
integer :: i,itot,itot_and
character*(2048) :: output(1)
string_bite = 0_bit_kind
call set_bit_to_integer(bite,string_bite,Nint)
itot = 0
itot_and = 0
is_integer_in_string = .False.
!print*,''
!print*,''
!print*,'bite = ',bite
!call bitstring_to_str( output(1), string_bite, Nint )
! print *, trim(output(1))
!call bitstring_to_str( output(1), string, Nint )
! print *, trim(output(1))
do i = 1, Nint
itot += popcnt(string(i))
itot_and += popcnt(ior(string(i),string_bite(i)))
enddo
!print*,'itot,itot_and',itot,itot_and
if(itot == itot_and)then
is_integer_in_string = .True.
endif
!pause
BEGIN_DOC
! Checks is the orbital orb is set to 1 in the bit string
END_DOC
integer, intent(in) :: orb, Nint
integer(bit_kind), intent(in) :: bitmask(Nint)
integer :: j, k
k = ishft(orb-1,-bit_kind_shift)+1
j = orb-ishft(k-1,bit_kind_shift)-1
is_integer_in_string = iand(bitmask(k), ibset(0_bit_kind, j)) /= 0_bit_kind
end

11
src/cas_based_on_top/on_top_cas_prov.irp.f
View File

@ -15,14 +15,17 @@
pure_act_on_top_of_r = 0.d0
do l = 1, n_act_orb
phi_l = act_mos_in_r_array(l,ipoint)
if (dabs(phi_l) < 1.d-12) cycle
do k = 1, n_act_orb
phi_k = act_mos_in_r_array(k,ipoint)
phi_k = act_mos_in_r_array(k,ipoint) * phi_l
if (dabs(phi_k) < 1.d-12) cycle
do j = 1, n_act_orb
phi_j = act_mos_in_r_array(j,ipoint)
phi_j = act_mos_in_r_array(j,ipoint) * phi_k
if (dabs(phi_j) < 1.d-12) cycle
do i = 1, n_act_orb
phi_i = act_mos_in_r_array(i,ipoint)
phi_i = act_mos_in_r_array(i,ipoint) * phi_j
! 1 2 1 2
pure_act_on_top_of_r += act_2_rdm_ab_mo(i,j,k,l,istate) * phi_i * phi_j * phi_k * phi_l
pure_act_on_top_of_r = pure_act_on_top_of_r + act_2_rdm_ab_mo(i,j,k,l,istate) * phi_i !* phi_j * phi_k * phi_l
enddo
enddo
enddo

18
src/casscf_cipsi/chol_bielec.irp.f
View File

@ -191,10 +191,15 @@ double precision function bielec_PQxx_no(i_mo, j_mo, i_ca, j_ca)
END_DOC
integer, intent(in) :: i_ca, j_ca, i_mo, j_mo
integer :: ii_ca, jj_ca
double precision :: bielec_no_basis
ii_ca = list_core_inact_act(i_ca)
jj_ca = list_core_inact_act(j_ca)
bielec_PQxx_no = bielec_no_basis(i_mo,j_mo,ii_ca,jj_ca)
! double precision :: bielec_no_basis
! bielec_PQxx_no = bielec_no_basis(i_mo,j_mo,ii_ca,jj_ca)
integer :: i
bielec_PQxx_no = 0.d0
do i = 1, cholesky_mo_num
bielec_PQxx_no = bielec_PQxx_no + cholesky_no_total_transp(i,i_mo, j_mo) * cholesky_no_total_transp(i,ii_ca,jj_ca)
enddo
end
double precision function bielec_PxxQ_no(i_mo, j_ca, i_ca, j_mo)
@ -206,10 +211,15 @@ double precision function bielec_PxxQ_no(i_mo, j_ca, i_ca, j_mo)
END_DOC
integer, intent(in) :: i_ca, j_ca, i_mo, j_mo
integer :: ii_ca, jj_ca
double precision :: bielec_no_basis
ii_ca = list_core_inact_act(i_ca)
jj_ca = list_core_inact_act(j_ca)
bielec_PxxQ_no = bielec_no_basis(i_mo, jj_ca, ii_ca, j_mo)
double precision :: bielec_no_basis
! bielec_PxxQ_no = bielec_no_basis(i_mo, jj_ca, ii_ca, j_mo)
integer :: i
bielec_PxxQ_no = 0.d0
do i = 1, cholesky_mo_num
bielec_PxxQ_no = bielec_PxxQ_no + cholesky_no_total_transp(i,i_mo, jj_ca) * cholesky_no_total_transp(i,ii_ca,j_mo)
enddo
end

17
src/casscf_cipsi/gradient.irp.f
View File

@ -163,14 +163,21 @@ real*8 function gradvec_it(i,t)
tt=list_act(t)
gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii))
gradvec_it-=occnum(tt)*Fipq(ii,tt)
do y=1,n_act_orb ! active
! y3=y+n_core_inact_orb ! list_act(y)
do x=1,n_act_orb ! active
! x3=x+n_core_inact_orb ! list_act(x)
do v=1,n_act_orb ! active
vv=list_act(v)
do x=1,n_act_orb ! active
x3=x+n_core_inact_orb ! list_act(x)
do y=1,n_act_orb ! active
y3=y+n_core_inact_orb ! list_act(y)
! Gamma(2) a a a a 1/r12 i a a a
gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3)
! gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3)
integer :: ichol
double precision :: tmp
tmp = 0.d0
do ichol=1,cholesky_mo_num
tmp = tmp + cholesky_no_total_transp(ichol,vv,ii) * cholesky_no_total_transp(ichol,list_act(x),list_act(y))
enddo
gradvec_it = gradvec_it - 2.D0*P0tuvx_no(t,v,x,y)*tmp
end do
end do
end do

172
src/casscf_cipsi/hessian.irp.f
View File

@ -17,7 +17,8 @@ real*8 function hessmat_itju(i,t,j,u)
if (i.eq.j) then
if (t.eq.u) then
! diagonal element
term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) &
term = occnum(tt)*Fipq(ii,ii) + &
2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) &
-2.D0*(Fipq(ii,ii)+Fapq(ii,ii))
term+=2.D0*(3.D0*bielec_pxxq_no(tt,i,i,tt)-bielec_pqxx_no(tt,tt,i,i))
term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq_no(tt,i,i,tt) &
@ -240,73 +241,176 @@ real*8 function hessmat_taub(t,a,u,b)
END_DOC
implicit none
integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y
integer :: v3,x3
real*8 :: term,t1,t2,t3
integer :: v3,x3, ichol
real*8 :: term,t1,t2,t3, tmp
double precision :: bielec_pqxx_no,bielec_pxxq_no
double precision, allocatable :: tmp1(:), tmp2(:,:)
allocate(tmp1(n_act_orb))
allocate(tmp2(n_act_orb,n_act_orb))
tt=list_act(t)
aa=list_virt(a)
if (t == u) then
if (a == b) then
! ta/ta
t1=occnum(tt)*Fipq(aa,aa)
t1=occnum(tt)*Fipq(aa,aa) - occnum(tt)*Fipq(tt,tt)
t2=0.D0
t3=0.D0
t1-=occnum(tt)*Fipq(tt,tt)
! do x=1,n_act_orb
! x3=x+n_core_inact_orb
! do v=1,n_act_orb
! v3=v+n_core_inact_orb
! tmp = 0.d0
! do ichol = 1, cholesky_mo_num
! tmp = tmp + cholesky_no_total_transp(ichol,aa,aa) * cholesky_no_total_transp(ichol,v3,x3)
! enddo
! t2 = t2 + 2.D0*P0tuvx_no(t,t,v,x)*tmp
! enddo
! enddo
do x=1,n_act_orb
x3=x+n_core_inact_orb
call dgemv('T', cholesky_mo_num, n_act_orb, 2.d0, &
cholesky_no_total_transp(1,n_core_inact_orb+1,x3), cholesky_mo_num, &
cholesky_no_total_transp(1,aa,aa), 1, 0.d0, &
tmp1, 1)
do v=1,n_act_orb
vv=list_act(v)
v3=v+n_core_inact_orb
t2 = t2 + P0tuvx_no(t,t,v,x)*tmp1(v)
enddo
enddo
! do v=1,n_act_orb
! v3=v+n_core_inact_orb
! do x=1,n_act_orb
! x3=x+n_core_inact_orb
! tmp = 0.d0
! do ichol = 1, cholesky_mo_num
! tmp = tmp + cholesky_no_total_transp(ichol,aa,x3) * cholesky_no_total_transp(ichol,v3,aa)
! enddo
! t2 = t2 + 2.d0*(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))*tmp
! end do
! end do
call dgemm('T','N', n_act_orb, n_act_orb, cholesky_mo_num, 2.d0, &
cholesky_no_total_transp(1,n_core_inact_orb+1,aa), cholesky_mo_num, &
cholesky_no_total_transp(1,n_core_inact_orb+1,aa), cholesky_mo_num, 0.d0, &
tmp2, n_act_orb)
do v=1,n_act_orb
do x=1,n_act_orb
t2 = t2 + P0tuvx_no(t,x,v,t)*tmp2(x,v) + P0tuvx_no(t,x,t,v)*tmp2(x,v)
enddo
enddo
t3=0.D0
do x=1,n_act_orb
xx=list_act(x)
x3=x+n_core_inact_orb
t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
bielec_pxxq_no(aa,x3,v3,aa))
do y=1,n_act_orb
t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx)
do v=1,n_act_orb
t3 = t3 - P0tuvx_no(t,v,x,y)*bielecCI_no(v,t,y,xx)
end do
end do
end do
term=t1+t2+t3
term=t1+t2+t3*2.d0
else
bb=list_virt(b)
! ta/tb b/=a
term=occnum(tt)*Fipq(aa,bb)
do v=1,n_act_orb
vv=list_act(v)
v3=v+n_core_inact_orb
! do v=1,n_act_orb
! vv=list_act(v)
! v3=v+n_core_inact_orb
! do x=1,n_act_orb
! xx=list_act(x)
! x3=x+n_core_inact_orb
! term+=2.D0*P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3)
! end do
! end do
do x=1,n_act_orb
xx=list_act(x)
x3=x+n_core_inact_orb
term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) &
*bielec_pxxq_no(aa,x3,v3,bb))
end do
end do
call dgemv('T', cholesky_mo_num, n_act_orb, 2.d0, &
cholesky_no_total_transp(1,n_core_inact_orb+1,x3), cholesky_mo_num, &
cholesky_no_total_transp(1,aa,bb), 1, 0.d0, &
tmp1, 1)
do v=1,n_act_orb
term = term + P0tuvx_no(t,t,v,x)*tmp1(v)
enddo
enddo
! do v=1,n_act_orb
! vv=list_act(v)
! v3=v+n_core_inact_orb
! do x=1,n_act_orb
! xx=list_act(x)
! x3=x+n_core_inact_orb
! term+=2.d0*(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))*bielec_pxxq_no(aa,x3,v3,bb)
! end do
! end do
call dgemm('T','N', n_act_orb, n_act_orb, cholesky_mo_num, 2.d0, &
cholesky_no_total_transp(1,n_core_inact_orb+1,aa), cholesky_mo_num, &
cholesky_no_total_transp(1,n_core_inact_orb+1,bb), cholesky_mo_num, 0.d0, &
tmp2, n_act_orb)
do v=1,n_act_orb
do x=1,n_act_orb
term = term + P0tuvx_no(t,x,v,t)*tmp2(x,v) + P0tuvx_no(t,x,t,v)*tmp2(x,v)
enddo
enddo
end if
else
! ta/ub t/=u
uu=list_act(u)
bb=list_virt(b)
term=0.D0
do v=1,n_act_orb
vv=list_act(v)
v3=v+n_core_inact_orb
! do v=1,n_act_orb
! vv=list_act(v)
! v3=v+n_core_inact_orb
! do x=1,n_act_orb
! xx=list_act(x)
! x3=x+n_core_inact_orb
! term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3)
! end do
! end do
do x=1,n_act_orb
xx=list_act(x)
x3=x+n_core_inact_orb
term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) &
+(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) &
*bielec_pxxq_no(aa,x3,v3,bb))
end do
end do
call dgemv('T', cholesky_mo_num, n_act_orb, 2.d0, &
cholesky_no_total_transp(1,n_core_inact_orb+1,x3), cholesky_mo_num, &
cholesky_no_total_transp(1,aa,bb), 1, 0.d0, &
tmp1, 1)
do v=1,n_act_orb
term = term + P0tuvx_no(t,u,v,x)*tmp1(v)
enddo
enddo
! do v=1,n_act_orb
! vv=list_act(v)
! v3=v+n_core_inact_orb
! do x=1,n_act_orb
! xx=list_act(x)
! x3=x+n_core_inact_orb
! term+=2.D0*(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v))*bielec_pxxq_no(aa,x3,v3,bb)
! end do
! end do
call dgemm('T','N', n_act_orb, n_act_orb, cholesky_mo_num, 2.d0, &
cholesky_no_total_transp(1,n_core_inact_orb+1,aa), cholesky_mo_num, &
cholesky_no_total_transp(1,n_core_inact_orb+1,bb), cholesky_mo_num, 0.d0, &
tmp2, n_act_orb)
do v=1,n_act_orb
do x=1,n_act_orb
term = term + P0tuvx_no(t,x,v,u)*tmp2(x,v)+P0tuvx_no(t,x,u,v)*tmp2(x,v)
enddo
enddo
if (a.eq.b) then
term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu))
do v=1,n_act_orb
do y=1,n_act_orb
do x=1,n_act_orb
term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,uu)
term-=P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt)
term = term - P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,uu) &
- P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt)
end do
end do
end do

61
src/casscf_cipsi/mcscf_fock.irp.f
View File

@ -3,8 +3,7 @@ BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ]
! the inactive Fock matrix, in molecular orbitals
END_DOC
implicit none
integer :: p,q,k,kk,t,tt,u,uu
double precision :: bielec_pxxq_no, bielec_pqxx_no
integer :: i,p,q,k,kk,t,tt,u,uu
do q=1,mo_num
do p=1,mo_num
@ -15,15 +14,32 @@ BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ]
! the inactive Fock matrix
do k=1,n_core_inact_orb
kk=list_core_inact(k)
do q=1,mo_num
do p=1,mo_num
Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q)
end do
end do
! do q=1,mo_num
! do p=1,mo_num
! do i=1,cholesky_mo_num
! Fipq(p,q) = Fipq(p,q) + 2.d0* cholesky_no_total_transp(i,p,q) * cholesky_no_total_transp(i,kk,kk)
! enddo
! end do
! end do
call dgemv('T', cholesky_mo_num, mo_num*mo_num, 2.d0, &
cholesky_no_total_transp, cholesky_mo_num, &
cholesky_no_total_transp(1,kk,kk), 1, 1.d0, &
Fipq, 1)
! do q=1,mo_num
! do p=1,mo_num
! do i=1,cholesky_mo_num
! Fipq(p,q) = Fipq(p,q) - cholesky_no_total_transp(i,p,kk) * cholesky_no_total_transp(i,kk,q)
! enddo
! end do
! end do
call dgemm('T','N', mo_num, mo_num, cholesky_mo_num, -1.d0, &
cholesky_no_total_transp(1,1,kk), cholesky_mo_num, &
cholesky_no_total_transp(1,kk,1), cholesky_mo_num*mo_num, 1.d0, &
Fipq, mo_num)
end do
if (bavard) then
integer :: i
write(6,*)
write(6,*) ' the diagonal of the inactive effective Fock matrix '
write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num)
@ -45,19 +61,34 @@ BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ]
END_DOC
implicit none
integer :: p,q,k,kk,t,tt,u,uu
double precision :: bielec_pxxq_no, bielec_pqxx_no
Fapq = 0.d0
! the active Fock matrix, D0tu is diagonal
do t=1,n_act_orb
tt=list_act(t)
do q=1,mo_num
do p=1,mo_num
Fapq(p,q)+=occnum(tt) &
*(bielec_pqxx_no(p,q,tt,tt)-0.5D0*bielec_pxxq_no(p,tt,tt,q))
end do
end do
! do q=1,mo_num
! do p=1,mo_num
! do i=1,cholesky_mo_num
! Fapq(p,q) = Fapq(p,q) + occnum(tt)* cholesky_no_total_transp(i,p,q) * cholesky_no_total_transp(i,tt,tt)
! enddo
! end do
! end do
call dgemv('T', cholesky_mo_num, mo_num*mo_num, occnum(tt), &
cholesky_no_total_transp, cholesky_mo_num, &
cholesky_no_total_transp(1,tt,tt), 1, 1.d0, &
Fapq, 1)
! do q=1,mo_num
! do p=1,mo_num
! do i=1,cholesky_mo_num
! Fapq(p,q) = Fapq(p,q) - 0.5d0*occnum(tt)*cholesky_no_total_transp(i,p,tt) * cholesky_no_total_transp(i,tt,q)
! enddo
! end do
! end do
call dgemm('T','N', mo_num, mo_num, cholesky_mo_num, -0.5d0*occnum(tt), &
cholesky_no_total_transp(1,1,tt), cholesky_mo_num, &
cholesky_no_total_transp(1,tt,1), cholesky_mo_num*mo_num, 1.d0, &
Fapq, mo_num)
end do
if (bavard) then

102
src/casscf_cipsi/natorb.irp.f
View File

@ -72,84 +72,27 @@ BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
BEGIN_DOC
! 4-index transformation of 2part matrices
END_DOC
integer :: i,j,k,l,p,q
real*8 :: d(n_act_orb)
! index per index
! first quarter
P0tuvx_no(:,:,:,:) = P0tuvx(:,:,:,:)
double precision, allocatable :: tmp(:,:,:,:)
allocate(tmp(n_act_orb,n_act_orb,n_act_orb,n_act_orb))
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=P0tuvx_no(q,j,k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
P0tuvx_no(p,j,k,l)=d(p)
end do
end do
end do
end do
! 2nd quarter
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=P0tuvx_no(j,q,k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
P0tuvx_no(j,p,k,l)=d(p)
end do
end do
end do
end do
! 3rd quarter
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=P0tuvx_no(j,k,q,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
P0tuvx_no(j,k,p,l)=d(p)
end do
end do
end do
end do
! 4th quarter
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=P0tuvx_no(j,k,l,q)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
P0tuvx_no(j,k,l,p)=d(p)
end do
end do
end do
end do
call dgemm('T','N',(n_act_orb*n_act_orb*n_act_orb), n_act_orb, n_act_orb, 1.d0, &
P0tuvx, n_act_orb, natorbsCI, n_act_orb, 0.d0, &
tmp, (n_act_orb*n_act_orb*n_act_orb))
call dgemm('T','N',(n_act_orb*n_act_orb*n_act_orb), n_act_orb, n_act_orb, 1.d0, &
tmp, n_act_orb, natorbsCI, n_act_orb, 0.d0, &
P0tuvx_no, (n_act_orb*n_act_orb*n_act_orb))
call dgemm('T','N',(n_act_orb*n_act_orb*n_act_orb), n_act_orb, n_act_orb, 1.d0, &
P0tuvx_no, n_act_orb, natorbsCI, n_act_orb, 0.d0, &
tmp, (n_act_orb*n_act_orb*n_act_orb))
call dgemm('T','N',(n_act_orb*n_act_orb*n_act_orb), n_act_orb, n_act_orb, 1.d0, &
tmp, n_act_orb, natorbsCI, n_act_orb, 0.d0, &
P0tuvx_no, (n_act_orb*n_act_orb*n_act_orb))
deallocate(tmp)
END_PROVIDER
@ -160,6 +103,7 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)]
BEGIN_DOC
! Transformed one-e integrals
END_DOC
integer :: i,j, p, q
real*8 :: d(n_act_orb)
one_ints_no(:,:)=mo_one_e_integrals(:,:)
@ -168,10 +112,8 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)]
do j=1,mo_num
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=one_ints_no(list_act(q),j)*natorbsCI(q,p)
d(p) = d(p) + one_ints_no(list_act(q),j)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
@ -183,8 +125,6 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)]
do j=1,mo_num
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=one_ints_no(j,list_act(q))*natorbsCI(q,p)
end do

5
src/casscf_cipsi/reorder_orb.irp.f
View File

@ -26,6 +26,11 @@ subroutine reorder_orbitals_for_casscf
array(iorb) = 3 * mo_num + i
enddo
do i = 1, n_del_orb
iorb = list_del(i)
array(iorb) = 4 * mo_num + i
enddo
do i = 1, mo_num
iorder(i) = i
enddo

5
src/ccsd/ccsd_space_orb.irp.f
View File

@ -1,9 +1,10 @@
! Code
program ccsd
implicit none
BEGIN_DOC
! Closed-shell CCSD
END_DOC
read_wf = .True.
touch read_wf

15
src/ccsd/ccsd_space_orb_sub.irp.f
View File

@ -26,7 +26,6 @@ subroutine run_ccsd_space_orb
double precision, allocatable :: all_err(:,:), all_t(:,:)
integer, allocatable :: list_occ(:), list_vir(:)
integer(bit_kind) :: det(N_int,2)
integer :: nO, nV, nOa, nVa
call set_multiple_levels_omp(.False.)
@ -38,9 +37,8 @@ subroutine run_ccsd_space_orb
PROVIDE all_mo_integrals
endif
det = psi_det(:,:,cc_ref)
print*,'Reference determinant:'
call print_det(det,N_int)
call print_det(psi_det(1,1,cc_ref),N_int)
nOa = cc_nOa
nVa = cc_nVa
@ -57,10 +55,6 @@ subroutine run_ccsd_space_orb
allocate(list_occ(nO),list_vir(nV))
list_occ = cc_list_occ
list_vir = cc_list_vir
! Debug
!call extract_list_orb_space(det,nO,nV,list_occ,list_vir)
!print*,'occ',list_occ
!print*,'vir',list_vir
! GPU arrays
call gpu_allocate(d_cc_space_f_oo, nO, nO)
@ -183,10 +177,12 @@ subroutine run_ccsd_space_orb
call guess_t2(nO,nV,cc_space_f_o,cc_space_f_v,cc_space_v_oovv,h_t2)
call gpu_upload(h_t2, t2)
deallocate(h_t1, h_t2)
call update_tau_space(nO,nV,h_t1,t1,t2,tau)
call update_tau_space(nO,nV,t1%f,t1,t2,tau)
call update_tau_x_space(nO,nV,tau,tau_x)
call det_energy(det,uncorr_energy)
call det_energy(psi_det(1,1,cc_ref),uncorr_energy)
print*,'Det energy', uncorr_energy
call ccsd_energy_space_x(nO,nV,d_cc_space_v_oovv,d_cc_space_f_vo,tau_x,t1,energy)
@ -316,7 +312,6 @@ subroutine run_ccsd_space_orb
call save_energy(uncorr_energy + energy, e_t)
deallocate(h_t1, h_t2)
if (do_mo_cholesky) then
call gpu_deallocate(d_cc_space_v_oo_chol)
call gpu_deallocate(d_cc_space_v_ov_chol)

2
src/ccsd/ccsd_spin_orb.irp.f
View File

@ -1,5 +1,3 @@
! Prog
program ccsd
implicit none

269
src/ccsd/ccsd_spin_orb_sub.irp.f
View File

@ -1,6 +1,5 @@
! Code
subroutine run_ccsd_spin_orb
use gpu
implicit none
@ -8,165 +7,88 @@ subroutine run_ccsd_spin_orb
! CCSD in spin orbitals
END_DOC
double precision, allocatable :: t1(:,:), t2(:,:,:,:), tau(:,:,:,:), tau_t(:,:,:,:)
double precision, allocatable :: r1(:,:), r2(:,:,:,:)
double precision, allocatable :: cF_oo(:,:), cF_ov(:,:), cF_vv(:,:)
double precision, allocatable :: cW_oooo(:,:,:,:), cW_ovvo(:,:,:,:), cW_vvvv(:,:,:,:)
double precision, allocatable :: cW_oooo(:,:,:,:), cW_ovvo(:,:,:,:) !, cW_vvvv(:,:,:,:)
double precision, allocatable :: f_oo(:,:), f_ov(:,:), f_vv(:,:), f_o(:), f_v(:)
double precision, allocatable :: v_oooo(:,:,:,:), v_vooo(:,:,:,:), v_ovoo(:,:,:,:)
double precision, allocatable :: v_oovo(:,:,:,:), v_ooov(:,:,:,:), v_vvoo(:,:,:,:)
double precision, allocatable :: v_vovo(:,:,:,:), v_voov(:,:,:,:), v_ovvo(:,:,:,:)
double precision, allocatable :: v_ovov(:,:,:,:), v_oovv(:,:,:,:), v_vvvo(:,:,:,:)
double precision, allocatable :: v_vvov(:,:,:,:), v_vovv(:,:,:,:), v_ovvv(:,:,:,:)
double precision, allocatable :: v_vvvv(:,:,:,:)
double precision, allocatable :: f_o(:), f_v(:)
! double precision, allocatable :: v_ovvv(:,:,:,:)
double precision, allocatable :: all_err(:,:), all_t(:,:)
logical :: not_converged
integer, allocatable :: list_occ(:,:), list_vir(:,:)
integer :: nO,nV,nOa,nOb,nVa,nVb,nO_m,nV_m,nO_S(2),nV_S(2),n_spin(4)
integer :: n_spin(4)
integer :: nb_iter, i,j,a,b
double precision :: uncorr_energy, energy, max_r, max_r1, max_r2, cc, ta, tb,ti,tf,tbi,tfi
integer(bit_kind) :: det(N_int,2)
det = psi_det(:,:,cc_ref)
type(gpu_double4) :: t2, r2, tau, tau_t
type(gpu_double2) :: t1, r1
if (do_mo_cholesky) then
PROVIDE cholesky_mo_transp
FREE cholesky_ao
else
PROVIDE all_mo_integrals
endif
print*,'Reference determinant:'
call print_det(det,N_int)
! Extract number of occ/vir alpha/beta spin orbitals
!call extract_n_spin(det,n_spin)
nOa = cc_nOa !n_spin(1)
nOb = cc_nOb !n_spin(2)
nVa = cc_nVa !n_spin(3)
nVb = cc_nVb !n_spin(4)
! Total number of occ/vir spin orb
nO = cc_nOab !nOa + nOb
nV = cc_nVab !nVa + nVb
! Debug
!print*,nO,nV
! Number of occ/vir spin orb per spin
nO_S = cc_nO_S !(/nOa,nOb/)
nV_S = cc_nV_S !(/nVa,nVb/)
! Debug
!print*,nO_S,nV_S
! Maximal number of occ/vir
nO_m = cc_nO_m !max(nOa, nOb)
nV_m = cc_nV_m !max(nVa, nVb)
! Debug
!print*,nO_m,nV_m
allocate(list_occ(nO_m,2), list_vir(nV_m,2))
list_occ = cc_list_occ_spin
list_vir = cc_list_vir_spin
! Debug
!call extract_list_orb_spin(det,nO_m,nV_m,list_occ,list_vir)
!print*,list_occ(:,1)
!print*,list_occ(:,2)
!print*,list_vir(:,1)
!print*,list_vir(:,2)
call print_det(psi_det(1,1,cc_ref),N_int)
! Allocation
allocate(t1(nO,nV), t2(nO,nO,nV,nV), tau(nO,nO,nV,nV), tau_t(nO,nO,nV,nV))
allocate(r1(nO,nV), r2(nO,nO,nV,nV))
allocate(cF_oo(nO,nO), cF_ov(nO,nV), cF_vv(nV,nV))
allocate(cW_oooo(nO,nO,nO,nO), cW_ovvo(nO,nV,nV,nO))!, cW_vvvv(nV,nV,nV,nV))
allocate(v_oooo(nO,nO,nO,nO))
!allocate(v_vooo(nV,nO,nO,nO))
allocate(v_ovoo(nO,nV,nO,nO))
allocate(v_oovo(nO,nO,nV,nO))
allocate(v_ooov(nO,nO,nO,nV))
allocate(v_vvoo(nV,nV,nO,nO))
!allocate(v_vovo(nV,nO,nV,nO))
!allocate(v_voov(nV,nO,nO,nV))
allocate(v_ovvo(nO,nV,nV,nO))
allocate(v_ovov(nO,nV,nO,nV))
allocate(v_oovv(nO,nO,nV,nV))
!allocate(v_vvvo(nV,nV,nV,nO))
!allocate(v_vvov(nV,nV,nO,nV))
!allocate(v_vovv(nV,nO,nV,nV))
!allocate(v_ovvv(nO,nV,nV,nV))
!allocate(v_vvvv(nV,nV,nV,nV))
allocate(f_o(nO), f_v(nV))
allocate(f_oo(nO, nO))
allocate(f_ov(nO, nV))
allocate(f_vv(nV, nV))
allocate(cF_oo(cc_nOab,cc_nOab), cF_ov(cc_nOab,cc_nVab), cF_vv(cc_nVab,cc_nVab))
allocate(cW_oooo(cc_nOab,cc_nOab,cc_nOab,cc_nOab), cW_ovvo(cc_nOab,cc_nVab,cc_nVab,cc_nOab))!, cW_vvvv(cc_nVab,cc_nVab,cc_nVab,cc_nVab))
allocate(f_o(cc_nOab), f_v(cc_nVab))
call gpu_allocate(t1, cc_nOab,cc_nVab)
call gpu_allocate(r1, cc_nOab,cc_nVab)
call gpu_allocate(t2, cc_nOab,cc_nOab,cc_nVab,cc_nVab)
call gpu_allocate(r2, cc_nOab,cc_nOab,cc_nVab,cc_nVab)
call gpu_allocate(tau, cc_nOab,cc_nOab,cc_nVab,cc_nVab)
call gpu_allocate(tau_t, cc_nOab,cc_nOab,cc_nVab,cc_nVab)
! Allocation for the diis
if (cc_update_method == 'diis') then
allocate(all_err(nO*nV+nO*nO*nV*nV,cc_diis_depth), all_t(nO*nV+nO*nO*nV*nV,cc_diis_depth))
allocate(all_err(cc_nOab*cc_nVab+cc_nOab*cc_nOab*cc_nVab*cc_nVab,cc_diis_depth), all_t(cc_nOab*cc_nVab+cc_nOab*cc_nOab*cc_nVab*cc_nVab,cc_diis_depth))
all_err = 0d0
all_t = 0d0
endif
! Fock elements
call gen_f_spin(det, nO_m,nO_m, nO_S,nO_S, list_occ,list_occ, nO,nO, f_oo)
call gen_f_spin(det, nO_m,nV_m, nO_S,nV_S, list_occ,list_vir, nO,nV, f_ov)
call gen_f_spin(det, nV_m,nV_m, nV_S,nV_S, list_vir,list_vir, nV,nV, f_vv)
! Diag elements
do i = 1, nO
f_o(i) = f_oo(i,i)
do i = 1, cc_nOab
f_o(i) = cc_spin_f_oo(i,i)
enddo
do i = 1, nV
f_v(i) = f_vv(i,i)
do i = 1, cc_nVab
f_v(i) = cc_spin_f_vv(i,i)
enddo
! Bi electronic integrals from list
call wall_time(ti)
! OOOO
call gen_v_spin(nO_m,nO_m,nO_m,nO_m, nO_S,nO_S,nO_S,nO_S, list_occ,list_occ,list_occ,list_occ, nO,nO,nO,nO, v_oooo)
! OOO V
!call gen_v_spin(nV_m,nO_m,nO_m,nO_m, nV_S,nO_S,nO_S,nO_S, list_vir,list_occ,list_occ,list_occ, nV,nO,nO,nO, v_vooo)
call gen_v_spin(nO_m,nV_m,nO_m,nO_m, nO_S,nV_S,nO_S,nO_S, list_occ,list_vir,list_occ,list_occ, nO,nV,nO,nO, v_ovoo)
call gen_v_spin(nO_m,nO_m,nV_m,nO_m, nO_S,nO_S,nV_S,nO_S, list_occ,list_occ,list_vir,list_occ, nO,nO,nV,nO, v_oovo)
call gen_v_spin(nO_m,nO_m,nO_m,nV_m, nO_S,nO_S,nO_S,nV_S, list_occ,list_occ,list_occ,list_vir, nO,nO,nO,nV, v_ooov)
! OO VV
call gen_v_spin(nV_m,nV_m,nO_m,nO_m, nV_S,nV_S,nO_S,nO_S, list_vir,list_vir,list_occ,list_occ, nV,nV,nO,nO, v_vvoo)
!call gen_v_spin(nV_m,nO_m,nV_m,nO_m, nV_S,nO_S,nV_S,nO_S, list_vir,list_occ,list_vir,list_occ, nV,nO,nV,nO, v_vovo)
!call gen_v_spin(nV_m,nO_m,nO_m,nV_m, nV_S,nO_S,nO_S,nV_S, list_vir,list_occ,list_occ,list_vir, nV,nO,nO,nV, v_voov)
call gen_v_spin(nO_m,nV_m,nV_m,nO_m, nO_S,nV_S,nV_S,nO_S, list_occ,list_vir,list_vir,list_occ, nO,nV,nV,nO, v_ovvo)
call gen_v_spin(nO_m,nV_m,nO_m,nV_m, nO_S,nV_S,nO_S,nV_S, list_occ,list_vir,list_occ,list_vir, nO,nV,nO,nV, v_ovov)
call gen_v_spin(nO_m,nO_m,nV_m,nV_m, nO_S,nO_S,nV_S,nV_S, list_occ,list_occ,list_vir,list_vir, nO,nO,nV,nV, v_oovv)
! O VVV
!call gen_v_spin(nV_m,nV_m,nV_m,nO_m, nV_S,nV_S,nV_S,nO_S, list_vir,list_vir,list_vir,list_occ, nV,nV,nV,nO, v_vvvo)
!call gen_v_spin(nV_m,nV_m,nO_m,nV_m, nV_S,nV_S,nO_S,nV_S, list_vir,list_vir,list_occ,list_vir, nV,nV,nO,nV, v_vvov)
!call gen_v_spin(nV_m,nO_m,nV_m,nV_m, nV_S,nO_S,nV_S,nV_S, list_vir,list_occ,list_vir,list_vir, nV,nO,nV,nV, v_vovv)
!call gen_v_spin(nO_m,nV_m,nV_m,nV_m, nO_S,nV_S,nV_S,nV_S, list_occ,list_vir,list_vir,list_vir, nO,nV,nV,nV, v_ovvv)
! VVVV
!call gen_v_spin(nV_m,nV_m,nV_m,nV_m, nV_S,nV_S,nV_S,nV_S, list_vir,list_vir,list_vir,list_vir, nV,nV,nV,nV, v_vvvv)
call wall_time(tf)
if (cc_dev) then
print*,'Load bi elec int:',tf-ti,'s'
endif
! Init of T
t1 = 0d0
call guess_t1(nO,nV,f_o,f_v,f_ov,t1)
call guess_t2(nO,nV,f_o,f_v,v_oovv,t2)
call compute_tau_spin(nO,nV,t1,t2,tau)
call compute_tau_t_spin(nO,nV,t1,t2,tau_t)
double precision, allocatable :: h_t1(:,:), h_t2(:,:,:,:)
allocate(h_t1(cc_nOab,cc_nVab), h_t2(cc_nOab,cc_nOab,cc_nVab,cc_nVab))
h_t1 = 0d0
call guess_t1(cc_nOab,cc_nVab,f_o,f_v,cc_spin_f_ov,h_t1)
call gpu_upload(h_t1, t1)
call guess_t2(cc_nOab,cc_nVab,f_o,f_v,cc_spin_v_oovv,h_t2)
call gpu_upload(h_t2, t2)
deallocate(h_t1,h_t2)
call compute_tau_spin(cc_nOab,cc_nVab,t1%f,t2%f,tau%f)
call compute_tau_t_spin(cc_nOab,cc_nVab,t1%f,t2%f,tau_t%f)
call det_energy(psi_det(1,1,cc_ref),uncorr_energy)
print*,'Det energy', uncorr_energy
call ccsd_energy_spin(cc_nOab,cc_nVab,t1%f,t2%f,cc_spin_F_ov,cc_spin_v_oovv,energy)
print*,'guess energy', uncorr_energy+energy, energy
! Loop init
nb_iter = 0
not_converged = .True.
r1 = 0d0
r2 = 0d0
max_r1 = 0d0
max_r2 = 0d0
call det_energy(det,uncorr_energy)
print*,'Det energy', uncorr_energy
call ccsd_energy_spin(nO,nV,t1,t2,F_ov,v_oovv,energy)
print*,'guess energy', uncorr_energy+energy, energy
write(*,'(A77)') ' -----------------------------------------------------------------------------'
write(*,'(A77)') ' | It. | E(CCSD) (Ha) | Correlation (Ha) | Conv. T1 | Conv. T2 |'
write(*,'(A77)') ' -----------------------------------------------------------------------------'
@ -177,68 +99,46 @@ subroutine run_ccsd_spin_orb
do while (not_converged)
! Intermediates
call wall_time(tbi)
call wall_time(ti)
call compute_cF_oo(nO,nV,t1,tau_t,F_oo,F_ov,v_ooov,v_oovv,cF_oo)
call compute_cF_ov(nO,nV,t1,F_ov,v_oovv,cF_ov)
call compute_cF_vv(nO,nV,t1,tau_t,F_ov,F_vv,v_oovv,cF_vv)
call wall_time(tf)
if (cc_dev) then
print*,'Compute cFs:',tf-ti,'s'
endif
call compute_cF_oo(cc_nOab,cc_nVab,t1%f,tau_t%f,cc_spin_F_oo,cc_spin_F_ov,cc_spin_v_ooov,cc_spin_v_oovv,cF_oo)
call compute_cF_ov(cc_nOab,cc_nVab,t1%f,cc_spin_F_ov,cc_spin_v_oovv,cF_ov)
call compute_cF_vv(cc_nOab,cc_nVab,t1%f,tau_t%f,cc_spin_F_ov,cc_spin_F_vv,cc_spin_v_oovv,cF_vv)
call wall_time(ti)
call compute_cW_oooo(nO,nV,t1,t2,tau,v_oooo,v_ooov,v_oovv,cW_oooo)
call compute_cW_ovvo(nO,nV,t1,t2,tau,v_ovvo,v_oovo,v_oovv,cW_ovvo)
!call compute_cW_vvvv(nO,nV,t1,t2,tau,v_vvvv,v_vovv,v_oovv,cW_vvvv)
call wall_time(tf)
if (cc_dev) then
print*,'Compute cFs:',tf-ti,'s'
endif
call compute_cW_oooo(cc_nOab,cc_nVab,t1%f,t2%f,tau%f,cc_spin_v_oooo,cc_spin_v_ooov,cc_spin_v_oovv,cW_oooo)
call compute_cW_ovvo(cc_nOab,cc_nVab,t1%f,t2%f,tau%f,cc_spin_v_ovvo,cc_spin_v_oovo,cc_spin_v_oovv,cW_ovvo)
! Residuals
call wall_time(ti)
call compute_r1_spin(nO,nV,t1,t2,f_o,f_v,F_ov,cF_oo,cF_ov,cF_vv,v_oovo,v_ovov,r1)
call wall_time(tf)
if (cc_dev) then
print*,'Compute r1:',tf-ti,'s'
endif
call wall_time(ti)
call compute_r2_spin(nO,nV,t1,t2,tau,f_o,f_v,cF_oo,cF_ov,cF_vv,cW_oooo,cW_ovvo,v_ovoo,v_oovv,v_ovvo,r2)
call wall_time(tf)
if (cc_dev) then
print*,'Compute r2:',tf-ti,'s'
endif
call compute_r1_spin(cc_nOab,cc_nVab,t1%f,t2%f,f_o,f_v,cc_spin_F_ov,cF_oo,cF_ov,cF_vv,cc_spin_v_oovo,cc_spin_v_ovov,r1%f)
call compute_r2_spin(cc_nOab,cc_nVab,t1%f,t2%f,tau%f,f_o,f_v,cF_oo,cF_ov,cF_vv,cW_oooo,cW_ovvo,cc_spin_v_ovoo,cc_spin_v_oovv,cc_spin_v_ovvo,r2%f)
! Max elements in the residuals
max_r1 = maxval(abs(r1(:,:)))
max_r2 = maxval(abs(r2(:,:,:,:)))
max_r1 = maxval(abs(r1%f(:,:)))
max_r2 = maxval(abs(r2%f(:,:,:,:)))
max_r = max(max_r1,max_r2)
call wall_time(ti)
! Update
if (cc_update_method == 'diis') then
!call update_t_ccsd(nO,nV,nb_iter,f_o,f_v,r1,r2,t1,t2,all_err1,all_err2,all_t1,all_t2)
!call update_t_ccsd_diis(nO,nV,nb_iter,f_o,f_v,r1,r2,t1,t2,all_err1,all_err2,all_t1,all_t2)
call update_t_ccsd_diis_v3(nO,nV,nb_iter,f_o,f_v,r1,r2,t1,t2,all_err,all_t)
!call update_t_ccsd(cc_nOab,cc_nVab,nb_iter,f_o,f_v,r1%f,r2%f,t1%f,t2%f,all_err1,all_err2,all_t1%f,all_t2)
!call update_t_ccsd_diis(cc_nOab,cc_nVab,nb_iter,f_o,f_v,r1%f,r2%f,t1%f,t2%f,all_err1,all_err2,all_t1%f,all_t2)
call update_t_ccsd_diis_v3(cc_nOab,cc_nVab,nb_iter,f_o,f_v,r1%f,r2%f,t1%f,t2%f,all_err,all_t)
! Standard update as T = T - Delta
elseif (cc_update_method == 'none') then
call update_t1(nO,nV,f_o,f_v,r1,t1)
call update_t2(nO,nV,f_o,f_v,r2,t2)
call update_t1(cc_nOab,cc_nVab,f_o,f_v,r1%f,t1%f)
call update_t2(cc_nOab,cc_nVab,f_o,f_v,r2%f,t2%f)
else
print*,'Unkonw cc_method_method: '//cc_update_method
endif
call compute_tau_spin(nO,nV,t1,t2,tau)
call compute_tau_t_spin(nO,nV,t1,t2,tau_t)
call compute_tau_spin(cc_nOab,cc_nVab,t1%f,t2%f,tau%f)
call compute_tau_t_spin(cc_nOab,cc_nVab,t1%f,t2%f,tau_t%f)
call wall_time(tf)
if (cc_dev) then
print*,'Update:',tf-ti,'s'
endif
! Print
call ccsd_energy_spin(nO,nV,t1,t2,F_ov,v_oovv,energy)
call ccsd_energy_spin(cc_nOab,cc_nVab,t1%f,t2%f,cc_spin_F_ov,cc_spin_v_oovv,energy)
call wall_time(tfi)
write(*,'(A3,I6,A3,F18.12,A3,F16.12,A3,ES10.2,A3,ES10.2,A2)') ' | ',nb_iter,' | ', &
@ -270,8 +170,8 @@ subroutine run_ccsd_spin_orb
print*,''
if (write_amplitudes) then
call write_t1(nO,nV,t1)
call write_t2(nO,nV,t2)
call write_t1(cc_nOab,cc_nVab,t1%f)
call write_t2(cc_nOab,cc_nVab,t2%f)
call ezfio_set_utils_cc_io_amplitudes('Read')
endif
@ -279,29 +179,15 @@ subroutine run_ccsd_spin_orb
if (cc_update_method == 'diis') then
deallocate(all_err,all_t)
endif
deallocate(tau,tau_t)
deallocate(r1,r2)
deallocate(cF_oo,cF_ov,cF_vv)
deallocate(cW_oooo,cW_ovvo)!,cW_vvvv)
deallocate(v_oooo)
deallocate(v_ovoo,v_oovo)
deallocate(v_ovvo,v_ovov,v_oovv)
double precision :: t_corr
t_corr = 0.d0
if (cc_par_t .and. elec_alpha_num +elec_beta_num > 2) then
print*,'CCSD(T) calculation...'
call wall_time(ta)
!allocate(v_vvvo(nV,nV,nV,nO))
!call gen_v_spin(cc_nV_m,cc_nV_m,cc_nV_m,cc_nO_m, &
! cc_nV_S,cc_nV_S,cc_nV_S,cc_nO_S, &
! cc_list_vir_spin,cc_list_vir_spin,cc_list_vir_spin,cc_list_occ_spin, &
! nV,nV,nV,nO, v_vvvo)
!call ccsd_par_t_spin(nO,nV,t1,t2,f_o,f_v,f_ov,v_ooov,v_vvoo,v_vvvo,t_corr)
call ccsd_par_t_spin_v2(nO,nV,t1,t2,f_o,f_v,f_ov,v_ooov,v_vvoo,t_corr)
!print*,'Working on it...'
!call abort
call ccsd_par_t_spin_v2(cc_nOab,cc_nVab,t1%f,t2%f,f_o,f_v,cc_spin_f_ov,cc_spin_v_ooov,cc_spin_v_vvoo,t_corr)
call wall_time(tb)
print*,'Done'
print*,'Time: ',tb-ta, ' s'
@ -314,10 +200,14 @@ subroutine run_ccsd_spin_orb
call save_energy(uncorr_energy + energy, t_corr)
deallocate(f_oo,f_ov,f_vv,f_o,f_v)
deallocate(v_ooov,v_vvoo,t1,t2)
!deallocate(v_ovvv,v_vvvo,v_vovv)
!deallocate(v_vvvv)
deallocate(f_o,f_v)
call gpu_deallocate(t1)
call gpu_deallocate(r1)
call gpu_deallocate(t2)
call gpu_deallocate(r2)
call gpu_deallocate(tau)
call gpu_deallocate(tau_t)
end
@ -908,6 +798,7 @@ subroutine compute_r2_spin(nO,nV,t1,t2,tau,f_o,f_v,cF_oo,cF_ov,cF_vv,cW_oooo,cW_
! 0.5d0, tau , size(tau,1) * size(tau,2), &
! cW_vvvv, size(cW_vvvv,1) * size(cW_vvvv,2), &
! 1d0 , r2 , size(r2,1) * size(r2,2))
double precision :: ti,tf
call wall_time(ti)
call use_cW_vvvf(nO,nV,t1,t2,tau,v_oovv,r2)

20
src/cipsi/selection.irp.f
View File

@ -1478,17 +1478,19 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
integer, parameter :: bant=1
double precision, allocatable :: hij_cache1(:), hij_cache2(:)
allocate (hij_cache1(mo_num),hij_cache2(mo_num))
double precision, allocatable :: hij_cache(:,:)
PROVIDE mo_integrals_threshold
allocate(hij_cache(mo_num,mo_num))
if(sp == 3) then ! AB
h1 = p(1,1)
h2 = p(1,2)
call get_mo_two_e_integrals_ij(h2,h1,mo_num,hij_cache,mo_integrals_map)
do p1=1, mo_num
if(bannedOrb(p1, 1)) cycle
call get_mo_two_e_integrals(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map)
do p2=1, mo_num
if(bannedOrb(p2,2)) cycle
if(banned(p1, p2, bant)) cycle ! rentable?
@ -1497,7 +1499,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
call i_h_j(gen, det, N_int, hij)
else
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hij = hij_cache1(p2) * phase
hij = hij_cache(p2,p1) * phase
end if
if (dabs(hij) < mo_integrals_threshold) cycle
!DIR$ LOOP COUNT AVG(4)
@ -1508,12 +1510,12 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
end do
else ! AA BB
p1 = p(1,sp)
p2 = p(2,sp)
call get_mo_two_e_integrals_ij(p2,p1,mo_num,hij_cache,mo_integrals_map)
do puti=1, mo_num
if (bannedOrb(puti, sp)) cycle
call get_mo_two_e_integrals(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map)
call get_mo_two_e_integrals(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map)
do putj=puti+1, mo_num
if(bannedOrb(putj, sp)) cycle
if(banned(puti, putj, bant)) cycle ! rentable?
@ -1522,7 +1524,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
call i_h_j(gen, det, N_int, hij)
if (dabs(hij) < mo_integrals_threshold) cycle
else
hij = hij_cache1(putj) - hij_cache2(putj)
hij = hij_cache(putj,puti) - hij_cache(puti,putj)
if (dabs(hij) < mo_integrals_threshold) cycle
hij = hij * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
end if
@ -1532,9 +1534,11 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
enddo
end do
end do
end if
deallocate(hij_cache1,hij_cache2)
deallocate(hij_cache)
end

3
src/cipsi_utils/pt2_stoch_routines.irp.f
View File

@ -212,6 +212,7 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
ipos += 1
endif
enddo
call write_int(6,pt2_stoch_istate,'State')
call write_int(6,sum(pt2_F),'Number of tasks')
call write_int(6,ipos,'Number of fragmented tasks')
@ -530,7 +531,7 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_
avg = E0 + pt2_data_S(t) % pt2(pt2_stoch_istate) / dble(c)
avg2 = v0 + pt2_data_S(t) % variance(pt2_stoch_istate) / dble(c)
avg3(:) = n0(:) + pt2_data_S(t) % overlap(:,pt2_stoch_istate) / dble(c)
if ((avg /= 0.d0) .or. (n == N_det_generators) ) then
if (((c>=10).and.(avg /= 0.d0)) .or. (n == N_det_generators) ) then
do_exit = .true.
endif
if (qp_stop()) then

2
src/cipsi_utils/run_pt2_slave.irp.f
View File

@ -350,7 +350,6 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2_data, b, task
enddo
rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
deallocate(pt2_serialized)
if (rc == -1) then
print *, irp_here, ': error sending result'
stop 3
@ -358,6 +357,7 @@ subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2_data, b, task
else if(rc /= size(pt2_serialized)*8) then
stop 'push'
endif
deallocate(pt2_serialized)
rc = f77_zmq_send( zmq_socket_push, task_id, n_tasks*4, ZMQ_SNDMORE)

15
src/dav_general_mat/dav_general.irp.f
View File

@ -228,20 +228,13 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
shift = N_st_diag*(iter-1)
shift2 = N_st_diag*iter
if ((iter > 1).or.(itertot == 1)) then
! Compute |W_k> = \sum_i |i><i|H|u_k>
! -----------------------------------
! Gram-Smitt to orthogonalize all new guess with the previous vectors
call ortho_qr(U,size(U,1),sze,shift2)
call ortho_qr(U,size(U,1),sze,shift2)
! call H_S2_u_0_nstates_openmp(W(:,shift+1),U(:,shift+1),N_st_diag,sze)
call hpsi(W(:,shift+1),U(:,shift+1),N_st_diag,sze,h_mat)
else
! Already computed in update below
continue
endif
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
! -------------------------------------------
@ -311,7 +304,7 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
do i=1,sze
U(i,shift2+k) = &
(lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
/max(H_jj(i) - lambda (k),1.d-2)
/max(dabs(H_jj(i) - lambda (k)),1.d-2) * dsign(1d0,H_jj(i) - lambda (k))
enddo
if (k <= N_st) then
@ -337,7 +330,7 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
do k=1,N_st
if (residual_norm(k) > 1.e8) then
if (residual_norm(k) > 1.d8) then
print *, 'Davidson failed'
stop -1
endif
@ -365,13 +358,15 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, &
U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
do k=1,N_st_diag
do i=1,sze
U(i,k) = u_in(i,k)
enddo
enddo
call ortho_qr(U,size(U,1),sze,N_st_diag)
call ortho_qr(U,size(U,1),sze,N_st_diag)
do j=1,N_st_diag
k=1
do while ((k<sze).and.(U(k,j) == 0.d0))

6
src/davidson/u0_hs2_u0.irp.f
View File

@ -158,7 +158,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,
double precision, intent(out) :: v_t(N_st,sze), s_t(N_st,sze)
PROVIDE ref_bitmask_energy N_int
PROVIDE ref_bitmask_energy N_int all_mo_integrals
select case (N_int)
case (1)
@ -291,7 +291,7 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend,
ASSERT (istart > 0)
ASSERT (istep > 0)
!$OMP DO SCHEDULE(guided,64)
!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
krow = psi_bilinear_matrix_rows(k_a)
@ -469,7 +469,7 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend,
enddo
!$OMP END DO
!$OMP DO SCHEDULE(guided,64)
!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep

24
src/determinants/spindeterminants.irp.f
View File

@ -14,7 +14,7 @@ integer*8 function spin_det_search_key(det,Nint)
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det(Nint)
integer(bit_kind), parameter :: unsigned_shift = -huge(1_bit_kind) ! 100...00
integer(bit_kind), parameter :: unsigned_shift = 1_bit_kind-huge(1_bit_kind) ! 100...00
integer :: i
spin_det_search_key = det(1)
do i=2,Nint
@ -197,7 +197,9 @@ integer function get_index_in_psi_det_alpha_unique(key,Nint)
enddo
i += 1
ASSERT (i <= N_det_alpha_unique)
if (i> N_det_alpha_unique) then
call qp_bug(irp_here, i, 'i> N_det_alpha_unique')
endif
!DIR$ FORCEINLINE
do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref)
@ -219,12 +221,15 @@ integer function get_index_in_psi_det_alpha_unique(key,Nint)
endif
i += 1
if (i > N_det_alpha_unique) then
ASSERT (get_index_in_psi_det_alpha_unique > 0)
return
exit
endif
enddo
if (get_index_in_psi_det_alpha_unique <= 0) then
call qp_bug(irp_here, get_index_in_psi_det_alpha_unique, 'get_index_in_psi_det_alpha_unique <= 0')
endif
end
integer function get_index_in_psi_det_beta_unique(key,Nint)
@ -277,7 +282,9 @@ integer function get_index_in_psi_det_beta_unique(key,Nint)
enddo
i += 1
ASSERT (i <= N_det_beta_unique)
if (i > N_det_beta_unique) then
call qp_bug(irp_here, i, 'i> N_det_beta_unique')
endif
!DIR$ FORCEINLINE
do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref)
@ -299,12 +306,15 @@ integer function get_index_in_psi_det_beta_unique(key,Nint)
endif
i += 1
if (i > N_det_beta_unique) then
ASSERT (get_index_in_psi_det_beta_unique > 0)
return
exit
endif
enddo
if (get_index_in_psi_det_beta_unique <= 0) then
call qp_bug(irp_here, i, 'get_index_in_psi_det_beta_unique <= 0')
endif
end

92
src/dft_utils_in_r/ao_in_r.irp.f
View File

@ -8,21 +8,14 @@ BEGIN_PROVIDER[double precision, aos_in_r_array, (ao_num,n_points_final_grid)]
END_DOC
implicit none
integer :: i, j
double precision :: tmp_array(ao_num), r(3)
integer :: i
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,r,tmp_array,j) &
!$OMP SHARED(aos_in_r_array,n_points_final_grid,ao_num,final_grid_points)
!$OMP PRIVATE (i) &
!$OMP SHARED(aos_in_r_array,n_points_final_grid,final_grid_points)
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call give_all_aos_at_r(r, tmp_array)
do j = 1, ao_num
aos_in_r_array(j,i) = tmp_array(j)
enddo
call give_all_aos_at_r(final_grid_points(1,i), aos_in_r_array(1,i))
enddo
!$OMP END PARALLEL DO
@ -62,25 +55,27 @@ BEGIN_PROVIDER[double precision, aos_grad_in_r_array, (ao_num,n_points_final_gri
implicit none
integer :: i, j, m
double precision :: aos_array(ao_num), r(3)
double precision :: aos_grad_array(3,ao_num)
double precision :: r(3)
double precision, allocatable :: aos_grad_array(:,:), aos_array(:)
!$OMP PARALLEL DO &
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,r,aos_array,aos_grad_array) &
!$OMP SHARED(aos_grad_in_r_array,n_points_final_grid,ao_num,final_grid_points)
allocate(aos_grad_array(3,ao_num), aos_array(ao_num))
!$OMP DO
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call give_all_aos_and_grad_at_r(r,aos_array,aos_grad_array)
call give_all_aos_and_grad_at_r(final_grid_points(1,i),aos_array,aos_grad_array)
do m = 1, 3
do j = 1, ao_num
aos_grad_in_r_array(j,i,m) = aos_grad_array(m,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP END DO
deallocate(aos_grad_array,aos_array)
!$OMP END PARALLEL
END_PROVIDER
@ -126,25 +121,25 @@ END_PROVIDER
! k = 1 : x, k= 2, y, k 3, z
END_DOC
integer :: i,j,m
double precision :: aos_array(ao_num), r(3)
double precision :: aos_grad_array(3,ao_num)
double precision :: aos_lapl_array(3,ao_num)
!$OMP PARALLEL DO &
double precision, allocatable :: aos_lapl_array(:,:), aos_grad_array(:,:), aos_array(:)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,r,aos_array,aos_grad_array,aos_lapl_array,j,m) &
!$OMP PRIVATE (i,aos_array,aos_grad_array,aos_lapl_array,j,m) &
!$OMP SHARED(aos_lapl_in_r_array,n_points_final_grid,ao_num,final_grid_points)
allocate( aos_array(ao_num), aos_grad_array(3,ao_num), aos_lapl_array(3,ao_num))
!$OMP DO
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array)
call give_all_aos_and_grad_and_lapl_at_r(final_grid_points(1,i),aos_array,aos_grad_array,aos_lapl_array)
do j = 1, ao_num
do m = 1, 3
aos_lapl_in_r_array(m,j,i) = aos_lapl_array(m,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP END DO
deallocate( aos_array, aos_grad_array, aos_lapl_array)
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER[double precision, aos_grad_in_r_array_transp_bis, (n_points_final_grid,ao_num,3)]
@ -187,22 +182,14 @@ END_PROVIDER
BEGIN_PROVIDER[double precision, aos_in_r_array_extra, (ao_num,n_points_extra_final_grid)]
implicit none
BEGIN_DOC
! aos_in_r_array_extra(i,j) = value of the ith ao on the jth grid point
! aos_in_r_array_extra(i,j) = value of the ith ao on the jth grid point of the EXTRA grid
END_DOC
integer :: i,j
double precision :: aos_array(ao_num), r(3)
integer :: i
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,r,aos_array,j) &
!$OMP SHARED(aos_in_r_array_extra,n_points_extra_final_grid,ao_num,final_grid_points_extra)
!$OMP DEFAULT (NONE) PRIVATE (i) &
!$OMP SHARED(aos_in_r_array_extra,n_points_extra_final_grid,final_grid_points_extra)
do i = 1, n_points_extra_final_grid
r(1) = final_grid_points_extra(1,i)
r(2) = final_grid_points_extra(2,i)
r(3) = final_grid_points_extra(3,i)
call give_all_aos_at_r(r,aos_array)
do j = 1, ao_num
aos_in_r_array_extra(j,i) = aos_array(j)
enddo
call give_all_aos_at_r(final_grid_points_extra(1,i),aos_in_r_array_extra(1,i))
enddo
!$OMP END PARALLEL DO
@ -214,7 +201,7 @@ END_PROVIDER
BEGIN_PROVIDER[double precision, aos_in_r_array_extra_transp, (n_points_extra_final_grid,ao_num)]
BEGIN_DOC
! aos_in_r_array_extra_transp(i,j) = value of the jth ao on the ith grid point
! aos_in_r_array_extra_transp(i,j) = value of the jth ao on the ith grid point of the EXTRA grid
END_DOC
implicit none
@ -235,25 +222,26 @@ BEGIN_PROVIDER[double precision, aos_grad_in_r_array_extra, (ao_num,n_points_ext
implicit none
integer :: i, j, m
double precision :: aos_array(ao_num), r(3)
double precision :: aos_grad_array(3,ao_num)
double precision, allocatable :: aos_array(:), aos_grad_array(:,:)
!$OMP PARALLEL DO &
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,r,aos_array,aos_grad_array) &
!$OMP PRIVATE (i,j,m,aos_array,aos_grad_array) &
!$OMP SHARED(aos_grad_in_r_array_extra,n_points_extra_final_grid,ao_num,final_grid_points_extra)
allocate(aos_array(ao_num), aos_grad_array(3,ao_num))
!$OMP DO
do i = 1, n_points_extra_final_grid
r(1) = final_grid_points_extra(1,i)
r(2) = final_grid_points_extra(2,i)
r(3) = final_grid_points_extra(3,i)
call give_all_aos_and_grad_at_r(r, aos_array, aos_grad_array)
call give_all_aos_and_grad_at_r(final_grid_points_extra(1,i), aos_array, aos_grad_array)
do m = 1, 3
do j = 1, ao_num
aos_grad_in_r_array_extra(j,i,m) = aos_grad_array(m,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP END DO
deallocate(aos_array,aos_grad_array)
!$OMP END PARALLEL
END_PROVIDER

56
src/dft_utils_in_r/mo_in_r.irp.f
View File

@ -21,20 +21,11 @@
BEGIN_DOC
! mos_in_r_array(i,j) = value of the ith mo on the jth grid point
END_DOC
integer :: i,j
double precision :: mos_array(mo_num), r(3)
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,r,mos_array,j) &
integer :: i
!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE (i) &
!$OMP SHARED(mos_in_r_array_omp,n_points_final_grid,mo_num,final_grid_points)
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call give_all_mos_at_r(r,mos_array)
do j = 1, mo_num
mos_in_r_array_omp(j,i) = mos_array(j)
enddo
call give_all_mos_at_r(final_grid_points(1,i),mos_in_r_array_omp(1,i))
enddo
!$OMP END PARALLEL DO
END_PROVIDER
@ -181,3 +172,44 @@
END_PROVIDER
!!!!!EXTRA GRID
BEGIN_PROVIDER[double precision, mos_in_r_array_extra_omp, (mo_num,n_points_extra_final_grid)]
implicit none
BEGIN_DOC
! mos_in_r_array_extra(i,j) = value of the ith mo on the jth grid point on the EXTRA GRID
END_DOC
integer :: i,j
double precision :: mos_array_extra(mo_num), r(3)
print*,'coucou'
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,r,mos_array_extra,j) &
!$OMP SHARED(mos_in_r_array_extra_omp,n_points_extra_final_grid,mo_num,final_grid_points_extra)
do i = 1, n_points_extra_final_grid
r(1) = final_grid_points_extra(1,i)
r(2) = final_grid_points_extra(2,i)
r(3) = final_grid_points_extra(3,i)
call give_all_mos_at_r(r,mos_array_extra)
do j = 1, mo_num
mos_in_r_array_extra_omp(j,i) = mos_array_extra(j)
enddo
enddo
!$OMP END PARALLEL DO
print*,'coucou fin'
END_PROVIDER
BEGIN_PROVIDER[double precision, mos_in_r_array_extra_transp,(n_points_extra_final_grid,mo_num)]
implicit none
BEGIN_DOC
! mos_in_r_array_extra_transp(i,j) = value of the jth mo on the ith grid point
END_DOC
integer :: i,j
do i = 1, n_points_extra_final_grid
do j = 1, mo_num
mos_in_r_array_extra_transp(i,j) = mos_in_r_array_extra_omp(j,i)
enddo
enddo
END_PROVIDER

9
src/ezfio_files/EZFIO.cfg Normal file
View File

@ -0,0 +1,9 @@
[ezfio_convention]
type: integer
doc: Version of the EZFIO conventions
interface: ezfio, provider, ocaml
default: 20210101
# EZFIO conventions
# 20210101: Old conventions
# 20250211: Changed normalization of AOs: Moved GAMESS convention from primitives to AOs for compatibility with trexio.

2
src/fci/pt2.irp.f
View File

@ -15,11 +15,11 @@ program pt2
! sampling.
!
END_DOC
PROVIDE all_mo_integrals
if (.not. is_zmq_slave) then
read_wf = .True.
threshold_generators = 1.d0
SOFT_TOUCH read_wf threshold_generators
PROVIDE all_mo_integrals
PROVIDE psi_energy
call run
else

17
src/mo_basis/mos.irp.f
View File

@ -346,3 +346,20 @@ subroutine ao_ortho_cano_to_ao(A_ao,LDA_ao,A,LDA)
deallocate(T)
end
BEGIN_PROVIDER [ double precision, mo_sphe_coef, (ao_sphe_num, mo_num) ]
implicit none
BEGIN_DOC
! MO coefficients in the basis of spherical harmonics AOs.
END_DOC
double precision, allocatable :: tmp(:,:)
allocate (tmp(ao_sphe_num,ao_num))
call dgemm('T','N',ao_sphe_num,ao_num,ao_num, 1.d0, &
ao_cart_to_sphe_coef,ao_num, &
mo_coef,size(mo_coef,1), 0.d0, &
mo_sphe_coef, size(mo_sphe_coef,1))
deallocate (tmp)
END_PROVIDER

2
src/mo_basis/utils.irp.f
View File

@ -228,7 +228,7 @@ subroutine mo_as_svd_vectors_of_mo_matrix_eig(matrix,lda,m,n,eig,label)
call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),U,size(U,1),0.d0,mo_coef,size(mo_coef,1))
do i=1,m
if (eig(i) > 1.d-20) then
if (D(i) > 1.d-20) then
eig(i) = D(i)
else
eig(i) = 0.d0

12
src/mo_two_e_ints/EZFIO.cfg
View File

@ -1,3 +1,9 @@
[do_mo_cholesky]
type: logical
doc: Use Cholesky decomposition of MO integrals in CI calculations
interface: ezfio,provider,ocaml
default: False
[io_mo_cholesky]
type: Disk_access
doc: Read/Write |MO| Cholesky integrals from/to disk [ Write | Read | None ]
@ -29,4 +35,10 @@ doc: Read/Write MO integrals with the long range interaction from/to disk [ W
interface: ezfio,provider,ocaml
default: None
[mo_cholesky_double]
type: logical
doc: Use double precision to build integrals from Cholesky vectors
interface: ezfio,provider,ocaml
default: True

66
src/mo_two_e_ints/cholesky.irp.f
View File

@ -1,13 +1,5 @@
BEGIN_PROVIDER [ logical, do_mo_cholesky ]
implicit none
BEGIN_DOC
! If True, use Cholesky vectors for MO integrals
END_DOC
do_mo_cholesky = do_ao_cholesky
! do_mo_cholesky = .False.
END_PROVIDER
BEGIN_PROVIDER [ integer, cholesky_mo_num ]
BEGIN_PROVIDER [ integer, cholesky_mo_num ]
&BEGIN_PROVIDER [ integer, cholesky_mo_num_split, (1:5)]
implicit none
BEGIN_DOC
! Number of Cholesky vectors in MO basis
@ -21,6 +13,12 @@ BEGIN_PROVIDER [ integer, cholesky_mo_num ]
else
cholesky_mo_num = cholesky_ao_num
endif
cholesky_mo_num_split(1) = 0
cholesky_mo_num_split(2) = cholesky_mo_num/4
cholesky_mo_num_split(3) = 2*cholesky_mo_num_split(2)
cholesky_mo_num_split(4) = 3*cholesky_mo_num_split(2)
cholesky_mo_num_split(5) = cholesky_mo_num
cholesky_mo_num_split += 1
END_PROVIDER
BEGIN_PROVIDER [ double precision, cholesky_mo, (mo_num, mo_num, cholesky_mo_num) ]
@ -132,3 +130,51 @@ BEGIN_PROVIDER [ double precision, cholesky_semi_mo_transp_simple, (cholesky_mo_
END_PROVIDER
BEGIN_PROVIDER [ real, cholesky_mo_sp, (mo_num, mo_num, cholesky_mo_num) ]
implicit none
BEGIN_DOC
! Cholesky vectors in MO basis in stored in single precision
END_DOC
integer :: k, i, j
call set_multiple_levels_omp(.False.)
!$OMP PARALLEL DO PRIVATE(k)
do k=1,cholesky_mo_num
do j=1,mo_num
do i=1,mo_num
cholesky_mo_sp(i,j,k) = cholesky_mo_transp_sp(k,i,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
BEGIN_PROVIDER [ real, cholesky_mo_transp_sp, (cholesky_mo_num, mo_num, mo_num) ]
implicit none
BEGIN_DOC
! Cholesky vectors in MO basis in s. Warning: it is transposed wrt cholesky_ao:
!
! - cholesky_ao is (ao_num^2 x cholesky_ao_num)
!
! - cholesky_mo_transp is (cholesky_mo_num x mo_num^2)
END_DOC
integer :: i,j,k
!$OMP PARALLEL DO PRIVATE(k)
do j=1,mo_num
do i=1,mo_num
do k=1,cholesky_mo_num
cholesky_mo_transp_sp(k,i,j) = cholesky_mo_transp(k,i,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER

189
src/mo_two_e_ints/map_integrals.irp.f
View File

@ -9,7 +9,6 @@ BEGIN_PROVIDER [ logical, all_mo_integrals ]
PROVIDE mo_two_e_integrals_in_map mo_integrals_cache mo_two_e_integrals_jj_exchange mo_two_e_integrals_jj_anti mo_two_e_integrals_jj big_array_exchange_integrals big_array_coulomb_integrals mo_one_e_integrals
END_PROVIDER
!! MO Map
!! ======
@ -73,10 +72,12 @@ BEGIN_PROVIDER [ double precision, mo_integrals_cache, (0_8:mo_integrals_cache_s
integer(key_kind) :: idx
real(integral_kind) :: integral
FREE ao_integrals_cache
if (do_mo_cholesky) then
call set_multiple_levels_omp(.False.)
!$OMP PARALLEL DO PRIVATE (k,l,ii)
!$OMP PARALLEL DO PRIVATE(k,l,ii) SCHEDULE(dynamic)
do l=mo_integrals_cache_min,mo_integrals_cache_max
do k=mo_integrals_cache_min,mo_integrals_cache_max
ii = int(l-mo_integrals_cache_min,8)
@ -93,7 +94,7 @@ BEGIN_PROVIDER [ double precision, mo_integrals_cache, (0_8:mo_integrals_cache_s
!$OMP END PARALLEL DO
else
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) SCHEDULE(dynamic)
do l=mo_integrals_cache_min,mo_integrals_cache_max
do k=mo_integrals_cache_min,mo_integrals_cache_max
do j=mo_integrals_cache_min,mo_integrals_cache_max
@ -178,12 +179,20 @@ double precision function get_two_e_integral(i,j,k,l,map)
if (do_mo_cholesky) then
double precision, external :: ddot
real, external :: sdot
integer :: isplit
if (mo_cholesky_double) then
get_two_e_integral = ddot(cholesky_mo_num, cholesky_mo_transp(1,i,k), 1, cholesky_mo_transp(1,j,l), 1)
else
get_two_e_integral = sdot(cholesky_mo_num, cholesky_mo_transp_sp(1,i,k), 1, cholesky_mo_transp_sp(1,j,l), 1)
! get_two_e_integral = 0.d0
! do kk=1,cholesky_mo_num
! get_two_e_integral = get_two_e_integral + cholesky_mo_transp(kk,i,k)*cholesky_mo_transp(kk,i,l)
! do isplit=1,4
! get_two_e_integral = get_two_e_integral + &
! sdot(cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),i,k), 1, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),j,l), 1)
! enddo
endif
else
@ -214,7 +223,8 @@ subroutine get_mo_two_e_integrals(j,k,l,sze,out_val,map)
real(integral_kind) :: tmp
integer(key_kind) :: i1, idx
integer(key_kind) :: p,q,r,s,i2
PROVIDE mo_two_e_integrals_in_map mo_integrals_cache
real, allocatable :: out_val_sp(:)
PROVIDE mo_two_e_integrals_in_map mo_integrals_cache cholesky_mo_transp cholesky_mo_transp_sp
if (banned_excitation(j,l)) then
out_val(1:sze) = 0.d0
@ -225,6 +235,10 @@ subroutine get_mo_two_e_integrals(j,k,l,sze,out_val,map)
ii = ior(ii, k-mo_integrals_cache_min)
ii = ior(ii, j-mo_integrals_cache_min)
if (do_mo_cholesky.and. .not.mo_cholesky_double) then
allocate(out_val_sp(mo_num))
endif
if (iand(ii, -mo_integrals_cache_size) == 0) then
! Some integrals are in the cache
@ -232,11 +246,35 @@ subroutine get_mo_two_e_integrals(j,k,l,sze,out_val,map)
if (do_mo_cholesky) then
!TODO: here
!TODO: bottleneck here
if (mo_cholesky_double) then
call dgemv('T', cholesky_mo_num, mo_integrals_cache_min-1, 1.d0, &
cholesky_mo_transp(1,1,k), cholesky_mo_num, &
cholesky_mo_transp(1,j,l), 1, 0.d0, &
out_val, 1)
else
call sgemv('T', cholesky_mo_num, mo_integrals_cache_min-1, 1., &
cholesky_mo_transp_sp(1,1,k), cholesky_mo_num, &
cholesky_mo_transp_sp(1,j,l), 1, 0., &
out_val_sp, 1)
out_val(1:mo_integrals_cache_min-1) = out_val_sp(1:mo_integrals_cache_min-1)
! integer :: isplit
! isplit=1
! call sgemv('T', cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! mo_integrals_cache_min-1, 1., &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),1,k), cholesky_mo_num, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),j,l), 1, 0., &
! out_val_sp, 1)
! out_val(1:mo_integrals_cache_min-1) = out_val_sp(1:mo_integrals_cache_min-1)
! do isplit=2,4
! call sgemv('T', cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! mo_integrals_cache_min-1, 1., &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),1,k), cholesky_mo_num, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),j,l), 1, 0., &
! out_val_sp, 1)
! out_val(1:mo_integrals_cache_min-1) += out_val_sp(1:mo_integrals_cache_min-1)
! enddo
endif
else
@ -270,11 +308,34 @@ subroutine get_mo_two_e_integrals(j,k,l,sze,out_val,map)
if (do_mo_cholesky) then
!TODO: here
!TODO: bottleneck here
if (mo_cholesky_double) then
call dgemv('T', cholesky_mo_num, mo_num-mo_integrals_cache_max, 1.d0, &
cholesky_mo_transp(1,mo_integrals_cache_max+1,k), cholesky_mo_num, &
cholesky_mo_transp(1,j,l), 1, 0.d0, &
out_val(mo_integrals_cache_max+1), 1)
else
call sgemv('T', cholesky_mo_num, mo_num-mo_integrals_cache_max, 1., &
cholesky_mo_transp_sp(1,mo_integrals_cache_max+1,k), cholesky_mo_num, &
cholesky_mo_transp_sp(1,j,l), 1, 0., &
out_val_sp(mo_integrals_cache_max+1), 1)
out_val(mo_integrals_cache_max+1:sze) = out_val_sp(mo_integrals_cache_max+1:sze)
! isplit=1
! call sgemv('T', cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! mo_num-mo_integrals_cache_max, 1., &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),mo_integrals_cache_max+1,k), cholesky_mo_num, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),j,l), 1, 0., &
! out_val_sp(mo_integrals_cache_max+1), 1)
! out_val(mo_integrals_cache_max+1:sze) = out_val_sp(mo_integrals_cache_max+1:sze)
! do isplit=2,4
! call sgemv('T', cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! mo_num-mo_integrals_cache_max, 1., &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),mo_integrals_cache_max+1,k), cholesky_mo_num, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),j,l), 1, 0., &
! out_val_sp(mo_integrals_cache_max+1), 1)
! out_val(mo_integrals_cache_max+1:sze) += out_val_sp(mo_integrals_cache_max+1:sze)
! enddo
endif
else
@ -306,11 +367,34 @@ subroutine get_mo_two_e_integrals(j,k,l,sze,out_val,map)
if (do_mo_cholesky) then
!TODO: here
call dgemv('T', cholesky_mo_num, mo_num, 1.d0, &
!TODO: bottleneck here
if (mo_cholesky_double) then
call dgemv('T', cholesky_mo_num, sze, 1.d0, &
cholesky_mo_transp(1,1,k), cholesky_mo_num, &
cholesky_mo_transp(1,j,l), 1, 0.d0, &
out_val, 1)
else
call sgemv('T', cholesky_mo_num, sze, 1., &
cholesky_mo_transp_sp(1,1,k), cholesky_mo_num, &
cholesky_mo_transp_sp(1,j,l), 1, 0., &
out_val_sp, 1)
out_val(1:sze) = out_val_sp(1:sze)
! isplit=1
! call sgemv('T', cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! sze, 1., &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),1,k), cholesky_mo_num, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),j,l), 1, 0., &
! out_val_sp, 1)
! out_val(1:sze) = out_val_sp(1:sze)
! do isplit=2,4
! call sgemv('T', cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! sze, 1., &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),1,k), cholesky_mo_num, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),j,l), 1, 0., &
! out_val_sp, 1)
! out_val(1:sze) += out_val_sp(1:sze)
! enddo
endif
else
@ -383,16 +467,43 @@ subroutine get_mo_two_e_integrals_ij(k,l,sze,out_array,map)
double precision, intent(out) :: out_array(sze,sze)
type(map_type), intent(inout) :: map
integer :: j
real(integral_kind), allocatable :: tmp_val(:)
if ( (mo_integrals_cache_min>1).or.(mo_integrals_cache_max<mo_num) ) then
if (do_mo_cholesky) then
if (mo_cholesky_double) then
call dgemm('T', 'N', mo_num, mo_num, cholesky_mo_num, 1.d0, &
cholesky_mo_transp(1,1,k), cholesky_mo_num, &
cholesky_mo_transp(1,1,l), cholesky_mo_num, 0.d0, &
out_array, sze)
else
real, allocatable :: out_array_sp(:,:)
allocate(out_array_sp(sze,sze))
call sgemm('T', 'N', mo_num, mo_num, cholesky_mo_num, 1.0, &
cholesky_mo_transp_sp(1,1,k), cholesky_mo_num, &
cholesky_mo_transp_sp(1,1,l), cholesky_mo_num, 0.0, &
out_array_sp, sze)
out_array(1:sze,1:sze) = out_array_sp(1:sze,1:sze)
!
! isplit=1
! call sgemm('T', 'N', mo_num, mo_num, &
! cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), 1., &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),1,k), cholesky_mo_num, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),1,l), cholesky_mo_num, 0., &
! out_array_sp, sze)
! out_array(1:sze,1:sze) = out_array_sp(1:sze,1:sze)
! integer :: isplit
! do isplit=2,4
! call sgemm('T', 'N', mo_num, mo_num, &
! cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), 1., &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),1,k), cholesky_mo_num, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),1,l), cholesky_mo_num, 0., &
! out_array_sp, sze)
! out_array(1:sze,1:sze) = out_array(1:sze,1:sze) + out_array_sp(1:sze,1:sze)
! enddo
deallocate(out_array_sp)
endif
else
@ -513,7 +624,7 @@ subroutine get_mo_two_e_integrals_exch_ii(k,l,sze,out_val,map)
type(map_type), intent(inout) :: map
integer :: i
double precision, external :: get_two_e_integral
PROVIDE mo_two_e_integrals_in_map
PROVIDE mo_two_e_integrals_in_map mo_cholesky_double
if ( (mo_integrals_cache_min>1).or.(mo_integrals_cache_max<mo_num) ) then
@ -523,15 +634,14 @@ subroutine get_mo_two_e_integrals_exch_ii(k,l,sze,out_val,map)
(l>=mo_integrals_cache_min).and.(l<=mo_integrals_cache_max) ) then
double precision, external :: ddot
real, external :: sdot
integer :: kk
if (mo_cholesky_double) then
do i=1,mo_integrals_cache_min-1
out_val(i) = ddot(cholesky_mo_num, cholesky_mo_transp(1,i,k), 1, &
cholesky_mo_transp(1,i,l), 1)
! out_val(i) = 0.d0
! do kk=1,cholesky_mo_num
! out_val(i) = out_val(i) + cholesky_mo_transp(kk,i,k)*cholesky_mo_transp(kk,i,l)
! enddo
enddo
do i=mo_integrals_cache_min,mo_integrals_cache_max
@ -541,22 +651,55 @@ subroutine get_mo_two_e_integrals_exch_ii(k,l,sze,out_val,map)
do i=mo_integrals_cache_max, sze
out_val(i) = ddot(cholesky_mo_num, cholesky_mo_transp(1,i,k), 1, &
cholesky_mo_transp(1,i,l), 1)
! out_val(i) = 0.d0
! do kk=1,cholesky_mo_num
! out_val(i) = out_val(i) + cholesky_mo_transp(kk,i,k)*cholesky_mo_transp(kk,i,l)
! enddo
enddo
else
integer :: isplit
do i=1,mo_integrals_cache_min-1
out_val(i) = sdot(cholesky_mo_num, cholesky_mo_transp_sp(1,i,k), 1, cholesky_mo_transp_sp(1,i,l), 1)
! out_val(i) = 0.d0
! do isplit=1,4
! out_val(i) += sdot(cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),i,k), 1, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),i,l), 1)
! enddo
enddo
do i=mo_integrals_cache_min,mo_integrals_cache_max
out_val(i) = get_two_e_integral_cache(i,i,k,l)
enddo
do i=mo_integrals_cache_max, sze
out_val(i) = sdot(cholesky_mo_num, cholesky_mo_transp_sp(1,i,k), 1, cholesky_mo_transp_sp(1,i,l), 1)
! out_val(i) = 0.d0
! do isplit=1,4
! out_val(i) += sdot(cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),i,k), 1, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),i,l), 1)
! enddo
enddo
endif
else
if (mo_cholesky_double) then
do i=1,sze
out_val(i) = ddot(cholesky_mo_num, cholesky_mo_transp(1,i,k), 1, &
cholesky_mo_transp(1,i,l), 1)
enddo
else
do i=1,sze
out_val(i) = sdot(cholesky_mo_num, cholesky_mo_transp_sp(1,i,k), 1, cholesky_mo_transp_sp(1,i,l), 1)
! out_val(i) = 0.d0
! do kk=1,cholesky_mo_num
! out_val(i) = out_val(i) + cholesky_mo_transp(kk,i,k)*cholesky_mo_transp(kk,i,l)
! do isplit=1,4
! out_val(i) += sdot(cholesky_mo_num_split(isplit+1) - cholesky_mo_num_split(isplit), &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),i,k), 1, &
! cholesky_mo_transp_sp(cholesky_mo_num_split(isplit),i,l), 1)
! enddo
enddo
endif
endif

2
src/mp2/mp2.irp.f
View File

@ -7,7 +7,7 @@ subroutine run
double precision, allocatable :: pt2(:), norm_pert(:)
double precision :: H_pert_diag, E_old
integer :: N_st, iter
PROVIDE Fock_matrix_diag_mo H_apply_buffer_allocated
PROVIDE all_mo_integrals Fock_matrix_diag_mo H_apply_buffer_allocated
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st))
E_old = HF_energy

24
src/mrci/EZFIO.cfg Normal file
View File

@ -0,0 +1,24 @@
[energy]
type: double precision
doc: Calculated Selected CASSD energy
interface: ezfio
size: (determinants.n_states)
[energy_pt2]
type: double precision
doc: Calculated CASSD energy + PT2
interface: ezfio
size: (determinants.n_states)
[do_ddci]
type: logical
doc: If true, remove purely inactive double excitations
interface: ezfio,provider,ocaml
default: False
[do_only_1h1p]
type: logical
doc: If true, do only one hole/one particle excitations
interface: ezfio,provider,ocaml
default: False

4
src/mrci/NEED Normal file
View File

@ -0,0 +1,4 @@
cipsi
generators_cas
selectors_full
davidson_undressed

17
src/mrci/README.rst Normal file
View File

@ -0,0 +1,17 @@
====
mrci
====
|CIPSI| algorithm in the multi-reference CI space (CAS + Singles and Doubles).
This module is the same as the :ref:`fci` module, except for the choice of the
generator and selector determinants.
The inactive, active and virtual |MOs| will need to be set with the
:ref:`qp_set_mo_class` program.
.. seealso::
The documentation of the :ref:`fci` module.

8
src/mrci/class.irp.f Normal file
View File

@ -0,0 +1,8 @@
BEGIN_PROVIDER [ logical, do_only_cas ]
implicit none
BEGIN_DOC
! In the CAS+SD case, always false
END_DOC
do_only_cas = .False.
END_PROVIDER

64
src/mrci/mrci.irp.f Normal file
View File

@ -0,0 +1,64 @@
program mrci
implicit none
BEGIN_DOC
! Selected CAS+Singles and Doubles with stochastic selection
! and PT2.
!
! This program performs a |CIPSI|-like selected |CI| using a
! stochastic scheme for both the selection of the important Slater
! determinants and the computation of the |PT2| correction. This
! |CIPSI|-like algorithm will be performed for the lowest states of
! the variational space (see :option:`determinants n_states`). The
! program will stop when reaching at least one the two following
! conditions:
!
! * number of Slater determinants > :option:`determinants n_det_max`
! * |PT2| < :option:`perturbation pt2_max`
!
! The following other options can be of interest:
!
! :option:`determinants read_wf`
! When set to |false|, the program starts with a ROHF-like Slater
! determinant as a guess wave function. When set to |true|, the
! program starts with the wave function(s) stored in the |EZFIO|
! directory as guess wave function(s).
!
! :option:`determinants s2_eig`
! When set to |true|, the selection will systematically add all the
! necessary Slater determinants in order to have a pure spin wave
! function with an |S^2| value corresponding to
! :option:`determinants expected_s2`.
!
! For excited states calculations, it is recommended to start with
! :ref:`.cis.` or :ref:`.cisd.` guess wave functions, eventually in
! a restricted set of |MOs|, and to set :option:`determinants s2_eig`
! to |true|.
!
END_DOC
PROVIDE all_mo_integrals
if (.not.is_zmq_slave) then
PROVIDE psi_det psi_coef
write(json_unit,json_array_open_fmt) 'fci'
double precision, allocatable :: Ev(:),PT2(:)
allocate(Ev(N_states), PT2(N_states))
if (do_pt2) then
call run_stochastic_cipsi(Ev,PT2)
else
call run_cipsi
endif
write(json_unit,json_dict_uopen_fmt)
write(json_unit,json_dict_close_fmtx)
write(json_unit,json_array_close_fmtx)
call json_close
else
PROVIDE pt2_min_parallel_tasks
call run_slave_cipsi
endif
end

10
src/mrci/save_energy.irp.f Normal file
View File

@ -0,0 +1,10 @@
subroutine save_energy(E,pt2)
implicit none
BEGIN_DOC
! Saves the energy in |EZFIO|.
END_DOC
double precision, intent(in) :: E(N_states), pt2(N_states)
call ezfio_set_mrci_energy(E(1:N_states))
call ezfio_set_mrci_energy_pt2(E(1:N_states)+pt2(1:N_states))
end

107
src/mu_of_r/mu_of_r_conditions.irp.f
View File

@ -22,15 +22,26 @@
endif
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
if(mu_of_r_potential.EQ."hf")then
do ipoint = 1, n_points_final_grid
mu_of_r_prov(ipoint,istate) = mu_of_r_hf(ipoint)
enddo
else if(mu_of_r_potential.EQ."hf_old")then
do ipoint = 1, n_points_final_grid
mu_of_r_prov(ipoint,istate) = mu_of_r_hf_old(ipoint)
enddo
else if(mu_of_r_potential.EQ."hf_sparse")then
do ipoint = 1, n_points_final_grid
mu_of_r_prov(ipoint,istate) = mu_of_r_hf_sparse(ipoint)
enddo
else if(mu_of_r_potential.EQ."cas_full".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then
do ipoint = 1, n_points_final_grid
mu_of_r_prov(ipoint,istate) = mu_of_r_psi_cas(ipoint,istate)
enddo
else if(mu_of_r_potential.EQ."proj")then
do ipoint = 1, n_points_final_grid
mu_of_r_prov(ipoint,istate) = mu_of_r_projector_mo(ipoint)
enddo
else
print*,'you requested the following mu_of_r_potential'
print*,mu_of_r_potential
@ -38,7 +49,6 @@
stop
endif
enddo
enddo
if (write_mu_of_r) then
print*,'Writing mu(r) on disk ...'
@ -201,7 +211,7 @@
END_PROVIDER
BEGIN_PROVIDER [double precision, mu_average_prov, (N_states)]
BEGIN_PROVIDER [double precision, mu_average_prov, (N_states)]
implicit none
BEGIN_DOC
! average value of mu(r) weighted with the total one-e density and divided by the number of electrons
@ -223,5 +233,94 @@
enddo
mu_average_prov(istate) = mu_average_prov(istate) / elec_num_grid_becke(istate)
enddo
END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, mu_average_prov2, (N_states)]
implicit none
BEGIN_DOC
! average value of mu(r) weighted with square of the total one-e density
!
! !!!!!! WARNING !!!!!! if no_core_density == .True. then all contributions from the core orbitals
!
! in the one- and two-body density matrix are excluded
END_DOC
integer :: ipoint,istate
double precision :: weight,density,norm
mu_average_prov2 = 0.d0
do istate = 1, N_states
norm = 0.d0
do ipoint = 1, n_points_final_grid
weight =final_weight_at_r_vector(ipoint)
density = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate) &
+ one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
if(mu_of_r_prov(ipoint,istate).gt.1.d+09)cycle
mu_average_prov2(istate) += mu_of_r_prov(ipoint,istate) * weight * density*density
norm = norm + density*density*weight
enddo
mu_average_prov2(istate) = mu_average_prov2(istate) / norm
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, mu_of_r_projector_mo, (n_points_final_grid) ]
implicit none
BEGIN_DOC
! mu(r) computed with the projector onto the atomic basis
! P_B(\mathbf{r},\mathbf{r}') = \sum_{ij} |
! \chi_{i} \rangle \left[S^{-1}\right]_{ij} \langle \chi_{j} |
! \] where $i$ and $j$ denote all atomic orbitals.
END_DOC
double precision, parameter :: factor = dsqrt(2.d0*dacos(-1.d0))
double precision, allocatable :: tmp(:,:)
integer :: ipoint
do ipoint=1,n_points_final_grid
mu_of_r_projector_mo(ipoint) = 0.d0
integer :: i,j
do j=1,n_inact_act_orb
i = list_inact_act(j)
mu_of_r_projector_mo(ipoint) = mu_of_r_projector_mo(ipoint) + &
mos_in_r_array_omp(i,ipoint) * mos_in_r_array_omp(i,ipoint)
enddo
do j=1,n_virt_orb
i = list_virt(j)
mu_of_r_projector_mo(ipoint) = mu_of_r_projector_mo(ipoint) + &
mos_in_r_array_omp(i,ipoint) * mos_in_r_array_omp(i,ipoint)
enddo
enddo
do ipoint=1,n_points_final_grid
! epsilon
mu_of_r_projector_mo(ipoint) = 1.d0/(2.d0*dacos(-1.d0) * mu_of_r_projector_mo(ipoint)**(2.d0/3.d0))
! mu
mu_of_r_projector_mo(ipoint) = 1.d0/dsqrt( 2.d0*mu_of_r_projector_mo(ipoint) )
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, mu_average_proj, (N_states)]
implicit none
BEGIN_DOC
! average value of mu(r) weighted with the total one-e density and divided by the number of electrons
!
! !!!!!! WARNING !!!!!! if no_core_density == .True. then all contributions from the core orbitals
!
! in the one- and two-body density matrix are excluded
END_DOC
integer :: ipoint,istate
double precision :: weight,density
do istate = 1, N_states
mu_average_proj(istate) = 0.d0
do ipoint = 1, n_points_final_grid
weight =final_weight_at_r_vector(ipoint)
density = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate) &
+ one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
mu_average_proj(istate) += mu_of_r_projector_mo(ipoint) * weight * density
enddo
mu_average_proj(istate) = mu_average_proj(istate) / elec_num_grid_becke(istate)
enddo
END_PROVIDER

5
src/scf_utils/roothaan_hall_scf.irp.f
View File

@ -70,7 +70,7 @@ END_DOC
dim_DIIS = min(dim_DIIS+1,max_dim_DIIS)
if ( (scf_algorithm == 'DIIS').and.(dabs(Delta_energy_SCF) > 1.d-6) ) then
if ( (scf_algorithm == 'DIIS').and.(dabs(Delta_energy_SCF) > 1.d-10) ) then
! Store Fock and error matrices at each iteration
do j=1,ao_num
@ -228,9 +228,10 @@ END_DOC
do while (i<mo_num)
j=i+1
m=1
do while ( (j<=mo_num).and.(fock_matrix_diag_mo(j)-fock_matrix_diag_mo(i) < 1.d-5) )
do while ( (fock_matrix_diag_mo(j)-fock_matrix_diag_mo(i) < 1.d-5) )
j += 1
m += 1
if (j > mo_num) exit
enddo
if (m>1) then
call dgemm('N','T',ao_num,ao_num,m,1.d0,mo_coef(1,i),size(mo_coef,1),mo_coef(1,i),size(mo_coef,1),0.d0,S,size(S,1))

1
src/tools/print_energy.irp.f
View File

@ -15,7 +15,6 @@ end
subroutine run
implicit none
call print_mol_properties
print *, psi_energy + nuclear_repulsion
call print_energy_components
! print *, 'E(HF) = ', HF_energy
print *, 'E(CI) = ', psi_energy + nuclear_repulsion

7
src/trexio/EZFIO.cfg
View File

@ -22,6 +22,13 @@ doc: If True, export MO coefficients
interface: ezfio, ocaml, provider
default: True
[export_cartesian]
type: logical
doc: If False, export everything in the spherical AO basis
interface: ezfio, ocaml, provider
default: True
[export_ao_one_e_ints]
type: logical
doc: If True, export one-electron integrals in AO basis

72
src/trexio/export_trexio_routines.irp.f
View File

@ -15,6 +15,8 @@ subroutine export_trexio(update,full_path)
integer, external :: getunitandopen
integer :: i,j,l
if (full_path) then
fp = trexio_filename
call system('realpath '//trim(fp)//' > '//trim(fp)//'.tmp')
@ -75,6 +77,7 @@ subroutine export_trexio(update,full_path)
rc = trexio_read_metadata_code_num(f(k), code_num)
if (rc == TREXIO_ATTR_MISSING) then
i = 1
code_num = 0
code(:) = ""
else
rc = trexio_read_metadata_code(f(k), code, 64)
@ -95,6 +98,7 @@ subroutine export_trexio(update,full_path)
rc = trexio_read_metadata_author_num(f(k), author_num)
if (rc == TREXIO_ATTR_MISSING) then
i = 1
author_num = 0
author(:) = ""
else
rc = trexio_read_metadata_author(f(k), author, 64)
@ -271,7 +275,7 @@ subroutine export_trexio(update,full_path)
call trexio_assert(rc, TREXIO_SUCCESS)
allocate(factor(shell_num))
factor(1:shell_num) = shell_normalization_factor(1:shell_num)
factor(1:shell_num) = 1.d0
rc = trexio_write_basis_shell_factor(f(1), factor)
call trexio_assert(rc, TREXIO_SUCCESS)
@ -303,22 +307,19 @@ subroutine export_trexio(update,full_path)
print *, 'AOs'
rc = trexio_write_ao_num(f(1), ao_num)
if (export_cartesian) then
rc = trexio_write_ao_cartesian(f(1), 1)
call trexio_assert(rc, TREXIO_SUCCESS)
rc = trexio_write_ao_cartesian(f(1), 1)
rc = trexio_write_ao_num(f(1), ao_num)
call trexio_assert(rc, TREXIO_SUCCESS)
rc = trexio_write_ao_shell(f(1), ao_shell)
call trexio_assert(rc, TREXIO_SUCCESS)
integer :: i, pow0(3), powA(3), j, l, nz
double precision :: normA, norm0, C_A(3), overlap_x, overlap_z, overlap_y, c
nz=100
C_A(1) = 0.d0
C_A(2) = 0.d0
C_A(3) = 0.d0
if (ezfio_convention >= 20250211) then
rc = trexio_write_ao_normalization(f(1), ao_coef_normalization_factor)
else
allocate(factor(ao_num))
do i=1,ao_num
@ -326,8 +327,26 @@ subroutine export_trexio(update,full_path)
factor(i) = (ao_coef_normalized(i,1)+tiny(1.d0))/(ao_coef_normalized(l,1)+tiny(1.d0))
enddo
rc = trexio_write_ao_normalization(f(1), factor)
call trexio_assert(rc, TREXIO_SUCCESS)
deallocate(factor)
endif
call trexio_assert(rc, TREXIO_SUCCESS)
else
rc = trexio_write_ao_cartesian(f(1), 0)
call trexio_assert(rc, TREXIO_SUCCESS)
rc = trexio_write_ao_num(f(1), ao_sphe_num)
call trexio_assert(rc, TREXIO_SUCCESS)
rc = trexio_write_ao_shell(f(1), ao_sphe_shell)
call trexio_assert(rc, TREXIO_SUCCESS)
rc = trexio_write_ao_normalization(f(1), ao_sphe_coef_normalization_factor)
call trexio_assert(rc, TREXIO_SUCCESS)
endif
endif
@ -335,7 +354,10 @@ subroutine export_trexio(update,full_path)
! ------------------
if (export_ao_one_e_ints) then
print *, 'AO one-e integrals'
double precision, allocatable :: tmp_ao(:,:)
if (export_cartesian) then
print *, 'AO one-e integrals (cartesian)'
rc = trexio_write_ao_1e_int_overlap(f(1),ao_overlap)
call trexio_assert(rc, TREXIO_SUCCESS)
@ -347,11 +369,30 @@ subroutine export_trexio(update,full_path)
call trexio_assert(rc, TREXIO_SUCCESS)
if (do_pseudo) then
rc = trexio_write_ao_1e_int_ecp(f(1), ao_pseudo_integrals_local + ao_pseudo_integrals_non_local)
rc = trexio_write_ao_1e_int_ecp(f(1), ao_pseudo_integrals)
call trexio_assert(rc, TREXIO_SUCCESS)
endif
rc = trexio_write_ao_1e_int_core_hamiltonian(f(1),ao_one_e_integrals)
else
print *, 'AO one-e integrals (spherical)'
rc = trexio_write_ao_1e_int_overlap(f(1),ao_sphe_overlap)
call trexio_assert(rc, TREXIO_SUCCESS)
rc = trexio_write_ao_1e_int_kinetic(f(1),ao_sphe_kinetic_integrals)
call trexio_assert(rc, TREXIO_SUCCESS)
rc = trexio_write_ao_1e_int_potential_n_e(f(1),ao_sphe_integrals_n_e)
call trexio_assert(rc, TREXIO_SUCCESS)
if (do_pseudo) then
rc = trexio_write_ao_1e_int_ecp(f(1), ao_sphe_pseudo_integrals)
call trexio_assert(rc, TREXIO_SUCCESS)
endif
rc = trexio_write_ao_1e_int_core_hamiltonian(f(1),ao_sphe_one_e_integrals)
endif
call trexio_assert(rc, TREXIO_SUCCESS)
end if
@ -459,8 +500,13 @@ subroutine export_trexio(update,full_path)
call trexio_assert(rc, TREXIO_SUCCESS)
enddo
if (export_cartesian) then
rc = trexio_write_mo_coefficient(f(1), mo_coef)
call trexio_assert(rc, TREXIO_SUCCESS)
else
rc = trexio_write_mo_coefficient(f(1), mo_sphe_coef)
call trexio_assert(rc, TREXIO_SUCCESS)
endif
if ( (trim(mo_label) == 'Canonical').and. &
(export_mo_two_e_ints_cholesky.or.export_mo_two_e_ints) ) then

1
src/two_body_rdm/act_2_rdm.irp.f
View File

@ -145,6 +145,7 @@
print*,''
print*,'Providing act_2_rdm_spin_trace_mo '
character*(128) :: name_file
PROVIDE all_mo_integrals
name_file = 'act_2_rdm_spin_trace_mo'
ispin = 4
act_2_rdm_spin_trace_mo = 0.d0

164
src/two_rdm_routines/davidson_like_2rdm.irp.f
View File

@ -13,7 +13,7 @@ subroutine orb_range_2_rdm_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st,sz
END_DOC
integer, intent(in) :: N_st,sze
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
double precision, intent(in) :: u_0(sze,N_st)
integer :: k
@ -50,7 +50,7 @@ subroutine orb_range_2_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
double precision, intent(in) :: u_t(N_st,N_det)
integer :: k
@ -91,7 +91,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
double precision, intent(in) :: u_t(N_st,N_det)
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(omp_lock_kind) :: lock_2rdm
integer :: i,j,k,l
@ -139,6 +139,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
sze_buff = 6 * norb + elec_alpha_num * elec_alpha_num * 60
sze_buff = sze_buff*100
list_orb_reverse = -1000
do i = 1, norb
list_orb_reverse(list_orb(i)) = i
@ -154,6 +155,8 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
! Prepare the array of all alpha single excitations
! -------------------------------------------------
double precision, allocatable :: big_array_local(:,:,:,:,:)
PROVIDE N_int nthreads_davidson elec_alpha_num
!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
!$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2rdm,&
@ -173,7 +176,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
!$OMP buffer, doubles, n_doubles, &
!$OMP tmp_det2, idx, l, kcol_prev, &
!$OMP singles_a, n_singles_a, singles_b, &
!$OMP n_singles_b, nkeys, keys, values)
!$OMP n_singles_b, nkeys, keys, values, big_array_local)
! Alpha/Beta double excitations
! =============================
@ -184,6 +187,8 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
singles_b(maxab), &
doubles(maxab), &
idx(maxab))
allocate( big_array_local(N_states,dim1, dim1, dim1, dim1) )
big_array_local(:,:,:,:,:) = 0.d0
kcol_prev=-1
@ -191,8 +196,9 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
ASSERT (istart > 0)
ASSERT (istep > 0)
!$OMP DO SCHEDULE(dynamic,64)
!$OMP DO SCHEDULE(dynamic)
do k_a=istart+ishift,iend,istep
!print *, 'aa', k_a, '/', iend
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
@ -254,33 +260,36 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
do l= 1, N_states
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
if(alpha_beta)then
! only ONE contribution
if (nkeys+1 .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
else if (spin_trace)then
! TWO contributions
! if(alpha_beta)then
! ! only ONE contribution
! if (nkeys+1 .ge. sze_buff) then
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! nkeys = 0
! endif
! else if (spin_trace)then
! ! TWO contributions
if (nkeys+2 .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
endif
endif
! endif
call orb_range_off_diag_double_to_all_states_ab_dm_buffer(tmp_det,tmp_det2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
enddo
endif
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
enddo
enddo
!$OMP END DO NOWAIT
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
enddo
enddo
!$OMP END DO
!$OMP DO SCHEDULE(dynamic,64)
!$OMP DO SCHEDULE(dynamic)
do k_a=istart+ishift,iend,istep
!print *, 'ab', k_a, '/', iend
! Single and double alpha exitations
@ -331,6 +340,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
! ----------------------------------
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
do i=1,n_singles_a
l_a = singles_a(i)
ASSERT (l_a <= N_det)
@ -342,25 +352,27 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
do l= 1, N_states
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
! increment the alpha/beta part for single excitations
if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
endif
call orb_range_off_diag_single_to_all_states_ab_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! increment the alpha/alpha part for single excitations
if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
endif
call orb_range_off_diag_single_to_all_states_aa_dm_buffer(tmp_det,tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
endif
enddo
endif
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! nkeys = 0
! Compute Hij for all alpha doubles
! ----------------------------------
@ -377,14 +389,15 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
if (nkeys+4 .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
endif
call orb_range_off_diag_double_to_all_states_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
enddo
endif
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! nkeys = 0
! Single and double beta excitations
@ -432,6 +445,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
! ----------------------------------
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
if(alpha_beta.or.spin_trace.or.beta_beta)then
do i=1,n_singles_b
l_b = singles_b(i)
ASSERT (l_b <= N_det)
@ -444,23 +458,26 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
do l= 1, N_states
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
if(alpha_beta.or.spin_trace.or.beta_beta)then
! increment the alpha/beta part for single excitations
if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
endif
call orb_range_off_diag_single_to_all_states_ab_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! increment the beta /beta part for single excitations
if (nkeys+4 * elec_alpha_num .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
endif
call orb_range_off_diag_single_to_all_states_bb_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
endif
enddo
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! nkeys = 0
! Compute Hij for all beta doubles
! ----------------------------------
@ -478,7 +495,8 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
if (nkeys+4 .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
endif
call orb_range_off_diag_double_to_all_states_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
@ -487,8 +505,8 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
enddo
endif
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! nkeys = 0
! Diagonal contribution
@ -514,15 +532,27 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
c_1(l) = u_t(l,k_a) * u_t(l,k_a)
enddo
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
if (nkeys+elec_alpha_num*elec_alpha_num .ge. sze_buff) then
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
endif
call orb_range_diag_to_all_states_2_rdm_dm_buffer(tmp_det,c_1,N_states,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
! call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
call update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
nkeys = 0
end do
!$OMP END DO
!$OMP END DO NOWAIT
deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values)
!$OMP CRITICAL
do i=1,N_states
big_array(:,:,:,:,i) = big_array(:,:,:,:,i) + big_array_local(i,:,:,:,:)
enddo
!$OMP END CRITICAL
deallocate(big_array_local)
!$OMP END PARALLEL
end
@ -550,22 +580,66 @@ subroutine update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,loc
integer :: istate
integer :: i,h1,h2,p1,p2
integer, allocatable :: iorder(:)
integer*8, allocatable :: to_sort(:)
allocate(iorder(nkeys))
do i=1,nkeys
iorder(i) = i
enddo
! If the lock is already taken, sort the keys while waiting for a faster access
if (.not.omp_test_lock(lock_2rdm)) then
allocate(to_sort(nkeys))
do i=1,nkeys
h1 = keys(1,iorder(i))
h2 = keys(2,iorder(i))-1
p1 = keys(3,iorder(i))-1
p2 = keys(4,iorder(i))-1
to_sort(i) = int(h1,8) + int(dim1,8)*(int(h2,8) + int(dim1,8)*(int(p1,8) + int(dim1,8)*int(p2,8)))
enddo
call i8sort(to_sort, iorder, nkeys)
deallocate(to_sort)
call omp_set_lock(lock_2rdm)
endif
! print*,'*************'
! print*,'updating'
! print*,'nkeys',nkeys
do istate = 1, N_st
do i = 1, nkeys
h1 = keys(1,iorder(i))
h2 = keys(2,iorder(i))
p1 = keys(3,iorder(i))
p2 = keys(4,iorder(i))
big_array(h1,h2,p1,p2,istate) = big_array(h1,h2,p1,p2,istate) + values(istate,iorder(i))
enddo
enddo
call omp_unset_lock(lock_2rdm)
deallocate(iorder)
end
subroutine update_keys_values_n_states_local(keys,values,nkeys,dim1,n_st,big_array_local)
use omp_lib
implicit none
integer, intent(in) :: n_st,nkeys,dim1
integer, intent(in) :: keys(4,nkeys)
double precision, intent(in) :: values(n_st,nkeys)
double precision, intent(inout) :: big_array_local(n_st,dim1,dim1,dim1,dim1)
integer :: istate
integer :: i,h1,h2,p1,p2
do i = 1, nkeys
h1 = keys(1,i)
h2 = keys(2,i)
p1 = keys(3,i)
p2 = keys(4,i)
do istate = 1, N_st
! print*,h1,h2,p1,p2,values(istate,i)
big_array(h1,h2,p1,p2,istate) += values(istate,i)
big_array_local(istate,h1,h2,p1,p2) = big_array_local(istate,h1,h2,p1,p2) + values(istate,i)
enddo
enddo
call omp_unset_lock(lock_2rdm)
end

653
src/two_rdm_routines/update_rdm.irp.f
View File

@ -1,4 +1,15 @@
subroutine orb_range_diag_to_all_states_2_rdm_dm_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
logical function is_integer_in_string_local(orb,bitmask,Nint)
use bitmasks
implicit none
integer, intent(in) :: orb, Nint
integer(bit_kind), intent(in) :: bitmask(Nint)
integer :: j, k
k = ishft(orb-1,-bit_kind_shift)+1
j = orb-ishft(k-1,bit_kind_shift)-1
is_integer_in_string_local = iand(bitmask(k), ibset(0_bit_kind, j)) /= 0_bit_kind
end
subroutine orb_range_diag_to_all_states_2_rdm_dm_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
@ -22,7 +33,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
@ -47,15 +58,16 @@
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
logical :: is_integer_in_string
logical :: is_integer_in_string_local
integer :: i1,i2,istate
if(alpha_beta)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
! If alpha/beta, electron 1 is alpha, electron 2 is beta
! Therefore you don't necessayr have symmetry between electron 1 and 2
@ -80,11 +92,12 @@
enddo
else if (alpha_alpha)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -104,12 +117,14 @@
keys(4,nkeys) = h1
enddo
enddo
else if (beta_beta)then
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -129,13 +144,15 @@
keys(4,nkeys) = h1
enddo
enddo
else if(spin_trace)then
! 0.5 * (alpha beta + beta alpha)
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -154,12 +171,8 @@
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -181,9 +194,9 @@
enddo
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -204,28 +217,28 @@
enddo
enddo
endif
end
end
subroutine orb_range_off_diag_double_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
!
! c_1 is the array of the contributions to the rdm for all states
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
! routine that updates the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
!
! c_1 is the array of the contributions to the rdm for all states
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
@ -234,26 +247,29 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
logical :: is_integer_in_string_local
if (ispin <= 2) return
! alpha_alpha = .False.
! beta_beta = .False.
! alpha_beta = .False.
! spin_trace = .False.
! if( ispin == 1)then
! alpha_alpha = .True.
! else if(ispin == 2)then
! beta_beta = .True.
! else if(ispin == 3)then
! alpha_beta = .True.
! else if(ispin == 4)then
! spin_trace = .True.
! endif
call get_double_excitation(det_1,det_2,exc,phase,N_int)
h1 = exc(1,1,1)
if(list_orb_reverse(h1).lt.0)return
h1 = list_orb_reverse(h1)
@ -266,10 +282,11 @@
p2 = exc(1,2,2)
if(list_orb_reverse(p2).lt.0)return
p2 = list_orb_reverse(p2)
if(alpha_beta)then
! if(alpha_beta)then
nkeys += 1
phase = phase * 0.5d0
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -277,36 +294,36 @@
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
else if(spin_trace)then
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
endif
end
! else if(spin_trace)then
! nkeys += 1
! do istate = 1, N_st
! values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
! enddo
! keys(1,nkeys) = h1
! keys(2,nkeys) = h2
! keys(3,nkeys) = p1
! keys(4,nkeys) = p2
! nkeys += 1
! do istate = 1, N_st
! values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
! enddo
! keys(1,nkeys) = h2
! keys(2,nkeys) = h1
! keys(3,nkeys) = p2
! keys(4,nkeys) = p1
! endif
end
subroutine orb_range_off_diag_single_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_single_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
! routine that updates the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
!
@ -333,7 +350,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
@ -342,16 +359,12 @@
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
logical :: is_integer_in_string_local
if (ispin <= 2) return
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
@ -360,129 +373,145 @@
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_beta)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
else if(spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
endif
end
subroutine orb_range_off_diag_single_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,1)
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0 * phase
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,2)
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0 * phase
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
else if(spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,1)
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0 * phase
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,2)
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0 * phase
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
endif
end
subroutine orb_range_off_diag_single_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
@ -512,7 +541,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
@ -521,40 +550,42 @@
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
logical :: is_integer_in_string_local
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
! beta_beta = .False.
! alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
return
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! if(alpha_alpha.or.spin_trace)then
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_alpha.or.spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0*phase
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -563,7 +594,16 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -572,29 +612,20 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = h2
enddo
else
return
endif
endif
end
! endif
end
subroutine orb_range_off_diag_single_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_single_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -624,7 +655,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
@ -632,42 +663,43 @@
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
logical :: is_integer_in_string_local
! alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
! alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
return
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! if(beta_beta.or.spin_trace)then
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(beta_beta.or.spin_trace)then
if (exc(0,1,1) == 1) then
return
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0*phase
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -676,7 +708,16 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -685,28 +726,19 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = h2
enddo
endif
endif
end
! endif
end
subroutine orb_range_off_diag_double_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -735,7 +767,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: i,j,h1,h2,p1,p2,istate
@ -743,38 +775,39 @@
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
logical :: is_integer_in_string_local
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
! beta_beta = .False.
! alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
return
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
if(list_orb_reverse(h1).lt.0)return
h1 = list_orb_reverse(h1)
h2 =exc(2,1)
if(list_orb_reverse(h2).lt.0)return
h2 = list_orb_reverse(h2)
p1 =exc(1,2)
if(list_orb_reverse(p1).lt.0)return
p1 = list_orb_reverse(p1)
p2 =exc(2,2)
if(list_orb_reverse(p2).lt.0)return
h1 = list_orb_reverse(h1)
h2 = list_orb_reverse(h2)
p1 = list_orb_reverse(p1)
p2 = list_orb_reverse(p2)
if(alpha_alpha.or.spin_trace)then
phase = 0.5d0*phase
! if(alpha_alpha.or.spin_trace)then
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -783,7 +816,16 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -792,25 +834,16 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
! endif
end
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end
subroutine orb_range_off_diag_double_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -840,25 +873,23 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
logical :: is_integer_in_string_local
! alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
! alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
return
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
@ -874,10 +905,12 @@
p2 =exc(2,2)
if(list_orb_reverse(p2).lt.0)return
p2 = list_orb_reverse(p2)
if(beta_beta.or.spin_trace)then
! if(beta_beta.or.spin_trace)then
phase = 0.5d0*phase
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -886,7 +919,16 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -895,21 +937,12 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end
! endif
end

23
src/utils/bug.irp.f Normal file
View File

@ -0,0 +1,23 @@
subroutine qp_bug(from, code, message)
implicit none
BEGIN_DOC
! This routine prints a bug report
END_DOC
character*(*) :: from
integer :: code
character*(*) :: message
print *, ''
print *, '======================='
print *, 'Bug in Quantum Package!'
print *, '======================='
print *, ''
print *, ' from: ', trim(from)
print *, ' code: ', code
print *, ' info: ', trim(message)
print *, ''
print *, 'Please report this bug at https://github.com/QuantumPackage/qp2/issues'
print *, 'with your output file attached.'
print *, ''
stop -1
end subroutine qp_bug

9
src/utils/linear_algebra.irp.f
View File

@ -1392,15 +1392,6 @@ subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
call dgemm('T', 'T', n, m, n_svd, 1.d0, Vt, size(Vt,1), U, size(U,1), 0.d0, C, size(C,1))
! C = 0.d0
! do i=1,m
! do j=1,n
! do k=1,n_svd
! C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
! enddo
! enddo
! enddo
deallocate(U,D,Vt,work,A_tmp)
end

2
src/utils/map_module.f90
View File

@ -157,7 +157,7 @@ subroutine cache_map_reallocate(map,sze)
stop 2
endif
if (associated(map%value)) then
do i=1_8,min(size(map%key),map%n_elements)
do i=1_8,min(size(map%value),map%n_elements)
value_new(i) = map%value(i)
enddo
deallocate(map%value)

885
src/utils_cc/mo_integrals_cc.irp.f
View File

File diff suppressed because it is too large Load Diff