"""
Fortran module LanczosOps: July 2017 (dj, updated)
Containing the Lanczos algorithm.
**Authors**
* D. Jaschke
* M. L. Wall
**Details**
The following subroutines / functions are defined for the
symmetric tensors.
+---------------------+-------------+---------+---------+
| procedure | include.f90 | mpi.f90 | omp.f90 |
+=====================+=============+=========+=========+
| Lanczos | X | | |
+---------------------+-------------+---------+---------+
"""
[docs]def Lanczos_tensor_tensor():
"""
fortran-subroutine - ?? (mlw)
Use the Lanczos iteration to find the energy minimizing tensor
of the effective hamiltonian L.W.R. This routine assumes that psi
is the orthogonality center so that its bases define a vector space.
**Arguments**
Lc : TYPE(tensorlist), inout
Contains contractions of Hamiltonian with left part of the wave vector.
Wn : TYPE(tensor), inout
The MPO matrix for the corresponding n sites.
Rc : TYPE(tensorlist), inout
Contains contractions of Hamiltonian with right part of the wave vector.
eigval : REAL(KIND=rKind), out
Eigenvalue found during the Lanczos search.
Psin : TYPE(PSI_TYPE), inout
On entry the tensor representing the local eigenvalue problem and used
to generate initial guess etc. On exit the new eigenvector from the
Lanczos search.
**Details**
(template defined in LanczosOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine Lanczos_tensor_tensor(Lc, Wn, Rc, eigval, Psin, &
leftmost, rightmost, &
max_iter, tol, errst)
type(tensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_tensor), intent(inout) :: Wn
real(KIND=rKind), intent(out) :: eigval
type(tensor), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
integer, intent(in) :: max_iter
real(KIND=rKind), intent(in) :: tol
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: kk
! defining the number of Lanczos vectors used
integer :: finalkk
! intermediate tensors
type(tensor) :: Lanc, Hpsi, Temp
! eigenvector, vectors for diagonal and off-diagonal elements
real(KIND=rKind), allocatable :: beta(:), alpha(:), betap(:), &
alphap(:), evec(:)
! Flag for criterion to exit alogithm
logical :: quitflag
!if(present(errst)) errst = 0
! Store the initial lanczos vector for use in obtaining eigenvector
! later
call copy(Lanc, Psin, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: '//&
! 'copy failed.', 'LanczosOps_include.f90:96', &
! errst=errst)) return
quitflag = .false.
! Allocate arrays and initialize
allocate(alpha(max_iter + 1), beta(max_iter + 1), &
alphap(max_iter + 1), betap(max_iter + 1), &
evec(max_iter + 1))
alpha = 0.0_rKind
beta = 0.0_rKind
! Hpsi = H * Psi
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, rightmost, &
errst=errst)
!if(prop_error('Lanczos_tensor_tensor: mpo_dot_psi '//&
! 'failed.', 'LanczosOps_include.f90:113', errst=errst)) return
! 1) Build the basis of Lanczos vectors
! =====================================
kk = 1
alpha(1) = real(dot(Psin, Hpsi, errst=errst), KIND=rKind)
!if(prop_error('Lanczos_tensor_tensor: dot failed.', &
! 'LanczosOps_include.f90:121', errst=errst)) return
call gaxpy(Hpsi, -alpha(1), Psin, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: gaxpy failed.', &
! 'LanczosOps_include.f90:125', errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
evec(1) = 1.0_rKind
eigval = alpha(1)
! Loop up to matrix size
finalkk = 0
do kk = 1, max_iter
! Check soft and hard convergence criteria
if((beta(kk) < tol) .or. (kk == max_iter)) then
quitflag = .true.
exit
end if
! Perform the recursion
call pointto(Temp, Psin)
call pointto(Psin, Hpsi)
call scale(done / beta(kk), Psin, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: scale.', &
! 'LanczosOps_include.f90:149', errst=errst)) return
call pointto(Hpsi, Temp)
call scale(-done * beta(kk), Hpsi)
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, rightmost, &
beta=done, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:157', &
! errst=errst)) return
finalkk = finalkk + 1
alpha(kk + 1) = real(dot(Psin, Hpsi), KIND=rKind)
call gaxpy(HPsi, -alpha(kk + 1), Psin, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:165', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
alphap(1:kk + 1) = alpha(1:kk + 1)
betap(1:kk) = beta(1:kk)
call eigd(alphap(1:kk + 1), betap(1:kk), eigval, &
evec(1:kk + 1), errst=errst)
!if(prop_error('Lanczos_tensor_tensor: eigd.', &
! 'LanczosOps_include.f90:176', errst=errst)) return
! exit with converged residual
if(abs(evec(kk + 1) * beta(kk)) <= tol) then
exit
end if
end do
! 2) Regenerate lanczos vectors to transform eigenvector to correct
! basis ========================================================
! ========
call destroy(Psin)
call copy(Psin, Lanc, scalar=done * evec(1))
! Hpsi = H * Lanc
call destroy(Hpsi)
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, rightmost, &
errst=errst)
!if(prop_error('Lanczos_tensor_tensor: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:196', &
! errst=errst)) return
alpha(1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(1), Lanc, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: gaxpy failed.', &
! 'LanczosOps_include.f90:202', errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
! Loop up to matrix size
do kk = 1, finalkk
! Perform the recursion
call pointto(Temp, Lanc)
call pointto(Lanc, Hpsi)
call scale(done / beta(kk), Lanc)
call pointto(Hpsi, Temp)
call scale(-done * beta(kk), Hpsi)
call gaxpy(Psin, evec(kk + 1), Lanc, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:219', &
! errst=errst)) return
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, rightmost, &
beta=done, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:225', &
! errst=errst)) return
alpha(kk + 1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Lanc, errst=errst)
!if(prop_error('Lanczos_tensor_tensor: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:231', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
end do
call destroy(Hpsi)
call destroy(Lanc)
deallocate(alpha, beta, evec, alphap, betap)
call scale(1.0_rKind / sqrt(norm(Psin)), Psin)
end subroutine Lanczos_tensor_tensor
"""
return
[docs]def Lanczos_tensorc_tensorc():
"""
fortran-subroutine - ?? (mlw)
**Arguments**
Use the Lanczos iteration to find the energy minimizing tensor
of the effective hamiltonian L.W.R. This routine assumes that psi
is the orthogonality center so that its bases define a vector space.
Lc : TYPE(tensorlistc), inout
Contains contractions of Hamiltonian with left part of the wave vector.
Wn : TYPE(tensorc), inout
The MPO matrix for the corresponding n sites.
Rc : TYPE(tensorlistc), inout
Contains contractions of Hamiltonian with right part of the wave vector.
eigval : REAL(KIND=rKind), out
Eigenvalue found during the Lanczos search.
Psin : TYPE(PSI_TYPE), inout
On entry the tensor representing the local eigenvalue problem and used
to generate initial guess etc. On exit the new eigenvector from the
Lanczos search.
**Details**
(template defined in LanczosOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine Lanczos_tensorc_tensorc(Lc, Wn, Rc, eigval, Psin, &
leftmost, rightmost, &
max_iter, tol, errst)
type(tensorlistc), intent(inout) :: Lc, Rc
type(sr_matrix_tensorc), intent(inout) :: Wn
real(KIND=rKind), intent(out) :: eigval
type(tensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
integer, intent(in) :: max_iter
real(KIND=rKind), intent(in) :: tol
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: kk
! defining the number of Lanczos vectors used
integer :: finalkk
! intermediate tensors
type(tensorc) :: Lanc, Hpsi, Temp
! eigenvector, vectors for diagonal and off-diagonal elements
real(KIND=rKind), allocatable :: beta(:), alpha(:), betap(:), &
alphap(:), evec(:)
! Flag for criterion to exit alogithm
logical :: quitflag
!if(present(errst)) errst = 0
! Store the initial lanczos vector for use in obtaining eigenvector
! later
call copy(Lanc, Psin, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: '//&
! 'copy failed.', 'LanczosOps_include.f90:96', &
! errst=errst)) return
quitflag = .false.
! Allocate arrays and initialize
allocate(alpha(max_iter + 1), beta(max_iter + 1), &
alphap(max_iter + 1), betap(max_iter + 1), &
evec(max_iter + 1))
alpha = 0.0_rKind
beta = 0.0_rKind
! Hpsi = H * Psi
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, rightmost, &
errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: mpo_dot_psi '//&
! 'failed.', 'LanczosOps_include.f90:113', errst=errst)) return
! 1) Build the basis of Lanczos vectors
! =====================================
kk = 1
alpha(1) = real(dot(Psin, Hpsi, errst=errst), KIND=rKind)
!if(prop_error('Lanczos_tensorc_tensorc: dot failed.', &
! 'LanczosOps_include.f90:121', errst=errst)) return
call gaxpy(Hpsi, -alpha(1), Psin, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: gaxpy failed.', &
! 'LanczosOps_include.f90:125', errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
evec(1) = 1.0_rKind
eigval = alpha(1)
! Loop up to matrix size
finalkk = 0
do kk = 1, max_iter
! Check soft and hard convergence criteria
if((beta(kk) < tol) .or. (kk == max_iter)) then
quitflag = .true.
exit
end if
! Perform the recursion
call pointto(Temp, Psin)
call pointto(Psin, Hpsi)
call scale(zone / beta(kk), Psin, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: scale.', &
! 'LanczosOps_include.f90:149', errst=errst)) return
call pointto(Hpsi, Temp)
call scale(-zone * beta(kk), Hpsi)
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, rightmost, &
beta=zone, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:157', &
! errst=errst)) return
finalkk = finalkk + 1
alpha(kk + 1) = real(dot(Psin, Hpsi), KIND=rKind)
call gaxpy(HPsi, -alpha(kk + 1), Psin, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:165', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
alphap(1:kk + 1) = alpha(1:kk + 1)
betap(1:kk) = beta(1:kk)
call eigd(alphap(1:kk + 1), betap(1:kk), eigval, &
evec(1:kk + 1), errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: eigd.', &
! 'LanczosOps_include.f90:176', errst=errst)) return
! exit with converged residual
if(abs(evec(kk + 1) * beta(kk)) <= tol) then
exit
end if
end do
! 2) Regenerate lanczos vectors to transform eigenvector to correct
! basis ========================================================
! ========
call destroy(Psin)
call copy(Psin, Lanc, scalar=zone * evec(1))
! Hpsi = H * Lanc
call destroy(Hpsi)
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, rightmost, &
errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:196', &
! errst=errst)) return
alpha(1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(1), Lanc, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: gaxpy failed.', &
! 'LanczosOps_include.f90:202', errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
! Loop up to matrix size
do kk = 1, finalkk
! Perform the recursion
call pointto(Temp, Lanc)
call pointto(Lanc, Hpsi)
call scale(zone / beta(kk), Lanc)
call pointto(Hpsi, Temp)
call scale(-zone * beta(kk), Hpsi)
call gaxpy(Psin, evec(kk + 1), Lanc, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:219', &
! errst=errst)) return
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, rightmost, &
beta=zone, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:225', &
! errst=errst)) return
alpha(kk + 1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Lanc, errst=errst)
!if(prop_error('Lanczos_tensorc_tensorc: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:231', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
end do
call destroy(Hpsi)
call destroy(Lanc)
deallocate(alpha, beta, evec, alphap, betap)
call scale(1.0_rKind / sqrt(norm(Psin)), Psin)
end subroutine Lanczos_tensorc_tensorc
"""
return
[docs]def Lanczos_qtensor_qtensor():
"""
fortran-subroutine - ?? (mlw)
**Arguments**
Use the Lanczos iteration to find the energy minimizing tensor
of the effective hamiltonian L.W.R. This routine assumes that psi
is the orthogonality center so that its bases define a vector space.
Lc : TYPE(qtensorlist), inout
Contains contractions of Hamiltonian with left part of the wave vector.
Wn : TYPE(qtensor), inout
The MPO matrix for the corresponding n sites.
Rc : TYPE(qtensorlist), inout
Contains contractions of Hamiltonian with right part of the wave vector.
eigval : REAL(KIND=rKind), out
Eigenvalue found during the Lanczos search.
Psin : TYPE(PSI_TYPE), inout
On entry the tensor representing the local eigenvalue problem and used
to generate initial guess etc. On exit the new eigenvector from the
Lanczos search.
**Details**
(template defined in LanczosOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine Lanczos_qtensor_qtensor(Lc, Wn, Rc, eigval, Psin, &
leftmost, rightmost, &
max_iter, tol, errst)
type(qtensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensor), intent(inout) :: Wn
real(KIND=rKind), intent(out) :: eigval
type(qtensor), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
integer, intent(in) :: max_iter
real(KIND=rKind), intent(in) :: tol
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: kk
! defining the number of Lanczos vectors used
integer :: finalkk
! intermediate tensors
type(qtensor) :: Lanc, Hpsi, Temp
! eigenvector, vectors for diagonal and off-diagonal elements
real(KIND=rKind), allocatable :: beta(:), alpha(:), betap(:), &
alphap(:), evec(:)
! Flag for criterion to exit alogithm
logical :: quitflag
!if(present(errst)) errst = 0
! Store the initial lanczos vector for use in obtaining eigenvector
! later
call copy(Lanc, Psin, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: '//&
! 'copy failed.', 'LanczosOps_include.f90:96', &
! errst=errst)) return
quitflag = .false.
! Allocate arrays and initialize
allocate(alpha(max_iter + 1), beta(max_iter + 1), &
alphap(max_iter + 1), betap(max_iter + 1), &
evec(max_iter + 1))
alpha = 0.0_rKind
beta = 0.0_rKind
! Hpsi = H * Psi
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, rightmost, &
errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: mpo_dot_psi '//&
! 'failed.', 'LanczosOps_include.f90:113', errst=errst)) return
! 1) Build the basis of Lanczos vectors
! =====================================
kk = 1
alpha(1) = real(dot(Psin, Hpsi, errst=errst), KIND=rKind)
!if(prop_error('Lanczos_qtensor_qtensor: dot failed.', &
! 'LanczosOps_include.f90:121', errst=errst)) return
call gaxpy(Hpsi, -alpha(1), Psin, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: gaxpy failed.', &
! 'LanczosOps_include.f90:125', errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
evec(1) = 1.0_rKind
eigval = alpha(1)
! Loop up to matrix size
finalkk = 0
do kk = 1, max_iter
! Check soft and hard convergence criteria
if((beta(kk) < tol) .or. (kk == max_iter)) then
quitflag = .true.
exit
end if
! Perform the recursion
call pointto(Temp, Psin)
call pointto(Psin, Hpsi)
call scale(done / beta(kk), Psin, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: scale.', &
! 'LanczosOps_include.f90:149', errst=errst)) return
call pointto(Hpsi, Temp)
call scale(-done * beta(kk), Hpsi)
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, rightmost, &
beta=done, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:157', &
! errst=errst)) return
finalkk = finalkk + 1
alpha(kk + 1) = real(dot(Psin, Hpsi), KIND=rKind)
call gaxpy(HPsi, -alpha(kk + 1), Psin, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:165', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
alphap(1:kk + 1) = alpha(1:kk + 1)
betap(1:kk) = beta(1:kk)
call eigd(alphap(1:kk + 1), betap(1:kk), eigval, &
evec(1:kk + 1), errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: eigd.', &
! 'LanczosOps_include.f90:176', errst=errst)) return
! exit with converged residual
if(abs(evec(kk + 1) * beta(kk)) <= tol) then
exit
end if
end do
! 2) Regenerate lanczos vectors to transform eigenvector to correct
! basis ========================================================
! ========
call destroy(Psin)
call copy(Psin, Lanc, scalar=done * evec(1))
! Hpsi = H * Lanc
call destroy(Hpsi)
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, rightmost, &
errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:196', &
! errst=errst)) return
alpha(1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(1), Lanc, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: gaxpy failed.', &
! 'LanczosOps_include.f90:202', errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
! Loop up to matrix size
do kk = 1, finalkk
! Perform the recursion
call pointto(Temp, Lanc)
call pointto(Lanc, Hpsi)
call scale(done / beta(kk), Lanc)
call pointto(Hpsi, Temp)
call scale(-done * beta(kk), Hpsi)
call gaxpy(Psin, evec(kk + 1), Lanc, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:219', &
! errst=errst)) return
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, rightmost, &
beta=done, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:225', &
! errst=errst)) return
alpha(kk + 1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Lanc, errst=errst)
!if(prop_error('Lanczos_qtensor_qtensor: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:231', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
end do
call destroy(Hpsi)
call destroy(Lanc)
deallocate(alpha, beta, evec, alphap, betap)
call scale(1.0_rKind / sqrt(norm(Psin)), Psin)
end subroutine Lanczos_qtensor_qtensor
"""
return
[docs]def Lanczos_qtensorc_qtensorc():
"""
fortran-subroutine - ?? (mlw)
**Arguments**
Use the Lanczos iteration to find the energy minimizing tensor
of the effective hamiltonian L.W.R. This routine assumes that psi
is the orthogonality center so that its bases define a vector space.
Lc : TYPE(qtensorclist), inout
Contains contractions of Hamiltonian with left part of the wave vector.
Wn : TYPE(qtensorc), inout
The MPO matrix for the corresponding n sites.
Rc : TYPE(qtensorclist), inout
Contains contractions of Hamiltonian with right part of the wave vector.
eigval : REAL(KIND=rKind), out
Eigenvalue found during the Lanczos search.
Psin : TYPE(PSI_TYPE), inout
On entry the tensor representing the local eigenvalue problem and used
to generate initial guess etc. On exit the new eigenvector from the
Lanczos search.
**Details**
(template defined in LanczosOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine Lanczos_qtensorc_qtensorc(Lc, Wn, Rc, eigval, Psin, &
leftmost, rightmost, &
max_iter, tol, errst)
type(qtensorclist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensorc), intent(inout) :: Wn
real(KIND=rKind), intent(out) :: eigval
type(qtensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
integer, intent(in) :: max_iter
real(KIND=rKind), intent(in) :: tol
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: kk
! defining the number of Lanczos vectors used
integer :: finalkk
! intermediate tensors
type(qtensorc) :: Lanc, Hpsi, Temp
! eigenvector, vectors for diagonal and off-diagonal elements
real(KIND=rKind), allocatable :: beta(:), alpha(:), betap(:), &
alphap(:), evec(:)
! Flag for criterion to exit alogithm
logical :: quitflag
!if(present(errst)) errst = 0
! Store the initial lanczos vector for use in obtaining eigenvector
! later
call copy(Lanc, Psin, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: '//&
! 'copy failed.', 'LanczosOps_include.f90:96', &
! errst=errst)) return
quitflag = .false.
! Allocate arrays and initialize
allocate(alpha(max_iter + 1), beta(max_iter + 1), &
alphap(max_iter + 1), betap(max_iter + 1), &
evec(max_iter + 1))
alpha = 0.0_rKind
beta = 0.0_rKind
! Hpsi = H * Psi
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, rightmost, &
errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: mpo_dot_psi '//&
! 'failed.', 'LanczosOps_include.f90:113', errst=errst)) return
! 1) Build the basis of Lanczos vectors
! =====================================
kk = 1
alpha(1) = real(dot(Psin, Hpsi, errst=errst), KIND=rKind)
!if(prop_error('Lanczos_qtensorc_qtensorc: dot failed.', &
! 'LanczosOps_include.f90:121', errst=errst)) return
call gaxpy(Hpsi, -alpha(1), Psin, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: gaxpy failed.', &
! 'LanczosOps_include.f90:125', errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
evec(1) = 1.0_rKind
eigval = alpha(1)
! Loop up to matrix size
finalkk = 0
do kk = 1, max_iter
! Check soft and hard convergence criteria
if((beta(kk) < tol) .or. (kk == max_iter)) then
quitflag = .true.
exit
end if
! Perform the recursion
call pointto(Temp, Psin)
call pointto(Psin, Hpsi)
call scale(zone / beta(kk), Psin, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: scale.', &
! 'LanczosOps_include.f90:149', errst=errst)) return
call pointto(Hpsi, Temp)
call scale(-zone * beta(kk), Hpsi)
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, rightmost, &
beta=zone, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:157', &
! errst=errst)) return
finalkk = finalkk + 1
alpha(kk + 1) = real(dot(Psin, Hpsi), KIND=rKind)
call gaxpy(HPsi, -alpha(kk + 1), Psin, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:165', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
alphap(1:kk + 1) = alpha(1:kk + 1)
betap(1:kk) = beta(1:kk)
call eigd(alphap(1:kk + 1), betap(1:kk), eigval, &
evec(1:kk + 1), errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: eigd.', &
! 'LanczosOps_include.f90:176', errst=errst)) return
! exit with converged residual
if(abs(evec(kk + 1) * beta(kk)) <= tol) then
exit
end if
end do
! 2) Regenerate lanczos vectors to transform eigenvector to correct
! basis ========================================================
! ========
call destroy(Psin)
call copy(Psin, Lanc, scalar=zone * evec(1))
! Hpsi = H * Lanc
call destroy(Hpsi)
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, rightmost, &
errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:196', &
! errst=errst)) return
alpha(1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(1), Lanc, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: gaxpy failed.', &
! 'LanczosOps_include.f90:202', errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
! Loop up to matrix size
do kk = 1, finalkk
! Perform the recursion
call pointto(Temp, Lanc)
call pointto(Lanc, Hpsi)
call scale(zone / beta(kk), Lanc)
call pointto(Hpsi, Temp)
call scale(-zone * beta(kk), Hpsi)
call gaxpy(Psin, evec(kk + 1), Lanc, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:219', &
! errst=errst)) return
call mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, rightmost, &
beta=zone, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: '//&
! 'mpo_dot_psi failed.', 'LanczosOps_include.f90:225', &
! errst=errst)) return
alpha(kk + 1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Lanc, errst=errst)
!if(prop_error('Lanczos_qtensorc_qtensorc: gaxpy '//&
! 'failed.', 'LanczosOps_include.f90:231', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
end do
call destroy(Hpsi)
call destroy(Lanc)
deallocate(alpha, beta, evec, alphap, betap)
call scale(1.0_rKind / sqrt(norm(Psin)), Psin)
end subroutine Lanczos_qtensorc_qtensorc
"""
return
[docs]def projectedlanczos_tensor_tensor():
"""
fortran-subroutine -
**Arguments**
Use the Lanczos iteration to find the energy minimizing tensor
of the effective Hamiltonian L.W.R. This routine assumes that psi
is the orthogonality center so that its bases define a vector space.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projectedlanczos_tensor_tensor(Lc, Wn, Rc, eigval, Psin, &
Psiprojs, leftmost, rightmost, max_iter, tol, errst)
type(tensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_tensor), intent(inout) :: Wn
real(KIND=rKind), intent(out) :: eigval
type(tensor), intent(inout) :: Psin
type(tensor), pointer, intent(inout) :: Psiprojs(:)
logical, intent(in) :: leftmost, rightmost
integer, intent(in) :: max_iter
real(KIND=rKind), intent(in) :: tol
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: kk
! defining the number of Lanczos vectors used
integer :: finalkk
! intermediate tensors
type(tensor) :: Lanc, Hpsi, Temp
! eigenvector, vectors for diagonal and off-diagonal elements
real(KIND=rKind), allocatable :: beta(:), alpha(:), betap(:), &
alphap(:), evec(:)
! Flag for criterion to exit alogithm
logical :: quitflag
!if(present(errst)) errst = 0
! Store the initial lanczos vector for use in obtaining eigenvector
! later
call copy(Lanc, Psin, errst=errst)
!if(prop_error('projectedanczos_tensor_tensor: '//&
! 'copy failed.', 'LanczosOps_include.f90:293', &
! errst=errst)) return
quitflag = .false.
! Allocate arrays and initialize
allocate(alpha(max_iter + 1), beta(max_iter + 1), &
alphap(max_iter + 1), betap(max_iter + 1), &
evec(max_iter + 1))
alpha = 0.0_rKind
beta = 0.0_rKind
! Hpsi = H * Psi
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, &
rightmost, Psiprojs, errst=errst)
!if(prop_error('ProjectedLanczos_tensor_tensor: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:310', &
! errst=errst)) return
! 1) Build the basis of Lanczos vectors
! -------------------------------------
kk = 1
alpha(1) = real(dot(Psin, Hpsi, errst=errst), KIND=rKind)
!if(prop_error('projectedanczos_tensor_tensor: '//&
! 'dot failed.', 'LanczosOps_include.f90:319', &
! errst=errst)) return
call gaxpy(Hpsi, -alpha(1), Psin, errst=errst)
!if(prop_error('projectedanczos_tensor_tensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:324', &
! errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
evec(1) = 1.0_rKind
eigval = alpha(1)
! Loop up to matrix size
finalkk = 0
do kk = 1, max_iter
! Check soft and hard convergence criteria
if((beta(kk) < tol) .or. (kk == max_iter)) then
quitflag = .true.
exit
end if
! Perform the recursion
call pointto(Temp, Psin)
call pointto(Psin, Hpsi)
call scale(done / beta(kk), Psin, errst=errst)
!if(prop_error('projectedanczos_tensor_tensor: '//&
! 'scale failed.', 'LanczosOps_include.f90:349', &
! errst=errst)) return
call pointto(Hpsi, Temp)
call scale(-done * beta(kk), Hpsi)
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, &
rightmost, Psiprojs, beta=done, errst=errst)
!if(prop_error('ProjectedLanczos_tensor_tensor: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:358', &
! errst=errst)) return
finalkk = finalkk + 1
alpha(kk + 1) = real(dot(Psin, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Psin, errst=errst)
!if(prop_error('projectedanczos_tensor_tensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:366', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
alphap(1:kk + 1) = alpha(1:kk + 1)
betap(1:kk) = beta(1:kk)
call eigd(alphap(1:kk + 1), betap(1:kk), eigval, evec(1:kk + 1), &
errst=errst)
!if(prop_error('ProjectedLanczos_tensor_tensor: '//&
! 'eigd.', 'LanczosOps_include.f90:377', errst=errst)) return
! exit with converged residual
if(abs(evec(kk + 1) * beta(kk)) <= tol) then
exit
end if
end do
! 2) Regenerate lanczos vectors to transform eigenvector to correct
! basis ========================================================
! ========
call destroy(Psin)
call copy(Psin, Lanc, scalar=done * evec(1))
! Hpsi = H * Lanc
call destroy(Hpsi)
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, &
rightmost, Psiprojs, errst=errst)
!if(prop_error('ProjectedLanczos_tensor_tensor: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:397', &
! errst=errst)) return
alpha(1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(1), Lanc, errst=errst)
!if(prop_error('projectedanczos_tensor_tensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:403', &
! errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
! Loop up to matrix size
do kk = 1, finalkk
! Perform the recursion
call pointto(Temp, Lanc)
call pointto(Lanc, Hpsi)
call scale(done / beta(kk), Lanc)
call pointto(Hpsi, Temp)
call scale(-done * beta(kk), Hpsi)
call gaxpy(Psin, evec(kk + 1), Lanc, errst=errst)
!if(prop_error('projectedanczos_tensor_tensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:421', &
! errst=errst)) return
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, &
rightmost, Psiprojs, beta=done, errst=errst)
!if(prop_error('ProjectedLanczos_tensor_tensor: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:427', &
! errst=errst)) return
alpha(kk + 1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Lanc, errst=errst)
!if(prop_error('projectedanczos_tensor_tensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:433', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
end do
call destroy(Hpsi)
call destroy(Lanc)
deallocate(alpha, beta, evec, alphap, betap)
! Renormalize (accounts for nonorthogonality of lanczos vectors)
call scale(1.0_rKind / sqrt(norm(Psin)), Psin)
end subroutine projectedlanczos_tensor_tensor
"""
return
[docs]def projectedlanczos_tensorc_tensorc():
"""
fortran-subroutine -
**Arguments**
Use the Lanczos iteration to find the energy minimizing tensor
of the effective Hamiltonian L.W.R. This routine assumes that psi
is the orthogonality center so that its bases define a vector space.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projectedlanczos_tensorc_tensorc(Lc, Wn, Rc, eigval, Psin, &
Psiprojs, leftmost, rightmost, max_iter, tol, errst)
type(tensorlistc), intent(inout) :: Lc, Rc
type(sr_matrix_tensorc), intent(inout) :: Wn
real(KIND=rKind), intent(out) :: eigval
type(tensorc), intent(inout) :: Psin
type(tensorc), pointer, intent(inout) :: Psiprojs(:)
logical, intent(in) :: leftmost, rightmost
integer, intent(in) :: max_iter
real(KIND=rKind), intent(in) :: tol
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: kk
! defining the number of Lanczos vectors used
integer :: finalkk
! intermediate tensors
type(tensorc) :: Lanc, Hpsi, Temp
! eigenvector, vectors for diagonal and off-diagonal elements
real(KIND=rKind), allocatable :: beta(:), alpha(:), betap(:), &
alphap(:), evec(:)
! Flag for criterion to exit alogithm
logical :: quitflag
!if(present(errst)) errst = 0
! Store the initial lanczos vector for use in obtaining eigenvector
! later
call copy(Lanc, Psin, errst=errst)
!if(prop_error('projectedanczos_tensorc_tensorc: '//&
! 'copy failed.', 'LanczosOps_include.f90:293', &
! errst=errst)) return
quitflag = .false.
! Allocate arrays and initialize
allocate(alpha(max_iter + 1), beta(max_iter + 1), &
alphap(max_iter + 1), betap(max_iter + 1), &
evec(max_iter + 1))
alpha = 0.0_rKind
beta = 0.0_rKind
! Hpsi = H * Psi
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, &
rightmost, Psiprojs, errst=errst)
!if(prop_error('ProjectedLanczos_tensorc_tensorc: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:310', &
! errst=errst)) return
! 1) Build the basis of Lanczos vectors
! -------------------------------------
kk = 1
alpha(1) = real(dot(Psin, Hpsi, errst=errst), KIND=rKind)
!if(prop_error('projectedanczos_tensorc_tensorc: '//&
! 'dot failed.', 'LanczosOps_include.f90:319', &
! errst=errst)) return
call gaxpy(Hpsi, -alpha(1), Psin, errst=errst)
!if(prop_error('projectedanczos_tensorc_tensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:324', &
! errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
evec(1) = 1.0_rKind
eigval = alpha(1)
! Loop up to matrix size
finalkk = 0
do kk = 1, max_iter
! Check soft and hard convergence criteria
if((beta(kk) < tol) .or. (kk == max_iter)) then
quitflag = .true.
exit
end if
! Perform the recursion
call pointto(Temp, Psin)
call pointto(Psin, Hpsi)
call scale(zone / beta(kk), Psin, errst=errst)
!if(prop_error('projectedanczos_tensorc_tensorc: '//&
! 'scale failed.', 'LanczosOps_include.f90:349', &
! errst=errst)) return
call pointto(Hpsi, Temp)
call scale(-zone * beta(kk), Hpsi)
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, &
rightmost, Psiprojs, beta=zone, errst=errst)
!if(prop_error('ProjectedLanczos_tensorc_tensorc: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:358', &
! errst=errst)) return
finalkk = finalkk + 1
alpha(kk + 1) = real(dot(Psin, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Psin, errst=errst)
!if(prop_error('projectedanczos_tensorc_tensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:366', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
alphap(1:kk + 1) = alpha(1:kk + 1)
betap(1:kk) = beta(1:kk)
call eigd(alphap(1:kk + 1), betap(1:kk), eigval, evec(1:kk + 1), &
errst=errst)
!if(prop_error('ProjectedLanczos_tensorc_tensorc: '//&
! 'eigd.', 'LanczosOps_include.f90:377', errst=errst)) return
! exit with converged residual
if(abs(evec(kk + 1) * beta(kk)) <= tol) then
exit
end if
end do
! 2) Regenerate lanczos vectors to transform eigenvector to correct
! basis ========================================================
! ========
call destroy(Psin)
call copy(Psin, Lanc, scalar=zone * evec(1))
! Hpsi = H * Lanc
call destroy(Hpsi)
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, &
rightmost, Psiprojs, errst=errst)
!if(prop_error('ProjectedLanczos_tensorc_tensorc: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:397', &
! errst=errst)) return
alpha(1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(1), Lanc, errst=errst)
!if(prop_error('projectedanczos_tensorc_tensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:403', &
! errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
! Loop up to matrix size
do kk = 1, finalkk
! Perform the recursion
call pointto(Temp, Lanc)
call pointto(Lanc, Hpsi)
call scale(zone / beta(kk), Lanc)
call pointto(Hpsi, Temp)
call scale(-zone * beta(kk), Hpsi)
call gaxpy(Psin, evec(kk + 1), Lanc, errst=errst)
!if(prop_error('projectedanczos_tensorc_tensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:421', &
! errst=errst)) return
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, &
rightmost, Psiprojs, beta=zone, errst=errst)
!if(prop_error('ProjectedLanczos_tensorc_tensorc: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:427', &
! errst=errst)) return
alpha(kk + 1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Lanc, errst=errst)
!if(prop_error('projectedanczos_tensorc_tensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:433', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
end do
call destroy(Hpsi)
call destroy(Lanc)
deallocate(alpha, beta, evec, alphap, betap)
! Renormalize (accounts for nonorthogonality of lanczos vectors)
call scale(1.0_rKind / sqrt(norm(Psin)), Psin)
end subroutine projectedlanczos_tensorc_tensorc
"""
return
[docs]def projectedlanczos_qtensor_qtensor():
"""
fortran-subroutine -
**Arguments**
Use the Lanczos iteration to find the energy minimizing tensor
of the effective Hamiltonian L.W.R. This routine assumes that psi
is the orthogonality center so that its bases define a vector space.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projectedlanczos_qtensor_qtensor(Lc, Wn, Rc, eigval, Psin, &
Psiprojs, leftmost, rightmost, max_iter, tol, errst)
type(qtensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensor), intent(inout) :: Wn
real(KIND=rKind), intent(out) :: eigval
type(qtensor), intent(inout) :: Psin
type(qtensor), pointer, intent(inout) :: Psiprojs(:)
logical, intent(in) :: leftmost, rightmost
integer, intent(in) :: max_iter
real(KIND=rKind), intent(in) :: tol
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: kk
! defining the number of Lanczos vectors used
integer :: finalkk
! intermediate tensors
type(qtensor) :: Lanc, Hpsi, Temp
! eigenvector, vectors for diagonal and off-diagonal elements
real(KIND=rKind), allocatable :: beta(:), alpha(:), betap(:), &
alphap(:), evec(:)
! Flag for criterion to exit alogithm
logical :: quitflag
!if(present(errst)) errst = 0
! Store the initial lanczos vector for use in obtaining eigenvector
! later
call copy(Lanc, Psin, errst=errst)
!if(prop_error('projectedanczos_qtensor_qtensor: '//&
! 'copy failed.', 'LanczosOps_include.f90:293', &
! errst=errst)) return
quitflag = .false.
! Allocate arrays and initialize
allocate(alpha(max_iter + 1), beta(max_iter + 1), &
alphap(max_iter + 1), betap(max_iter + 1), &
evec(max_iter + 1))
alpha = 0.0_rKind
beta = 0.0_rKind
! Hpsi = H * Psi
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, &
rightmost, Psiprojs, errst=errst)
!if(prop_error('ProjectedLanczos_qtensor_qtensor: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:310', &
! errst=errst)) return
! 1) Build the basis of Lanczos vectors
! -------------------------------------
kk = 1
alpha(1) = real(dot(Psin, Hpsi, errst=errst), KIND=rKind)
!if(prop_error('projectedanczos_qtensor_qtensor: '//&
! 'dot failed.', 'LanczosOps_include.f90:319', &
! errst=errst)) return
call gaxpy(Hpsi, -alpha(1), Psin, errst=errst)
!if(prop_error('projectedanczos_qtensor_qtensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:324', &
! errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
evec(1) = 1.0_rKind
eigval = alpha(1)
! Loop up to matrix size
finalkk = 0
do kk = 1, max_iter
! Check soft and hard convergence criteria
if((beta(kk) < tol) .or. (kk == max_iter)) then
quitflag = .true.
exit
end if
! Perform the recursion
call pointto(Temp, Psin)
call pointto(Psin, Hpsi)
call scale(done / beta(kk), Psin, errst=errst)
!if(prop_error('projectedanczos_qtensor_qtensor: '//&
! 'scale failed.', 'LanczosOps_include.f90:349', &
! errst=errst)) return
call pointto(Hpsi, Temp)
call scale(-done * beta(kk), Hpsi)
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, &
rightmost, Psiprojs, beta=done, errst=errst)
!if(prop_error('ProjectedLanczos_qtensor_qtensor: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:358', &
! errst=errst)) return
finalkk = finalkk + 1
alpha(kk + 1) = real(dot(Psin, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Psin, errst=errst)
!if(prop_error('projectedanczos_qtensor_qtensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:366', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
alphap(1:kk + 1) = alpha(1:kk + 1)
betap(1:kk) = beta(1:kk)
call eigd(alphap(1:kk + 1), betap(1:kk), eigval, evec(1:kk + 1), &
errst=errst)
!if(prop_error('ProjectedLanczos_qtensor_qtensor: '//&
! 'eigd.', 'LanczosOps_include.f90:377', errst=errst)) return
! exit with converged residual
if(abs(evec(kk + 1) * beta(kk)) <= tol) then
exit
end if
end do
! 2) Regenerate lanczos vectors to transform eigenvector to correct
! basis ========================================================
! ========
call destroy(Psin)
call copy(Psin, Lanc, scalar=done * evec(1))
! Hpsi = H * Lanc
call destroy(Hpsi)
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, &
rightmost, Psiprojs, errst=errst)
!if(prop_error('ProjectedLanczos_qtensor_qtensor: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:397', &
! errst=errst)) return
alpha(1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(1), Lanc, errst=errst)
!if(prop_error('projectedanczos_qtensor_qtensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:403', &
! errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
! Loop up to matrix size
do kk = 1, finalkk
! Perform the recursion
call pointto(Temp, Lanc)
call pointto(Lanc, Hpsi)
call scale(done / beta(kk), Lanc)
call pointto(Hpsi, Temp)
call scale(-done * beta(kk), Hpsi)
call gaxpy(Psin, evec(kk + 1), Lanc, errst=errst)
!if(prop_error('projectedanczos_qtensor_qtensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:421', &
! errst=errst)) return
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, &
rightmost, Psiprojs, beta=done, errst=errst)
!if(prop_error('ProjectedLanczos_qtensor_qtensor: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:427', &
! errst=errst)) return
alpha(kk + 1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Lanc, errst=errst)
!if(prop_error('projectedanczos_qtensor_qtensor: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:433', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
end do
call destroy(Hpsi)
call destroy(Lanc)
deallocate(alpha, beta, evec, alphap, betap)
! Renormalize (accounts for nonorthogonality of lanczos vectors)
call scale(1.0_rKind / sqrt(norm(Psin)), Psin)
end subroutine projectedlanczos_qtensor_qtensor
"""
return
[docs]def projectedlanczos_qtensorc_qtensorc():
"""
fortran-subroutine -
**Arguments**
Use the Lanczos iteration to find the energy minimizing tensor
of the effective Hamiltonian L.W.R. This routine assumes that psi
is the orthogonality center so that its bases define a vector space.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projectedlanczos_qtensorc_qtensorc(Lc, Wn, Rc, eigval, Psin, &
Psiprojs, leftmost, rightmost, max_iter, tol, errst)
type(qtensorclist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensorc), intent(inout) :: Wn
real(KIND=rKind), intent(out) :: eigval
type(qtensorc), intent(inout) :: Psin
type(qtensorc), pointer, intent(inout) :: Psiprojs(:)
logical, intent(in) :: leftmost, rightmost
integer, intent(in) :: max_iter
real(KIND=rKind), intent(in) :: tol
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: kk
! defining the number of Lanczos vectors used
integer :: finalkk
! intermediate tensors
type(qtensorc) :: Lanc, Hpsi, Temp
! eigenvector, vectors for diagonal and off-diagonal elements
real(KIND=rKind), allocatable :: beta(:), alpha(:), betap(:), &
alphap(:), evec(:)
! Flag for criterion to exit alogithm
logical :: quitflag
!if(present(errst)) errst = 0
! Store the initial lanczos vector for use in obtaining eigenvector
! later
call copy(Lanc, Psin, errst=errst)
!if(prop_error('projectedanczos_qtensorc_qtensorc: '//&
! 'copy failed.', 'LanczosOps_include.f90:293', &
! errst=errst)) return
quitflag = .false.
! Allocate arrays and initialize
allocate(alpha(max_iter + 1), beta(max_iter + 1), &
alphap(max_iter + 1), betap(max_iter + 1), &
evec(max_iter + 1))
alpha = 0.0_rKind
beta = 0.0_rKind
! Hpsi = H * Psi
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, &
rightmost, Psiprojs, errst=errst)
!if(prop_error('ProjectedLanczos_qtensorc_qtensorc: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:310', &
! errst=errst)) return
! 1) Build the basis of Lanczos vectors
! -------------------------------------
kk = 1
alpha(1) = real(dot(Psin, Hpsi, errst=errst), KIND=rKind)
!if(prop_error('projectedanczos_qtensorc_qtensorc: '//&
! 'dot failed.', 'LanczosOps_include.f90:319', &
! errst=errst)) return
call gaxpy(Hpsi, -alpha(1), Psin, errst=errst)
!if(prop_error('projectedanczos_qtensorc_qtensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:324', &
! errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
evec(1) = 1.0_rKind
eigval = alpha(1)
! Loop up to matrix size
finalkk = 0
do kk = 1, max_iter
! Check soft and hard convergence criteria
if((beta(kk) < tol) .or. (kk == max_iter)) then
quitflag = .true.
exit
end if
! Perform the recursion
call pointto(Temp, Psin)
call pointto(Psin, Hpsi)
call scale(zone / beta(kk), Psin, errst=errst)
!if(prop_error('projectedanczos_qtensorc_qtensorc: '//&
! 'scale failed.', 'LanczosOps_include.f90:349', &
! errst=errst)) return
call pointto(Hpsi, Temp)
call scale(-zone * beta(kk), Hpsi)
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Psin, leftmost, &
rightmost, Psiprojs, beta=zone, errst=errst)
!if(prop_error('ProjectedLanczos_qtensorc_qtensorc: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:358', &
! errst=errst)) return
finalkk = finalkk + 1
alpha(kk + 1) = real(dot(Psin, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Psin, errst=errst)
!if(prop_error('projectedanczos_qtensorc_qtensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:366', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
alphap(1:kk + 1) = alpha(1:kk + 1)
betap(1:kk) = beta(1:kk)
call eigd(alphap(1:kk + 1), betap(1:kk), eigval, evec(1:kk + 1), &
errst=errst)
!if(prop_error('ProjectedLanczos_qtensorc_qtensorc: '//&
! 'eigd.', 'LanczosOps_include.f90:377', errst=errst)) return
! exit with converged residual
if(abs(evec(kk + 1) * beta(kk)) <= tol) then
exit
end if
end do
! 2) Regenerate lanczos vectors to transform eigenvector to correct
! basis ========================================================
! ========
call destroy(Psin)
call copy(Psin, Lanc, scalar=zone * evec(1))
! Hpsi = H * Lanc
call destroy(Hpsi)
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, &
rightmost, Psiprojs, errst=errst)
!if(prop_error('ProjectedLanczos_qtensorc_qtensorc: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:397', &
! errst=errst)) return
alpha(1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(1), Lanc, errst=errst)
!if(prop_error('projectedanczos_qtensorc_qtensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:403', &
! errst=errst)) return
beta(1) = sqrt(norm(Hpsi))
! Loop up to matrix size
do kk = 1, finalkk
! Perform the recursion
call pointto(Temp, Lanc)
call pointto(Lanc, Hpsi)
call scale(zone / beta(kk), Lanc)
call pointto(Hpsi, Temp)
call scale(-zone * beta(kk), Hpsi)
call gaxpy(Psin, evec(kk + 1), Lanc, errst=errst)
!if(prop_error('projectedanczos_qtensorc_qtensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:421', &
! errst=errst)) return
call projected_mpo_dot_psi(Hpsi, Lc, Wn, Rc, Lanc, leftmost, &
rightmost, Psiprojs, beta=zone, errst=errst)
!if(prop_error('ProjectedLanczos_qtensorc_qtensorc: '//&
! 'projected_mpo_dot_psi failed.', 'LanczosOps_include.f90:427', &
! errst=errst)) return
alpha(kk + 1) = real(dot(Lanc, Hpsi), KIND=rKind)
call gaxpy(Hpsi, -alpha(kk + 1), Lanc, errst=errst)
!if(prop_error('projectedanczos_qtensorc_qtensorc: '//&
! 'gaxpy failed.', 'LanczosOps_include.f90:433', &
! errst=errst)) return
beta(kk + 1) = sqrt(norm(Hpsi))
end do
call destroy(Hpsi)
call destroy(Lanc)
deallocate(alpha, beta, evec, alphap, betap)
! Renormalize (accounts for nonorthogonality of lanczos vectors)
call scale(1.0_rKind / sqrt(norm(Psin)), Psin)
end subroutine projectedlanczos_qtensorc_qtensorc
"""
return