LanczosOps¶
Fortran module LanczosOps: July 2017 (dj, updated)
Containing the Lanczos algorithm.
Authors
Jaschke
Wall
Details
The following subroutines / functions are defined for the symmetric tensors.
procedure |
include.f90 |
mpi.f90 |
omp.f90 |
|---|---|---|---|
Lanczos |
X |
- LanczosOps_f90.Lanczos_tensor_tensor()[source]¶
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
- LcTYPE(tensorlist), inout
Contains contractions of Hamiltonian with left part of the wave vector.
- WnTYPE(tensor), inout
The MPO matrix for the corresponding n sites.
- RcTYPE(tensorlist), inout
Contains contractions of Hamiltonian with right part of the wave vector.
- eigvalREAL(KIND=rKind), out
Eigenvalue found during the Lanczos search.
- PsinTYPE(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
show / hide f90 codesubroutine 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
- LanczosOps_f90.Lanczos_tensorc_tensorc()[source]¶
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.
- LcTYPE(tensorlistc), inout
Contains contractions of Hamiltonian with left part of the wave vector.
- WnTYPE(tensorc), inout
The MPO matrix for the corresponding n sites.
- RcTYPE(tensorlistc), inout
Contains contractions of Hamiltonian with right part of the wave vector.
- eigvalREAL(KIND=rKind), out
Eigenvalue found during the Lanczos search.
- PsinTYPE(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
show / hide f90 codesubroutine 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
- LanczosOps_f90.Lanczos_qtensor_qtensor()[source]¶
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.
- LcTYPE(qtensorlist), inout
Contains contractions of Hamiltonian with left part of the wave vector.
- WnTYPE(qtensor), inout
The MPO matrix for the corresponding n sites.
- RcTYPE(qtensorlist), inout
Contains contractions of Hamiltonian with right part of the wave vector.
- eigvalREAL(KIND=rKind), out
Eigenvalue found during the Lanczos search.
- PsinTYPE(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
show / hide f90 codesubroutine 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
- LanczosOps_f90.Lanczos_qtensorc_qtensorc()[source]¶
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.
- LcTYPE(qtensorclist), inout
Contains contractions of Hamiltonian with left part of the wave vector.
- WnTYPE(qtensorc), inout
The MPO matrix for the corresponding n sites.
- RcTYPE(qtensorclist), inout
Contains contractions of Hamiltonian with right part of the wave vector.
- eigvalREAL(KIND=rKind), out
Eigenvalue found during the Lanczos search.
- PsinTYPE(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
show / hide f90 codesubroutine 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
- LanczosOps_f90.projectedlanczos_tensor_tensor()[source]¶
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
show / hide f90 codesubroutine 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
- LanczosOps_f90.projectedlanczos_tensorc_tensorc()[source]¶
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
show / hide f90 codesubroutine 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
- LanczosOps_f90.projectedlanczos_qtensor_qtensor()[source]¶
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
show / hide f90 codesubroutine 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
- LanczosOps_f90.projectedlanczos_qtensorc_qtensorc()[source]¶
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
show / hide f90 codesubroutine 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