mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-08-24 21:21:47 +02:00
commit
a6824a4fe8
2
Makefile
2
Makefile
@ -2,4 +2,4 @@ default: build.ninja
|
||||
bash -c "source quantum_package.rc ; ninja"
|
||||
|
||||
build.ninja:
|
||||
@bash -c ' echo '' ; echo xxxxxxxxxxxxxxxxxx ; echo "The QP is not configured yet. Please run the ./configure command" ; echo xxxxxxxxxxxxxxxxxx ; echo '' ; ./configure --help' | more
|
||||
@bash -c ' echo '' ; echo xxxxxxxxxxxxxxxxxx ; echo "QP is not configured yet. Please run the ./configure command" ; echo xxxxxxxxxxxxxxxxxx ; echo '' ; ./configure --help' | more
|
||||
|
@ -227,8 +227,8 @@ def write_ezfio(res, filename):
|
||||
shell_index += [nshell_tot] * len(b.prim)
|
||||
|
||||
shell_num = len(ang_mom)
|
||||
assert(shell_index[0] = 1)
|
||||
assert(shell_index[-1] = shell_num)
|
||||
assert(shell_index[0] == 1)
|
||||
assert(shell_index[-1] == shell_num)
|
||||
|
||||
# ~#~#~#~#~ #
|
||||
# W r i t e #
|
||||
|
@ -97,7 +97,7 @@ end
|
||||
|
||||
def get_repositories():
|
||||
l_result = [f for f in os.listdir(QP_PLUGINS) \
|
||||
if f not in [".gitignore", "local"] ]
|
||||
if f not in [".gitignore", "local", "README.rst"] ]
|
||||
return sorted(l_result)
|
||||
|
||||
|
||||
|
10
configure
vendored
10
configure
vendored
@ -9,7 +9,7 @@ echo "QP_ROOT="$QP_ROOT
|
||||
unset CC
|
||||
unset CCXX
|
||||
|
||||
TREXIO_VERSION=2.3.2
|
||||
TREXIO_VERSION=2.4.2
|
||||
|
||||
# Force GCC instead of ICC for dependencies
|
||||
export CC=gcc
|
||||
@ -219,7 +219,7 @@ EOF
|
||||
tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz
|
||||
cd trexio-${VERSION}
|
||||
./configure --prefix=\${QP_ROOT} --without-hdf5 CFLAGS='-g'
|
||||
make -j 8 && make -j 8 check && make -j 8 install
|
||||
(make -j 8 || make) && make check && make -j 8 install
|
||||
tar -zxvf "\${QP_ROOT}"/external/qp2-dependencies/${ARCHITECTURE}/ninja.tar.gz
|
||||
mv ninja "\${QP_ROOT}"/bin/
|
||||
EOF
|
||||
@ -233,7 +233,7 @@ EOF
|
||||
tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz
|
||||
cd trexio-${VERSION}
|
||||
./configure --prefix=\${QP_ROOT} CFLAGS="-g"
|
||||
make -j 8 && make -j 8 check && make -j 8 install
|
||||
(make -j 8 || make) && make check && make -j 8 install
|
||||
EOF
|
||||
elif [[ ${PACKAGE} = qmckl ]] ; then
|
||||
|
||||
@ -245,7 +245,7 @@ EOF
|
||||
tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz
|
||||
cd qmckl-${VERSION}
|
||||
./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc CFLAGS='-g'
|
||||
make && make -j 4 check && make install
|
||||
(make -j 8 || make) && make check && make install
|
||||
EOF
|
||||
elif [[ ${PACKAGE} = qmckl-intel ]] ; then
|
||||
|
||||
@ -257,7 +257,7 @@ EOF
|
||||
tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz
|
||||
cd qmckl-${VERSION}
|
||||
./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc --with-icc --with-ifort CFLAGS='-g'
|
||||
make && make -j 4 check && make install
|
||||
(make -j 8 || make) && make check && make install
|
||||
EOF
|
||||
|
||||
|
||||
|
@ -22,10 +22,15 @@ let of_string ~units s =
|
||||
}
|
||||
| [ name; x; y; z ] ->
|
||||
let e = Element.of_string name in
|
||||
begin
|
||||
try
|
||||
{ element = e ;
|
||||
charge = Element.to_charge e;
|
||||
coord = Point3d.of_string ~units (String.concat " " [x; y; z])
|
||||
}
|
||||
with
|
||||
| err -> (Printf.eprintf "name = \"%s\"\nxyz = (%s,%s,%s)\n%!" name x y z ; raise err)
|
||||
end
|
||||
| _ -> raise (AtomError s)
|
||||
|
||||
|
||||
|
@ -142,13 +142,21 @@ let of_xyz_string
|
||||
result
|
||||
|
||||
|
||||
let regexp_r = Str.regexp {|
|}
|
||||
let regexp_t = Str.regexp {| |}
|
||||
|
||||
|
||||
let of_xyz_file
|
||||
?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1))
|
||||
?(units=Units.Angstrom)
|
||||
filename =
|
||||
let lines =
|
||||
match Io_ext.input_lines filename with
|
||||
Io_ext.input_lines filename
|
||||
|> List.map (fun s -> Str.global_replace regexp_r "" s)
|
||||
|> List.map (fun s -> Str.global_replace regexp_t " " s)
|
||||
in
|
||||
let lines =
|
||||
match lines with
|
||||
| natoms :: title :: rest ->
|
||||
let natoms =
|
||||
try
|
||||
@ -173,6 +181,8 @@ let of_zmt_file
|
||||
?(units=Units.Angstrom)
|
||||
filename =
|
||||
Io_ext.read_all filename
|
||||
|> Str.global_replace regexp_r ""
|
||||
|> Str.global_replace regexp_t " "
|
||||
|> Zmatrix.of_string
|
||||
|> Zmatrix.to_xyz_string
|
||||
|> of_xyz_string ~charge ~multiplicity ~units
|
||||
|
@ -24,7 +24,9 @@ let of_string ~units s =
|
||||
let l = s
|
||||
|> String_ext.split ~on:' '
|
||||
|> List.filter (fun x -> x <> "")
|
||||
|> list_map float_of_string
|
||||
|> list_map (fun x ->
|
||||
try float_of_string x with
|
||||
| Failure msg -> (Printf.eprintf "Bad string: \"%s\"\n%!" x ; failwith msg) )
|
||||
|> Array.of_list
|
||||
in
|
||||
{ x = l.(0) *. f ;
|
||||
|
@ -322,6 +322,12 @@ END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, noL_0e]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < Phi_left | L | Phi_right >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, ipoint
|
||||
double precision :: t0, t1
|
||||
@ -330,10 +336,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
|
||||
double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
|
||||
double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
|
||||
|
||||
|
||||
call wall_time(t0)
|
||||
print*, " Providing noL_0e ..."
|
||||
|
||||
if(elec_alpha_num .eq. elec_beta_num) then
|
||||
|
||||
allocate(tmp(elec_beta_num))
|
||||
@ -708,11 +710,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(t1)
|
||||
print*, " Wall time for noL_0e (min) = ", (t1 - t0)/60.d0
|
||||
|
||||
print*, " noL_0e = ", noL_0e
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
@ -107,8 +107,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing int2_grad1_u12_ao_transp ...'
|
||||
call wall_time(wall0)
|
||||
!print *, ' providing int2_grad1_u12_ao_transp ...'
|
||||
!call wall_time(wall0)
|
||||
|
||||
if(test_cycle_tc) then
|
||||
|
||||
@ -142,15 +142,15 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
|
||||
call print_memory_usage()
|
||||
!call wall_time(wall1)
|
||||
!print *, ' wall time for int2_grad1_u12_ao_transp (min) = ', (wall1 - wall0) / 60.d0
|
||||
!call print_memory_usage()
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
|
||||
BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
@ -159,7 +159,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
PROVIDE int2_grad1_u12_ao_transp
|
||||
|
||||
!print *, ' providing int2_grad1_u12_bimo_transp'
|
||||
!print *, ' providing int2_grad1_u12_bimo_transp ...'
|
||||
!call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
@ -178,22 +178,24 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!FREE int2_grad1_u12_ao_transp
|
||||
|
||||
!call wall_time(wall1)
|
||||
!print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
|
||||
!print *, ' wall time for int2_grad1_u12_bimo_transp (min) =', (wall1 - wall0) / 60.d0
|
||||
!call print_memory_usage()
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
|
||||
BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
!call wall_time(wall0)
|
||||
!print *, ' Providing int2_grad1_u12_bimo_t ...'
|
||||
!print *, ' providing int2_grad1_u12_bimo_t ...'
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
PROVIDE int2_grad1_u12_bimo_transp
|
||||
@ -211,17 +213,21 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,
|
||||
FREE int2_grad1_u12_bimo_transp
|
||||
|
||||
!call wall_time(wall1)
|
||||
!print *, ' wall time for int2_grad1_u12_bimo_t,', wall1 - wall0
|
||||
!print *, ' wall time for int2_grad1_u12_bimo_t (min) =', (wall1 - wall0) / 60.d0
|
||||
!call print_memory_usage()
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
|
||||
BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
!call wall_time(wall0)
|
||||
!print *, ' providing int2_grad1_u12_ao_t ...'
|
||||
|
||||
PROVIDE int2_grad1_u12_ao
|
||||
|
||||
@ -235,6 +241,10 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3,
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!call wall_time(wall1)
|
||||
!print *, ' wall time for int2_grad1_u12_ao_t (min) =', (wall1 - wall0) / 60.d0
|
||||
!call print_memory_usage()
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
@ -275,8 +285,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid,
|
||||
double precision :: xyz
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
|
||||
call wall_time(wall0)
|
||||
!print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
|
||||
!call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
@ -300,8 +310,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid,
|
||||
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu_transp
|
||||
! FREE mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0
|
||||
!call wall_time(wall1)
|
||||
!print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
@ -323,8 +333,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_
|
||||
double precision :: xyz
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
|
||||
call wall_time(wall0)
|
||||
!print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
|
||||
!call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
@ -343,8 +353,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
|
||||
!call wall_time(wall1)
|
||||
!print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -123,7 +123,7 @@ subroutine give_integrals_3_body_bi_ort_spin( n, sigma_n, l, sigma_l, k, sigma_k
|
||||
endif
|
||||
|
||||
return
|
||||
end subroutine give_integrals_3_body_bi_ort_spin
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
@ -168,7 +168,7 @@ subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
|
||||
integral = integral + tmp * final_weight_at_r_vector(ipoint)
|
||||
enddo
|
||||
|
||||
end subroutine give_integrals_3_body_bi_ort
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -16,10 +16,10 @@ double precision function bi_ortho_mo_ints(l, k, j, i)
|
||||
integer :: m, n, p, q
|
||||
|
||||
bi_ortho_mo_ints = 0.d0
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do n = 1, ao_num
|
||||
do m = 1, ao_num
|
||||
do q = 1, ao_num
|
||||
do n = 1, ao_num
|
||||
! p1h1p2h2 l1 l2 r1 r2
|
||||
bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
|
||||
enddo
|
||||
@ -27,7 +27,7 @@ double precision function bi_ortho_mo_ints(l, k, j, i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end function bi_ortho_mo_ints
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
@ -40,16 +40,83 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l, m, n, p, q
|
||||
integer :: i, j, k, l, m, n, p, q, s, r
|
||||
double precision :: t1, t2, tt1, tt2
|
||||
double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:)
|
||||
double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), ao_two_e_tc_tot_tmp(:,:,:)
|
||||
|
||||
print *, ' PROVIDING mo_bi_ortho_tc_two_e_chemist ...'
|
||||
call wall_time(t1)
|
||||
call print_memory_usage()
|
||||
|
||||
PROVIDE mo_r_coef mo_l_coef
|
||||
|
||||
if(ao_to_mo_tc_n3) then
|
||||
|
||||
print*, ' memory scale of TC ao -> mo: O(N3) '
|
||||
|
||||
if(.not.read_tc_integ) then
|
||||
stop 'read_tc_integ needs to be set to true'
|
||||
endif
|
||||
|
||||
allocate(a_jkp(ao_num,ao_num,mo_num))
|
||||
allocate(a_kpq(ao_num,mo_num,mo_num))
|
||||
allocate(ao_two_e_tc_tot_tmp(ao_num,ao_num,ao_num))
|
||||
|
||||
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read")
|
||||
|
||||
call wall_time(tt1)
|
||||
|
||||
mo_bi_ortho_tc_two_e_chemist(:,:,:,:) = 0.d0
|
||||
do l = 1, ao_num
|
||||
read(11) ao_two_e_tc_tot_tmp(:,:,:)
|
||||
|
||||
do s = 1, mo_num
|
||||
|
||||
call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 &
|
||||
, ao_two_e_tc_tot_tmp(1,1,1), ao_num, mo_l_coef(1,1), ao_num &
|
||||
, 0.d0, a_jkp(1,1,1), ao_num*ao_num)
|
||||
|
||||
call dgemm( 'T', 'N', ao_num*mo_num, mo_num, ao_num, 1.d0 &
|
||||
, a_jkp(1,1,1), ao_num, mo_r_coef(1,1), ao_num &
|
||||
, 0.d0, a_kpq(1,1,1), ao_num*mo_num)
|
||||
|
||||
call dgemm( 'T', 'N', mo_num*mo_num, mo_num, ao_num, mo_r_coef(l,s) &
|
||||
, a_kpq(1,1,1), ao_num, mo_l_coef(1,1), ao_num &
|
||||
, 1.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,s), mo_num*mo_num)
|
||||
|
||||
enddo ! s
|
||||
|
||||
if(l == 2) then
|
||||
call wall_time(tt2)
|
||||
print*, ' 1 / mo_num done in (min)', (tt2-tt1)/60.d0
|
||||
print*, ' estimated time required (min)', dble(mo_num-1)*(tt2-tt1)/60.d0
|
||||
elseif(l == 11) then
|
||||
call wall_time(tt2)
|
||||
print*, ' 10 / mo_num done in (min)', (tt2-tt1)/60.d0
|
||||
print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/(60.d0*10.d0)
|
||||
elseif(l == 101) then
|
||||
call wall_time(tt2)
|
||||
print*, ' 100 / mo_num done in (min)', (tt2-tt1)/60.d0
|
||||
print*, ' estimated time required (min)', dble(mo_num-100)*(tt2-tt1)/(60.d0*100.d0)
|
||||
endif
|
||||
enddo ! l
|
||||
|
||||
close(11)
|
||||
|
||||
deallocate(a_jkp, a_kpq, ao_two_e_tc_tot_tmp)
|
||||
|
||||
else
|
||||
|
||||
print*, ' memory scale of TC ao -> mo: O(N4) '
|
||||
|
||||
allocate(a2(ao_num,ao_num,ao_num,mo_num))
|
||||
|
||||
call dgemm( 'T', 'N', ao_num*ao_num*ao_num, mo_num, ao_num, 1.d0 &
|
||||
, ao_two_e_tc_tot(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
|
||||
, 0.d0 , a2(1,1,1,1), ao_num*ao_num*ao_num)
|
||||
, 0.d0, a2(1,1,1,1), ao_num*ao_num*ao_num)
|
||||
|
||||
FREE ao_two_e_tc_tot
|
||||
|
||||
allocate(a1(ao_num,ao_num,mo_num,mo_num))
|
||||
|
||||
@ -72,6 +139,7 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
|
||||
|
||||
deallocate(a2)
|
||||
|
||||
endif
|
||||
|
||||
!allocate(a1(mo_num,ao_num,ao_num,ao_num))
|
||||
!a1 = 0.d0
|
||||
@ -135,6 +203,10 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
|
||||
!enddo
|
||||
!deallocate(a1)
|
||||
|
||||
call wall_time(t2)
|
||||
print *, ' WALL TIME for PROVIDING mo_bi_ortho_tc_two_e_chemist (min)', (t2-t1)/60.d0
|
||||
call print_memory_usage()
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
@ -176,6 +248,34 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num,
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_transp, (mo_num, mo_num, mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_bi_ortho_tc_two_e_transp(i,j,k,l) = <k l| V(r_12) |i j> = transpose of mo_bi_ortho_tc_two_e
|
||||
!
|
||||
! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
|
||||
!
|
||||
END_DOC
|
||||
|
||||
integer :: i,j,k,l
|
||||
print*,'Providing mo_bi_ortho_tc_two_e_transp'
|
||||
double precision :: t0,t1
|
||||
call wall_time(t0)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
mo_bi_ortho_tc_two_e_transp(i,j,k,l) = mo_bi_ortho_tc_two_e(k,l,i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(t1)
|
||||
|
||||
print *, ' WALL TIME for PROVIDING mo_bi_ortho_tc_two_e_transp (min)', (t1-t0)/60.d0
|
||||
|
||||
END_PROVIDER
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj, (mo_num,mo_num)]
|
||||
@ -232,3 +332,23 @@ END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_2e_3idx_coulomb_integrals_transp , (mo_num,mo_num,mo_num)]
|
||||
&BEGIN_PROVIDER [double precision, tc_2e_3idx_exchange_integrals_transp, (mo_num,mo_num,mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! tc_2e_3idx_coulomb_integrals_transp (j,k,i) = <jk|ji>
|
||||
! tc_2e_3idx_exchange_integrals_transp(j,k,i) = <kj|ji>
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i, j, k
|
||||
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
tc_2e_3idx_coulomb_integrals_transp(j, k,i) = mo_bi_ortho_tc_two_e_transp(j ,k ,j ,i )
|
||||
tc_2e_3idx_exchange_integrals_transp(j,k,i) = mo_bi_ortho_tc_two_e_transp(k ,j ,j ,i )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
@ -56,10 +56,10 @@
|
||||
print*,'Average trace of overlap_bi_ortho is different from 1 by ', dabs(accu_d-1.d0)
|
||||
print*,'And bi orthogonality is off by an average of ',accu_nd
|
||||
print*,'****************'
|
||||
print*,'Overlap matrix betwee mo_l_coef and mo_r_coef '
|
||||
do i = 1, mo_num
|
||||
write(*,'(100(F16.10,X))')overlap_bi_ortho(i,:)
|
||||
enddo
|
||||
!print*,'Overlap matrix betwee mo_l_coef and mo_r_coef '
|
||||
!do i = 1, mo_num
|
||||
! write(*,'(100(F16.10,X))')overlap_bi_ortho(i,:)
|
||||
!enddo
|
||||
endif
|
||||
print*,'Average trace of overlap_bi_ortho (should be 1.)'
|
||||
print*,'accu_d = ',accu_d
|
||||
|
108
plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
Normal file
108
plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
Normal file
@ -0,0 +1,108 @@
|
||||
subroutine get_d0_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
|
||||
!todo: indices/conjg should be okay for complex
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
|
||||
integer(bit_kind), intent(in) :: phasemask(N_int,2)
|
||||
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
|
||||
integer(bit_kind) :: det(N_int, 2)
|
||||
double precision, intent(in) :: coefs(N_states,2)
|
||||
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
|
||||
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
|
||||
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
|
||||
|
||||
integer :: i, j, k, s, h1, h2, p1, p2, puti, putj, mm
|
||||
double precision :: phase
|
||||
double precision :: hij,hji
|
||||
double precision, external :: get_phase_bi
|
||||
logical :: ok
|
||||
|
||||
integer, parameter :: bant=1
|
||||
double precision, allocatable :: hij_cache1(:), hij_cache2(:)
|
||||
allocate (hij_cache1(mo_num),hij_cache2(mo_num))
|
||||
double precision, allocatable :: hji_cache1(:), hji_cache2(:)
|
||||
allocate (hji_cache1(mo_num),hji_cache2(mo_num))
|
||||
! print*,'in get_d0_new'
|
||||
! call debug_det(gen,N_int)
|
||||
! print*,'coefs',coefs(1,:)
|
||||
|
||||
if(sp == 3) then ! AB
|
||||
h1 = p(1,1)
|
||||
h2 = p(1,2)
|
||||
do p1=1, mo_num
|
||||
if(bannedOrb(p1, 1)) cycle
|
||||
! call get_mo_two_e_integrals_complex(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map)
|
||||
do mm = 1, mo_num
|
||||
hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,p1,h2,h1)
|
||||
hji_cache1(mm) = mo_bi_ortho_tc_two_e_transp(mm,p1,h2,h1)
|
||||
enddo
|
||||
!!!!!!!!!! <alpha|H|psi>
|
||||
do p2=1, mo_num
|
||||
if(bannedOrb(p2,2)) cycle
|
||||
if(banned(p1, p2, bant)) cycle ! rentable?
|
||||
if(p1 == h1 .or. p2 == h2) then
|
||||
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
|
||||
! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
|
||||
! call i_h_j_complex(det, gen, N_int, hij)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e_both(det,gen,N_int, hij,hji)
|
||||
else
|
||||
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
|
||||
hij = hij_cache1(p2) * phase
|
||||
hji = hji_cache1(p2) * phase
|
||||
end if
|
||||
if (hij == 0.d0.or.hji == 0.d0) cycle
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij ! HOTSPOT
|
||||
mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji ! HOTSPOT
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
|
||||
else ! AA BB
|
||||
p1 = p(1,sp)
|
||||
p2 = p(2,sp)
|
||||
do puti=1, mo_num
|
||||
if(bannedOrb(puti, sp)) cycle
|
||||
! call get_mo_two_e_integrals_complex(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1)
|
||||
hij_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2)
|
||||
hji_cache1(mm) = mo_bi_ortho_tc_two_e_transp(mm,puti,p2,p1)
|
||||
hji_cache2(mm) = mo_bi_ortho_tc_two_e_transp(mm,puti,p1,p2)
|
||||
enddo
|
||||
!!!!!!!!!! <alpha|H|psi>
|
||||
do putj=puti+1, mo_num
|
||||
if(bannedOrb(putj, sp)) cycle
|
||||
if(banned(puti, putj, bant)) cycle ! rentable?
|
||||
if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
|
||||
call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
|
||||
!call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
|
||||
! call i_h_j_complex(det, gen, N_int, hij)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e_both(det,gen,N_int, hij,hji)
|
||||
if (hij == 0.d0.or.hji == 0.d0) cycle
|
||||
else
|
||||
! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj))
|
||||
! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj))
|
||||
hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1))
|
||||
hji = (mo_bi_ortho_tc_two_e_transp(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e_transp(puti, putj, p2, p1))
|
||||
if (hij == 0.d0.or.hji == 0.d0) cycle
|
||||
phase = get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
|
||||
hij = (hij) * phase
|
||||
hji = (hji) * phase
|
||||
end if
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
|
||||
enddo
|
||||
end do
|
||||
|
||||
end do
|
||||
end if
|
||||
|
||||
deallocate(hij_cache1,hij_cache2)
|
||||
end
|
||||
|
350
plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
Normal file
350
plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
Normal file
@ -0,0 +1,350 @@
|
||||
subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
|
||||
!todo: indices should be okay for complex?
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
|
||||
integer(bit_kind), intent(in) :: phasemask(N_int,2)
|
||||
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
|
||||
integer(bit_kind) :: det(N_int, 2)
|
||||
double precision, intent(in) :: coefs(N_states,2)
|
||||
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
|
||||
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
|
||||
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
|
||||
double precision, external :: get_phase_bi
|
||||
double precision, external :: mo_two_e_integral_complex
|
||||
logical :: ok
|
||||
|
||||
logical, allocatable :: lbanned(:,:)
|
||||
integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
|
||||
integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l, mm
|
||||
|
||||
integer, parameter :: turn2(2) = (/2,1/)
|
||||
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
|
||||
|
||||
integer :: bant
|
||||
double precision, allocatable :: hij_cache(:,:)
|
||||
double precision :: hij, tmp_rowij(N_states, mo_num), tmp_rowij2(N_states, mo_num),phase
|
||||
double precision, allocatable :: hji_cache(:,:)
|
||||
double precision :: hji, tmp_rowji(N_states, mo_num), tmp_rowji2(N_states, mo_num)
|
||||
! PROVIDE mo_integrals_map N_int
|
||||
! print*,'in get_d1_new'
|
||||
! call debug_det(gen,N_int)
|
||||
! print*,'coefs',coefs(1,:)
|
||||
|
||||
allocate (lbanned(mo_num, 2))
|
||||
allocate (hij_cache(mo_num,2))
|
||||
allocate (hji_cache(mo_num,2))
|
||||
lbanned = bannedOrb
|
||||
|
||||
do i=1, p(0,1)
|
||||
lbanned(p(i,1), 1) = .true.
|
||||
end do
|
||||
do i=1, p(0,2)
|
||||
lbanned(p(i,2), 2) = .true.
|
||||
end do
|
||||
|
||||
ma = 1
|
||||
if(p(0,2) >= 2) ma = 2
|
||||
mi = turn2(ma)
|
||||
|
||||
bant = 1
|
||||
|
||||
if(sp == 3) then
|
||||
!move MA
|
||||
if(ma == 2) bant = 2
|
||||
puti = p(1,mi)
|
||||
hfix = h(1,ma)
|
||||
p1 = p(1,ma)
|
||||
p2 = p(2,ma)
|
||||
if(.not. bannedOrb(puti, mi)) then
|
||||
! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
|
||||
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
|
||||
hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2)
|
||||
hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1)
|
||||
enddo
|
||||
!! <alpha|H|psi>
|
||||
tmp_rowij = 0.d0
|
||||
tmp_rowji = 0.d0
|
||||
do putj=1, hfix-1
|
||||
if(lbanned(putj, ma)) cycle
|
||||
if(banned(putj, puti,bant)) cycle
|
||||
hij = hij_cache(putj,1) - hij_cache(putj,2)
|
||||
hji = hji_cache(putj,1) - hji_cache(putj,2)
|
||||
if (hij /= 0.d0.and.hji/=0.d0) then
|
||||
phase = get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,2)
|
||||
tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
do putj=hfix+1, mo_num
|
||||
if(lbanned(putj, ma)) cycle
|
||||
if(banned(putj, puti,bant)) cycle
|
||||
hij = hij_cache(putj,2) - hij_cache(putj,1)
|
||||
hji = hji_cache(putj,2) - hji_cache(putj,1)
|
||||
if (hij /= 0.d0.and.hji/=0.d0) then
|
||||
phase = get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,2)
|
||||
tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
|
||||
if(ma == 1) then
|
||||
mat_r(1:N_states,1:mo_num,puti) = mat_r(1:N_states,1:mo_num,puti) + tmp_rowij(1:N_states,1:mo_num)
|
||||
mat_l(1:N_states,1:mo_num,puti) = mat_l(1:N_states,1:mo_num,puti) + tmp_rowji(1:N_states,1:mo_num)
|
||||
else
|
||||
do l=1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k,puti,l) = mat_r(k,puti,l) + tmp_rowij(k,l)
|
||||
mat_l(k,puti,l) = mat_l(k,puti,l) + tmp_rowji(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
!MOVE MI
|
||||
pfix = p(1,mi)
|
||||
tmp_rowij = 0.d0
|
||||
tmp_rowij2 = 0.d0
|
||||
tmp_rowji = 0.d0
|
||||
tmp_rowji2 = 0.d0
|
||||
! call get_mo_two_e_integrals_complex(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1)
|
||||
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2)
|
||||
hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p1)
|
||||
hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p2)
|
||||
enddo
|
||||
putj = p1
|
||||
!! <alpha|H|psi>
|
||||
do puti=1,mo_num !HOT
|
||||
if(lbanned(puti,mi)) cycle
|
||||
!p1 fixed
|
||||
putj = p1
|
||||
if(.not. banned(putj,puti,bant)) then
|
||||
hij = hij_cache(puti,2)
|
||||
hji = hji_cache(puti,2)
|
||||
if (hij /= 0.d0.and.hji/=0.d0) then
|
||||
phase = get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,2)
|
||||
tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
!
|
||||
putj = p2
|
||||
if(.not. banned(putj,puti,bant)) then
|
||||
hij = hij_cache(puti,1)
|
||||
hji = hji_cache(puti,1)
|
||||
if (hij /= 0.d0.and.hji/=0.d0) then
|
||||
phase = get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
do k=1,N_states
|
||||
tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,2)
|
||||
tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
if(mi == 1) then
|
||||
mat_r(:,:,p1) = mat_r(:,:,p1) + tmp_rowij(:,:)
|
||||
mat_r(:,:,p2) = mat_r(:,:,p2) + tmp_rowij2(:,:)
|
||||
mat_l(:,:,p1) = mat_l(:,:,p1) + tmp_rowji(:,:)
|
||||
mat_l(:,:,p2) = mat_l(:,:,p2) + tmp_rowji2(:,:)
|
||||
else
|
||||
do l=1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij(k,l)
|
||||
mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij2(k,l)
|
||||
mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji(k,l)
|
||||
mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji2(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end if
|
||||
|
||||
else ! sp /= 3
|
||||
|
||||
if(p(0,ma) == 3) then
|
||||
do i=1,3
|
||||
hfix = h(1,ma)
|
||||
puti = p(i, ma)
|
||||
p1 = p(turn3(1,i), ma)
|
||||
p2 = p(turn3(2,i), ma)
|
||||
! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
|
||||
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
|
||||
hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2)
|
||||
hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1)
|
||||
enddo
|
||||
!! <alpha|H|psi>
|
||||
tmp_rowij = 0.d0
|
||||
tmp_rowji = 0.d0
|
||||
do putj=1,hfix-1
|
||||
if(banned(putj,puti,1)) cycle
|
||||
if(lbanned(putj,ma)) cycle
|
||||
hij = hij_cache(putj,1) - hij_cache(putj,2)
|
||||
hji = hji_cache(putj,1) - hji_cache(putj,2)
|
||||
if (hij /= 0.d0.and.hji/=0.d0) then
|
||||
phase = get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,2)
|
||||
tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,1)
|
||||
endif
|
||||
end do
|
||||
do putj=hfix+1,mo_num
|
||||
if(banned(putj,puti,1)) cycle
|
||||
if(lbanned(putj,ma)) cycle
|
||||
hij = hij_cache(putj,2) - hij_cache(putj,1)
|
||||
hji = hji_cache(putj,2) - hji_cache(putj,1)
|
||||
if (hij /= 0.d0.and.hji/=0.d0) then
|
||||
phase = get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,2)
|
||||
tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,1)
|
||||
endif
|
||||
end do
|
||||
|
||||
mat_r(:, :puti-1, puti) = mat_r(:, :puti-1, puti) + tmp_rowij(:,:puti-1)
|
||||
mat_l(:, :puti-1, puti) = mat_l(:, :puti-1, puti) + tmp_rowji(:,:puti-1)
|
||||
do l=puti,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, l) = mat_r(k, puti,l) + tmp_rowij(k,l)
|
||||
mat_l(k, puti, l) = mat_l(k, puti,l) + tmp_rowji(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end do
|
||||
else
|
||||
hfix = h(1,mi)
|
||||
pfix = p(1,mi)
|
||||
p1 = p(1,ma)
|
||||
p2 = p(2,ma)
|
||||
tmp_rowij = 0.d0
|
||||
tmp_rowij2 = 0.d0
|
||||
tmp_rowji = 0.d0
|
||||
tmp_rowji2 = 0.d0
|
||||
! call get_mo_two_e_integrals_complex(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,pfix)
|
||||
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix)
|
||||
hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,pfix)
|
||||
hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,pfix)
|
||||
enddo
|
||||
putj = p2
|
||||
!! <alpha|H|psi>
|
||||
do puti=1,mo_num
|
||||
if(lbanned(puti,ma)) cycle
|
||||
putj = p2
|
||||
if(.not. banned(puti,putj,1)) then
|
||||
hij = hij_cache(puti,1)
|
||||
hji = hji_cache(puti,1)
|
||||
if (hij /= 0.d0.and.hji/=0.d0) then
|
||||
phase = get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,2)
|
||||
tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
|
||||
putj = p1
|
||||
if(.not. banned(puti,putj,1)) then
|
||||
hij = hij_cache(puti,2)
|
||||
hji = hji_cache(puti,2)
|
||||
if (hij /= 0.d0.and.hji/=0.d0) then
|
||||
phase = get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
do k=1,N_states
|
||||
tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,2)
|
||||
tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
mat_r(:,:p2-1,p2) = mat_r(:,:p2-1,p2) + tmp_rowij(:,:p2-1)
|
||||
mat_l(:,:p2-1,p2) = mat_l(:,:p2-1,p2) + tmp_rowji(:,:p2-1)
|
||||
do l=p2,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij(k,l)
|
||||
mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji(k,l)
|
||||
enddo
|
||||
enddo
|
||||
mat_r(:,:p1-1,p1) = mat_r(:,:p1-1,p1) + tmp_rowij2(:,:p1-1)
|
||||
mat_l(:,:p1-1,p1) = mat_l(:,:p1-1,p1) + tmp_rowji2(:,:p1-1)
|
||||
do l=p1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij2(k,l)
|
||||
mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji2(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end if
|
||||
end if
|
||||
deallocate(lbanned,hij_cache, hji_cache)
|
||||
|
||||
!! MONO
|
||||
if(sp == 3) then
|
||||
s1 = 1
|
||||
s2 = 2
|
||||
else
|
||||
s1 = sp
|
||||
s2 = sp
|
||||
end if
|
||||
|
||||
do i1=1,p(0,s1)
|
||||
ib = 1
|
||||
if(s1 == s2) ib = i1+1
|
||||
do i2=ib,p(0,s2)
|
||||
p1 = p(i1,s1)
|
||||
p2 = p(i2,s2)
|
||||
if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle
|
||||
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
|
||||
! gen is a selector; mask is ionized generator; det is alpha
|
||||
! hij is contribution to <psi|H|alpha>
|
||||
! call i_h_j_complex(gen, det, N_int, hij)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e_both(det, gen, N_int, hij,hji)
|
||||
! call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * dconjg(hij)
|
||||
mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij
|
||||
mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
end
|
||||
|
@ -25,9 +25,6 @@ subroutine get_d2_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h,
|
||||
|
||||
integer :: bant
|
||||
bant = 1
|
||||
! print*, 'in get_d2_new'
|
||||
! call debug_det(gen,N_int)
|
||||
! print*,'coefs',coefs(1,:)
|
||||
|
||||
tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles
|
||||
|
||||
|
235
plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f
Normal file
235
plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f
Normal file
@ -0,0 +1,235 @@
|
||||
|
||||
subroutine get_d2_new_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
|
||||
!todo: indices/conjg should be correct for complex
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
|
||||
integer(bit_kind), intent(in) :: phasemask(N_int,2)
|
||||
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
|
||||
double precision, intent(in) :: coefs(N_states,2)
|
||||
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
|
||||
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
|
||||
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
|
||||
|
||||
double precision, external :: get_phase_bi
|
||||
|
||||
integer :: i, j, k, tip, ma, mi, puti, putj
|
||||
integer :: h1, h2, p1, p2, i1, i2
|
||||
double precision :: phase
|
||||
double precision :: hij,hji
|
||||
|
||||
integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/))
|
||||
integer, parameter :: turn2(2) = (/2, 1/)
|
||||
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
|
||||
|
||||
integer :: bant
|
||||
bant = 1
|
||||
|
||||
tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles
|
||||
|
||||
ma = sp !1:(alpha,alpha); 2:(b,b); 3:(a,b)
|
||||
if(p(0,1) > p(0,2)) ma = 1 ! more alpha particles than beta particles
|
||||
if(p(0,1) < p(0,2)) ma = 2 ! fewer alpha particles than beta particles
|
||||
mi = mod(ma, 2) + 1
|
||||
|
||||
if(sp == 3) then ! if one alpha and one beta xhole
|
||||
!(where xholes refer to the ionizations from the generator, not the holes occupied in the ionized generator)
|
||||
if(ma == 2) bant = 2 ! if more beta particles than alpha particles
|
||||
|
||||
if(tip == 3) then ! if 3 of one particle spin and 1 of the other particle spin
|
||||
puti = p(1, mi)
|
||||
if(bannedOrb(puti, mi)) return
|
||||
h1 = h(1, ma)
|
||||
h2 = h(2, ma)
|
||||
|
||||
!! <alpha|H|psi>
|
||||
do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma
|
||||
putj = p(i, ma)
|
||||
if(banned(putj,puti,bant)) cycle
|
||||
i1 = turn3(1,i)
|
||||
i2 = turn3(2,i)
|
||||
p1 = p(i1, ma)
|
||||
p2 = p(i2, ma)
|
||||
|
||||
! |G> = |psi_{gen,i}>
|
||||
! |G'> = a_{x1} a_{x2} |G>
|
||||
! |alpha> = a_{puti}^{\dagger} a_{putj}^{\dagger} |G'>
|
||||
! |alpha> = t_{x1,x2}^{puti,putj} |G>
|
||||
! hij = <psi_{selectors,i}|H|alpha>
|
||||
! |alpha> = t_{p1,p2}^{h1,h2}|psi_{selectors,i}>
|
||||
!todo: <i|H|j> = (<h1,h2|p1,p2> - <h1,h2|p2,p1>) * phase
|
||||
! <psi|H|j> += dconjg(c_i) * <i|H|j>
|
||||
! <j|H|i> = (<p1,p2|h1,h2> - <p2,p1|h1,h2>) * phase
|
||||
! <j|H|psi> += <j|H|i> * c_i
|
||||
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
|
||||
! hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e( h1, h2, p2, p1)
|
||||
! hji = mo_bi_ortho_tc_two_e_transp(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e_transp( h1, h2, p2, p1)
|
||||
hij = mo_bi_ortho_tc_two_e_transp(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e_transp( p1, p2, h2, h1)
|
||||
hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e( p1, p2, h2, h1)
|
||||
if (hij == 0.d0.or.hji==0.d0) cycle
|
||||
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
phase = get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
|
||||
if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hij
|
||||
mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hji
|
||||
enddo
|
||||
else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
|
||||
enddo
|
||||
end if
|
||||
end do
|
||||
else ! if 2 alpha and 2 beta particles
|
||||
h1 = h(1,1)
|
||||
h2 = h(1,2)
|
||||
!! <alpha|H|psi>
|
||||
do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle
|
||||
putj = p(j, 2)
|
||||
if(bannedOrb(putj, 2)) cycle
|
||||
p2 = p(turn2(j), 2)
|
||||
do i = 1,2
|
||||
puti = p(i, 1)
|
||||
if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle
|
||||
p1 = p(turn2(i), 1)
|
||||
! hij = <psi_{selectors,i}|H|alpha>
|
||||
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
! hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2 )
|
||||
! hji = mo_bi_ortho_tc_two_e_transp(h1, h2, p1, p2 )
|
||||
hij = mo_bi_ortho_tc_two_e_transp(p1, p2 ,h1, h2 )
|
||||
hji = mo_bi_ortho_tc_two_e( p1, p2, h1, h2)
|
||||
if (hij /= 0.d0.or.hji==0.d0) then
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
|
||||
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
|
||||
else ! if holes are (a,a) or (b,b)
|
||||
if(tip == 0) then ! if particles are (a,a,a,a) or (b,b,b,b)
|
||||
h1 = h(1, ma)
|
||||
h2 = h(2, ma)
|
||||
!! <alpha|H|psi>
|
||||
do i=1,3
|
||||
puti = p(i, ma)
|
||||
if(bannedOrb(puti,ma)) cycle
|
||||
do j=i+1,4
|
||||
putj = p(j, ma)
|
||||
if(bannedOrb(putj,ma)) cycle
|
||||
if(banned(puti,putj,1)) cycle
|
||||
|
||||
i1 = turn2d(1, i, j)
|
||||
i2 = turn2d(2, i, j)
|
||||
p1 = p(i1, ma)
|
||||
p2 = p(i2, ma)
|
||||
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
hij = mo_bi_ortho_tc_two_e_transp(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e_transp(p1, p2, h2,h1 )
|
||||
hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p1, p2, h2,h1 )
|
||||
if (hij == 0.d0.or.hji == 0.d0) cycle
|
||||
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
phase = get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,2) * hij
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) +coefs(k,1) * hji
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
else if(tip == 3) then ! if particles are (a,a,a,b) (ma=1,mi=2) or (a,b,b,b) (ma=2,mi=1)
|
||||
h1 = h(1, mi)
|
||||
h2 = h(1, ma)
|
||||
p1 = p(1, mi)
|
||||
!! <alpha|H|psi>
|
||||
do i=1,3
|
||||
puti = p(turn3(1,i), ma)
|
||||
if(bannedOrb(puti,ma)) cycle
|
||||
putj = p(turn3(2,i), ma)
|
||||
if(bannedOrb(putj,ma)) cycle
|
||||
if(banned(puti,putj,1)) cycle
|
||||
p2 = p(i, ma)
|
||||
|
||||
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
hij = mo_bi_ortho_tc_two_e_transp(p1, p2 ,h1, h2)
|
||||
hji = mo_bi_ortho_tc_two_e(p1, p2,h1, h2 )
|
||||
if (hij == 0.d0) cycle
|
||||
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
|
||||
phase = get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji * phase
|
||||
if (puti < putj) then
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
|
||||
enddo
|
||||
else
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hij
|
||||
mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hji
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
else ! tip == 4 (a,a,b,b)
|
||||
puti = p(1, sp)
|
||||
putj = p(2, sp)
|
||||
if(.not. banned(puti,putj,1)) then
|
||||
p1 = p(1, mi)
|
||||
p2 = p(2, mi)
|
||||
h1 = h(1, mi)
|
||||
h2 = h(2, mi)
|
||||
!! <alpha|H|psi>
|
||||
! hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2))
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
hij = (mo_bi_ortho_tc_two_e_transp(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e_transp(p2,p1,h1, h2))
|
||||
hji = (mo_bi_ortho_tc_two_e(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e(p2,p1,h1, h2))
|
||||
if (hij /= 0.d0.or.hji==0.d0) then
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
|
||||
phase = get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
|
||||
hij = hij * phase
|
||||
hji = hji* phase
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
|
||||
enddo
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
end
|
@ -67,6 +67,7 @@ subroutine tc_pt2
|
||||
call pt2_alloc(pt2_data_err, N_states)
|
||||
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
|
||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
||||
call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
|
||||
|
||||
end
|
||||
|
||||
|
@ -636,10 +636,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
|
||||
negMask(i,2) = not(mask(i,2))
|
||||
end do
|
||||
|
||||
! print*,'in selection '
|
||||
do i = 1, N_sel
|
||||
! call debug_det(det(1,1,i),N_int)
|
||||
! print*,i,dabs(psi_selectors_coef_transp_tc(1,2,i) * psi_selectors_coef_transp_tc(1,1,i))
|
||||
if(interesting(i) < 0) then
|
||||
stop 'prefetch interesting(i) and det(i)'
|
||||
endif
|
||||
@ -691,12 +688,24 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
|
||||
|
||||
call get_mask_phase(psi_det_sorted_tc(1,1,interesting(i)), phasemask,N_int)
|
||||
if(nt == 4) then
|
||||
if(transpose_two_e_int)then
|
||||
call get_d2_new_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
else
|
||||
call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
endif
|
||||
elseif(nt == 3) then
|
||||
if(transpose_two_e_int)then
|
||||
call get_d1_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
else
|
||||
call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
endif
|
||||
else
|
||||
if(transpose_two_e_int)then
|
||||
call get_d0_transp (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
else
|
||||
call get_d0_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
endif
|
||||
endif
|
||||
elseif(nt == 4) then
|
||||
call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int)
|
||||
call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int)
|
||||
@ -887,79 +896,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
||||
call diag_htilde_mu_mat_fock_bi_ortho(N_int, det, hmono, htwoe, hthree, hii)
|
||||
do istate = 1,N_states
|
||||
delta_E = E0(istate) - Hii + E_shift
|
||||
double precision :: alpha_h_psi_tmp, psi_h_alpha_tmp, error
|
||||
if(debug_tc_pt2 == 1)then !! Using the old version
|
||||
psi_h_alpha = 0.d0
|
||||
alpha_h_psi = 0.d0
|
||||
do iii = 1, N_det_selectors
|
||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
|
||||
call htilde_mu_mat_bi_ortho_tot_slow(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
|
||||
call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int)
|
||||
if(degree == 0)then
|
||||
print*,'problem !!!'
|
||||
print*,'a determinant is already in the wave function !!'
|
||||
print*,'it corresponds to the selector number ',iii
|
||||
call debug_det(det,N_int)
|
||||
stop
|
||||
endif
|
||||
! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
|
||||
! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
|
||||
psi_h_alpha += i_h_alpha * psi_selectors_coef_tc(iii,2,1) ! left function
|
||||
alpha_h_psi += alpha_h_i * psi_selectors_coef_tc(iii,1,1) ! right function
|
||||
enddo
|
||||
else if(debug_tc_pt2 == 2)then !! debugging the new version
|
||||
! psi_h_alpha_tmp = 0.d0
|
||||
! alpha_h_psi_tmp = 0.d0
|
||||
! do iii = 1, N_det_selectors ! old version
|
||||
! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
|
||||
! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
|
||||
! psi_h_alpha_tmp += i_h_alpha * psi_selectors_coef_tc(iii,1,1) ! left function
|
||||
! alpha_h_psi_tmp += alpha_h_i * psi_selectors_coef_tc(iii,2,1) ! right function
|
||||
! enddo
|
||||
psi_h_alpha_tmp = mat_l(istate, p1, p2) ! new version
|
||||
alpha_h_psi_tmp = mat_r(istate, p1, p2) ! new version
|
||||
psi_h_alpha = 0.d0
|
||||
alpha_h_psi = 0.d0
|
||||
do iii = 1, N_det ! old version
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(psi_det(1,1,iii), det, N_int, i_h_alpha)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_det(1,1,iii), N_int, alpha_h_i)
|
||||
psi_h_alpha += i_h_alpha * psi_l_coef_bi_ortho(iii,1) ! left function
|
||||
alpha_h_psi += alpha_h_i * psi_r_coef_bi_ortho(iii,1) ! right function
|
||||
enddo
|
||||
if(dabs(psi_h_alpha*alpha_h_psi/delta_E).gt.1.d-10)then
|
||||
error = dabs(psi_h_alpha * alpha_h_psi - psi_h_alpha_tmp * alpha_h_psi_tmp)/dabs(psi_h_alpha * alpha_h_psi)
|
||||
if(error.gt.1.d-2)then
|
||||
call debug_det(det, N_int)
|
||||
print*,'error =',error,psi_h_alpha * alpha_h_psi/delta_E,psi_h_alpha_tmp * alpha_h_psi_tmp/delta_E
|
||||
print*,psi_h_alpha , alpha_h_psi
|
||||
print*,psi_h_alpha_tmp , alpha_h_psi_tmp
|
||||
print*,'selectors '
|
||||
do iii = 1, N_det_selectors ! old version
|
||||
print*,'iii',iii,psi_selectors_coef_tc(iii,1,1),psi_selectors_coef_tc(iii,2,1)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
|
||||
print*,i_h_alpha,alpha_h_i
|
||||
call debug_det(psi_selectors(1,1,iii),N_int)
|
||||
enddo
|
||||
! print*,'psi_det '
|
||||
! do iii = 1, N_det! old version
|
||||
! print*,'iii',iii,psi_l_coef_bi_ortho(iii,1),psi_r_coef_bi_ortho(iii,1)
|
||||
! call debug_det(psi_det(1,1,iii),N_int)
|
||||
! enddo
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
else
|
||||
psi_h_alpha = mat_l(istate, p1, p2)
|
||||
alpha_h_psi = mat_r(istate, p1, p2)
|
||||
endif
|
||||
val = 4.d0 * psi_h_alpha * alpha_h_psi
|
||||
tmp = dsqrt(delta_E * delta_E + val)
|
||||
! if (delta_E < 0.d0) then
|
||||
! tmp = -tmp
|
||||
! endif
|
||||
e_pert(istate) = 0.25 * val / delta_E
|
||||
! e_pert(istate) = 0.5d0 * (tmp - delta_E)
|
||||
if(dsqrt(tmp).gt.1.d-4.and.dabs(psi_h_alpha).gt.1.d-4)then
|
||||
coef(istate) = e_pert(istate) / psi_h_alpha
|
||||
else
|
||||
@ -976,15 +917,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
||||
if(e_pert(istate).gt.0.d0)e_pert(istate)=0.d0
|
||||
endif
|
||||
|
||||
! if(selection_tc == 1 )then
|
||||
! if(e_pert(istate).lt.0.d0)then
|
||||
! e_pert(istate) = 0.d0
|
||||
! endif
|
||||
! else if(selection_tc == -1)then
|
||||
! if(e_pert(istate).gt.0.d0)then
|
||||
! e_pert(istate) = 0.d0
|
||||
! endif
|
||||
! endif
|
||||
enddo
|
||||
|
||||
|
||||
|
@ -88,6 +88,9 @@ subroutine run_stochastic_cipsi
|
||||
call pt2_dealloc(pt2_data_err)
|
||||
call pt2_alloc(pt2_data, N_states)
|
||||
call pt2_alloc(pt2_data_err, N_states)
|
||||
if(transpose_two_e_int)then
|
||||
provide mo_bi_ortho_tc_two_e_transp
|
||||
endif
|
||||
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
|
||||
! stop
|
||||
|
||||
|
@ -13,6 +13,8 @@ program tc_pt2_prog
|
||||
|
||||
pruning = -1.d0
|
||||
touch pruning
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
! pt2_relative_error = 0.01d0
|
||||
! touch pt2_relative_error
|
||||
|
@ -3,7 +3,7 @@ To localize the MOs:
|
||||
```
|
||||
qp run localization
|
||||
```
|
||||
By default, the different otbital classes are automatically set by splitting
|
||||
By default, the different orbital classes are automatically set by splitting
|
||||
the orbitales in the following classes:
|
||||
- Core -> Core
|
||||
- Active, doubly occupied -> Inactive
|
||||
|
@ -3,3 +3,4 @@ hamiltonian
|
||||
jastrow
|
||||
ao_tc_eff_map
|
||||
bi_ortho_mos
|
||||
trexio
|
||||
|
@ -31,24 +31,63 @@ subroutine print_aos()
|
||||
integer :: i, ipoint
|
||||
double precision :: r(3)
|
||||
double precision :: ao_val, ao_der(3), ao_lap
|
||||
double precision :: mo_val, mo_der(3), mo_lap
|
||||
|
||||
PROVIDE final_grid_points aos_in_r_array aos_grad_in_r_array aos_lapl_in_r_array
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
print*, r
|
||||
write(1000, '(3(f15.7, 3X))') r
|
||||
enddo
|
||||
|
||||
double precision :: accu_vgl(5)
|
||||
double precision :: accu_vgl_nrm(5)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
do i = 1, ao_num
|
||||
ao_val = aos_in_r_array (i,ipoint)
|
||||
ao_der(:) = aos_grad_in_r_array(i,ipoint,:)
|
||||
ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint)
|
||||
write(*, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
|
||||
write(111, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
ao_val = aos_in_r_array_qmckl (i,ipoint)
|
||||
ao_der(:) = aos_grad_in_r_array_qmckl(i,ipoint,:)
|
||||
ao_lap = aos_lapl_in_r_array_qmckl(i,ipoint)
|
||||
write(222, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
|
||||
enddo
|
||||
enddo
|
||||
|
||||
accu_vgl = 0.d0
|
||||
accu_vgl_nrm = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
ao_val = aos_in_r_array (i,ipoint)
|
||||
ao_der(:) = aos_grad_in_r_array(i,ipoint,:)
|
||||
ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint)
|
||||
accu_vgl_nrm(1) += dabs(ao_val)
|
||||
accu_vgl_nrm(2) += dabs(ao_der(1))
|
||||
accu_vgl_nrm(3) += dabs(ao_der(2))
|
||||
accu_vgl_nrm(4) += dabs(ao_der(3))
|
||||
accu_vgl_nrm(5) += dabs(ao_lap)
|
||||
|
||||
ao_val -= aos_in_r_array_qmckl (i,ipoint)
|
||||
ao_der(:) -= aos_grad_in_r_array_qmckl(i,ipoint,:)
|
||||
ao_lap -= aos_lapl_in_r_array_qmckl(i,ipoint)
|
||||
accu_vgl(1) += dabs(ao_val)
|
||||
accu_vgl(2) += dabs(ao_der(1))
|
||||
accu_vgl(3) += dabs(ao_der(2))
|
||||
accu_vgl(4) += dabs(ao_der(3))
|
||||
accu_vgl(5) += dabs(ao_lap)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
accu_vgl(:) *= 1.d0 / accu_vgl_nrm(:)
|
||||
print *, accu_vgl
|
||||
|
||||
return
|
||||
end
|
||||
|
||||
|
@ -132,6 +132,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
|
||||
double precision, allocatable :: A(:,:,:,:), b(:), A_tmp(:,:,:,:)
|
||||
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
|
||||
double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
|
||||
double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
|
||||
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
|
||||
|
||||
|
||||
@ -176,18 +177,19 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
|
||||
! --- --- ---
|
||||
! get A
|
||||
|
||||
allocate(tmp(n_points_final_grid,ao_num,ao_num))
|
||||
allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
|
||||
allocate(A(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp2(ipoint,i,j) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
@ -195,7 +197,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
|
||||
, tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
|
||||
, 0.d0, A(1,1,1,1), ao_num*ao_num)
|
||||
|
||||
allocate(A_tmp(ao_num,ao_num,ao_num,ao_num))
|
||||
@ -207,13 +209,13 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
|
||||
allocate(b(ao_num*ao_num))
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
u1e_tmp(ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * u1e_tmp(ipoint)
|
||||
u1e_tmp(ipoint) = u1e_tmp(ipoint)
|
||||
enddo
|
||||
|
||||
call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
|
||||
call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp1(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
|
||||
|
||||
deallocate(u1e_tmp)
|
||||
deallocate(tmp)
|
||||
deallocate(tmp1, tmp2)
|
||||
|
||||
! --- --- ---
|
||||
! solve Ax = b
|
||||
|
@ -167,7 +167,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
integer :: jpoint
|
||||
integer :: i_nucl, p, mpA, npA, opA
|
||||
double precision :: r2(3)
|
||||
double precision :: dx, dy, dz, r12, tmp, r12_inv
|
||||
double precision :: dx, dy, dz, r12, tmp
|
||||
double precision :: mu_val, mu_tmp, mu_der(3)
|
||||
double precision :: rn(3), f1A, grad1_f1A(3), f2A, grad2_f2A(3), g12, grad1_g12(3)
|
||||
double precision :: tmp1, tmp2
|
||||
@ -191,19 +191,15 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
|
||||
r12 = dx * dx + dy * dy + dz * dz
|
||||
|
||||
if(r12 .lt. 1d-20) then
|
||||
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
|
||||
if(r12 .lt. 1d-10) then
|
||||
gradx(jpoint) = 0.d0
|
||||
grady(jpoint) = 0.d0
|
||||
gradz(jpoint) = 0.d0
|
||||
cycle
|
||||
endif
|
||||
|
||||
r12_inv = 1.d0/dsqrt(r12)
|
||||
r12 = r12*r12_inv
|
||||
|
||||
tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) * r12_inv
|
||||
tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
|
||||
|
||||
gradx(jpoint) = tmp * dx
|
||||
grady(jpoint) = tmp * dy
|
||||
@ -224,29 +220,23 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
|
||||
|
||||
r12 = dx * dx + dy * dy + dz * dz
|
||||
call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
|
||||
mu_tmp = mu_val * r12
|
||||
tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
|
||||
gradx(jpoint) = tmp * mu_der(1)
|
||||
grady(jpoint) = tmp * mu_der(2)
|
||||
gradz(jpoint) = tmp * mu_der(3)
|
||||
|
||||
if(r12 .lt. 1d-20) then
|
||||
if(r12 .lt. 1d-10) then
|
||||
gradx(jpoint) = 0.d0
|
||||
grady(jpoint) = 0.d0
|
||||
gradz(jpoint) = 0.d0
|
||||
cycle
|
||||
endif
|
||||
|
||||
r12_inv = 1.d0/dsqrt(r12)
|
||||
r12 = r12*r12_inv
|
||||
|
||||
call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
|
||||
|
||||
mu_tmp = mu_val * r12
|
||||
tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
|
||||
|
||||
gradx(jpoint) = tmp * mu_der(1)
|
||||
grady(jpoint) = tmp * mu_der(2)
|
||||
gradz(jpoint) = tmp * mu_der(3)
|
||||
|
||||
tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) * r12_inv
|
||||
tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
|
||||
|
||||
gradx(jpoint) = gradx(jpoint) + tmp * dx
|
||||
grady(jpoint) = grady(jpoint) + tmp * dy
|
||||
@ -273,8 +263,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dx * dx + dy * dy + dz * dz
|
||||
|
||||
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
|
||||
if(r12 .lt. 1d-10) then
|
||||
gradx(jpoint) = 0.d0
|
||||
grady(jpoint) = 0.d0
|
||||
@ -282,8 +271,6 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
cycle
|
||||
endif
|
||||
|
||||
r12 = dsqrt(r12)
|
||||
|
||||
tmp = 1.d0 + a_boys * r12
|
||||
tmp = 0.5d0 / (r12 * tmp * tmp)
|
||||
|
||||
@ -294,13 +281,16 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
|
||||
elseif(j2e_type .eq. "Boys_Handy") then
|
||||
|
||||
integer :: powmax
|
||||
powmax = max(maxval(jBH_m),maxval(jBH_n))
|
||||
|
||||
integer :: powmax1, powmax, powmax2
|
||||
double precision, allocatable :: f1A_power(:), f2A_power(:), double_p(:), g12_power(:)
|
||||
allocate (f1A_power(-1:powmax), f2A_power(-1:powmax), g12_power(-1:powmax), double_p(0:powmax))
|
||||
|
||||
do p=0,powmax
|
||||
powmax1 = max(maxval(jBH_m), maxval(jBH_n))
|
||||
powmax2 = maxval(jBH_o)
|
||||
powmax = max(powmax1, powmax2)
|
||||
|
||||
allocate(f1A_power(-1:powmax), f2A_power(-1:powmax), g12_power(-1:powmax), double_p(0:powmax))
|
||||
|
||||
do p = 0, powmax
|
||||
double_p(p) = dble(p)
|
||||
enddo
|
||||
|
||||
@ -321,7 +311,6 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
gradx(jpoint) = 0.d0
|
||||
grady(jpoint) = 0.d0
|
||||
gradz(jpoint) = 0.d0
|
||||
|
||||
do i_nucl = 1, nucl_num
|
||||
|
||||
rn(1) = nucl_coord(i_nucl,1)
|
||||
@ -332,23 +321,15 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
call jBH_elem_fct_grad(jBH_en(i_nucl), r2, rn, f2A, grad2_f2A)
|
||||
call jBH_elem_fct_grad(jBH_ee(i_nucl), r1, r2, g12, grad1_g12)
|
||||
|
||||
|
||||
! Compute powers of f1A and f2A
|
||||
|
||||
do p = 1, maxval(jBH_m(:,i_nucl))
|
||||
do p = 1, powmax1
|
||||
f1A_power(p) = f1A_power(p-1) * f1A
|
||||
enddo
|
||||
|
||||
do p = 1, maxval(jBH_n(:,i_nucl))
|
||||
f2A_power(p) = f2A_power(p-1) * f2A
|
||||
enddo
|
||||
|
||||
do p = 1, maxval(jBH_o(:,i_nucl))
|
||||
do p = 1, powmax2
|
||||
g12_power(p) = g12_power(p-1) * g12
|
||||
enddo
|
||||
|
||||
|
||||
|
||||
do p = 1, jBH_size
|
||||
mpA = jBH_m(p,i_nucl)
|
||||
npA = jBH_n(p,i_nucl)
|
||||
@ -358,27 +339,22 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
tmp = tmp * 0.5d0
|
||||
endif
|
||||
|
||||
!TODO : Powers to optimize here
|
||||
|
||||
! tmp1 = 0.d0
|
||||
! if(mpA .gt. 0) then
|
||||
! tmp1 = tmp1 + dble(mpA) * f1A**(mpA-1) * f2A**npA
|
||||
! endif
|
||||
! if(npA .gt. 0) then
|
||||
! tmp1 = tmp1 + dble(npA) * f1A**(npA-1) * f2A**mpA
|
||||
! endif
|
||||
! tmp1 = tmp1 * g12**(opA)
|
||||
!
|
||||
! tmp2 = 0.d0
|
||||
! if(opA .gt. 0) then
|
||||
! tmp2 = tmp2 + dble(opA) * g12**(opA-1) * (f1A**(mpA) * f2A**(npA) + f1A**(npA) * f2A**(mpA))
|
||||
! endif
|
||||
|
||||
tmp1 = double_p(mpA) * f1A_power(mpA-1) * f2A_power(npA) + double_p(npA) * f1A_power(npA-1) * f2A_power(mpA)
|
||||
tmp1 = tmp1 * g12_power(opA)
|
||||
|
||||
tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA))
|
||||
|
||||
!tmp1 = 0.d0
|
||||
!if(mpA .gt. 0) then
|
||||
! tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA)
|
||||
!endif
|
||||
!if(npA .gt. 0) then
|
||||
! tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA)
|
||||
!endif
|
||||
!tmp1 = tmp1 * g12**dble(opA)
|
||||
!tmp2 = 0.d0
|
||||
!if(opA .gt. 0) then
|
||||
! tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA))
|
||||
!endif
|
||||
|
||||
gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1))
|
||||
grady(jpoint) = grady(jpoint) + tmp * (tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2))
|
||||
@ -418,7 +394,7 @@ subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r2(3)
|
||||
double precision :: dx, dy, dz, r12, r12_inv, tmp
|
||||
double precision :: dx, dy, dz, r12, tmp
|
||||
|
||||
|
||||
do jpoint = 1, n_points_extra_final_grid ! r2
|
||||
@ -431,19 +407,15 @@ subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
|
||||
r12 = dx * dx + dy * dy + dz * dz
|
||||
|
||||
if(r12 .lt. 1d-20) then
|
||||
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
|
||||
if(r12 .lt. 1d-10) then
|
||||
gradx(jpoint) = 0.d0
|
||||
grady(jpoint) = 0.d0
|
||||
gradz(jpoint) = 0.d0
|
||||
cycle
|
||||
endif
|
||||
|
||||
r12_inv = 1.d0 / dsqrt(r12)
|
||||
r12 = r12 * r12_inv
|
||||
|
||||
tmp = 0.5d0 * (1.d0 - derf(mu * r12)) * r12_inv
|
||||
tmp = 0.5d0 * (1.d0 - derf(mu * r12)) / r12
|
||||
|
||||
gradx(jpoint) = tmp * dx
|
||||
grady(jpoint) = tmp * dy
|
||||
@ -467,7 +439,7 @@ subroutine j12_r1_seq(r1, n_grid2, res)
|
||||
integer :: jpoint
|
||||
double precision :: r2(3)
|
||||
double precision :: dx, dy, dz
|
||||
double precision :: mu_tmp, r12, mu_erf_inv
|
||||
double precision :: mu_tmp, r12
|
||||
|
||||
PROVIDE final_grid_points_extra
|
||||
|
||||
@ -475,7 +447,6 @@ subroutine j12_r1_seq(r1, n_grid2, res)
|
||||
|
||||
PROVIDE mu_erf
|
||||
|
||||
mu_erf_inv = 1.d0 / mu_erf
|
||||
do jpoint = 1, n_points_extra_final_grid ! r2
|
||||
|
||||
r2(1) = final_grid_points_extra(1,jpoint)
|
||||
@ -489,7 +460,7 @@ subroutine j12_r1_seq(r1, n_grid2, res)
|
||||
|
||||
mu_tmp = mu_erf * r12
|
||||
|
||||
res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) * mu_erf_inv
|
||||
res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
|
||||
enddo
|
||||
|
||||
elseif(j2e_type .eq. "Boys") then
|
||||
|
@ -179,7 +179,7 @@ double precision function num_v_ij_erf_rk_cst_mu_env(i, j, ipoint)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
r12 = dsqrt(dx*dx + dy*dy + dz*dz)
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
|
||||
@ -228,7 +228,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
r12 = dsqrt(dx*dx + dy*dy + dz*dz)
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
|
||||
@ -530,7 +530,7 @@ subroutine num_int2_u_grad1u_total_env2(i, j, ipoint, integ)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
r12 = dsqrt(dx*dx + dy*dy + dz*dz)
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp0 = env_nucl(r2)
|
||||
|
@ -75,3 +75,107 @@ BEGIN_PROVIDER [ integer*8, qmckl_ctx_jastrow ]
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, aos_in_r_array_qmckl, (ao_num,n_points_final_grid)]
|
||||
&BEGIN_PROVIDER [ double precision, aos_grad_in_r_array_qmckl, (ao_num,n_points_final_grid,3)]
|
||||
&BEGIN_PROVIDER [ double precision, aos_lapl_in_r_array_qmckl, (ao_num, n_points_final_grid)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! AOS computed with qmckl
|
||||
END_DOC
|
||||
use qmckl
|
||||
|
||||
integer*8 :: qmckl_ctx
|
||||
integer(qmckl_exit_code) :: rc
|
||||
|
||||
qmckl_ctx = qmckl_context_create()
|
||||
|
||||
rc = qmckl_trexio_read(qmckl_ctx, trexio_file, 1_8*len(trim(trexio_filename)))
|
||||
if (rc /= QMCKL_SUCCESS) then
|
||||
print *, irp_here, 'qmckl error in read_trexio'
|
||||
rc = qmckl_check(qmckl_ctx, rc)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
rc = qmckl_set_point(qmckl_ctx, 'N', n_points_final_grid*1_8, final_grid_points, n_points_final_grid*3_8)
|
||||
if (rc /= QMCKL_SUCCESS) then
|
||||
print *, irp_here, 'qmckl error in set_electron_point'
|
||||
rc = qmckl_check(qmckl_ctx, rc)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
double precision, allocatable :: vgl(:,:,:)
|
||||
allocate( vgl(ao_num,5,n_points_final_grid))
|
||||
rc = qmckl_get_ao_basis_ao_vgl_inplace(qmckl_ctx, vgl, n_points_final_grid*ao_num*5_8)
|
||||
if (rc /= QMCKL_SUCCESS) then
|
||||
print *, irp_here, 'qmckl error in get_ao_vgl'
|
||||
rc = qmckl_check(qmckl_ctx, rc)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
integer :: i,k
|
||||
do k=1,n_points_final_grid
|
||||
do i=1,ao_num
|
||||
aos_in_r_array_qmckl(i,k) = vgl(i,1,k)
|
||||
aos_grad_in_r_array_qmckl(i,k,1) = vgl(i,2,k)
|
||||
aos_grad_in_r_array_qmckl(i,k,2) = vgl(i,3,k)
|
||||
aos_grad_in_r_array_qmckl(i,k,3) = vgl(i,4,k)
|
||||
aos_lapl_in_r_array_qmckl(i,k) = vgl(i,5,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mos_in_r_array_qmckl, (mo_num,n_points_final_grid)]
|
||||
&BEGIN_PROVIDER [ double precision, mos_grad_in_r_array_qmckl, (mo_num,n_points_final_grid,3)]
|
||||
&BEGIN_PROVIDER [ double precision, mos_lapl_in_r_array_qmckl, (mo_num, n_points_final_grid)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! moS computed with qmckl
|
||||
END_DOC
|
||||
use qmckl
|
||||
|
||||
integer*8 :: qmckl_ctx
|
||||
integer(qmckl_exit_code) :: rc
|
||||
|
||||
qmckl_ctx = qmckl_context_create()
|
||||
|
||||
rc = qmckl_trexio_read(qmckl_ctx, trexio_file, 1_8*len(trim(trexio_filename)))
|
||||
if (rc /= QMCKL_SUCCESS) then
|
||||
print *, irp_here, 'qmckl error in read_trexio'
|
||||
rc = qmckl_check(qmckl_ctx, rc)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
rc = qmckl_set_point(qmckl_ctx, 'N', n_points_final_grid*1_8, final_grid_points, n_points_final_grid*3_8)
|
||||
if (rc /= QMCKL_SUCCESS) then
|
||||
print *, irp_here, 'qmckl error in set_electron_point'
|
||||
rc = qmckl_check(qmckl_ctx, rc)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
double precision, allocatable :: vgl(:,:,:)
|
||||
allocate( vgl(mo_num,5,n_points_final_grid))
|
||||
rc = qmckl_get_mo_basis_mo_vgl_inplace(qmckl_ctx, vgl, n_points_final_grid*mo_num*5_8)
|
||||
if (rc /= QMCKL_SUCCESS) then
|
||||
print *, irp_here, 'qmckl error in get_mo_vgl'
|
||||
rc = qmckl_check(qmckl_ctx, rc)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
integer :: i,k
|
||||
do k=1,n_points_final_grid
|
||||
do i=1,mo_num
|
||||
mos_in_r_array_qmckl(i,k) = vgl(i,1,k)
|
||||
mos_grad_in_r_array_qmckl(i,k,1) = vgl(i,2,k)
|
||||
mos_grad_in_r_array_qmckl(i,k,2) = vgl(i,3,k)
|
||||
mos_grad_in_r_array_qmckl(i,k,3) = vgl(i,4,k)
|
||||
mos_lapl_in_r_array_qmckl(i,k) = vgl(i,5,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
@ -45,13 +45,91 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
|
||||
|
||||
print *, ' Numerical integration over r1 and r2 will be performed'
|
||||
|
||||
! TODO combine 1shot & int2_grad1_u12_ao_num
|
||||
if(tc_save_mem) then
|
||||
|
||||
integer :: n_blocks, n_rest, n_pass
|
||||
integer :: i_blocks, i_rest, i_pass, ii
|
||||
double precision :: mem, n_double
|
||||
double precision, allocatable :: tmp(:,:,:), xx(:)
|
||||
double precision, allocatable :: tmp_grad1_u12(:,:,:)
|
||||
|
||||
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
|
||||
|
||||
allocate(tmp(n_points_extra_final_grid,ao_num,ao_num), xx(n_points_extra_final_grid))
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (j, i, jpoint) &
|
||||
!$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do jpoint = 1, n_points_extra_final_grid
|
||||
tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
call total_memory(mem)
|
||||
mem = max(1.d0, qp_max_mem - mem)
|
||||
n_double = mem * 1.d8
|
||||
n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
|
||||
n_rest = int(mod(n_points_final_grid, n_blocks))
|
||||
n_pass = int((n_points_final_grid - n_rest) / n_blocks)
|
||||
call write_int(6, n_pass, 'Number of passes')
|
||||
call write_int(6, n_blocks, 'Size of the blocks')
|
||||
call write_int(6, n_rest, 'Size of the last block')
|
||||
allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3))
|
||||
do i_pass = 1, n_pass
|
||||
ii = (i_pass-1)*n_blocks + 1
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_blocks, ipoint) &
|
||||
!$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, xx, tmp_grad1_u12)
|
||||
!$OMP DO
|
||||
do i_blocks = 1, n_blocks
|
||||
ipoint = ii - 1 + i_blocks ! r1
|
||||
call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1), tmp_grad1_u12(1,i_blocks,2), tmp_grad1_u12(1,i_blocks,3), xx(1))
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
do m = 1, 3
|
||||
call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
|
||||
, 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(tmp_grad1_u12)
|
||||
if(n_rest .gt. 0) then
|
||||
allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3))
|
||||
ii = n_pass*n_blocks + 1
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_rest, ipoint) &
|
||||
!$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, xx, tmp_grad1_u12)
|
||||
!$OMP DO
|
||||
do i_rest = 1, n_rest
|
||||
ipoint = ii - 1 + i_rest ! r1
|
||||
call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1), tmp_grad1_u12(1,i_rest,2), tmp_grad1_u12(1,i_rest,3), xx(1))
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
do m = 1, 3
|
||||
call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
|
||||
, 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num)
|
||||
enddo
|
||||
deallocate(tmp_grad1_u12)
|
||||
endif
|
||||
deallocate(tmp,xx)
|
||||
|
||||
else
|
||||
! TODO combine 1shot & int2_grad1_u12_ao_num
|
||||
PROVIDE int2_grad1_u12_ao_num
|
||||
int2_grad1_u12_ao = int2_grad1_u12_ao_num
|
||||
|
||||
!PROVIDE int2_grad1_u12_ao_num_1shot
|
||||
!int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
|
||||
endif
|
||||
|
||||
elseif(tc_integ_type .eq. "semi-analytic") then
|
||||
|
||||
@ -177,13 +255,88 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
|
||||
|
||||
print *, ' Numerical integration over r1 and r2 will be performed'
|
||||
|
||||
! TODO combine 1shot & int2_grad1_u12_square_ao_num
|
||||
if(tc_save_mem) then
|
||||
|
||||
integer :: n_blocks, n_rest, n_pass
|
||||
integer :: i_blocks, i_rest, i_pass, ii
|
||||
double precision :: mem, n_double
|
||||
double precision, allocatable :: tmp(:,:,:), xx(:,:,:)
|
||||
double precision, allocatable :: tmp_grad1_u12_squared(:,:)
|
||||
|
||||
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
|
||||
|
||||
allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (j, i, jpoint) &
|
||||
!$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do jpoint = 1, n_points_extra_final_grid
|
||||
tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
call total_memory(mem)
|
||||
mem = max(1.d0, qp_max_mem - mem)
|
||||
n_double = mem * 1.d8
|
||||
n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
|
||||
n_rest = int(mod(n_points_final_grid, n_blocks))
|
||||
n_pass = int((n_points_final_grid - n_rest) / n_blocks)
|
||||
call write_int(6, n_pass, 'Number of passes')
|
||||
call write_int(6, n_blocks, 'Size of the blocks')
|
||||
call write_int(6, n_rest, 'Size of the last block')
|
||||
allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks), xx(n_points_extra_final_grid,n_blocks,3))
|
||||
do i_pass = 1, n_pass
|
||||
ii = (i_pass-1)*n_blocks + 1
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_blocks, ipoint) &
|
||||
!$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, xx, final_grid_points, tmp_grad1_u12_squared)
|
||||
!$OMP DO
|
||||
do i_blocks = 1, n_blocks
|
||||
ipoint = ii - 1 + i_blocks ! r1
|
||||
call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, xx(1,i_blocks,1), xx(1,i_blocks,2), xx(1,i_blocks,3), tmp_grad1_u12_squared(1,i_blocks))
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, -0.5d0 &
|
||||
, tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
|
||||
, 0.d0, int2_grad1_u12_square_ao(1,1,ii), ao_num*ao_num)
|
||||
enddo
|
||||
deallocate(tmp_grad1_u12_squared, xx)
|
||||
if(n_rest .gt. 0) then
|
||||
ii = n_pass*n_blocks + 1
|
||||
allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest), xx(n_points_extra_final_grid,n_rest,3))
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_rest, ipoint) &
|
||||
!$OMP SHARED (n_rest, n_points_extra_final_grid, ii, xx, final_grid_points, tmp_grad1_u12_squared)
|
||||
!$OMP DO
|
||||
do i_rest = 1, n_rest
|
||||
ipoint = ii - 1 + i_rest ! r1
|
||||
call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, xx(1,i_rest,1), xx(1,i_rest,2), xx(1,i_rest,3), tmp_grad1_u12_squared(1,i_rest))
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, -0.5d0 &
|
||||
, tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
|
||||
, 0.d0, int2_grad1_u12_square_ao(1,1,ii), ao_num*ao_num)
|
||||
deallocate(tmp_grad1_u12_squared, xx)
|
||||
endif
|
||||
deallocate(tmp)
|
||||
|
||||
else
|
||||
|
||||
! TODO combine 1shot & int2_grad1_u12_square_ao_num
|
||||
PROVIDE int2_grad1_u12_square_ao_num
|
||||
int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
|
||||
|
||||
!PROVIDE int2_grad1_u12_square_ao_num_1shot
|
||||
!int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
|
||||
endif
|
||||
|
||||
elseif(tc_integ_type .eq. "semi-analytic") then
|
||||
|
||||
|
@ -66,9 +66,7 @@
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_blocks, ipoint) &
|
||||
!$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
|
||||
!$OMP final_grid_points, tmp_grad1_u12, &
|
||||
!$OMP tmp_grad1_u12_squared)
|
||||
!$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
|
||||
!$OMP DO
|
||||
do i_blocks = 1, n_blocks
|
||||
ipoint = ii - 1 + i_blocks ! r1
|
||||
@ -102,9 +100,7 @@
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_rest, ipoint) &
|
||||
!$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
|
||||
!$OMP final_grid_points, tmp_grad1_u12, &
|
||||
!$OMP tmp_grad1_u12_squared)
|
||||
!$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
|
||||
!$OMP DO
|
||||
do i_rest = 1, n_rest
|
||||
ipoint = ii - 1 + i_rest ! r1
|
||||
@ -131,7 +127,7 @@
|
||||
deallocate(tmp)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num =', time1-time0
|
||||
print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num = (min)', (time1-time0) / 60.d0
|
||||
call print_memory_usage()
|
||||
|
||||
END_PROVIDER
|
||||
|
@ -1125,6 +1125,7 @@ subroutine test_fit_coef_A1()
|
||||
double precision :: accu, norm, diff
|
||||
double precision, allocatable :: A1(:,:)
|
||||
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:)
|
||||
double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
|
||||
|
||||
! ---
|
||||
|
||||
@ -1165,16 +1166,17 @@ subroutine test_fit_coef_A1()
|
||||
|
||||
call wall_time(t1)
|
||||
|
||||
allocate(tmp(ao_num,ao_num,n_points_final_grid))
|
||||
allocate(tmp1(ao_num,ao_num,n_points_final_grid), tmp2(ao_num,ao_num,n_points_final_grid))
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp1(i,j,ipoint) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp2(i,j,ipoint) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
@ -1184,9 +1186,9 @@ subroutine test_fit_coef_A1()
|
||||
allocate(A2(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
|
||||
, tmp1(1,1,1), ao_num*ao_num, tmp2(1,1,1), ao_num*ao_num &
|
||||
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
|
||||
deallocate(tmp)
|
||||
deallocate(tmp1, tmp2)
|
||||
|
||||
call wall_time(t2)
|
||||
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
|
||||
@ -1238,6 +1240,7 @@ subroutine test_fit_coef_inv()
|
||||
double precision, allocatable :: A1(:,:), A1_inv(:,:), A1_tmp(:,:)
|
||||
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:), A2_inv(:,:,:,:)
|
||||
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A2_tmp(:,:,:,:)
|
||||
double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
|
||||
|
||||
cutoff_svd = 5d-8
|
||||
|
||||
@ -1286,16 +1289,17 @@ subroutine test_fit_coef_inv()
|
||||
|
||||
call wall_time(t1)
|
||||
|
||||
allocate(tmp(n_points_final_grid,ao_num,ao_num))
|
||||
allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp2(ipoint,i,j) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
@ -1305,10 +1309,10 @@ subroutine test_fit_coef_inv()
|
||||
allocate(A2(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
|
||||
, tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
|
||||
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
|
||||
|
||||
deallocate(tmp)
|
||||
deallocate(tmp1, tmp2)
|
||||
|
||||
call wall_time(t2)
|
||||
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
|
||||
|
@ -33,8 +33,10 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
double precision :: weight1, ao_k_r, ao_i_r
|
||||
double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
|
||||
double precision :: time0, time1
|
||||
double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:)
|
||||
double precision, allocatable :: c_mat(:,:,:)
|
||||
logical, external :: ao_two_e_integral_zero
|
||||
double precision, external :: get_ao_two_e_integral
|
||||
double precision, external :: ao_two_e_integral
|
||||
|
||||
PROVIDe tc_integ_type
|
||||
PROVIDE env_type
|
||||
@ -53,7 +55,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
print*, ' Reading ao_two_e_tc_tot from ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
|
||||
|
||||
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read")
|
||||
read(11) ao_two_e_tc_tot
|
||||
do i = 1, ao_num
|
||||
read(11) ao_two_e_tc_tot(:,:,:,i)
|
||||
enddo
|
||||
close(11)
|
||||
|
||||
else
|
||||
@ -65,8 +69,39 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
|
||||
PROVIDE int2_grad1_u12_square_ao
|
||||
|
||||
allocate(c_mat(n_points_final_grid,ao_num,ao_num))
|
||||
if(tc_save_mem_loops) then
|
||||
|
||||
print*, ' LOOPS are used to evaluate Hermitian part of ao_two_e_tc_tot ...'
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l, ipoint, ao_i_r, ao_k_r, weight1) &
|
||||
!$OMP SHARED (ao_num, n_points_final_grid, ao_two_e_tc_tot, &
|
||||
!$OMP aos_in_r_array_transp, final_weight_at_r_vector, int2_grad1_u12_square_ao)
|
||||
!$OMP DO COLLAPSE(4)
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
ao_two_e_tc_tot(j,l,k,i) = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight1 = final_weight_at_r_vector(ipoint)
|
||||
ao_i_r = aos_in_r_array_transp(ipoint,i)
|
||||
ao_k_r = aos_in_r_array_transp(ipoint,k)
|
||||
ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) + int2_grad1_u12_square_ao(j,l,ipoint) * weight1 * ao_i_r * ao_k_r
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
else
|
||||
|
||||
print*, ' DGEMM are used to evaluate Hermitian part of ao_two_e_tc_tot ...'
|
||||
|
||||
allocate(c_mat(n_points_final_grid,ao_num,ao_num))
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, k, ipoint) &
|
||||
@ -81,10 +116,11 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
|
||||
, 0.d0, ao_two_e_tc_tot, ao_num*ao_num)
|
||||
deallocate(c_mat)
|
||||
endif
|
||||
|
||||
FREE int2_grad1_u12_square_ao
|
||||
|
||||
@ -96,6 +132,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
! an additional term is added here directly instead of
|
||||
! being added in int2_grad1_u12_square_ao for performance
|
||||
|
||||
allocate(c_mat(n_points_final_grid,ao_num,ao_num))
|
||||
PROVIDE int2_u2_env2
|
||||
|
||||
!$OMP PARALLEL &
|
||||
@ -127,10 +164,13 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
, int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
|
||||
, 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
|
||||
|
||||
deallocate(c_mat)
|
||||
FREE int2_u2_env2
|
||||
endif ! use_ipp
|
||||
|
||||
deallocate(c_mat)
|
||||
call wall_time(time1)
|
||||
print*, ' done with Hermitian part after (min) ', (time1 - time0) / 60.d0
|
||||
call print_memory_usage()
|
||||
|
||||
! ---
|
||||
|
||||
@ -138,13 +178,48 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
|
||||
PROVIDE int2_grad1_u12_ao
|
||||
|
||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
|
||||
if(tc_save_mem_loops) then
|
||||
|
||||
print*, ' LOOPS are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...'
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l, ipoint, ao_i_r, ao_k_r, weight1) &
|
||||
!$OMP SHARED (ao_num, n_points_final_grid, ao_two_e_tc_tot, &
|
||||
!$OMP aos_in_r_array_transp, final_weight_at_r_vector, &
|
||||
!$OMP int2_grad1_u12_ao, aos_grad_in_r_array_transp_bis)
|
||||
!$OMP DO COLLAPSE(4)
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
|
||||
ao_i_r = aos_in_r_array_transp(ipoint,i)
|
||||
ao_k_r = aos_in_r_array_transp(ipoint,k)
|
||||
ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) &
|
||||
- weight1 * int2_grad1_u12_ao(j,l,ipoint,1) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) &
|
||||
- weight1 * int2_grad1_u12_ao(j,l,ipoint,2) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) &
|
||||
- weight1 * int2_grad1_u12_ao(j,l,ipoint,3) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
else
|
||||
|
||||
print*, ' DGEMM are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...'
|
||||
|
||||
allocate(c_mat(n_points_final_grid,ao_num,ao_num))
|
||||
do m = 1, 3
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
|
||||
!$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, &
|
||||
!$OMP ao_num, n_points_final_grid, final_weight_at_r_vector)
|
||||
!$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, c_mat, &
|
||||
!$OMP ao_num, n_points_final_grid, final_weight_at_r_vector, m)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
@ -154,23 +229,20 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
ao_i_r = aos_in_r_array_transp(ipoint,i)
|
||||
ao_k_r = aos_in_r_array_transp(ipoint,k)
|
||||
|
||||
b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1))
|
||||
b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2))
|
||||
b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
|
||||
c_mat(ipoint,k,i) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,m) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,m))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do m = 1, 3
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
|
||||
, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
|
||||
, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
|
||||
, 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
|
||||
enddo
|
||||
deallocate(b_mat)
|
||||
deallocate(c_mat)
|
||||
|
||||
FREE int2_grad1_u12_ao
|
||||
end if
|
||||
|
||||
if(tc_integ_type .eq. "semi-analytic") then
|
||||
FREE int2_grad1_u2e_ao
|
||||
@ -178,16 +250,50 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
|
||||
endif ! var_tc
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' done with non-Hermitian part after (min) ', (time1 - time0) / 60.d0
|
||||
call print_memory_usage()
|
||||
|
||||
! ---
|
||||
|
||||
call sum_A_At(ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
|
||||
|
||||
PROVIDE ao_integrals_map
|
||||
! ---
|
||||
|
||||
logical :: integ_zero
|
||||
double precision :: integ_val
|
||||
|
||||
print*, ' adding ERI to ao_two_e_tc_tot ...'
|
||||
|
||||
if(tc_save_mem) then
|
||||
print*, ' ao_integrals_map will not be used'
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP PRIVATE(i, j, k, l, integ_zero, integ_val) &
|
||||
!$OMP SHARED(ao_num, ao_two_e_tc_tot)
|
||||
!$OMP DO COLLAPSE(4)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
integ_zero = ao_two_e_integral_zero(i,j,k,l)
|
||||
if(.not. integ_zero) then
|
||||
! i,k : r1 j,l : r2
|
||||
integ_val = ao_two_e_integral(i,k,j,l)
|
||||
ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + integ_val
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
else
|
||||
print*, ' ao_integrals_map will be used'
|
||||
PROVIDE ao_integrals_map
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
|
||||
!$OMP PRIVATE(i, j, k, l)
|
||||
!$OMP DO
|
||||
!$OMP DO COLLAPSE(4)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
@ -200,8 +306,11 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
!call clear_ao_map()
|
||||
FREE ao_integrals_map
|
||||
endif
|
||||
|
||||
if(tc_integ_type .eq. "numeric") then
|
||||
if((tc_integ_type .eq. "numeric") .and. (.not. tc_save_mem)) then
|
||||
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
|
||||
endif
|
||||
|
||||
@ -211,7 +320,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
||||
print*, ' Saving ao_two_e_tc_tot in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
|
||||
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write")
|
||||
call ezfio_set_work_empty(.False.)
|
||||
write(11) ao_two_e_tc_tot
|
||||
do i = 1, ao_num
|
||||
write(11) ao_two_e_tc_tot(:,:,:,i)
|
||||
enddo
|
||||
close(11)
|
||||
call ezfio_set_tc_keywords_io_tc_integ('Read')
|
||||
endif
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -273,60 +273,6 @@ end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine lapack_diag_non_sym_right(n, A, WR, WI, VR)
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: A(n,n)
|
||||
double precision, intent(out) :: WR(n), WI(n), VR(n,n)
|
||||
|
||||
integer :: i, lda, ldvl, ldvr, LWORK, INFO
|
||||
double precision, allocatable :: Atmp(:,:), WORK(:), VL(:,:)
|
||||
|
||||
lda = n
|
||||
ldvl = 1
|
||||
ldvr = n
|
||||
|
||||
allocate( Atmp(n,n), VL(1,1) )
|
||||
Atmp(1:n,1:n) = A(1:n,1:n)
|
||||
|
||||
allocate(WORK(1))
|
||||
LWORK = -1
|
||||
call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
|
||||
if(INFO.gt.0)then
|
||||
print*,'dgeev failed !!',INFO
|
||||
stop
|
||||
endif
|
||||
|
||||
LWORK = max(int(WORK(1)), 1) ! this is the optimal size of WORK
|
||||
deallocate(WORK)
|
||||
|
||||
allocate(WORK(LWORK))
|
||||
|
||||
! Actual diagonalization
|
||||
call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
|
||||
if(INFO.ne.0) then
|
||||
print*,'dgeev failed !!', INFO
|
||||
stop
|
||||
endif
|
||||
|
||||
deallocate(Atmp, WORK, VL)
|
||||
|
||||
! print *, ' JOBL = F'
|
||||
! print *, ' eigenvalues'
|
||||
! do i = 1, n
|
||||
! write(*, '(1000(F16.10,X))') WR(i), WI(i)
|
||||
! enddo
|
||||
! print *, ' right eigenvect'
|
||||
! do i = 1, n
|
||||
! write(*, '(1000(F16.10,X))') VR(:,i)
|
||||
! enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine non_hrmt_real_diag(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||
|
||||
BEGIN_DOC
|
||||
@ -1780,70 +1726,6 @@ end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_nd, S, stop_ifnot)
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n, m
|
||||
double precision, intent(in) :: Vl(n,m), Vr(n,m), W(n,n)
|
||||
double precision, intent(in) :: thr_d, thr_nd
|
||||
logical, intent(in) :: stop_ifnot
|
||||
double precision, intent(out) :: accu_d, accu_nd, S(m,m)
|
||||
|
||||
integer :: i, j
|
||||
double precision, allocatable :: SS(:,:), tmp(:,:)
|
||||
|
||||
print *, ' check weighted bi-orthogonality'
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp(m,n))
|
||||
call dgemm( 'T', 'N', m, n, n, 1.d0 &
|
||||
, Vl, size(Vl, 1), W, size(W, 1) &
|
||||
, 0.d0, tmp, size(tmp, 1) )
|
||||
call dgemm( 'N', 'N', m, m, n, 1.d0 &
|
||||
, tmp, size(tmp, 1), Vr, size(Vr, 1) &
|
||||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(tmp)
|
||||
|
||||
!print *, ' overlap matrix:'
|
||||
!do i = 1, m
|
||||
! write(*,'(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
do i = 1, m
|
||||
do j = 1, m
|
||||
if(i==j) then
|
||||
accu_d = accu_d + dabs(S(i,i))
|
||||
else
|
||||
accu_nd = accu_nd + S(j,i) * S(j,i)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
accu_nd = dsqrt(accu_nd)
|
||||
|
||||
print *, ' accu_nd = ', accu_nd
|
||||
print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
|
||||
|
||||
! ---
|
||||
|
||||
if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
|
||||
print *, ' non bi-orthogonal vectors !'
|
||||
print *, ' accu_nd = ', accu_nd
|
||||
print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
|
||||
!print *, ' overlap matrix:'
|
||||
!do i = 1, m
|
||||
! write(*,'(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
stop
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ifnot)
|
||||
|
||||
implicit none
|
||||
@ -2144,6 +2026,7 @@ subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0)
|
||||
enddo
|
||||
!print*,' accu_nd after = ', accu_nd
|
||||
if(accu_nd .gt. 1d-12) then
|
||||
print*, ' accu_nd =', accu_nd
|
||||
print*, ' your strategy for degenerates orbitals failed !'
|
||||
print*, m, 'deg on', i
|
||||
stop
|
||||
|
@ -1,670 +0,0 @@
|
||||
subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
|
||||
!
|
||||
! of a non hermitian matrix A(n,n)
|
||||
!
|
||||
! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: A(n,n)
|
||||
integer, intent(out) :: n_real_eigv
|
||||
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||
|
||||
integer :: i, j, n_degen,k , iteration
|
||||
double precision :: shift_current
|
||||
double precision :: r,thr,accu_d, accu_nd
|
||||
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||
double precision, allocatable :: im_part(:),re_part(:)
|
||||
double precision :: accu,thr_cut, thr_norm=1d0
|
||||
|
||||
|
||||
thr_cut = 1.d-15
|
||||
print*,'Computing the left/right eigenvectors ...'
|
||||
print*,'Using the degeneracy splitting algorithm'
|
||||
! initialization
|
||||
shift_current = 1.d-15
|
||||
iteration = 0
|
||||
print*,'***** iteration = ',iteration
|
||||
|
||||
|
||||
! pre-processing the matrix :: sorting by diagonal elements
|
||||
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||
! print*,'Aw'
|
||||
do i = 1, n
|
||||
iorder_origin(i) = i
|
||||
diag_elem(i) = A(i,i)
|
||||
! write(*,'(100(F16.10,X))')A(:,i)
|
||||
enddo
|
||||
call dsort(diag_elem, iorder_origin, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||
allocate(im_part(n),iorder(n))
|
||||
allocate( S(n,n) )
|
||||
|
||||
|
||||
Aw = A_save
|
||||
call cancel_small_elmts(aw,n,thr_cut)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv += 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
|
||||
|
||||
do while(n_real_eigv.ne.n)
|
||||
iteration += 1
|
||||
print*,'***** iteration = ',iteration
|
||||
if(shift_current.gt.1.d-3)then
|
||||
print*,'shift_current > 1.d-3 !!'
|
||||
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||
stop
|
||||
endif
|
||||
Aw = A_save
|
||||
call cancel_small_elmts(Aw,n,thr_cut)
|
||||
call split_matrix_degen(Aw,n,shift_current)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv+= 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
enddo
|
||||
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||
do i = 1, n
|
||||
eigval(i) = WR(i)
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(eigval,iorder,n)
|
||||
do i = 1, n
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||
enddo
|
||||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
print *, ' bi-orthogonality: not imposed yet'
|
||||
print *, ' '
|
||||
print *, ' '
|
||||
print *, ' orthog between degen eigenvect'
|
||||
print *, ' '
|
||||
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||
allocate(S_nh_inv_half(n,n))
|
||||
logical :: complex_root
|
||||
deallocate(S_nh_inv_half)
|
||||
call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp)
|
||||
call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
print*,'Must be a deep problem ...'
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!! RECOMPUTING THE EIGENVALUES
|
||||
eigval = 0.d0
|
||||
do i = 1, n
|
||||
iorder(i) = i
|
||||
accu = 0.d0
|
||||
do j = 1, n
|
||||
accu += VL(j,i) * VR(j,i)
|
||||
do k = 1, n
|
||||
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||
enddo
|
||||
enddo
|
||||
eigval(i) *= 1.d0/accu
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
enddo
|
||||
!! RESORT JUST TO BE SURE
|
||||
call dsort(eigval, iorder, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
reigvec(j,i) = VR(j,iorder(i))
|
||||
leigvec(j,i) = VL(j,iorder(i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'Checking for final reigvec/leigvec'
|
||||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
print*,'Eigenvectors are not bi orthonormal ..'
|
||||
print*,'accu_nd = ',accu_nd
|
||||
stop
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
|
||||
!
|
||||
! of a non hermitian matrix A(n,n)
|
||||
!
|
||||
! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: A(n,n)
|
||||
integer, intent(out) :: n_real_eigv
|
||||
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||
|
||||
integer :: i, j, n_degen,k , iteration
|
||||
double precision :: shift_current
|
||||
double precision :: r,thr,accu_d, accu_nd
|
||||
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||
double precision, allocatable :: im_part(:),re_part(:)
|
||||
double precision :: accu,thr_cut, thr_norm=1.d0
|
||||
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||
logical :: complex_root
|
||||
|
||||
|
||||
thr_cut = 1.d-15
|
||||
print*,'Computing the left/right eigenvectors ...'
|
||||
print*,'Using the degeneracy splitting algorithm'
|
||||
! initialization
|
||||
shift_current = 1.d-15
|
||||
iteration = 0
|
||||
print*,'***** iteration = ',iteration
|
||||
|
||||
|
||||
! pre-processing the matrix :: sorting by diagonal elements
|
||||
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||
! print*,'Aw'
|
||||
do i = 1, n
|
||||
iorder_origin(i) = i
|
||||
diag_elem(i) = A(i,i)
|
||||
! write(*,'(100(F16.10,X))')A(:,i)
|
||||
enddo
|
||||
call dsort(diag_elem, iorder_origin, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||
allocate(im_part(n),iorder(n))
|
||||
allocate( S(n,n) )
|
||||
allocate(S_nh_inv_half(n,n))
|
||||
|
||||
|
||||
Aw = A_save
|
||||
call cancel_small_elmts(aw,n,thr_cut)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv += 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
|
||||
|
||||
do while(n_real_eigv.ne.n)
|
||||
iteration += 1
|
||||
print*,'***** iteration = ',iteration
|
||||
if(shift_current.gt.1.d-3)then
|
||||
print*,'shift_current > 1.d-3 !!'
|
||||
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||
stop
|
||||
endif
|
||||
Aw = A_save
|
||||
! thr_cut = shift_current
|
||||
call cancel_small_elmts(Aw,n,thr_cut)
|
||||
call split_matrix_degen(Aw,n,shift_current)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv+= 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
enddo
|
||||
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||
do i = 1, n
|
||||
eigval(i) = WR(i)
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(eigval,iorder,n)
|
||||
do i = 1, n
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||
enddo
|
||||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
print *, ' bi-orthogonality: not imposed yet'
|
||||
if(complex_root) then
|
||||
print *, ' '
|
||||
print *, ' '
|
||||
print *, ' orthog between degen eigenvect'
|
||||
print *, ' '
|
||||
! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
|
||||
call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp) ! orthogonalization of reigvec
|
||||
call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp) ! orthogonalization of leigvec
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ', accu_nd
|
||||
call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half, complex_root)
|
||||
if(complex_root)then
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
|
||||
else
|
||||
print*,'S^{-1/2} exists !!'
|
||||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
endif
|
||||
endif
|
||||
else ! the matrix S^{-1/2} exists
|
||||
print*,'S^{-1/2} exists !!'
|
||||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
endif
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
print*,'Must be a deep problem ...'
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
|
||||
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!! RECOMPUTING THE EIGENVALUES
|
||||
eigval = 0.d0
|
||||
do i = 1, n
|
||||
iorder(i) = i
|
||||
accu = 0.d0
|
||||
do j = 1, n
|
||||
accu += VL(j,i) * VR(j,i)
|
||||
do k = 1, n
|
||||
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||
enddo
|
||||
enddo
|
||||
eigval(i) *= 1.d0/accu
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
enddo
|
||||
!! RESORT JUST TO BE SURE
|
||||
call dsort(eigval, iorder, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
reigvec(j,i) = VR(j,iorder(i))
|
||||
leigvec(j,i) = VL(j,iorder(i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'Checking for final reigvec/leigvec'
|
||||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
print*,'Eigenvectors are not bi orthonormal ..'
|
||||
print*,'accu_nd = ',accu_nd
|
||||
stop
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! routine returning the eigenvalues and left/right eigenvectors of the TC fock matrix
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: A(n,n)
|
||||
integer, intent(out) :: n_real_eigv
|
||||
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||
|
||||
integer :: i, j, n_degen,k , iteration
|
||||
double precision :: shift_current
|
||||
double precision :: r,thr,accu_d, accu_nd
|
||||
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||
double precision, allocatable :: im_part(:),re_part(:)
|
||||
double precision :: accu,thr_cut
|
||||
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||
logical :: complex_root
|
||||
double precision :: thr_norm=1d0
|
||||
|
||||
|
||||
thr_cut = 1.d-15
|
||||
print*,'Computing the left/right eigenvectors ...'
|
||||
print*,'Using the degeneracy splitting algorithm'
|
||||
! initialization
|
||||
shift_current = 1.d-15
|
||||
iteration = 0
|
||||
print*,'***** iteration = ',iteration
|
||||
|
||||
|
||||
! pre-processing the matrix :: sorting by diagonal elements
|
||||
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||
! print*,'Aw'
|
||||
do i = 1, n
|
||||
iorder_origin(i) = i
|
||||
diag_elem(i) = A(i,i)
|
||||
! write(*,'(100(F16.10,X))')A(:,i)
|
||||
enddo
|
||||
call dsort(diag_elem, iorder_origin, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||
allocate(im_part(n),iorder(n))
|
||||
allocate( S(n,n) )
|
||||
allocate(S_nh_inv_half(n,n))
|
||||
|
||||
|
||||
Aw = A_save
|
||||
call cancel_small_elmts(aw,n,thr_cut)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv += 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
|
||||
|
||||
do while(n_real_eigv.ne.n)
|
||||
iteration += 1
|
||||
print*,'***** iteration = ',iteration
|
||||
if(shift_current.gt.1.d-3)then
|
||||
print*,'shift_current > 1.d-3 !!'
|
||||
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||
stop
|
||||
endif
|
||||
Aw = A_save
|
||||
! thr_cut = shift_current
|
||||
call cancel_small_elmts(Aw,n,thr_cut)
|
||||
call split_matrix_degen(Aw,n,shift_current)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv+= 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
enddo
|
||||
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||
do i = 1, n
|
||||
eigval(i) = WR(i)
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(eigval,iorder,n)
|
||||
do i = 1, n
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||
enddo
|
||||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
print *, ' bi-orthogonality: not imposed yet'
|
||||
print *, ' '
|
||||
print *, ' '
|
||||
print *, ' Using impose_unique_biorthog_degen_eigvec'
|
||||
print *, ' '
|
||||
! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
|
||||
call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, leigvec_tmp, reigvec_tmp)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print*,'accu_nd = ',accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half,complex_root)
|
||||
if(complex_root)then
|
||||
print*,'S^{-1/2} does not exits, using QR bi-orthogonalization'
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
|
||||
else
|
||||
print*,'S^{-1/2} exists !!'
|
||||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
endif
|
||||
endif
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
print*,'Must be a deep problem ...'
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
|
||||
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!! RECOMPUTING THE EIGENVALUES
|
||||
eigval = 0.d0
|
||||
do i = 1, n
|
||||
iorder(i) = i
|
||||
accu = 0.d0
|
||||
do j = 1, n
|
||||
accu += VL(j,i) * VR(j,i)
|
||||
do k = 1, n
|
||||
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||
enddo
|
||||
enddo
|
||||
eigval(i) *= 1.d0/accu
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
enddo
|
||||
!! RESORT JUST TO BE SURE
|
||||
call dsort(eigval, iorder, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
reigvec(j,i) = VR(j,iorder(i))
|
||||
leigvec(j,i) = VL(j,iorder(i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'Checking for final reigvec/leigvec'
|
||||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
print*,'Eigenvectors are not bi orthonormal ..'
|
||||
print*,'accu_nd = ',accu_nd
|
||||
stop
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
1
plugins/local/normal_order_old/NEED
Normal file
1
plugins/local/normal_order_old/NEED
Normal file
@ -0,0 +1 @@
|
||||
|
4
plugins/local/normal_order_old/README.rst
Normal file
4
plugins/local/normal_order_old/README.rst
Normal file
@ -0,0 +1,4 @@
|
||||
================
|
||||
normal_order_old
|
||||
================
|
||||
|
1
plugins/local/old_delta_tc_qmc/NEED
Normal file
1
plugins/local/old_delta_tc_qmc/NEED
Normal file
@ -0,0 +1 @@
|
||||
|
4
plugins/local/old_delta_tc_qmc/README.rst
Normal file
4
plugins/local/old_delta_tc_qmc/README.rst
Normal file
@ -0,0 +1,4 @@
|
||||
================
|
||||
old_delta_tc_qmc
|
||||
================
|
||||
|
@ -27,7 +27,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
||||
|
||||
i = 1
|
||||
j = 1
|
||||
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||
|
||||
delta = 0.d0
|
||||
@ -39,7 +39,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
||||
do j = 1, ndet
|
||||
|
||||
! < I |Htilde | J >
|
||||
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
! < I |H | J >
|
||||
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||
|
||||
@ -78,7 +78,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
||||
|
||||
i = 1
|
||||
j = 1
|
||||
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
|
||||
delta = 0.d0
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||
@ -88,7 +88,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
||||
do j = 1, ndet
|
||||
|
||||
! < I |Htilde | J >
|
||||
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
|
||||
delta(i) = delta(i) + psicoef(j) * htc_tot
|
||||
enddo
|
@ -1,4 +1,4 @@
|
||||
program tc_keywords
|
||||
program old_delta_tc_qmc
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
@ -183,11 +183,3 @@ BEGIN_PROVIDER [ double precision, x_W_ij_erf_rk, ( n_points_final_grid,3,mo_num
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, sqrt_weight_at_r, (n_points_final_grid)]
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
do ipoint = 1, n_points_final_grid
|
||||
sqrt_weight_at_r(ipoint) = dsqrt(final_weight_at_r_vector(ipoint))
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
8
plugins/local/slater_tc/NEED
Normal file
8
plugins/local/slater_tc/NEED
Normal file
@ -0,0 +1,8 @@
|
||||
determinants
|
||||
normal_order_old
|
||||
bi_ort_ints
|
||||
bi_ortho_mos
|
||||
tc_keywords
|
||||
non_hermit_dav
|
||||
dav_general_mat
|
||||
tc_scf
|
@ -1,196 +1,3 @@
|
||||
subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase)
|
||||
use bitmasks
|
||||
BEGIN_DOC
|
||||
! returns the array, for each spin, of holes/particles between key_i and key_j
|
||||
!
|
||||
! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j>
|
||||
END_DOC
|
||||
include 'utils/constants.include.F'
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
||||
integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2)
|
||||
double precision, intent(out) :: phase
|
||||
integer :: ispin,k,i,pos
|
||||
integer(bit_kind) :: key_hole, key_particle
|
||||
integer(bit_kind) :: xorvec(N_int_max,2)
|
||||
holes_array = -1
|
||||
particles_array = -1
|
||||
degree_array = 0
|
||||
do i = 1, N_int
|
||||
xorvec(i,1) = xor( key_i(i,1), key_j(i,1))
|
||||
xorvec(i,2) = xor( key_i(i,2), key_j(i,2))
|
||||
degree_array(1) += popcnt(xorvec(i,1))
|
||||
degree_array(2) += popcnt(xorvec(i,2))
|
||||
enddo
|
||||
degree_array(1) = shiftr(degree_array(1),1)
|
||||
degree_array(2) = shiftr(degree_array(2),1)
|
||||
|
||||
do ispin = 1, 2
|
||||
k = 1
|
||||
!!! GETTING THE HOLES
|
||||
do i = 1, N_int
|
||||
key_hole = iand(xorvec(i,ispin),key_i(i,ispin))
|
||||
do while(key_hole .ne.0_bit_kind)
|
||||
pos = trailz(key_hole)
|
||||
holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
|
||||
key_hole = ibclr(key_hole,pos)
|
||||
k += 1
|
||||
if(k .gt.100)then
|
||||
print*,'WARNING in get_excitation_general'
|
||||
print*,'More than a 100-th excitation for spin ',ispin
|
||||
print*,'stoping ...'
|
||||
stop
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do ispin = 1, 2
|
||||
k = 1
|
||||
!!! GETTING THE PARTICLES
|
||||
do i = 1, N_int
|
||||
key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
|
||||
do while(key_particle .ne.0_bit_kind)
|
||||
pos = trailz(key_particle)
|
||||
particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
|
||||
key_particle = ibclr(key_particle,pos)
|
||||
k += 1
|
||||
if(k .gt.100)then
|
||||
print*,'WARNING in get_excitation_general '
|
||||
print*,'More than a 100-th excitation for spin ',ispin
|
||||
print*,'stoping ...'
|
||||
stop
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
integer :: h,p, i_ok
|
||||
integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
|
||||
integer :: exc(0:2,2,2)
|
||||
double precision :: phase_tmp
|
||||
allocate(det_i(Nint,2),det_ip(N_int,2))
|
||||
det_i = key_i
|
||||
phase = 1.d0
|
||||
do ispin = 1, 2
|
||||
do i = 1, degree_array(ispin)
|
||||
h = holes_array(i,ispin)
|
||||
p = particles_array(i,ispin)
|
||||
det_ip = det_i
|
||||
call do_single_excitation(det_ip,h,p,ispin,i_ok)
|
||||
if(i_ok == -1)then
|
||||
print*,'excitation was not possible '
|
||||
stop
|
||||
endif
|
||||
call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
|
||||
phase *= phase_tmp
|
||||
det_i = det_ip
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine get_holes_general(key_i, key_j,Nint, holes_array)
|
||||
use bitmasks
|
||||
BEGIN_DOC
|
||||
! returns the array, per spin, of holes between key_i and key_j
|
||||
!
|
||||
! with the following convention: a_{hole}|key_i> --> |key_j>
|
||||
END_DOC
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
||||
integer, intent(out) :: holes_array(100,2)
|
||||
integer(bit_kind) :: key_hole
|
||||
integer :: ispin,k,i,pos
|
||||
holes_array = -1
|
||||
do ispin = 1, 2
|
||||
k = 1
|
||||
do i = 1, N_int
|
||||
key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin))
|
||||
do while(key_hole .ne.0_bit_kind)
|
||||
pos = trailz(key_hole)
|
||||
holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
|
||||
key_hole = ibclr(key_hole,pos)
|
||||
k += 1
|
||||
if(k .gt.100)then
|
||||
print*,'WARNING in get_holes_general'
|
||||
print*,'More than a 100-th excitation for spin ',ispin
|
||||
print*,'stoping ...'
|
||||
stop
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine get_particles_general(key_i, key_j,Nint,particles_array)
|
||||
use bitmasks
|
||||
BEGIN_DOC
|
||||
! returns the array, per spin, of particles between key_i and key_j
|
||||
!
|
||||
! with the following convention: a^dagger_{particle}|key_i> --> |key_j>
|
||||
END_DOC
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
||||
integer, intent(out) :: particles_array(100,2)
|
||||
integer(bit_kind) :: key_particle
|
||||
integer :: ispin,k,i,pos
|
||||
particles_array = -1
|
||||
do ispin = 1, 2
|
||||
k = 1
|
||||
do i = 1, N_int
|
||||
key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
|
||||
do while(key_particle .ne.0_bit_kind)
|
||||
pos = trailz(key_particle)
|
||||
particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
|
||||
key_particle = ibclr(key_particle,pos)
|
||||
k += 1
|
||||
if(k .gt.100)then
|
||||
print*,'WARNING in get_holes_general'
|
||||
print*,'More than a 100-th excitation for spin ',ispin
|
||||
print*,'Those are the two determinants'
|
||||
call debug_det(key_i, N_int)
|
||||
call debug_det(key_j, N_int)
|
||||
print*,'stoping ...'
|
||||
stop
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase)
|
||||
implicit none
|
||||
integer, intent(in) :: degree(2), Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
||||
integer, intent(in) :: holes_array(100,2),particles_array(100,2)
|
||||
double precision, intent(out) :: phase
|
||||
integer :: i,ispin,h,p, i_ok
|
||||
integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
|
||||
integer :: exc(0:2,2,2)
|
||||
double precision :: phase_tmp
|
||||
allocate(det_i(Nint,2),det_ip(N_int,2))
|
||||
det_i = key_i
|
||||
phase = 1.d0
|
||||
do ispin = 1, 2
|
||||
do i = 1, degree(ispin)
|
||||
h = holes_array(i,ispin)
|
||||
p = particles_array(i,ispin)
|
||||
det_ip = det_i
|
||||
call do_single_excitation(det_ip,h,p,ispin,i_ok)
|
||||
if(i_ok == -1)then
|
||||
print*,'excitation was not possible '
|
||||
stop
|
||||
endif
|
||||
call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
|
||||
phase *= phase_tmp
|
||||
det_i = det_ip
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine H_tc_s2_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze)
|
||||
BEGIN_DOC
|
||||
! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
|
@ -181,3 +181,48 @@ end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, hji,hij)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! <key_j |H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||
!!
|
||||
! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: hji,hij
|
||||
integer :: degree
|
||||
|
||||
hji = 0.d0
|
||||
hij = 0.d0
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.gt.2) return
|
||||
|
||||
if(degree == 0) then
|
||||
call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,hji)
|
||||
hij = hji
|
||||
else if (degree == 1) then
|
||||
call single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint,key_j, key_i , hji,hij)
|
||||
else if(degree == 2) then
|
||||
call double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
|
||||
endif
|
||||
|
||||
if(degree==0) then
|
||||
hji += nuclear_repulsion
|
||||
hij += nuclear_repulsion
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
@ -19,13 +19,13 @@
|
||||
PROVIDE HF_bitmask
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call diag_htilde_mu_mat_bi_ortho_slow(N_int, HF_bitmask, hmono, htwoe, htot)
|
||||
call diag_htc_bi_orth_2e_brute(N_int, HF_bitmask, hmono, htwoe, htot)
|
||||
|
||||
ref_tc_energy_1e = hmono
|
||||
ref_tc_energy_2e = htwoe
|
||||
|
||||
if(three_body_h_tc) then
|
||||
call diag_htilde_three_body_ints_bi_ort_slow(N_int, HF_bitmask, hthree)
|
||||
call diag_htc_bi_orth_3e_brute(N_int, HF_bitmask, hthree)
|
||||
ref_tc_energy_3e = hthree
|
||||
else
|
||||
ref_tc_energy_3e = 0.d0
|
||||
@ -524,3 +524,310 @@ end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine diag_htc_bi_orth_2e_brute(Nint, key_i, hmono, htwoe, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono,htwoe,htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
double precision :: get_mo_two_e_integral_tc_int
|
||||
integer(bit_kind) :: key_i_core(Nint,2)
|
||||
|
||||
PROVIDE mo_bi_ortho_tc_two_e
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
do ispin = 1, 2
|
||||
do i = 1, Ne(ispin)
|
||||
ii = occ(i,ispin)
|
||||
hmono += mo_bi_ortho_tc_one_e(ii,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/beta two-body
|
||||
ispin = 1
|
||||
jspin = 2
|
||||
do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1))
|
||||
ii = occ(i,ispin)
|
||||
do j = 1, Ne(jspin) ! electron 2
|
||||
jj = occ(j,jspin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/alpha two-body
|
||||
do i = 1, Ne(ispin)
|
||||
ii = occ(i,ispin)
|
||||
do j = i+1, Ne(ispin)
|
||||
jj = occ(j,ispin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! beta/beta two-body
|
||||
do i = 1, Ne(jspin)
|
||||
ii = occ(i,jspin)
|
||||
do j = i+1, Ne(jspin)
|
||||
jj = occ(j,jspin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
htot = hmono + htwoe
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine diag_htc_bi_orth_3e_brute(Nint, key_i, hthree)
|
||||
|
||||
BEGIN_DOC
|
||||
! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm
|
||||
integer(bit_kind) :: key_i_core(Nint,2)
|
||||
double precision :: direct_int, exchange_int, ref
|
||||
double precision, external :: sym_3_e_int_from_6_idx_tensor
|
||||
double precision, external :: three_e_diag_parrallel_spin
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
if(core_tc_op) then
|
||||
do i = 1, Nint
|
||||
key_i_core(i,1) = xor(key_i(i,1), core_bitmask(i,1))
|
||||
key_i_core(i,2) = xor(key_i(i,2), core_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
|
||||
else
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
endif
|
||||
|
||||
hthree = 0.d0
|
||||
|
||||
if((Ne(1)+Ne(2)) .ge. 3) then
|
||||
|
||||
! alpha/alpha/beta three-body
|
||||
do i = 1, Ne(1)
|
||||
ii = occ(i,1)
|
||||
do j = i+1, Ne(1)
|
||||
jj = occ(j,1)
|
||||
do m = 1, Ne(2)
|
||||
mm = occ(m,2)
|
||||
!direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) !uses the 6-idx tensor
|
||||
!exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) !uses the 6-idx tensor
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) !uses 3-idx tensor
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) !uses 3-idx tensor
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! beta/beta/alpha three-body
|
||||
do i = 1, Ne(2)
|
||||
ii = occ(i,2)
|
||||
do j = i+1, Ne(2)
|
||||
jj = occ(j,2)
|
||||
do m = 1, Ne(1)
|
||||
mm = occ(m,1)
|
||||
!direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) !uses the 6-idx tensor
|
||||
!exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) !uses the 6-idx tensor
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii)
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii)
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/alpha/alpha three-body
|
||||
do i = 1, Ne(1)
|
||||
ii = occ(i,1) ! 1
|
||||
do j = i+1, Ne(1)
|
||||
jj = occ(j,1) ! 2
|
||||
do m = j+1, Ne(1)
|
||||
mm = occ(m,1) ! 3
|
||||
!hthree += sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) !uses the 6 idx tensor
|
||||
hthree += three_e_diag_parrallel_spin(mm,jj,ii) !uses only 3-idx tensors
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! beta/beta/beta three-body
|
||||
do i = 1, Ne(2)
|
||||
ii = occ(i,2) ! 1
|
||||
do j = i+1, Ne(2)
|
||||
jj = occ(j,2) ! 2
|
||||
do m = j+1, Ne(2)
|
||||
mm = occ(m,2) ! 3
|
||||
!hthree += sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) !uses the 6 idx tensor
|
||||
hthree += three_e_diag_parrallel_spin(mm,jj,ii) !uses only 3-idx tensors
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS
|
||||
!
|
||||
! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form <mji|-L|mji> for same spin matrix elements
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
|
||||
|
||||
three_e_diag_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
|
||||
|
||||
integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, j
|
||||
three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of <mjk|-L|mji> for same spin matrix elements
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
|
||||
|
||||
three_e_single_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_single_parrallel_spin_prov ...'
|
||||
|
||||
integral = three_e_single_parrallel_spin(1,1,1,1)
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_double_parrallel_spin_prov(m,l,j,k,i) = <mlk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
|
||||
|
||||
three_e_double_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_double_parrallel_spin_prov ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
integral = three_e_double_parrallel_spin(1,1,1,1,1)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
@ -505,3 +505,63 @@ subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
|
||||
|
||||
end
|
||||
|
||||
subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j |H_tilde | key_i> and <key_i |H_tilde | key_j> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hji,hij
|
||||
double precision :: hmono, htwoe_ji, htwoe_ij
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int,phase
|
||||
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe_ji = 0.d0
|
||||
htwoe_ij = 0.d0
|
||||
hji = 0.d0
|
||||
hij = 0.d0
|
||||
|
||||
if(degree.ne.2)then
|
||||
return
|
||||
endif
|
||||
integer :: degree_i,degree_j
|
||||
call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
|
||||
call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
|
||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
if(s1.ne.s2)then
|
||||
! opposite spin two-body
|
||||
htwoe_ji = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
htwoe_ij = mo_bi_ortho_tc_two_e_transp(p2,p1,h2,h1)
|
||||
else
|
||||
! same spin two-body
|
||||
! direct terms
|
||||
htwoe_ji = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
htwoe_ij = mo_bi_ortho_tc_two_e_transp(p2,p1,h2,h1)
|
||||
! exchange terms
|
||||
htwoe_ji -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
||||
htwoe_ij -= mo_bi_ortho_tc_two_e_transp(p1,p2,h2,h1)
|
||||
endif
|
||||
htwoe_ji *= phase
|
||||
hji = htwoe_ji
|
||||
htwoe_ij *= phase
|
||||
hij = htwoe_ij
|
||||
|
||||
end
|
@ -618,3 +618,145 @@ subroutine get_single_excitation_from_fock_tc_no_3e(Nint, key_i, key_j, h, p, sp
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j |H_tilde | key_i> and <key_i |H_tilde | key_j> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hji,hij
|
||||
|
||||
double precision :: hmono, htwoe
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int, phase
|
||||
double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2)
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
hji = 0.d0
|
||||
hij = 0.d0
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.ne.1)then
|
||||
return
|
||||
endif
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
|
||||
call get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h1, p1, s1, phase, hji,hij)
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h, p, spin, phase, hji,hij)
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer, intent(in) :: h, p, spin
|
||||
double precision, intent(in) :: phase
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: hji,hij
|
||||
double precision :: hmono_ji,htwoe_ji
|
||||
double precision :: hmono_ij,htwoe_ij
|
||||
|
||||
integer(bit_kind) :: differences(Nint,2)
|
||||
integer(bit_kind) :: hole(Nint,2)
|
||||
integer(bit_kind) :: partcl(Nint,2)
|
||||
integer :: occ_hole(Nint*bit_kind_size,2)
|
||||
integer :: occ_partcl(Nint*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
|
||||
integer :: i0,i
|
||||
double precision :: buffer_c_ji(mo_num), buffer_x_ji(mo_num)
|
||||
double precision :: buffer_c_ij(mo_num), buffer_x_ij(mo_num)
|
||||
|
||||
do i = 1, mo_num
|
||||
buffer_c_ji(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
|
||||
buffer_x_ji(i) = tc_2e_3idx_exchange_integrals(i,p,h)
|
||||
buffer_c_ij(i) = tc_2e_3idx_coulomb_integrals_transp(i,p,h)
|
||||
buffer_x_ij(i) = tc_2e_3idx_exchange_integrals_transp(i,p,h)
|
||||
enddo
|
||||
|
||||
do i = 1, Nint
|
||||
differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
|
||||
differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
|
||||
hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
|
||||
hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
|
||||
partcl(i,1) = iand(differences(i,1),key_i(i,1))
|
||||
partcl(i,2) = iand(differences(i,2),key_i(i,2))
|
||||
enddo
|
||||
|
||||
call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, Nint)
|
||||
call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, Nint)
|
||||
hmono_ji = mo_bi_ortho_tc_one_e(p,h)
|
||||
htwoe_ji = fock_op_2_e_tc_closed_shell(p,h)
|
||||
hmono_ij = mo_bi_ortho_tc_one_e(h,p)
|
||||
htwoe_ij = fock_op_2_e_tc_closed_shell(h,p)
|
||||
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1)
|
||||
htwoe_ji -= buffer_c_ji(i)
|
||||
htwoe_ij -= buffer_c_ij(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_hole(2)
|
||||
i = occ_hole(i0,2)
|
||||
htwoe_ji -= buffer_c_ji(i)
|
||||
htwoe_ij -= buffer_c_ij(i)
|
||||
enddo
|
||||
|
||||
! holes :: exchange terms
|
||||
do i0 = 1, n_occ_ab_hole(spin)
|
||||
i = occ_hole(i0,spin)
|
||||
htwoe_ji += buffer_x_ji(i)
|
||||
htwoe_ij += buffer_x_ij(i)
|
||||
enddo
|
||||
|
||||
! particles :: direct terms
|
||||
do i0 = 1, n_occ_ab_partcl(1)
|
||||
i = occ_partcl(i0,1)
|
||||
htwoe_ji += buffer_c_ji(i)
|
||||
htwoe_ij += buffer_c_ij(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_partcl(2)
|
||||
i = occ_partcl(i0,2)
|
||||
htwoe_ji += buffer_c_ji(i)
|
||||
htwoe_ij += buffer_c_ij(i)
|
||||
enddo
|
||||
|
||||
! particles :: exchange terms
|
||||
do i0 = 1, n_occ_ab_partcl(spin)
|
||||
i = occ_partcl(i0,spin)
|
||||
htwoe_ji -= buffer_x_ji(i)
|
||||
htwoe_ij -= buffer_x_ij(i)
|
||||
enddo
|
||||
htwoe_ji = htwoe_ji * phase
|
||||
hmono_ji = hmono_ji * phase
|
||||
hji = htwoe_ji + hmono_ji
|
||||
|
||||
htwoe_ij = htwoe_ij * phase
|
||||
hmono_ij = hmono_ij * phase
|
||||
hij = htwoe_ij + hmono_ij
|
||||
|
||||
end
|
||||
|
@ -22,6 +22,7 @@ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
|
||||
|
||||
if(noL_standard) then
|
||||
PROVIDE noL_0e
|
||||
print*, "noL_0e =", noL_0e
|
||||
PROVIDE noL_1e
|
||||
PROVIDE noL_2e
|
||||
endif
|
59
plugins/local/slater_tc_no_opt/.gitignore
vendored
Normal file
59
plugins/local/slater_tc_no_opt/.gitignore
vendored
Normal file
@ -0,0 +1,59 @@
|
||||
IRPF90_temp/
|
||||
IRPF90_man/
|
||||
build.ninja
|
||||
irpf90.make
|
||||
ezfio_interface.irp.f
|
||||
irpf90_entities
|
||||
tags
|
||||
Makefile
|
||||
ao_basis
|
||||
ao_one_e_ints
|
||||
ao_two_e_erf_ints
|
||||
ao_two_e_ints
|
||||
aux_quantities
|
||||
becke_numerical_grid
|
||||
bitmask
|
||||
cis
|
||||
cisd
|
||||
cipsi
|
||||
davidson
|
||||
davidson_dressed
|
||||
davidson_undressed
|
||||
density_for_dft
|
||||
determinants
|
||||
dft_keywords
|
||||
dft_utils_in_r
|
||||
dft_utils_one_e
|
||||
dft_utils_two_body
|
||||
dressing
|
||||
dummy
|
||||
electrons
|
||||
ezfio_files
|
||||
fci
|
||||
generators_cas
|
||||
generators_full
|
||||
hartree_fock
|
||||
iterations
|
||||
kohn_sham
|
||||
kohn_sham_rs
|
||||
mo_basis
|
||||
mo_guess
|
||||
mo_one_e_ints
|
||||
mo_two_e_erf_ints
|
||||
mo_two_e_ints
|
||||
mpi
|
||||
mrpt_utils
|
||||
nuclei
|
||||
perturbation
|
||||
pseudo
|
||||
psiref_cas
|
||||
psiref_utils
|
||||
scf_utils
|
||||
selectors_cassd
|
||||
selectors_full
|
||||
selectors_utils
|
||||
single_ref_method
|
||||
slave
|
||||
tools
|
||||
utils
|
||||
zmq
|
8
plugins/local/slater_tc_no_opt/NEED
Normal file
8
plugins/local/slater_tc_no_opt/NEED
Normal file
@ -0,0 +1,8 @@
|
||||
determinants
|
||||
normal_order_old
|
||||
bi_ort_ints
|
||||
bi_ortho_mos
|
||||
tc_keywords
|
||||
non_hermit_dav
|
||||
dav_general_mat
|
||||
tc_scf
|
4
plugins/local/slater_tc_no_opt/README.rst
Normal file
4
plugins/local/slater_tc_no_opt/README.rst
Normal file
@ -0,0 +1,4 @@
|
||||
================
|
||||
slater_tc_no_opt
|
||||
================
|
||||
|
@ -1,7 +1,7 @@
|
||||
|
||||
! ---
|
||||
|
||||
subroutine diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
|
||||
subroutine diag_htc_bi_orth_3e_brute(Nint, key_i, hthree)
|
||||
|
||||
BEGIN_DOC
|
||||
! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
7
plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f
Normal file
7
plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f
Normal file
@ -0,0 +1,7 @@
|
||||
program slater_tc_no_opt
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
end
|
@ -61,7 +61,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree,
|
||||
if(degree.gt.2) return
|
||||
|
||||
if(degree == 0) then
|
||||
call diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
|
||||
call diag_htc_bi_orth_2e_brute(Nint, key_i, hmono, htwoe, htot)
|
||||
else if (degree == 1) then
|
||||
call single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||
else if(degree == 2) then
|
||||
@ -76,7 +76,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree,
|
||||
else if((degree == 1) .and. (elec_num .gt. 2) .and. three_e_4_idx_term) then
|
||||
call single_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
|
||||
else if((degree == 0) .and. (elec_num .gt. 2) .and. three_e_3_idx_term) then
|
||||
call diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
|
||||
call diag_htc_bi_orth_3e_brute(Nint, key_i, hthree)
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -95,75 +95,6 @@ end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono,htwoe,htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
double precision :: get_mo_two_e_integral_tc_int
|
||||
integer(bit_kind) :: key_i_core(Nint,2)
|
||||
|
||||
PROVIDE mo_bi_ortho_tc_two_e
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
do ispin = 1, 2
|
||||
do i = 1, Ne(ispin)
|
||||
ii = occ(i,ispin)
|
||||
hmono += mo_bi_ortho_tc_one_e(ii,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/beta two-body
|
||||
ispin = 1
|
||||
jspin = 2
|
||||
do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1))
|
||||
ii = occ(i,ispin)
|
||||
do j = 1, Ne(jspin) ! electron 2
|
||||
jj = occ(j,jspin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/alpha two-body
|
||||
do i = 1, Ne(ispin)
|
||||
ii = occ(i,ispin)
|
||||
do j = i+1, Ne(ispin)
|
||||
jj = occ(j,ispin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! beta/beta two-body
|
||||
do i = 1, Ne(jspin)
|
||||
ii = occ(i,jspin)
|
||||
do j = i+1, Ne(jspin)
|
||||
jj = occ(j,jspin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
htot = hmono + htwoe
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||
|
||||
BEGIN_DOC
|
@ -88,7 +88,7 @@ subroutine test_slater_tc_opt
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1,N_det
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
|
||||
if(dabs(htot).gt.1.d-15)then
|
||||
i_count += 1.D0
|
||||
@ -124,7 +124,7 @@ subroutine timing_tot
|
||||
do j = 1, N_det
|
||||
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
@ -171,7 +171,7 @@ subroutine timing_diag
|
||||
do i = 1, N_det
|
||||
do j = i,i
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
@ -208,7 +208,7 @@ subroutine timing_single
|
||||
if(degree.ne.1)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
@ -250,7 +250,7 @@ subroutine timing_double
|
||||
if(degree.ne.2)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
@ -9,3 +9,14 @@ interface: ezfio
|
||||
doc: Coefficients for the right wave function
|
||||
type: double precision
|
||||
size: (determinants.n_det,determinants.n_states)
|
||||
|
||||
[tc_gs_energy]
|
||||
type: Threshold
|
||||
doc: TC GS Energy
|
||||
interface: ezfio
|
||||
|
||||
[tc_gs_var]
|
||||
type: Threshold
|
||||
doc: TC GS VAR
|
||||
interface: ezfio
|
||||
|
||||
|
@ -1,6 +1,2 @@
|
||||
bi_ort_ints
|
||||
bi_ortho_mos
|
||||
tc_keywords
|
||||
non_hermit_dav
|
||||
dav_general_mat
|
||||
tc_scf
|
||||
slater_tc
|
||||
|
@ -2,7 +2,7 @@
|
||||
BEGIN_PROVIDER [ double precision, e_tilde_00]
|
||||
implicit none
|
||||
double precision :: hmono,htwoe,hthree,htot
|
||||
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
|
||||
e_tilde_00 = htot
|
||||
END_PROVIDER
|
||||
|
||||
@ -18,16 +18,15 @@
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree == 1 .or. degree == 2)then
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
delta_e = e_tilde_00 - e_i0
|
||||
coef_pt1 = htilde_ij / delta_e
|
||||
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
e_pt2_tc_bi_orth += coef_pt1 * htilde_ij
|
||||
if(degree == 1)then
|
||||
e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij
|
||||
else
|
||||
! print*,'coef_pt1, e_pt2',coef_pt1,coef_pt1 * htilde_ij
|
||||
e_pt2_tc_bi_orth_double += coef_pt1 * htilde_ij
|
||||
endif
|
||||
endif
|
||||
@ -37,7 +36,7 @@
|
||||
BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00]
|
||||
implicit none
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij
|
||||
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
|
||||
call htilde_mu_mat_opt_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
|
||||
e_tilde_bi_orth_00 += nuclear_repulsion
|
||||
END_PROVIDER
|
||||
|
||||
@ -57,7 +56,7 @@
|
||||
e_corr_double_bi_orth = 0.d0
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
if(degree == 1)then
|
||||
e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
||||
e_corr_single_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
|
||||
@ -80,7 +79,7 @@
|
||||
do i = 1, N_det
|
||||
accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1)
|
||||
do j = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1)
|
||||
enddo
|
||||
enddo
|
||||
@ -99,8 +98,8 @@ BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)]
|
||||
if(degree==0)then
|
||||
coef_pt1_bi_ortho(i) = 1.d0
|
||||
else
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
delta_e = e_tilde_00 - e_i0
|
||||
coef_pt1 = htilde_ij / delta_e
|
||||
coef_pt1_bi_ortho(i)= coef_pt1
|
||||
|
@ -1,32 +0,0 @@
|
||||
program print_tc_energy
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'Hello world'
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
|
||||
PROVIDE j2e_type
|
||||
PROVIDE j1e_type
|
||||
PROVIDE env_type
|
||||
|
||||
print *, ' j2e_type = ', j2e_type
|
||||
print *, ' j1e_type = ', j1e_type
|
||||
print *, ' env_type = ', env_type
|
||||
|
||||
call write_tc_energy()
|
||||
|
||||
end
|
||||
|
@ -1,129 +0,0 @@
|
||||
program pt2_tc_cisd
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together
|
||||
! with the energy. Saves the left-right wave functions at the end.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
print*, ' nb of states = ', N_states
|
||||
print*, ' nb of det = ', N_det
|
||||
call routine_diag()
|
||||
|
||||
call routine
|
||||
end
|
||||
|
||||
subroutine routine
|
||||
implicit none
|
||||
integer :: i,h1,p1,h2,p2,s1,s2,degree
|
||||
double precision :: h0i,hi0,e00,ei,delta_e
|
||||
double precision :: norm,e_corr,coef,e_corr_pos,e_corr_neg,e_corr_abs
|
||||
|
||||
integer :: exc(0:2,2,2)
|
||||
double precision :: phase
|
||||
double precision :: eh1,ep1,eh2,ep2
|
||||
|
||||
norm = 0.d0
|
||||
e_corr = 0.d0
|
||||
e_corr_abs = 0.d0
|
||||
e_corr_pos = 0.d0
|
||||
e_corr_neg = 0.d0
|
||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,1), N_int, e00)
|
||||
do i = 2, N_det
|
||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,1), N_int, hi0)
|
||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,i), N_int, h0i)
|
||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, ei)
|
||||
call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i),degree,N_int)
|
||||
call get_excitation(psi_det(1,1,1), psi_det(1,1,i),exc,degree,phase,N_int)
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
eh1 = Fock_matrix_tc_diag_mo_tot(h1)
|
||||
ep1 = Fock_matrix_tc_diag_mo_tot(p1)
|
||||
delta_e = eh1 - ep1
|
||||
if (degree==2)then
|
||||
eh2 = Fock_matrix_tc_diag_mo_tot(h2)
|
||||
ep2 = Fock_matrix_tc_diag_mo_tot(p2)
|
||||
delta_e += eh2 - ep2
|
||||
endif
|
||||
! delta_e = e00 - ei
|
||||
coef = hi0/delta_e
|
||||
norm += coef*coef
|
||||
e_corr = coef* h0i
|
||||
if(e_corr.lt.0.d0)then
|
||||
e_corr_neg += e_corr
|
||||
elseif(e_corr.gt.0.d0)then
|
||||
e_corr_pos += e_corr
|
||||
endif
|
||||
e_corr_abs += dabs(e_corr)
|
||||
enddo
|
||||
print*,'e_corr_abs = ',e_corr_abs
|
||||
print*,'e_corr_pos = ',e_corr_pos
|
||||
print*,'e_corr_neg = ',e_corr_neg
|
||||
print*,'norm = ',dsqrt(norm)
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_diag()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k
|
||||
double precision :: dE
|
||||
|
||||
! provide eigval_right_tc_bi_orth
|
||||
! provide overlap_bi_ortho
|
||||
! provide htilde_matrix_elmt_bi_ortho
|
||||
|
||||
if(N_states .eq. 1) then
|
||||
|
||||
print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
|
||||
print*,'e_tc_left_right = ',e_tc_left_right
|
||||
print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00
|
||||
print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth
|
||||
print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
|
||||
print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
|
||||
print*,'***'
|
||||
print*,'e_corr_bi_orth = ',e_corr_bi_orth
|
||||
print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj
|
||||
print*,'e_corr_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs
|
||||
print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
|
||||
print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
|
||||
print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs
|
||||
print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs
|
||||
print*,'Left/right eigenvectors'
|
||||
do i = 1,N_det
|
||||
write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
print*,'eigval_right_tc_bi_orth : '
|
||||
do i = 1, N_states
|
||||
print*, i, eigval_right_tc_bi_orth(i)
|
||||
enddo
|
||||
|
||||
print*,''
|
||||
print*,'******************************************************'
|
||||
print*,'TC Excitation energies (au) (eV)'
|
||||
do i = 2, N_states
|
||||
dE = eigval_right_tc_bi_orth(i) - eigval_right_tc_bi_orth(1)
|
||||
print*, i, dE, dE/0.0367502d0
|
||||
enddo
|
||||
print*,''
|
||||
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
@ -1,140 +0,0 @@
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS
|
||||
!
|
||||
! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form <mji|-L|mji> for same spin matrix elements
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
|
||||
|
||||
three_e_diag_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
|
||||
|
||||
integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, j
|
||||
three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of <mjk|-L|mji> for same spin matrix elements
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
|
||||
|
||||
three_e_single_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_single_parrallel_spin_prov ...'
|
||||
|
||||
integral = three_e_single_parrallel_spin(1,1,1,1)
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_double_parrallel_spin_prov(m,l,j,k,i) = <mlk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
|
||||
|
||||
three_e_double_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_double_parrallel_spin_prov ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
integral = three_e_double_parrallel_spin(1,1,1,1,1)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
@ -1,36 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
program tc_cisd_sc2
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'Hello world'
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
call test
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test()
|
||||
implicit none
|
||||
! double precision, allocatable :: dressing_dets(:),e_corr_dets(:)
|
||||
! allocate(dressing_dets(N_det),e_corr_dets(N_det))
|
||||
! e_corr_dets = 0.d0
|
||||
! call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
|
||||
provide eigval_tc_cisd_sc2_bi_ortho
|
||||
end
|
@ -1,145 +0,0 @@
|
||||
BEGIN_PROVIDER [ double precision, reigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
|
||||
&BEGIN_PROVIDER [ double precision, leigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
|
||||
&BEGIN_PROVIDER [ double precision, eigval_tc_cisd_sc2_bi_ortho, (N_states)]
|
||||
implicit none
|
||||
integer :: it,n_real,degree,i,istate
|
||||
double precision :: e_before, e_current,thr, hmono,htwoe,hthree,accu
|
||||
double precision, allocatable :: e_corr_dets(:),h0j(:), h_sc2(:,:), dressing_dets(:)
|
||||
double precision, allocatable :: leigvec_tc_bi_orth_tmp(:,:),reigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
|
||||
allocate(leigvec_tc_bi_orth_tmp(N_det,N_det),reigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det))
|
||||
allocate(e_corr_dets(N_det),h0j(N_det),h_sc2(N_det,N_det),dressing_dets(N_det))
|
||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
|
||||
dressing_dets = 0.d0
|
||||
do i = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree == 1 .or. degree == 2)then
|
||||
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
|
||||
endif
|
||||
enddo
|
||||
reigvec_tc_bi_orth_tmp = 0.d0
|
||||
do i = 1, N_det
|
||||
reigvec_tc_bi_orth_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
|
||||
enddo
|
||||
vec_tmp = 0.d0
|
||||
do istate = 1, N_states
|
||||
vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
|
||||
enddo
|
||||
do istate = N_states+1, n_states_diag
|
||||
vec_tmp(istate,istate) = 1.d0
|
||||
enddo
|
||||
print*,'Diagonalizing the TC CISD '
|
||||
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
|
||||
do i = 1, N_det
|
||||
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
|
||||
enddo
|
||||
E_before = eigval_tmp(1)
|
||||
print*,'Starting from ',E_before
|
||||
|
||||
e_current = 10.d0
|
||||
thr = 1.d-5
|
||||
it = 0
|
||||
dressing_dets = 0.d0
|
||||
double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
|
||||
external htc_bi_ortho_calc_tdav_slow
|
||||
external htcdag_bi_ortho_calc_tdav_slow
|
||||
logical :: converged
|
||||
do while (dabs(E_before-E_current).gt.thr)
|
||||
it += 1
|
||||
E_before = E_current
|
||||
! h_sc2 = htilde_matrix_elmt_bi_ortho
|
||||
call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
|
||||
do i = 1, N_det
|
||||
! print*,'dressing_dets(i) = ',dressing_dets(i)
|
||||
h_sc2(i,i) += dressing_dets(i)
|
||||
enddo
|
||||
print*,'********************'
|
||||
print*,'iteration ',it
|
||||
! call non_hrmt_real_diag(N_det,h_sc2,&
|
||||
! leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,&
|
||||
! n_real,eigval_right_tmp)
|
||||
! print*,'eigval_right_tmp(1)',eigval_right_tmp(1)
|
||||
vec_tmp = 0.d0
|
||||
do istate = 1, N_states
|
||||
vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
|
||||
enddo
|
||||
do istate = N_states+1, n_states_diag
|
||||
vec_tmp(istate,istate) = 1.d0
|
||||
enddo
|
||||
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
|
||||
print*,'outside Davidson'
|
||||
print*,'eigval_tmp(1) = ',eigval_tmp(1)
|
||||
do i = 1, N_det
|
||||
reigvec_tc_bi_orth_tmp(i,1) = vec_tmp(i,1)
|
||||
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
|
||||
enddo
|
||||
! E_current = eigval_right_tmp(1)
|
||||
E_current = eigval_tmp(1)
|
||||
print*,'it, E(SC)^2 = ',it,E_current
|
||||
enddo
|
||||
eigval_tc_cisd_sc2_bi_ortho(1:N_states) = eigval_right_tmp(1:N_states)
|
||||
reigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = reigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
|
||||
leigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = leigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine get_cisd_sc2_dressing(dets,e_corr_dets,ndet,dressing_dets)
|
||||
implicit none
|
||||
use bitmasks
|
||||
integer, intent(in) :: ndet
|
||||
integer(bit_kind), intent(in) :: dets(N_int,2,ndet)
|
||||
double precision, intent(in) :: e_corr_dets(ndet)
|
||||
double precision, intent(out) :: dressing_dets(ndet)
|
||||
integer, allocatable :: degree(:),hole(:,:),part(:,:),spin(:,:)
|
||||
integer(bit_kind), allocatable :: hole_part(:,:,:)
|
||||
integer :: i,j,k, exc(0:2,2,2),h1,p1,h2,p2,s1,s2
|
||||
integer(bit_kind) :: xorvec(2,N_int)
|
||||
|
||||
double precision :: phase
|
||||
dressing_dets = 0.d0
|
||||
allocate(degree(ndet),hole(2,ndet),part(2,ndet), spin(2,ndet),hole_part(N_int,2,ndet))
|
||||
do i = 2, ndet
|
||||
call get_excitation_degree(HF_bitmask,dets(1,1,i),degree(i),N_int)
|
||||
do j = 1, N_int
|
||||
hole_part(j,1,i) = xor( HF_bitmask(j,1), dets(j,1,i))
|
||||
hole_part(j,2,i) = xor( HF_bitmask(j,2), dets(j,2,i))
|
||||
enddo
|
||||
if(degree(i) == 1)then
|
||||
call get_single_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
|
||||
else if(degree(i) == 2)then
|
||||
call get_double_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
|
||||
endif
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
hole(1,i) = h1
|
||||
hole(2,i) = h2
|
||||
part(1,i) = p1
|
||||
part(2,i) = p2
|
||||
spin(1,i) = s1
|
||||
spin(2,i) = s2
|
||||
enddo
|
||||
|
||||
integer :: same
|
||||
if(elec_alpha_num+elec_beta_num<3)return
|
||||
do i = 2, ndet
|
||||
do j = i+1, ndet
|
||||
same = 0
|
||||
if(degree(i) == degree(j) .and. degree(i)==1)cycle
|
||||
do k = 1, N_int
|
||||
xorvec(k,1) = iand(hole_part(k,1,i),hole_part(k,1,j))
|
||||
xorvec(k,2) = iand(hole_part(k,2,i),hole_part(k,2,j))
|
||||
same += popcnt(xorvec(k,1)) + popcnt(xorvec(k,2))
|
||||
enddo
|
||||
! print*,'i,j',i,j
|
||||
! call debug_det(dets(1,1,i),N_int)
|
||||
! call debug_det(hole_part(1,1,i),N_int)
|
||||
! call debug_det(dets(1,1,j),N_int)
|
||||
! call debug_det(hole_part(1,1,j),N_int)
|
||||
! print*,'same = ',same
|
||||
if(same.eq.0)then
|
||||
dressing_dets(i) += e_corr_dets(j)
|
||||
dressing_dets(j) += e_corr_dets(i)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
@ -6,8 +6,63 @@ subroutine write_tc_energy()
|
||||
double precision :: hmono, htwoe, hthree, htot
|
||||
double precision :: E_TC, O_TC
|
||||
double precision :: E_1e, E_2e, E_3e
|
||||
double precision, allocatable :: E_TC_tmp(:), E_1e_tmp(:), E_2e_tmp(:), E_3e_tmp(:)
|
||||
|
||||
do k = 1, n_states
|
||||
! GS
|
||||
! ---
|
||||
|
||||
allocate(E_TC_tmp(N_det), E_1e_tmp(N_det), E_2e_tmp(N_det), E_3e_tmp(N_det))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE(i, j, hmono, htwoe, hthree, htot) &
|
||||
!$OMP SHARED(N_det, psi_det, N_int, psi_l_coef_bi_ortho, psi_r_coef_bi_ortho, &
|
||||
!$OMP E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
|
||||
!$OMP DO
|
||||
do i = 1, N_det
|
||||
E_TC_tmp(i) = 0.d0
|
||||
E_1e_tmp(i) = 0.d0
|
||||
E_2e_tmp(i) = 0.d0
|
||||
E_3e_tmp(i) = 0.d0
|
||||
do j = 1, N_det
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
|
||||
E_TC_tmp(i) = E_TC_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htot
|
||||
E_1e_tmp(i) = E_1e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hmono
|
||||
E_2e_tmp(i) = E_2e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htwoe
|
||||
E_3e_tmp(i) = E_3e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hthree
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
E_1e = 0.d0
|
||||
E_2e = 0.d0
|
||||
E_3e = 0.d0
|
||||
E_TC = 0.d0
|
||||
O_TC = 0.d0
|
||||
do i = 1, N_det
|
||||
E_1e = E_1e + E_1e_tmp(i)
|
||||
E_2e = E_2e + E_2e_tmp(i)
|
||||
E_3e = E_3e + E_3e_tmp(i)
|
||||
E_TC = E_TC + E_TC_tmp(i)
|
||||
O_TC = O_TC + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(i,1)
|
||||
enddo
|
||||
|
||||
print *, ' state :', 1
|
||||
print *, " E_TC = ", E_TC / O_TC
|
||||
print *, " E_1e = ", E_1e / O_TC
|
||||
print *, " E_2e = ", E_2e / O_TC
|
||||
print *, " E_3e = ", E_3e / O_TC
|
||||
print *, " O_TC = ", O_TC
|
||||
|
||||
call ezfio_set_tc_bi_ortho_tc_gs_energy(E_TC/O_TC)
|
||||
|
||||
! ---
|
||||
|
||||
! ES
|
||||
! ---
|
||||
|
||||
do k = 2, n_states
|
||||
|
||||
E_TC = 0.d0
|
||||
E_1e = 0.d0
|
||||
@ -15,7 +70,7 @@ subroutine write_tc_energy()
|
||||
E_3e = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
|
||||
E_TC = E_TC + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htot
|
||||
E_1e = E_1e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * hmono
|
||||
E_2e = E_2e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htwoe
|
||||
@ -37,6 +92,8 @@ subroutine write_tc_energy()
|
||||
|
||||
enddo
|
||||
|
||||
deallocate(E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
@ -52,8 +109,8 @@ subroutine write_tc_var()
|
||||
|
||||
SIGMA_TC = 0.d0
|
||||
do j = 2, N_det
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j)
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1)
|
||||
SIGMA_TC = SIGMA_TC + htot_1j * htot_j1
|
||||
enddo
|
||||
|
||||
@ -66,3 +123,25 @@ end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine write_tc_gs_var_HF()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k
|
||||
double precision :: hmono, htwoe, hthree, htot
|
||||
double precision :: SIGMA_TC
|
||||
|
||||
SIGMA_TC = 0.d0
|
||||
do j = 2, N_det
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
|
||||
SIGMA_TC = SIGMA_TC + htot * htot
|
||||
enddo
|
||||
|
||||
print *, " SIGMA_TC = ", SIGMA_TC
|
||||
|
||||
call ezfio_set_tc_bi_ortho_tc_gs_var(SIGMA_TC)
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
|
@ -1,64 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
program test_natorb
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end.
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'Hello world'
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
call routine()
|
||||
! call test()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine routine()
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: fock_diag(:),eigval(:),leigvec(:,:),reigvec(:,:),mat_ref(:,:)
|
||||
allocate(eigval(mo_num),leigvec(mo_num,mo_num),reigvec(mo_num,mo_num),fock_diag(mo_num),mat_ref(mo_num, mo_num))
|
||||
double precision, allocatable :: eigval_ref(:),leigvec_ref(:,:),reigvec_ref(:,:)
|
||||
allocate(eigval_ref(mo_num),leigvec_ref(mo_num,mo_num),reigvec_ref(mo_num,mo_num))
|
||||
|
||||
double precision :: thr_deg
|
||||
integer :: i,n_real,j
|
||||
print*,'fock_matrix'
|
||||
do i = 1, mo_num
|
||||
fock_diag(i) = Fock_matrix_mo(i,i)
|
||||
print*,i,fock_diag(i)
|
||||
enddo
|
||||
thr_deg = 1.d-6
|
||||
mat_ref = -one_e_dm_mo
|
||||
print*,'diagonalization by block'
|
||||
call diag_mat_per_fock_degen(fock_diag,mat_ref,mo_num,thr_deg,leigvec,reigvec,eigval)
|
||||
call non_hrmt_bieig( mo_num, mat_ref&
|
||||
, leigvec_ref, reigvec_ref&
|
||||
, n_real, eigval_ref)
|
||||
print*,'TEST ***********************************'
|
||||
double precision :: accu_l, accu_r
|
||||
do i = 1, mo_num
|
||||
accu_l = 0.d0
|
||||
accu_r = 0.d0
|
||||
do j = 1, mo_num
|
||||
accu_r += reigvec_ref(j,i) * reigvec(j,i)
|
||||
accu_l += leigvec_ref(j,i) * leigvec(j,i)
|
||||
enddo
|
||||
print*,i
|
||||
write(*,'(I3,X,100(F16.10,X))')i,eigval(i),eigval_ref(i),accu_l,accu_r
|
||||
enddo
|
||||
end
|
@ -1,173 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
program test_normal_order
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'Hello world'
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
call provide_all_three_ints_bi_ortho()
|
||||
call test()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test
|
||||
implicit none
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
integer :: h1,h2,p1,p2,s1,s2,i_ok,degree,Ne(2)
|
||||
integer :: exc(0:2,2,2)
|
||||
integer(bit_kind), allocatable :: det_i(:,:)
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij,accu,phase,normal,hthree_tmp
|
||||
integer, allocatable :: occ(:,:)
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int)
|
||||
allocate(det_i(N_int,2))
|
||||
s1 = 1
|
||||
s2 = 2
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_beta_num
|
||||
do p1 = elec_alpha_num+1, mo_num
|
||||
do h2 = 1, elec_beta_num
|
||||
do p2 = elec_beta_num+1, mo_num
|
||||
hthree = 0.d0
|
||||
|
||||
det_i = ref_bitmask
|
||||
s1 = 1
|
||||
s2 = 2
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
hthree_tmp *= phase
|
||||
hthree += 0.5d0 * hthree_tmp
|
||||
det_i = ref_bitmask
|
||||
s1 = 2
|
||||
s2 = 1
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
hthree_tmp *= phase
|
||||
hthree += 0.5d0 * hthree_tmp
|
||||
|
||||
|
||||
! normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1)
|
||||
call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, normal)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
if(dabs(hthree-normal).gt.1.d-10)then
|
||||
! print*,pp2,pp1,hh2,hh1
|
||||
print*,p2,p1,h2,h1
|
||||
print*,hthree,normal,dabs(hthree-normal)
|
||||
stop
|
||||
endif
|
||||
! call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal)
|
||||
! normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu opposite spin = ',accu
|
||||
stop
|
||||
|
||||
! p2=6
|
||||
! p1=5
|
||||
! h2=2
|
||||
! h1=1
|
||||
|
||||
s1 = 1
|
||||
s2 = 1
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_alpha_num
|
||||
do p1 = elec_alpha_num+1, mo_num
|
||||
do p2 = p1+1, mo_num
|
||||
do h2 = h1+1, elec_alpha_num
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
integer :: hh1, pp1, hh2, pp2, ss1, ss2
|
||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
||||
hthree *= phase
|
||||
normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
||||
! normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
if(dabs(hthree-normal).gt.1.d-10)then
|
||||
print*,pp2,pp1,hh2,hh1
|
||||
print*,p2,p1,h2,h1
|
||||
print*,hthree,normal,dabs(hthree-normal)
|
||||
stop
|
||||
endif
|
||||
! print*,hthree,normal,dabs(hthree-normal)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu same spin alpha = ',accu
|
||||
|
||||
|
||||
s1 = 2
|
||||
s2 = 2
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_beta_num
|
||||
do p1 = elec_beta_num+1, mo_num
|
||||
do p2 = p1+1, mo_num
|
||||
do h2 = h1+1, elec_beta_num
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
||||
hthree *= phase
|
||||
! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
||||
normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
if(dabs(hthree-normal).gt.1.d-10)then
|
||||
print*,pp2,pp1,hh2,hh1
|
||||
print*,p2,p1,h2,h1
|
||||
print*,hthree,normal,dabs(hthree-normal)
|
||||
stop
|
||||
endif
|
||||
! print*,hthree,normal,dabs(hthree-normal)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu same spin beta = ',accu
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
@ -1,170 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
program test_tc
|
||||
|
||||
implicit none
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
call provide_all_three_ints_bi_ortho()
|
||||
call routine_h_triple_left
|
||||
call routine_h_triple_right
|
||||
! call routine_test_s2_davidson
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_h_triple_right
|
||||
implicit none
|
||||
logical :: do_right
|
||||
integer :: sze ,i, N_st, j
|
||||
double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0
|
||||
double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:)
|
||||
double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
|
||||
sze = N_det
|
||||
N_st = 1
|
||||
allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1))
|
||||
print*,'Checking first the Right '
|
||||
do i = 1, sze
|
||||
u_0(i,1) = psi_r_coef_bi_ortho(i,1)
|
||||
enddo
|
||||
double precision :: wall0,wall1
|
||||
call wall_time(wall0)
|
||||
call H_tc_s2_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze)
|
||||
call wall_time(wall1)
|
||||
print*,'time for omp',wall1 - wall0
|
||||
call wall_time(wall0)
|
||||
call H_tc_s2_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze)
|
||||
call wall_time(wall1)
|
||||
print*,'time serial ',wall1 - wall0
|
||||
accu_e = 0.d0
|
||||
accu_s = 0.d0
|
||||
do i = 1, sze
|
||||
accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1))
|
||||
accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1))
|
||||
enddo
|
||||
print*,'accu_e = ',accu_e
|
||||
print*,'accu_s = ',accu_s
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_h_triple_left
|
||||
implicit none
|
||||
logical :: do_right
|
||||
integer :: sze ,i, N_st, j
|
||||
double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0
|
||||
double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:)
|
||||
double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
|
||||
sze = N_det
|
||||
N_st = 1
|
||||
allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1))
|
||||
print*,'Checking the Left '
|
||||
do i = 1, sze
|
||||
u_0(i,1) = psi_l_coef_bi_ortho(i,1)
|
||||
enddo
|
||||
double precision :: wall0,wall1
|
||||
call wall_time(wall0)
|
||||
call H_tc_s2_dagger_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze)
|
||||
call wall_time(wall1)
|
||||
print*,'time for omp',wall1 - wall0
|
||||
call wall_time(wall0)
|
||||
call H_tc_s2_dagger_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze)
|
||||
call wall_time(wall1)
|
||||
print*,'time serial ',wall1 - wall0
|
||||
accu_e = 0.d0
|
||||
accu_s = 0.d0
|
||||
do i = 1, sze
|
||||
accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1))
|
||||
accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1))
|
||||
enddo
|
||||
print*,'accu_e = ',accu_e
|
||||
print*,'accu_s = ',accu_s
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine routine_test_s2_davidson
|
||||
implicit none
|
||||
double precision, allocatable :: H_jj(:),vec_tmp(:,:), energies(:) , s2(:)
|
||||
integer :: i,istate
|
||||
logical :: converged
|
||||
external H_tc_s2_dagger_u_0_opt
|
||||
external H_tc_s2_u_0_opt
|
||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),energies(n_states_diag), s2(n_states_diag))
|
||||
do i = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
||||
enddo
|
||||
! Preparing the left-eigenvector
|
||||
print*,'Computing the left-eigenvector '
|
||||
vec_tmp = 0.d0
|
||||
do istate = 1, N_states
|
||||
vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate)
|
||||
enddo
|
||||
do istate = N_states+1, n_states_diag
|
||||
vec_tmp(istate,istate) = 1.d0
|
||||
enddo
|
||||
do istate = 1, N_states
|
||||
leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
||||
enddo
|
||||
integer :: n_it_max
|
||||
n_it_max = 1
|
||||
call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt)
|
||||
double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
|
||||
integer :: sze,N_st
|
||||
logical :: do_right
|
||||
sze = N_det
|
||||
N_st = 1
|
||||
do_right = .False.
|
||||
allocate(s_0_new(N_det,1),v_0_new(N_det,1))
|
||||
call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right)
|
||||
double precision :: accu_e_0, accu_s_0
|
||||
accu_e_0 = 0.d0
|
||||
accu_s_0 = 0.d0
|
||||
do i = 1, sze
|
||||
accu_e_0 += v_0_new(i,1) * vec_tmp(i,1)
|
||||
accu_s_0 += s_0_new(i,1) * vec_tmp(i,1)
|
||||
enddo
|
||||
print*,'energies = ',energies
|
||||
print*,'s2 = ',s2
|
||||
print*,'accu_e_0',accu_e_0
|
||||
print*,'accu_s_0',accu_s_0
|
||||
|
||||
! Preparing the right-eigenvector
|
||||
print*,'Computing the right-eigenvector '
|
||||
vec_tmp = 0.d0
|
||||
do istate = 1, N_states
|
||||
vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate)
|
||||
enddo
|
||||
do istate = N_states+1, n_states_diag
|
||||
vec_tmp(istate,istate) = 1.d0
|
||||
enddo
|
||||
do istate = 1, N_states
|
||||
leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
||||
enddo
|
||||
n_it_max = 1
|
||||
call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_opt)
|
||||
sze = N_det
|
||||
N_st = 1
|
||||
do_right = .True.
|
||||
v_0_new = 0.d0
|
||||
s_0_new = 0.d0
|
||||
call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right)
|
||||
accu_e_0 = 0.d0
|
||||
accu_s_0 = 0.d0
|
||||
do i = 1, sze
|
||||
accu_e_0 += v_0_new(i,1) * vec_tmp(i,1)
|
||||
accu_s_0 += s_0_new(i,1) * vec_tmp(i,1)
|
||||
enddo
|
||||
print*,'energies = ',energies
|
||||
print*,'s2 = ',s2
|
||||
print*,'accu_e_0',accu_e_0
|
||||
print*,'accu_s_0',accu_s_0
|
||||
|
||||
end
|
@ -1,204 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
program test_tc_fock
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'Hello world'
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
!call routine_1
|
||||
!call routine_2
|
||||
! call routine_3()
|
||||
|
||||
! call test_3e
|
||||
call routine_tot
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_3e
|
||||
implicit none
|
||||
double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
|
||||
double precision :: hmono, htwoe, hthree, htot
|
||||
call htilde_mu_mat_bi_ortho_slow(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
|
||||
print*,'hmono = ',hmono
|
||||
print*,'htwoe = ',htwoe
|
||||
print*,'hthree= ',hthree
|
||||
print*,'htot = ',htot
|
||||
print*,''
|
||||
print*,''
|
||||
print*,'TC_one= ',tc_hf_one_e_energy
|
||||
print*,'TC_two= ',TC_HF_two_e_energy
|
||||
print*,'TC_3e = ',diag_three_elem_hf
|
||||
print*,'TC_tot= ',TC_HF_energy
|
||||
print*,''
|
||||
print*,''
|
||||
call give_aaa_contrib(integral_aaa)
|
||||
print*,'integral_aaa = ',integral_aaa
|
||||
call give_aab_contrib(integral_aab)
|
||||
print*,'integral_aab = ',integral_aab
|
||||
call give_abb_contrib(integral_abb)
|
||||
print*,'integral_abb = ',integral_abb
|
||||
call give_bbb_contrib(integral_bbb)
|
||||
print*,'integral_bbb = ',integral_bbb
|
||||
accu = integral_aaa + integral_aab + integral_abb + integral_bbb
|
||||
print*,'accu = ',accu
|
||||
print*,'delta = ',hthree - accu
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_3()
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer :: i, a, i_ok, s1
|
||||
double precision :: hmono, htwoe, hthree, htilde_ij
|
||||
double precision :: err_ai, err_tot, ref, new
|
||||
integer(bit_kind), allocatable :: det_i(:,:)
|
||||
|
||||
allocate(det_i(N_int,2))
|
||||
|
||||
err_tot = 0.d0
|
||||
|
||||
do s1 = 1, 2
|
||||
|
||||
det_i = ref_bitmask
|
||||
call debug_det(det_i, N_int)
|
||||
print*, ' HF det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
do i = 1, elec_num_tab(s1)
|
||||
do a = elec_num_tab(s1)+1, mo_num ! virtual
|
||||
|
||||
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i, i, a, s1, i_ok)
|
||||
if(i_ok == -1) then
|
||||
print*, 'PB !!'
|
||||
print*, i, a
|
||||
stop
|
||||
endif
|
||||
print*, ' excited det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
ref = hthree
|
||||
if(s1 == 1)then
|
||||
new = fock_a_tot_3e_bi_orth(a,i)
|
||||
else if(s1 == 2)then
|
||||
new = fock_b_tot_3e_bi_orth(a,i)
|
||||
endif
|
||||
err_ai = dabs(dabs(ref) - dabs(new))
|
||||
if(err_ai .gt. 1d-7) then
|
||||
print*,'s1 = ',s1
|
||||
print*, ' warning on', i, a
|
||||
print*, ref,new,err_ai
|
||||
endif
|
||||
print*, ref,new,err_ai
|
||||
err_tot += err_ai
|
||||
|
||||
write(22, *) htilde_ij
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print *, ' err_tot = ', err_tot
|
||||
|
||||
deallocate(det_i)
|
||||
|
||||
end subroutine routine_3
|
||||
|
||||
! ---
|
||||
subroutine routine_tot()
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer :: i, a, i_ok, s1,other_spin(2)
|
||||
double precision :: hmono, htwoe, hthree, htilde_ij
|
||||
double precision :: err_ai, err_tot, ref, new
|
||||
integer(bit_kind), allocatable :: det_i(:,:)
|
||||
|
||||
allocate(det_i(N_int,2))
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
err_tot = 0.d0
|
||||
|
||||
! do s1 = 1, 2
|
||||
s1 = 2
|
||||
det_i = ref_bitmask
|
||||
call debug_det(det_i, N_int)
|
||||
print*, ' HF det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
! do i = 1, elec_num_tab(s1)
|
||||
! do a = elec_num_tab(s1)+1, mo_num ! virtual
|
||||
do i = 1, elec_beta_num
|
||||
do a = elec_beta_num+1, mo_num! virtual
|
||||
print*,i,a
|
||||
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i, i, a, s1, i_ok)
|
||||
if(i_ok == -1) then
|
||||
print*, 'PB !!'
|
||||
print*, i, a
|
||||
stop
|
||||
endif
|
||||
|
||||
call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
||||
print*,htilde_ij
|
||||
! if(dabs(htilde_ij).lt.1.d-10)cycle
|
||||
print*, ' excited det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
if(s1 == 1)then
|
||||
new = Fock_matrix_tc_mo_alpha(a,i)
|
||||
else
|
||||
new = Fock_matrix_tc_mo_beta(a,i)
|
||||
endif
|
||||
ref = htilde_ij
|
||||
! if(s1 == 1)then
|
||||
! new = fock_a_tot_3e_bi_orth(a,i)
|
||||
! else if(s1 == 2)then
|
||||
! new = fock_b_tot_3e_bi_orth(a,i)
|
||||
! endif
|
||||
err_ai = dabs(dabs(ref) - dabs(new))
|
||||
if(err_ai .gt. 1d-7) then
|
||||
print*,'---------'
|
||||
print*,'s1 = ',s1
|
||||
print*, ' warning on', i, a
|
||||
print*, ref,new,err_ai
|
||||
print*,hmono, htwoe, hthree
|
||||
print*,'---------'
|
||||
endif
|
||||
print*, ref,new,err_ai
|
||||
err_tot += err_ai
|
||||
|
||||
write(22, *) htilde_ij
|
||||
enddo
|
||||
enddo
|
||||
! enddo
|
||||
|
||||
print *, ' err_tot = ', err_tot
|
||||
|
||||
deallocate(det_i)
|
||||
|
||||
end subroutine routine_3
|
@ -100,30 +100,12 @@ doc: If |true|, the states are re-ordered to match the input states
|
||||
default: False
|
||||
interface: ezfio,provider,ocaml
|
||||
|
||||
[bi_ortho]
|
||||
type: logical
|
||||
doc: If |true|, the MO basis is assumed to be bi-orthonormal
|
||||
interface: ezfio,provider,ocaml
|
||||
default: True
|
||||
|
||||
[symetric_fock_tc]
|
||||
[symmetric_fock_tc]
|
||||
type: logical
|
||||
doc: If |true|, using F+F^t as Fock TC
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[thresh_tcscf]
|
||||
type: Threshold
|
||||
doc: Threshold on the convergence of the Hartree Fock energy.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-8
|
||||
|
||||
[n_it_tcscf_max]
|
||||
type: Strictly_positive_int
|
||||
doc: Maximum number of SCF iterations
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 50
|
||||
|
||||
[selection_tc]
|
||||
type: integer
|
||||
doc: if +1: only positive is selected, -1: only negative is selected, :0 both positive and negative
|
||||
@ -160,30 +142,6 @@ doc: If |true|, maximize the overlap between orthogonalized left- and right eige
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[max_dim_diis_tcscf]
|
||||
type: integer
|
||||
doc: Maximum size of the DIIS extrapolation procedure
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 15
|
||||
|
||||
[level_shift_tcscf]
|
||||
type: Positive_float
|
||||
doc: Energy shift on the virtual MOs to improve TCSCF convergence
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.
|
||||
|
||||
[tcscf_algorithm]
|
||||
type: character*(32)
|
||||
doc: Type of TCSCF algorithm used. Possible choices are [Simple | DIIS]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: DIIS
|
||||
|
||||
[im_thresh_tcscf]
|
||||
type: Threshold
|
||||
doc: Thresholds on the Imag part of energy
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-7
|
||||
|
||||
[test_cycle_tc]
|
||||
type: logical
|
||||
doc: If |true|, the integrals of the three-body jastrow are computed with cycles
|
||||
@ -226,12 +184,6 @@ doc: Read/Write normal_two_body_bi_orth from/to disk [ Write | Read | None ]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: None
|
||||
|
||||
[debug_tc_pt2]
|
||||
type: integer
|
||||
doc: If :: 1 then you compute the TC-PT2 the old way, :: 2 then you check with the new version but without three-body
|
||||
interface: ezfio,provider,ocaml
|
||||
default: -1
|
||||
|
||||
[only_spin_tc_right]
|
||||
type: logical
|
||||
doc: If |true|, only the right part of WF is used to compute spin dens
|
||||
@ -285,3 +237,33 @@ type: logical
|
||||
doc: If |true|, you minimize the angle between the left and right vectors associated to degenerate orbitals
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[ao_to_mo_tc_n3]
|
||||
type: logical
|
||||
doc: If |true|, memory scale of TC ao -> mo: O(N3)
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[tc_save_mem_loops]
|
||||
type: logical
|
||||
doc: If |true|, use loops to save memory TC
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[tc_save_mem]
|
||||
type: logical
|
||||
doc: If |true|, more calc but less mem
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[im_thresh_tc]
|
||||
type: Threshold
|
||||
doc: Thresholds on the Imag part of TC energy
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-7
|
||||
|
||||
[transpose_two_e_int]
|
||||
type: logical
|
||||
doc: If |true|, you duplicate the two-electron TC integrals with the transpose matrix. Acceleates the PT2.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
1
plugins/local/tc_progs/NEED
Normal file
1
plugins/local/tc_progs/NEED
Normal file
@ -0,0 +1 @@
|
||||
tc_bi_ortho
|
53
plugins/local/tc_progs/print_tc_energy.irp.f
Normal file
53
plugins/local/tc_progs/print_tc_energy.irp.f
Normal file
@ -0,0 +1,53 @@
|
||||
program print_tc_energy
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
call write_int(6, my_n_pt_r_grid, 'radial external grid over')
|
||||
call write_int(6, my_n_pt_a_grid, 'angular external grid over')
|
||||
|
||||
if(tc_integ_type .eq. "numeric") then
|
||||
my_extra_grid_becke = .True.
|
||||
PROVIDE tc_grid2_a tc_grid2_r
|
||||
my_n_pt_r_extra_grid = tc_grid2_r
|
||||
my_n_pt_a_extra_grid = tc_grid2_a
|
||||
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
|
||||
|
||||
call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over')
|
||||
call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
|
||||
endif
|
||||
|
||||
call main()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine main()
|
||||
|
||||
implicit none
|
||||
|
||||
PROVIDE j2e_type
|
||||
PROVIDE j1e_type
|
||||
PROVIDE env_type
|
||||
|
||||
print *, ' j2e_type = ', j2e_type
|
||||
print *, ' j1e_type = ', j1e_type
|
||||
print *, ' env_type = ', env_type
|
||||
|
||||
call write_tc_energy()
|
||||
|
||||
end
|
||||
|
@ -6,7 +6,8 @@ program print_tc_var
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'Hello world'
|
||||
print *, ' TC VAR is available only for HF REF WF'
|
||||
print *, ' DO NOT FORGET TO RUN A CISD CALCULATION BEF'
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
@ -17,7 +18,7 @@ program print_tc_var
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
call write_tc_var()
|
||||
call write_tc_gs_var_HF()
|
||||
|
||||
end
|
||||
|
@ -61,12 +61,12 @@ subroutine routine
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree == 1 .or. degree == 2)then
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
delta_e = e_tilde_00 - e_i0
|
||||
coef_pt1 = htilde_ij / delta_e
|
||||
|
||||
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
contrib_pt = coef_pt1 * htilde_ij
|
||||
e_pt2 += contrib_pt
|
||||
|
@ -38,9 +38,9 @@ subroutine main()
|
||||
call ezfio_has_cisd_energy(exists)
|
||||
if(.not.exists) then
|
||||
|
||||
call ezfio_has_tc_scf_bitc_energy(exists)
|
||||
call ezfio_has_tc_scf_tcscf_energy(exists)
|
||||
if(exists) then
|
||||
call ezfio_get_tc_scf_bitc_energy(e_ref)
|
||||
call ezfio_get_tc_scf_tcscf_energy(e_ref)
|
||||
endif
|
||||
|
||||
else
|
||||
@ -59,7 +59,7 @@ subroutine main()
|
||||
|
||||
close(iunit)
|
||||
|
||||
end subroutine main
|
||||
end
|
||||
|
||||
! --
|
||||
|
||||
@ -89,7 +89,7 @@ subroutine write_lr_spindeterminants()
|
||||
call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
|
||||
deallocate(buffer)
|
||||
|
||||
end subroutine write_lr_spindeterminants
|
||||
end
|
||||
|
||||
! ---
|
||||
|
@ -49,8 +49,8 @@ subroutine main()
|
||||
U_SOM = 0.d0
|
||||
do i = 1, N_det
|
||||
if(i == i_HF) cycle
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
|
||||
U_SOM += htot_1 * htot_2
|
||||
enddo
|
||||
U_SOM = 0.5d0 * U_SOM
|
@ -1,6 +1,6 @@
|
||||
[bitc_energy]
|
||||
[tcscf_energy]
|
||||
type: Threshold
|
||||
doc: Energy bi-tc HF
|
||||
doc: TC-SCF ENERGY
|
||||
interface: ezfio
|
||||
|
||||
[converged_tcscf]
|
||||
@ -9,3 +9,33 @@ doc: If |true|, tc-scf has converged
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[max_dim_diis_tcscf]
|
||||
type: integer
|
||||
doc: Maximum size of the DIIS extrapolation procedure
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 15
|
||||
|
||||
[level_shift_tcscf]
|
||||
type: Positive_float
|
||||
doc: Energy shift on the virtual MOs to improve TCSCF convergence
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.
|
||||
|
||||
[thresh_tcscf]
|
||||
type: Threshold
|
||||
doc: Threshold on the convergence of the Hartree Fock energy.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-8
|
||||
|
||||
[n_it_tcscf_max]
|
||||
type: Strictly_positive_int
|
||||
doc: Maximum number of SCF iterations
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 50
|
||||
|
||||
[tc_Brillouin_Right]
|
||||
type: logical
|
||||
doc: If |true|, impose only right-Brillouin condition
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
|
@ -1,75 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
program combine_lr_tcscf
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
bi_ortho = .True.
|
||||
touch bi_ortho
|
||||
|
||||
call comb_orbitals()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine comb_orbitals()
|
||||
|
||||
implicit none
|
||||
integer :: i, m, n, nn, mm
|
||||
double precision :: accu_d, accu_nd
|
||||
double precision, allocatable :: R(:,:), L(:,:), Rnew(:,:), tmp(:,:), S(:,:)
|
||||
|
||||
n = ao_num
|
||||
m = mo_num
|
||||
nn = elec_alpha_num
|
||||
mm = m - nn
|
||||
|
||||
allocate(L(n,m), R(n,m), Rnew(n,m), S(m,m))
|
||||
L = mo_l_coef
|
||||
R = mo_r_coef
|
||||
|
||||
call check_weighted_biorthog(n, m, ao_overlap, L, R, accu_d, accu_nd, S, .true.)
|
||||
|
||||
allocate(tmp(n,nn))
|
||||
do i = 1, nn
|
||||
tmp(1:n,i) = R(1:n,i)
|
||||
enddo
|
||||
call impose_weighted_orthog_svd(n, nn, ao_overlap, tmp)
|
||||
do i = 1, nn
|
||||
Rnew(1:n,i) = tmp(1:n,i)
|
||||
enddo
|
||||
deallocate(tmp)
|
||||
|
||||
allocate(tmp(n,mm))
|
||||
do i = 1, mm
|
||||
tmp(1:n,i) = L(1:n,i+nn)
|
||||
enddo
|
||||
call impose_weighted_orthog_svd(n, mm, ao_overlap, tmp)
|
||||
do i = 1, mm
|
||||
Rnew(1:n,i+nn) = tmp(1:n,i)
|
||||
enddo
|
||||
deallocate(tmp)
|
||||
|
||||
call check_weighted_biorthog(n, m, ao_overlap, Rnew, Rnew, accu_d, accu_nd, S, .true.)
|
||||
|
||||
mo_r_coef = Rnew
|
||||
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
|
||||
|
||||
deallocate(L, R, Rnew, S)
|
||||
|
||||
end subroutine comb_orbitals
|
||||
|
||||
! ---
|
||||
|
@ -1,96 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_mo, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i, j
|
||||
integer :: liwork, lwork, n, info
|
||||
integer, allocatable :: iwork(:)
|
||||
double precision, allocatable :: work(:), F(:,:), F_save(:,:)
|
||||
double precision, allocatable :: diag(:)
|
||||
|
||||
PROVIDE mo_r_coef
|
||||
PROVIDE Fock_matrix_vartc_mo_tot
|
||||
|
||||
allocate( F(mo_num,mo_num), F_save(mo_num,mo_num) )
|
||||
allocate (diag(mo_num) )
|
||||
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
F(i,j) = Fock_matrix_vartc_mo_tot(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Insert level shift here
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
F(i,i) += 0.5d0 * level_shift_tcscf
|
||||
enddo
|
||||
do i = elec_alpha_num+1, mo_num
|
||||
F(i,i) += level_shift_tcscf
|
||||
enddo
|
||||
|
||||
n = mo_num
|
||||
lwork = 1+6*n + 2*n*n
|
||||
liwork = 3 + 5*n
|
||||
|
||||
allocate(work(lwork))
|
||||
allocate(iwork(liwork) )
|
||||
|
||||
lwork = -1
|
||||
liwork = -1
|
||||
|
||||
F_save = F
|
||||
call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
|
||||
|
||||
if (info /= 0) then
|
||||
print *, irp_here//' DSYEVD failed : ', info
|
||||
stop 1
|
||||
endif
|
||||
lwork = int(work(1))
|
||||
liwork = iwork(1)
|
||||
deallocate(iwork)
|
||||
deallocate(work)
|
||||
|
||||
allocate(work(lwork))
|
||||
allocate(iwork(liwork) )
|
||||
call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
|
||||
deallocate(iwork)
|
||||
|
||||
if (info /= 0) then
|
||||
F = F_save
|
||||
call dsyev('V', 'L', mo_num, F, size(F, 1), diag, work, lwork, info)
|
||||
|
||||
if (info /= 0) then
|
||||
print *, irp_here//' DSYEV failed : ', info
|
||||
stop 1
|
||||
endif
|
||||
endif
|
||||
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
fock_vartc_eigvec_mo(j,i) = F(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(work, F, F_save, diag)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_ao, (ao_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
|
||||
PROVIDE mo_r_coef
|
||||
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
||||
, mo_r_coef, size(mo_r_coef, 1), fock_vartc_eigvec_mo, size(fock_vartc_eigvec_mo, 1) &
|
||||
, 0.d0, fock_vartc_eigvec_ao, size(fock_vartc_eigvec_ao, 1))
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
@ -91,29 +91,15 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
double precision, allocatable :: F(:,:)
|
||||
|
||||
!print *, ' Providing FQS_SQF_ao ...'
|
||||
!call wall_time(t0)
|
||||
PROVIDE Fock_matrix_tc_ao_tot
|
||||
|
||||
allocate(F(ao_num,ao_num))
|
||||
if(var_tc) then
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
F(j,i) = Fock_matrix_vartc_ao_tot(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
PROVIDE Fock_matrix_tc_ao_tot
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
F(j,i) = Fock_matrix_tc_ao_tot(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
allocate(tmp(ao_num,ao_num))
|
||||
|
||||
! F x Q
|
||||
@ -140,9 +126,6 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
|
||||
deallocate(tmp)
|
||||
deallocate(F)
|
||||
|
||||
!call wall_time(t1)
|
||||
!print *, ' Wall time for FQS_SQF_ao =', t1-t0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
@ -152,61 +135,13 @@ BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
|
||||
implicit none
|
||||
double precision :: t0, t1
|
||||
|
||||
!print*, ' Providing FQS_SQF_mo ...'
|
||||
!call wall_time(t0)
|
||||
|
||||
PROVIDE mo_r_coef mo_l_coef
|
||||
PROVIDE FQS_SQF_ao
|
||||
|
||||
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
|
||||
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
|
||||
|
||||
!call wall_time(t1)
|
||||
!print*, ' Wall time for FQS_SQF_mo =', t1-t0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
! BEGIN_PROVIDER [ double precision, eigenval_Fock_tc_ao, (ao_num) ]
|
||||
!&BEGIN_PROVIDER [ double precision, eigenvec_Fock_tc_ao, (ao_num,ao_num) ]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! Eigenvalues and eigenvectors of the Fock matrix over the ao basis
|
||||
! !
|
||||
! ! F' = X.T x F x X where X = ao_overlap^(-1/2)
|
||||
! !
|
||||
! ! F' x Cr' = Cr' x E ==> F Cr = Cr x E with Cr = X x Cr'
|
||||
! ! F'.T x Cl' = Cl' x E ==> F.T Cl = Cl x E with Cl = X x Cl'
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
! implicit none
|
||||
! double precision, allocatable :: tmp1(:,:), tmp2(:,:)
|
||||
!
|
||||
! ! ---
|
||||
! ! Fock matrix in orthogonal basis: F' = X.T x F x X
|
||||
!
|
||||
! allocate(tmp1(ao_num,ao_num))
|
||||
! call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
! , Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), S_half_inv, size(S_half_inv, 1) &
|
||||
! , 0.d0, tmp1, size(tmp1, 1) )
|
||||
!
|
||||
! allocate(tmp2(ao_num,ao_num))
|
||||
! call dgemm( 'T', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
! , S_half_inv, size(S_half_inv, 1), tmp1, size(tmp1, 1) &
|
||||
! , 0.d0, tmp2, size(tmp2, 1) )
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! ! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues
|
||||
! ! TODO
|
||||
!
|
||||
! ! Back-transform eigenvectors: C =X.C'
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
~
|
||||
|
@ -1,280 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j, ipoint
|
||||
double precision :: ti, tf
|
||||
double precision :: loc_1, loc_2, loc_3
|
||||
double precision, allocatable :: Okappa(:), Jkappa(:,:)
|
||||
double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
|
||||
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
|
||||
double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
|
||||
Jkappa = 0.d0
|
||||
Okappa = 0.d0
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
|
||||
!$OMP SHARED (n_points_final_grid, elec_beta_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa)
|
||||
|
||||
allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
|
||||
tmp_omp_d2 = 0.d0
|
||||
tmp_omp_d1 = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do i = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
|
||||
tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
|
||||
tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
|
||||
tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do ipoint = 1, n_points_final_grid
|
||||
Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
|
||||
Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
|
||||
Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
|
||||
Okappa(ipoint) += tmp_omp_d1(ipoint)
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp_omp_d2, tmp_omp_d1)
|
||||
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp_1(n_points_final_grid,4))
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = 2.d0 * Okappa(ipoint)
|
||||
|
||||
tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1)
|
||||
tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2)
|
||||
tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3)
|
||||
|
||||
tmp_1(ipoint,4) = Okappa(ipoint)
|
||||
enddo
|
||||
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2) &
|
||||
!$OMP SHARED (n_points_final_grid, elec_beta_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP int2_grad1_u12_bimo_t, tmp_1)
|
||||
|
||||
allocate(tmp_omp_d2(n_points_final_grid,3))
|
||||
tmp_omp_d2 = 0.d0
|
||||
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do i = 1, elec_beta_num
|
||||
do j = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
|
||||
|
||||
tmp_omp_d2(ipoint,1) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
|
||||
tmp_omp_d2(ipoint,2) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
|
||||
tmp_omp_d2(ipoint,3) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
|
||||
tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
|
||||
tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp_omp_d2)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, a, b) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
|
||||
!$OMP tmp_2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
|
||||
tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
|
||||
tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, a, b, i) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP tmp_2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
tmp_2(:,4,b,a) = 0.d0
|
||||
do i = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
|
||||
, tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
|
||||
, tmp_1(1,1), 1 &
|
||||
, 0.d0, fock_3e_uhf_mo_cs(1,1), 1)
|
||||
|
||||
deallocate(tmp_1, tmp_2)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp_3(n_points_final_grid,5,mo_num), tmp_4(n_points_final_grid,5,mo_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP final_weight_at_r_vector, Jkappa, tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
tmp_3(:,:,b) = 0.d0
|
||||
tmp_4(:,:,b) = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
|
||||
|
||||
tmp_4(ipoint,1,b) = -2.d0 * mos_r_in_r_array_transp(ipoint,b) * ( Jkappa(ipoint,1) * Jkappa(ipoint,1) &
|
||||
+ Jkappa(ipoint,2) * Jkappa(ipoint,2) &
|
||||
+ Jkappa(ipoint,3) * Jkappa(ipoint,3) )
|
||||
tmp_4(ipoint,5,b) = mos_r_in_r_array_transp(ipoint,b)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b, i, loc_1, loc_2) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP Jkappa, tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
do i = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
|
||||
loc_2 = mos_r_in_r_array_transp(ipoint,i)
|
||||
|
||||
tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
|
||||
tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
|
||||
tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
|
||||
tmp_3(ipoint,5,b) += 2.d0 * loc_1 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
|
||||
+ Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
|
||||
+ Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
|
||||
|
||||
tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
|
||||
tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
|
||||
tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
|
||||
tmp_4(ipoint,1,b) += 2.d0 * loc_2 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
|
||||
+ Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
|
||||
+ Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
do i = 1, elec_beta_num
|
||||
do j = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
|
||||
loc_2 = mos_r_in_r_array_transp(ipoint,b)
|
||||
loc_3 = mos_r_in_r_array_transp(ipoint,i)
|
||||
|
||||
tmp_3(ipoint,5,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
|
||||
|
||||
tmp_4(ipoint,1,b) += ( loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) &
|
||||
- loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 &
|
||||
, tmp_3(1,1,1), 5*n_points_final_grid &
|
||||
, tmp_4(1,1,1), 5*n_points_final_grid &
|
||||
, 1.d0, fock_3e_uhf_mo_cs(1,1), mo_num)
|
||||
|
||||
deallocate(tmp_3, tmp_4)
|
||||
deallocate(Jkappa, Okappa)
|
||||
|
||||
! ---
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
@ -1,536 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_os, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_os, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Open Shell part of the Fock matrix from three-electron terms
|
||||
!
|
||||
! WARNING :: non hermitian if bi-ortho MOS used
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j, ipoint
|
||||
double precision :: loc_1, loc_2, loc_3, loc_4
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: Okappa(:), Jkappa(:,:), Obarkappa(:), Jbarkappa(:,:)
|
||||
double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
|
||||
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
|
||||
double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' Providing fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
|
||||
allocate(Jbarkappa(n_points_final_grid,3), Obarkappa(n_points_final_grid))
|
||||
Jkappa = 0.d0
|
||||
Okappa = 0.d0
|
||||
Jbarkappa = 0.d0
|
||||
Obarkappa = 0.d0
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
|
||||
!$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa, Obarkappa, Jbarkappa)
|
||||
|
||||
allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
|
||||
|
||||
tmp_omp_d2 = 0.d0
|
||||
tmp_omp_d1 = 0.d0
|
||||
!$OMP DO
|
||||
do i = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
|
||||
tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
|
||||
tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
|
||||
tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
!$OMP CRITICAL
|
||||
do ipoint = 1, n_points_final_grid
|
||||
Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
|
||||
Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
|
||||
Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
|
||||
Okappa(ipoint) += tmp_omp_d1(ipoint)
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
tmp_omp_d2 = 0.d0
|
||||
tmp_omp_d1 = 0.d0
|
||||
!$OMP DO
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
|
||||
tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
|
||||
tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
|
||||
tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
!$OMP CRITICAL
|
||||
do ipoint = 1, n_points_final_grid
|
||||
Jbarkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
|
||||
Jbarkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
|
||||
Jbarkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
|
||||
Obarkappa(ipoint) += tmp_omp_d1(ipoint)
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp_omp_d2, tmp_omp_d1)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp_1(n_points_final_grid,4))
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = -2.d0 * Okappa (ipoint)
|
||||
loc_2 = -2.d0 * Obarkappa(ipoint)
|
||||
loc_3 = Obarkappa(ipoint)
|
||||
|
||||
tmp_1(ipoint,1) = (loc_1 - loc_3) * Jbarkappa(ipoint,1) + loc_2 * Jkappa(ipoint,1)
|
||||
tmp_1(ipoint,2) = (loc_1 - loc_3) * Jbarkappa(ipoint,2) + loc_2 * Jkappa(ipoint,2)
|
||||
tmp_1(ipoint,3) = (loc_1 - loc_3) * Jbarkappa(ipoint,3) + loc_2 * Jkappa(ipoint,3)
|
||||
|
||||
tmp_1(ipoint,4) = Obarkappa(ipoint)
|
||||
enddo
|
||||
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, loc_1, loc_2, tmp_omp_d2) &
|
||||
!$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP int2_grad1_u12_bimo_t, tmp_1)
|
||||
|
||||
allocate(tmp_omp_d2(n_points_final_grid,3))
|
||||
|
||||
tmp_omp_d2 = 0.d0
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do i = 1, elec_beta_num
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
|
||||
loc_2 = mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
|
||||
|
||||
tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,1,j,i)
|
||||
tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,2,j,i)
|
||||
tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,3,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
!$OMP CRITICAL
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
|
||||
tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
|
||||
tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
tmp_omp_d2 = 0.d0
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
|
||||
|
||||
tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
|
||||
tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
|
||||
tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
!$OMP CRITICAL
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
|
||||
tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
|
||||
tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp_omp_d2)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, a, b) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
|
||||
!$OMP tmp_2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
|
||||
tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
|
||||
tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, a, b, i) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP tmp_2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
tmp_2(:,4,b,a) = 0.d0
|
||||
do i = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_2(ipoint,4,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 1.d0 &
|
||||
, tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
|
||||
, tmp_1(1,1), 1 &
|
||||
, 0.d0, fock_3e_uhf_mo_b_os(1,1), 1)
|
||||
|
||||
deallocate(tmp_1, tmp_2)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp_3(n_points_final_grid,2,mo_num), tmp_4(n_points_final_grid,2,mo_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
tmp_3(:,:,b) = 0.d0
|
||||
tmp_4(:,:,b) = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
|
||||
|
||||
loc_1 = -2.0d0 * mos_r_in_r_array_transp(ipoint,b)
|
||||
|
||||
tmp_4(ipoint,1,b) = loc_1 * ( Jbarkappa(ipoint,1) * (Jkappa(ipoint,1) + 0.25d0 * Jbarkappa(ipoint,1)) &
|
||||
+ Jbarkappa(ipoint,2) * (Jkappa(ipoint,2) + 0.25d0 * Jbarkappa(ipoint,2)) &
|
||||
+ Jbarkappa(ipoint,3) * (Jkappa(ipoint,3) + 0.25d0 * Jbarkappa(ipoint,3)) )
|
||||
|
||||
tmp_4(ipoint,2,b) = mos_r_in_r_array_transp(ipoint,b)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
|
||||
do i = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
|
||||
loc_2 = mos_r_in_r_array_transp(ipoint,i)
|
||||
|
||||
tmp_3(ipoint,2,b) += loc_1 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
|
||||
+ Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
|
||||
+ Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
|
||||
|
||||
tmp_4(ipoint,1,b) += loc_2 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
|
||||
+ Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
|
||||
+ Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
do i = 1, elec_beta_num
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_2 = mos_r_in_r_array_transp(ipoint,b)
|
||||
|
||||
tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
|
||||
|
||||
tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
call dgemm( 'T', 'N', mo_num, mo_num, 2*n_points_final_grid, 1.d0 &
|
||||
, tmp_3(1,1,1), 2*n_points_final_grid &
|
||||
, tmp_4(1,1,1), 2*n_points_final_grid &
|
||||
, 1.d0, fock_3e_uhf_mo_b_os(1,1), mo_num)
|
||||
|
||||
deallocate(tmp_3, tmp_4)
|
||||
|
||||
|
||||
|
||||
|
||||
! ---
|
||||
|
||||
fock_3e_uhf_mo_a_os = fock_3e_uhf_mo_b_os
|
||||
|
||||
allocate(tmp_1(n_points_final_grid,1))
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_1(ipoint,1) = Obarkappa(ipoint) + 2.d0 * Okappa(ipoint)
|
||||
enddo
|
||||
|
||||
allocate(tmp_2(n_points_final_grid,1,mo_num,mo_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, a, b, i) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP tmp_2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
tmp_2(:,1,b,a) = 0.d0
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_2(ipoint,1,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call dgemv( 'T', n_points_final_grid, mo_num*mo_num, 1.d0 &
|
||||
, tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
|
||||
, tmp_1(1,1), 1 &
|
||||
, 1.d0, fock_3e_uhf_mo_a_os(1,1), 1)
|
||||
|
||||
deallocate(tmp_1, tmp_2)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp_3(n_points_final_grid,8,mo_num), tmp_4(n_points_final_grid,8,mo_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
tmp_3(:,:,b) = 0.d0
|
||||
tmp_4(:,:,b) = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
|
||||
|
||||
tmp_4(ipoint,8,b) = mos_r_in_r_array_transp(ipoint,b)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
do i = 1, elec_beta_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
|
||||
loc_2 = mos_r_in_r_array_transp(ipoint,i)
|
||||
|
||||
tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
|
||||
tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
|
||||
tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
|
||||
|
||||
tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
|
||||
tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
|
||||
tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
|
||||
loc_3 = 2.d0 * loc_1
|
||||
loc_2 = mos_r_in_r_array_transp(ipoint,i)
|
||||
loc_4 = 2.d0 * loc_2
|
||||
|
||||
tmp_3(ipoint,5,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
|
||||
tmp_3(ipoint,6,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
|
||||
tmp_3(ipoint,7,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
|
||||
|
||||
tmp_3(ipoint,8,b) += loc_3 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
|
||||
+ (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
|
||||
+ (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
|
||||
|
||||
tmp_4(ipoint,1,b) += loc_4 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
|
||||
+ (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
|
||||
+ (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
|
||||
|
||||
tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
|
||||
tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
|
||||
tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
|
||||
|
||||
tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
|
||||
tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
|
||||
tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
|
||||
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
|
||||
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
|
||||
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
|
||||
!$OMP tmp_3, tmp_4)
|
||||
!$OMP DO
|
||||
do b = 1, mo_num
|
||||
|
||||
do i = 1, elec_beta_num
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
|
||||
loc_2 = mos_r_in_r_array_transp(ipoint,b)
|
||||
loc_3 = mos_r_in_r_array_transp(ipoint,i)
|
||||
|
||||
tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
|
||||
|
||||
tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
|
||||
|
||||
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
|
||||
loc_3 = mos_r_in_r_array_transp(ipoint,j)
|
||||
|
||||
tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,b,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,b,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
|
||||
|
||||
tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
|
||||
loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
|
||||
loc_3 = mos_r_in_r_array_transp(ipoint,i)
|
||||
|
||||
tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
|
||||
|
||||
tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! ---
|
||||
|
||||
call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 &
|
||||
, tmp_3(1,1,1), 8*n_points_final_grid &
|
||||
, tmp_4(1,1,1), 8*n_points_final_grid &
|
||||
, 1.d0, fock_3e_uhf_mo_a_os(1,1), mo_num)
|
||||
|
||||
deallocate(tmp_3, tmp_4)
|
||||
deallocate(Jkappa, Okappa)
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' Wall time for fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
@ -1,77 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Fock matrix alpha from three-electron terms
|
||||
!
|
||||
! WARNING :: non hermitian if bi-ortho MOS used
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision :: ti, tf
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' Providing fock_3e_uhf_mo_a ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
! CLOSED-SHELL PART
|
||||
PROVIDE fock_3e_uhf_mo_cs
|
||||
fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
|
||||
|
||||
if(elec_alpha_num .ne. elec_beta_num) then
|
||||
|
||||
! OPEN-SHELL PART
|
||||
PROVIDE fock_3e_uhf_mo_a_os
|
||||
|
||||
fock_3e_uhf_mo_a += fock_3e_uhf_mo_a_os
|
||||
endif
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Fock matrix beta from three-electron terms
|
||||
!
|
||||
! WARNING :: non hermitian if bi-ortho MOS used
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision :: ti, tf
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' Providing and fock_3e_uhf_mo_b ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
! CLOSED-SHELL PART
|
||||
PROVIDE fock_3e_uhf_mo_cs
|
||||
fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
|
||||
|
||||
if(elec_alpha_num .ne. elec_beta_num) then
|
||||
|
||||
! OPEN-SHELL PART
|
||||
PROVIDE fock_3e_uhf_mo_b_os
|
||||
|
||||
fock_3e_uhf_mo_b += fock_3e_uhf_mo_b_os
|
||||
endif
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' Wall time for fock_3e_uhf_mo_b =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
@ -1,490 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs_old, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_cs_old ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_mo_cs_old = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
|
||||
!$OMP SHARED (mo_num, elec_beta_num, fock_3e_uhf_mo_cs_old)
|
||||
|
||||
allocate(tmp(mo_num,mo_num))
|
||||
tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
tmp(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- 2.d0 * I_bij_aji &
|
||||
- 2.d0 * I_bij_iaj &
|
||||
- 2.d0 * I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
fock_3e_uhf_mo_cs_old(b,a) += tmp(b,a)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_cs_old =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_old, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! ALPHA part of the Fock matrix from three-electron terms
|
||||
!
|
||||
! WARNING :: non hermitian if bi-ortho MOS used
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j, o
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
PROVIDE fock_3e_uhf_mo_cs
|
||||
|
||||
!print *, ' Providing fock_3e_uhf_mo_a_old ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
o = elec_beta_num + 1
|
||||
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
|
||||
|
||||
PROVIDE fock_3e_uhf_mo_cs_old
|
||||
fock_3e_uhf_mo_a_old = fock_3e_uhf_mo_cs_old
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
|
||||
!$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a_old)
|
||||
|
||||
allocate(tmp(mo_num,mo_num))
|
||||
tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj &
|
||||
- 2.d0 * I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- 2.d0 * I_bij_iaj &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
tmp(b,a) -= 0.5d0 * ( I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
fock_3e_uhf_mo_a_old(b,a) += tmp(b,a)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' Wall time for fock_3e_uhf_mo_a_old =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_old, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! BETA part of the Fock matrix from three-electron terms
|
||||
!
|
||||
! WARNING :: non hermitian if bi-ortho MOS used
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j, o
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_b_old ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
o = elec_beta_num + 1
|
||||
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
|
||||
|
||||
PROVIDE fock_3e_uhf_mo_cs_old
|
||||
fock_3e_uhf_mo_b_old = fock_3e_uhf_mo_cs_old
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
|
||||
!$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b_old)
|
||||
|
||||
allocate(tmp(mo_num,mo_num))
|
||||
tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
- I_bij_aji &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
tmp(b,a) -= 0.5d0 * ( I_bij_aij &
|
||||
- I_bij_aji )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
fock_3e_uhf_mo_b_old(b,a) += tmp(b,a)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_b_old =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Equations (B6) and (B7)
|
||||
!
|
||||
! g <--> gamma
|
||||
! d <--> delta
|
||||
! e <--> eta
|
||||
! k <--> kappa
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: g, d, e, k, mu, nu
|
||||
double precision :: dm_ge_a, dm_ge_b, dm_ge
|
||||
double precision :: dm_dk_a, dm_dk_b, dm_dk
|
||||
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: f_tmp(:,:)
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_ao_a ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_ao_a = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
||||
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
||||
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
|
||||
|
||||
allocate(f_tmp(ao_num,ao_num))
|
||||
f_tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do g = 1, ao_num
|
||||
do e = 1, ao_num
|
||||
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
||||
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
|
||||
dm_ge = dm_ge_a + dm_ge_b
|
||||
do d = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
|
||||
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
|
||||
dm_dk = dm_dk_a + dm_dk_b
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
|
||||
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
|
||||
+ dm_ge_a * dm_dk_a * i_mugd_eknu &
|
||||
+ dm_ge_a * dm_dk_a * i_mugd_knue &
|
||||
- dm_ge_a * dm_dk * i_mugd_enuk &
|
||||
- dm_ge * dm_dk_a * i_mugd_kenu &
|
||||
- dm_ge_a * dm_dk_a * i_mugd_nuke &
|
||||
- dm_ge_b * dm_dk_b * i_mugd_nuke )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(f_tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Equations (B6) and (B7)
|
||||
!
|
||||
! g <--> gamma
|
||||
! d <--> delta
|
||||
! e <--> eta
|
||||
! k <--> kappa
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: g, d, e, k, mu, nu
|
||||
double precision :: dm_ge_a, dm_ge_b, dm_ge
|
||||
double precision :: dm_dk_a, dm_dk_b, dm_dk
|
||||
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: f_tmp(:,:)
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_ao_b ...'
|
||||
!call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_ao_b = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
||||
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
||||
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
|
||||
|
||||
allocate(f_tmp(ao_num,ao_num))
|
||||
f_tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do g = 1, ao_num
|
||||
do e = 1, ao_num
|
||||
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
||||
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
|
||||
dm_ge = dm_ge_a + dm_ge_b
|
||||
do d = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
|
||||
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
|
||||
dm_dk = dm_dk_a + dm_dk_b
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
|
||||
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
|
||||
+ dm_ge_b * dm_dk_b * i_mugd_eknu &
|
||||
+ dm_ge_b * dm_dk_b * i_mugd_knue &
|
||||
- dm_ge_b * dm_dk * i_mugd_enuk &
|
||||
- dm_ge * dm_dk_b * i_mugd_kenu &
|
||||
- dm_ge_b * dm_dk_b * i_mugd_nuke &
|
||||
- dm_ge_a * dm_dk_a * i_mugd_nuke )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(f_tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
@ -1,107 +0,0 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, good_hermit_tc_fock_mat, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! good_hermit_tc_fock_mat = Hermitian Upper triangular Fock matrix
|
||||
!
|
||||
! The converged eigenvectors of such matrix yield to orthonormal vectors satisfying the left Brillouin theorem
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i, j
|
||||
|
||||
good_hermit_tc_fock_mat = Fock_matrix_tc_mo_tot
|
||||
do j = 1, mo_num
|
||||
do i = 1, j-1
|
||||
good_hermit_tc_fock_mat(i,j) = Fock_matrix_tc_mo_tot(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! hermit_average_tc_fock_mat = (F + F^\dagger)/2
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i, j
|
||||
|
||||
hermit_average_tc_fock_mat = Fock_matrix_tc_mo_tot
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
hermit_average_tc_fock_mat(i,j) = 0.5d0 * (Fock_matrix_tc_mo_tot(j,i) + Fock_matrix_tc_mo_tot(i,j))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! ---
|
||||
BEGIN_PROVIDER [ double precision, grad_hermit]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! square of gradient of the energy
|
||||
END_DOC
|
||||
if(symetric_fock_tc)then
|
||||
grad_hermit = grad_hermit_average_tc_fock_mat
|
||||
else
|
||||
grad_hermit = grad_good_hermit_tc_fock_mat
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! grad_good_hermit_tc_fock_mat = norm of gradients of the upper triangular TC fock
|
||||
END_DOC
|
||||
integer :: i, j
|
||||
grad_good_hermit_tc_fock_mat = 0.d0
|
||||
do i = 1, elec_alpha_num
|
||||
do j = elec_alpha_num+1, mo_num
|
||||
grad_good_hermit_tc_fock_mat += dabs(good_hermit_tc_fock_mat(i,j))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad_hermit_average_tc_fock_mat]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! grad_hermit_average_tc_fock_mat = norm of gradients of the upper triangular TC fock
|
||||
END_DOC
|
||||
integer :: i, j
|
||||
grad_hermit_average_tc_fock_mat = 0.d0
|
||||
do i = 1, elec_alpha_num
|
||||
do j = elec_alpha_num+1, mo_num
|
||||
grad_hermit_average_tc_fock_mat += dabs(hermit_average_tc_fock_mat(i,j))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! ---
|
||||
|
||||
subroutine save_good_hermit_tc_eigvectors()
|
||||
|
||||
implicit none
|
||||
integer :: sign
|
||||
character*(64) :: label
|
||||
logical :: output
|
||||
|
||||
sign = 1
|
||||
label = "Canonical"
|
||||
output = .False.
|
||||
|
||||
if(symetric_fock_tc)then
|
||||
call mo_as_eigvectors_of_mo_matrix(hermit_average_tc_fock_mat, mo_num, mo_num, label, sign, output)
|
||||
else
|
||||
call mo_as_eigvectors_of_mo_matrix(good_hermit_tc_fock_mat, mo_num, mo_num, label, sign, output)
|
||||
endif
|
||||
end subroutine save_good_hermit_tc_eigvectors
|
||||
|
||||
! ---
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user