PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-22 20:34:58 +01:00
Code Releases Activity

fixed inout problem

Browse Source
This commit is contained in:
Abdallah Ammar 2023-04-16 19:47:00 +02:00
parent eea6758d26
commit 16a17f021a
1 changed files with 64 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
src/tc_bi_ortho/h_tc_s2_u0.irp.f
View File

@ -1,7 +1,6 @@
subroutine get_H_tc_s2_l0_r0(l_0,r_0,N_st,sze,energies, s2)
use bitmasks
implicit none
subroutine get_H_tc_s2_l0_r0(l_0, r_0, N_st, sze, energies, s2)
BEGIN_DOC
! Computes $e_0 = \langle l_0 | H | r_0\rangle$.
!
@ -11,6 +10,10 @@ subroutine get_H_tc_s2_l0_r0(l_0,r_0,N_st,sze,energies, s2)
!
! istart, iend, ishift, istep are used in ZMQ parallelization.
END_DOC
use bitmasks
implicit none
integer, intent(in) :: N_st,sze
double precision, intent(in) :: l_0(sze,N_st), r_0(sze,N_st)
double precision, intent(out) :: energies(N_st), s2(N_st)
@ -18,19 +21,23 @@ subroutine get_H_tc_s2_l0_r0(l_0,r_0,N_st,sze,energies, s2)
integer :: istate
double precision, allocatable :: s_0(:,:), v_0(:,:)
double precision :: u_dot_v, norm
allocate(s_0(sze,N_st), v_0(sze,N_st))
do_right = .True.
call H_tc_s2_u_0_opt(v_0,s_0,r_0,N_st,sze)
call H_tc_s2_u_0_opt(v_0, s_0, r_0, N_st, sze)
do istate = 1, N_st
norm = u_dot_v(l_0(1,istate),r_0(1,istate),sze)
energies(istate) = u_dot_v(l_0(1,istate),v_0(1,istate),sze)/norm
s2(istate) = u_dot_v(l_0(1,istate),s_0(1,istate),sze)/norm
enddo
end
subroutine H_tc_s2_u_0_opt(v_0,s_0,u_0,N_st,sze)
use bitmasks
implicit none
! ---
subroutine H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze)
BEGIN_DOC
! Computes $v_0 = H | u_0\rangle$.
!
@ -38,16 +45,24 @@ subroutine H_tc_s2_u_0_opt(v_0,s_0,u_0,N_st,sze)
!
! istart, iend, ishift, istep are used in ZMQ parallelization.
END_DOC
use bitmasks
implicit none
integer, intent(in) :: N_st,sze
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st), s_0(sze,N_st)
double precision, intent(in) :: u_0(sze,N_st)
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
logical :: do_right
do_right = .True.
call H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
call H_tc_s2_u_0_nstates_openmp(v_0, s_0, u_0, N_st, sze, do_right)
end
subroutine H_tc_s2_dagger_u_0_opt(v_0,s_0,u_0,N_st,sze)
use bitmasks
implicit none
! ---
subroutine H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze)
BEGIN_DOC
! Computes $v_0 = H | u_0\rangle$.
!
@ -55,17 +70,23 @@ subroutine H_tc_s2_dagger_u_0_opt(v_0,s_0,u_0,N_st,sze)
!
! istart, iend, ishift, istep are used in ZMQ parallelization.
END_DOC
integer, intent(in) :: N_st,sze
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st), s_0(sze,N_st)
logical :: do_right
do_right = .False.
call H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
end
subroutine H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
use bitmasks
implicit none
integer, intent(in) :: N_st,sze
double precision, intent(in) :: u_0(sze,N_st)
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
logical :: do_right
do_right = .False.
call H_tc_s2_u_0_nstates_openmp(v_0, s_0, u_0, N_st, sze, do_right)
end
! ---
subroutine H_tc_s2_u_0_nstates_openmp(v_0, s_0, u_0, N_st, sze, do_right)
BEGIN_DOC
! Computes $v_0 = H | u_0\rangle$.
!
@ -75,12 +96,18 @@ subroutine H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
!
! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
END_DOC
use bitmasks
implicit none
integer, intent(in) :: N_st,sze
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st), s_0(sze,N_st)
logical, intent(in) :: do_right
double precision, intent(in) :: u_0(sze,N_st)
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
integer :: k
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
allocate(u_t(N_st,N_det),v_t(N_st,N_det),s_t(N_st,N_det))
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
@ -119,6 +146,7 @@ subroutine H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
end
! ---
subroutine H_tc_s2_u_0_nstates_openmp_work(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep, do_right)
use bitmasks