mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-08-29 20:23:40 +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,9 +142,9 @@ 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
|
||||
|
||||
@ -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,8 +178,10 @@ 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
|
||||
@ -193,7 +195,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,
|
||||
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,7 +213,7 @@ 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
|
||||
@ -222,6 +224,10 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3,
|
||||
|
||||
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,17 +40,84 @@ 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)
|
||||
|
||||
FREE ao_two_e_tc_tot
|
||||
|
||||
allocate(a1(ao_num,ao_num,mo_num,mo_num))
|
||||
|
||||
call dgemm( 'T', 'N', ao_num*ao_num*mo_num, mo_num, ao_num, 1.d0 &
|
||||
@ -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,10 +281,13 @@ 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(:)
|
||||
|
||||
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
|
||||
@ -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,28 +339,23 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
|
||||
tmp = tmp * 0.5d0
|
||||
endif
|
||||
|
||||
!TODO : Powers to optimize here
|
||||
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**(mpA-1) * f2A**npA
|
||||
! tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA)
|
||||
!endif
|
||||
!if(npA .gt. 0) then
|
||||
! tmp1 = tmp1 + dble(npA) * f1A**(npA-1) * f2A**mpA
|
||||
! tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA)
|
||||
!endif
|
||||
! tmp1 = tmp1 * g12**(opA)
|
||||
!
|
||||
!tmp1 = tmp1 * g12**dble(opA)
|
||||
!tmp2 = 0.d0
|
||||
!if(opA .gt. 0) then
|
||||
! tmp2 = tmp2 + dble(opA) * g12**(opA-1) * (f1A**(mpA) * f2A**(npA) + f1A**(npA) * f2A**(mpA))
|
||||
! tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(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))
|
||||
|
||||
|
||||
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))
|
||||
gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * grad1_f1A(3) + tmp2 * grad1_g12(3))
|
||||
@ -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
|
||||
|
@ -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
|
||||
|
||||
! ---
|
||||
|
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user