"""
Fortran module TDVPOps: August 2017 (dj)
Contains the subroutines for the TDVP
**Authors**
* D. Jaschke
* M. L. Wall
**Details**
The following subroutines / functions are defined for the
applicable data type
+--------------------+-------------+---------+
| procedure | include.f90 | mpi.f90 |
+====================+=============+=========+
| tdvp2 | X | |
+--------------------+-------------+---------+
"""
[docs]def tdvp2_symm_mpo_complex():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_symm_mpo_complex(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(mpsc), intent(inout) :: Psi
complex(KIND=rKind), intent(in) :: deltat
type(mpo), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(tensorlistc), dimension(:), allocatable :: LR
! Modified time step for certain parts
complex(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_tensor), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(tensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_symm_mpo_complex:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_mpo : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_mpo : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_symm_mpo_complex
"""
return
[docs]def tdvp2_symm_mpoc_complex():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_symm_mpoc_complex(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(mpsc), intent(inout) :: Psi
complex(KIND=rKind), intent(in) :: deltat
type(mpoc), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(tensorlistc), dimension(:), allocatable :: LR
! Modified time step for certain parts
complex(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_tensorc), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(tensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_symm_mpoc_complex:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_mpoc : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_symm_mpoc_complex
"""
return
[docs]def tdvp2_symm_qmpo_complex():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_symm_qmpo_complex(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(qmpsc), intent(inout) :: Psi
complex(KIND=rKind), intent(in) :: deltat
type(qmpo), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(qtensorclist), dimension(:), allocatable :: LR
! Modified time step for certain parts
complex(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_qtensor), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(qtensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_symm_qmpo_complex:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_qmpo : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_symm_qmpo_complex
"""
return
[docs]def tdvp2_symm_qmpoc_complex():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_symm_qmpoc_complex(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(qmpsc), intent(inout) :: Psi
complex(KIND=rKind), intent(in) :: deltat
type(qmpoc), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(qtensorclist), dimension(:), allocatable :: LR
! Modified time step for certain parts
complex(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_qtensorc), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(qtensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_symm_qmpoc_complex:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_symm_qmpoc_complex
"""
return
[docs]def tdvp2_gen_mpo_complex():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_gen_mpo_complex(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(mpsc), intent(inout) :: Psi
complex(KIND=rKind), intent(in) :: deltat
type(mpo), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(tensorlistc), dimension(:), allocatable :: LR
! Modified time step for certain parts
complex(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_tensor), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(tensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_gen_mpo_complex:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_mpo : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_arnoldi_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_arnoldi_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_mpo : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_gen_mpo_complex
"""
return
[docs]def tdvp2_gen_mpoc_complex():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_gen_mpoc_complex(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(mpsc), intent(inout) :: Psi
complex(KIND=rKind), intent(in) :: deltat
type(mpoc), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(tensorlistc), dimension(:), allocatable :: LR
! Modified time step for certain parts
complex(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_tensorc), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(tensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_gen_mpoc_complex:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_arnoldi_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_arnoldi_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_mpoc : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_gen_mpoc_complex
"""
return
[docs]def tdvp2_gen_qmpo_complex():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_gen_qmpo_complex(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(qmpsc), intent(inout) :: Psi
complex(KIND=rKind), intent(in) :: deltat
type(qmpo), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(qtensorclist), dimension(:), allocatable :: LR
! Modified time step for certain parts
complex(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_qtensor), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(qtensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_gen_qmpo_complex:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_arnoldi_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_arnoldi_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_qmpo : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_gen_qmpo_complex
"""
return
[docs]def tdvp2_gen_qmpoc_complex():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_gen_qmpoc_complex(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(qmpsc), intent(inout) :: Psi
complex(KIND=rKind), intent(in) :: deltat
type(qmpoc), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(qtensorclist), dimension(:), allocatable :: LR
! Modified time step for certain parts
complex(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_qtensorc), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(qtensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_gen_qmpoc_complex:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_arnoldi_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_arnoldi_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_arnoldi_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_gen_qmpoc_complex
"""
return
[docs]def tdvp2_symm_mpo_real():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_symm_mpo_real(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(mps), intent(inout) :: Psi
real(KIND=rKind), intent(in) :: deltat
type(mpo), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(tensorlist), dimension(:), allocatable :: LR
! Modified time step for certain parts
real(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_tensor), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(tensor) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_symm_mpo_real:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_mpo : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpo : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_mpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_mpo : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_symm_mpo_real
"""
return
[docs]def tdvp2_symm_mpoc_real():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_symm_mpoc_real(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(mpsc), intent(inout) :: Psi
real(KIND=rKind), intent(in) :: deltat
type(mpoc), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(tensorlistc), dimension(:), allocatable :: LR
! Modified time step for certain parts
real(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_tensorc), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(tensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_symm_mpoc_real:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_mpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_mpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_mpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_mpoc : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_symm_mpoc_real
"""
return
[docs]def tdvp2_symm_qmpo_real():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_symm_qmpo_real(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(qmps), intent(inout) :: Psi
real(KIND=rKind), intent(in) :: deltat
type(qmpo), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(qtensorlist), dimension(:), allocatable :: LR
! Modified time step for certain parts
real(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_qtensor), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(qtensor) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_symm_qmpo_real:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpo : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpo : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpo : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_qmpo : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_symm_qmpo_real
"""
return
[docs]def tdvp2_symm_qmpoc_real():
"""
fortran-subroutine - August 2017 (dj, updated)
Propagate psi with the TEBD algorithm.
**Arguments**
converged : LOGICAL, out
Not referenced, only to provide equal interface.
cerr : REAL, inout
The cumulated error. The error done during this subroutine is
added to the incoming value.
renorm : CHARACTER, in
Flag if state vector should be renormalized to 1.
'N' : do not normalize (default); 'M' : normalize for MPS
1 / sqrt(norm);
pbc : LOGICAL, in
If PBC are used in any rule set. There is a check before,
but the debugging mode should ensure for now that there
are no calls with such a check.
**Details**
Currently uses complete reorthogonalization for stability.
(defined in TimeEvolutionOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine tdvp2_symm_qmpoc_real(Psi, deltat, Ham, converged, &
cerr, Cp, renorm, pbc, errst)
TYPE(qmpsc), intent(inout) :: Psi
real(KIND=rKind), intent(in) :: deltat
type(qmpoc), intent(inout) :: Ham
logical, intent(out) :: converged
real(KIND=rKind), intent(inout) :: cerr
type(ConvParam), intent(in) :: Cp
character, intent(in) :: renorm
logical, intent(in) :: pbc
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! save orthogonality center
integer :: ocsave
! provide local tolerance
real(KIND=rKind) :: local_tol
! Error from one step inside the algorithm
real(KIND=rKind) :: err
! Left-right overlaps
type(qtensorclist), dimension(:), allocatable :: LR
! Modified time step for certain parts
real(KIND=rKind) :: dt
! All two-site MPOs
type(sr_matrix_qtensorc), dimension(:), allocatable :: Hts
! Tensor representing two sites
type(qtensorc) :: Theta
!if(present(errst)) errst = 0
!if(pbc) then
! errst = raise_error('tdvp2_symm_qmpoc_real:'//&
! 'TDVP does not have PBC.', 99, 'TDVPOps_include.f90:97', &
! errst=errst)
! return
!end if
! Find criterion for convergence, right now always true
converged = .true.
if(Cp%psi_local_tol < 0.0_rKind) then
! One sweep = 2 * L local truncations
local_tol = Cp%psi_tol / (4.0_rKind * Psi%ll)
else
local_tol = Cp%psi_local_tol
end if
ocsave = Psi%oc
if(ocsave /= 1) then
call canonize(Psi, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : canonize (1) '//&
! 'failed.', errst=errst)) return
end if
dt = deltat / 2.0_rKind
call setuplr(LR, Psi, Ham, Psi, Psi%oc)
cerr = 0.0_rKind
! Prepare two site MPO matrices
allocate(Hts(Psi%ll - 1))
do jj = 1, (Psi%ll - 1)
call sdot(Hts(jj), Ham%Ws(jj), Ham%Ws(jj + 1))
end do
! Rightmoving sweep
! -----------------
do jj = 1, (Psi%ll - 2)
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), dt, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:145', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:152', errst=errst)) return
cerr = cerr + err
Psi%oc= jj + 1
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, jj, 1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:161', errst=errst)) return
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj + 1), LR(jj), Ham%Ws(jj + 1), &
LR(min(jj + 2, Psi%ll)), -dt, .false., &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:168', errst=errst)) return
end do
! Full time step at last H^{(2)}
! ------------------------------
jj = Psi%ll - 1
call contr(Theta, Psi%Aa(jj), Psi%Aa(jj + 1), [3], [1])
call destroy(Psi%Aa(jj))
call destroy(Psi%Aa(jj + 1))
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 1)), Hts(jj), &
LR(min(jj + 2, Psi%ll)), deltat, (1 == jj), &
(jj + 1 == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:187', errst=errst)) return
call split(Psi%Aa(jj), Psi%Lambda(jj + 1), Psi%Aa(jj + 1), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:194', errst=errst)) return
cerr = cerr + err
Psi%oc= jj
Psi%haslambda(jj + 1) = .true.
call destroy(Theta)
call updatelr(LR, Psi, Ham, Psi, Psi%ll, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:202', errst=errst)) return
! Leftmoving sweep
! ----------------
do jj = (Psi%ll - 1), 2, (-1)
! Evolve under Heff_{j+1}^{(1)}
call krylov_full_local(Psi%Aa(jj), LR(max(1, jj - 1)), Ham%Ws(jj), &
LR(min(jj + 1, Psi%ll)), -dt, (jj == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:213', errst=errst)) return
call contr(Theta, Psi%Aa(jj - 1), Psi%Aa(jj), [3], [1])
call destroy(Psi%Aa(jj - 1))
call destroy(Psi%Aa(jj))
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
! Evolve under Heff_j^{(2)}
call krylov_full_local(Theta, LR(max(1, jj - 2)), Hts(jj -1), &
LR(min(jj + 1, Psi%ll)), dt, (jj - 1 == 1), &
(jj == Psi%ll), Cp, pbc, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : krylov_full_local'//&
! ' failed.', 'TDVPOps_include.f90:226', errst=errst)) return
call split(Psi%Aa(jj - 1), Psi%Lambda(jj), Psi%Aa(jj), Theta, &
[1, 2], [3, 4], multlr=-1, trunc=local_tol, &
ncut=Cp%max_bond_dimension, err=err, renorm=renorm, &
method='Y', errst=errst)
!if(prop_error('tdvp2_method_qmpoc : split'//&
! ' failed.', 'TDVPOps_include.f90:233', errst=errst)) return
cerr = cerr + err
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
call destroy(Theta)
if(jj .ne. 2) then
call updatelr(LR, Psi, Ham, Psi, jj, -1, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : updatelr'//&
! ' failed.', 'TDVPOps_include.f90:242', errst=errst)) return
end if
end do
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('tdvp2_method_qmpoc : canonize (2) '//&
! 'failed.', errst=errst)) return
do jj = 1, (Psi%ll - 1)
call destroy(Hts(jj))
end do
do ii = 1, size(LR, 1)
do jj = 1, size(LR(ii)%Li, 1)
call destroy(LR(ii)%Li(jj))
end do
deallocate(LR(ii)%Li)
end do
deallocate(LR, Hts)
end subroutine tdvp2_symm_qmpoc_real
"""
return