"""
Fortran module MPSOps: June 2017 (dj, updated)
Containing basic operations for matrix product states.
**Authors**
* D. Jaschke
* M. L. Wall
**Details**
The error status can be decoded the following way
The following subroutines / functions are defined for the
applicable data type
+---------------------------------+-------------+-------------+-------------+
| Procedure | include.f90 | mpi.f90 | omp.f90 |
+=================================+=============+=============+=============+
| copy | X | | |
+---------------------------------+-------------+-------------+-------------+
| canonize | X | | |
+---------------------------------+-------------+-------------+-------------+
| canonize_svd | X | | |
+---------------------------------+-------------+-------------+-------------+
| destroy | X | | |
+---------------------------------+-------------+-------------+-------------+
| gaugesite_rq | X | | |
+---------------------------------+-------------+-------------+-------------+
| gaugesite_qr | X | | |
+---------------------------------+-------------+-------------+-------------+
| gaugesite_rsvd | X | | |
+---------------------------------+-------------+-------------+-------------+
| gaugesite_lsvd | X | | |
+---------------------------------+-------------+-------------+-------------+
| norm | X | | |
+---------------------------------+-------------+-------------+-------------+
| orthonormalize | X | | |
+---------------------------------+-------------+-------------+-------------+
| perturb | X | | |
+---------------------------------+-------------+-------------+-------------+
| print | X | | |
+---------------------------------+-------------+-------------+-------------+
| randomize | X | | |
+---------------------------------+-------------+-------------+-------------+
| read | X | | |
+---------------------------------+-------------+-------------+-------------+
| scale | X | | |
+---------------------------------+-------------+-------------+-------------+
| write | X | | |
+---------------------------------+-------------+-------------+-------------+
"""
[docs]def ConstructProjectors_tensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Given a set of NE MPSs psiBs and their overlap propagators with a
variational state LRAB construct a set of at most NE on-site tensors
psiProjs which can be used to project the effective Hamiltonian into the
orthogonal space.
**Arguments**
kk : INTEGER, in
Build the projectors for site kk in the single site version
or for sites (kk, kk + 1) in the two site version.
Psibs : TYPE(mps)(*), inout
??
LRAB : TYPE(tensorlist)(*), inout
The left-right overlaps.
Psiprojs : TYPE(tensor)(*), POINTER, inout
On output, the projectors.
nsites : INTEGER, in
Number of sites to build the projectors on. Either single site (1)
or two-sites (2).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ConstructProjectors_tensor(kk, Psibs, LRab, Psiprojs, &
nsites, errst)
integer, intent(in) :: kk
type(mps) :: Psibs(:)
type(tensorlist) :: LRAB(:)
type(tensor), pointer :: Psiprojs(:)
integer, intent(in) :: nsites
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! number of overlaps, Psibs
integer :: ne
! number of eigenvalues above tolerance
integer :: nkeep
! Projectors before pseudoinverse
type(tensor), pointer :: Rawpsiprojs(:)
! Gram matrix and its eigenvalues
real(KIND=rKind), dimension(:, :), allocatable:: nmat
real(KIND=rKind), dimension(:), allocatable :: ev
! Temporary tensors
type(tensor) :: Tmp, Tmpb
! tolerance singular value inversion
real(KIND=rKind) :: tol
ne = size(LRab)
allocate(Rawpsiprojs(ne))
! Construct the linear forms which impose orthogonality
! -----------------------------------------------------
if(nsites == 1) then
! One site version
! ................
do jj = 1, ne
! Step 1:E(a,i,b)= B(j)_{a,i,b'} L(j)%l(k+1) (b' b)
if(kk == Psibs(jj)%ll) then
call copy(Tmp, Psibs(jj)%Aa(kk))
else
call contr(Tmp, Psibs(jj)%Aa(kk), LRab(kk)%Li(kk + 1), &
[3], [1], errst=errst)
end if
! Step 2: rawpsiProjs(j)(a,i,b)=L(j)%l(k)%elem(a,a') E(a',i,b)
if(kk == 1) then
call copy(Rawpsiprojs(jj), Tmp)
else
call contr(Rawpsiprojs(jj), LRab(jj)%Li(kk - 1), Tmp, &
[2], [1], errst=errst)
end if
call destroy(Tmp)
end do
elseif(nsites == 2) then
! Two site version
! ................
do jj = 1, ne
! Contract left overlap
if(kk == 1) then
call copy(Tmp, Psibs(jj)%Aa(kk))
else
call contr(Tmp, LRab(jj)%Li(kk - 1), Psibs(jj)%Aa(kk), &
[2], [1], errst=errst)
end if
! Contract right overlap
if(kk + 1 == Psibs(jj)%ll) then
call copy(Tmpb, Psibs(jj)%Aa(kk + 1))
else
call contr(Tmpb, Psibs(jj)%Aa(kk + 1), LRab(jj)%Li(kk + 2), &
[3], [1], errst=errst)
end if
! Build two-site tensor
call contr(Rawpsiprojs(jj), Tmp, Tmpb, &
[3], [1], errst=errst)
call destroy(Tmp)
call destroy(Tmpb)
end do
else
stop 'Not implement nsites > 2'
end if
! Construct the Gram matrix
allocate(nmat(ne, ne), ev(ne))
do ii = 1, ne
! Diagonal element
nmat(ii, ii) = Dot(Rawpsiprojs(ii), Rawpsiprojs(ii))
do jj = (ii + 1), ne
! Upper triangular is enough for eigd
nmat(ii, jj) = Dot(Rawpsiprojs(ii), Rawpsiprojs(jj))
end do
end do
! Construct the pseudoinverse of the Gram matrix (default to upper)
call eigd(nmat, ev, ne, errst=errst)
!if(prop_error('constructprojectors_tensor: eigd failed.', &
! 'MPSOps_include.f90:162', errst=errst)) return
! Tolerance for singular value inversion=NE*||N||_2 *eps
nkeep = 0
tol = ne * maxval(ev) * numzero
do ii = ne, 1, (-1)
if(ev(ii) > tol) nkeep = nkeep + 1
end do
! Copy the raw projectors to the final ones
allocate(Psiprojs(nkeep))
do ii = 1, nkeep
call copy(Psiprojs(ii), Rawpsiprojs(1))
! jj = 1
call scale(nmat(1, ne - ii + 1), Psiprojs(ii))
do jj = 2, ne
call gaxpy(Psiprojs(ii), nmat(jj, ne - ii + 1), Rawpsiprojs(jj))
end do
call scale(1.0_rKind / sqrt(ev(ne - ii + 1)), Psiprojs(ii))
end do
do ii = 1, ne
call destroy(Rawpsiprojs(ii))
end do
deallocate(Rawpsiprojs, ev, nmat)
end subroutine constructprojectors_tensor
"""
return
[docs]def ConstructProjectors_tensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Given a set of NE MPSs psiBs and their overlap propagators with a
variational state LRAB construct a set of at most NE on-site tensors
psiProjs which can be used to project the effective Hamiltonian into the
orthogonal space.
**Arguments**
kk : INTEGER, in
Build the projectors for site kk in the single site version
or for sites (kk, kk + 1) in the two site version.
Psibs : TYPE(mpsc)(*), inout
??
LRAB : TYPE(tensorlistc)(*), inout
The left-right overlaps.
Psiprojs : TYPE(tensorc)(*), POINTER, inout
On output, the projectors.
nsites : INTEGER, in
Number of sites to build the projectors on. Either single site (1)
or two-sites (2).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ConstructProjectors_tensorc(kk, Psibs, LRab, Psiprojs, &
nsites, errst)
integer, intent(in) :: kk
type(mpsc) :: Psibs(:)
type(tensorlistc) :: LRAB(:)
type(tensorc), pointer :: Psiprojs(:)
integer, intent(in) :: nsites
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! number of overlaps, Psibs
integer :: ne
! number of eigenvalues above tolerance
integer :: nkeep
! Projectors before pseudoinverse
type(tensorc), pointer :: Rawpsiprojs(:)
! Gram matrix and its eigenvalues
complex(KIND=rKind), dimension(:, :), allocatable:: nmat
real(KIND=rKind), dimension(:), allocatable :: ev
! Temporary tensors
type(tensorc) :: Tmp, Tmpb
! tolerance singular value inversion
real(KIND=rKind) :: tol
ne = size(LRab)
allocate(Rawpsiprojs(ne))
! Construct the linear forms which impose orthogonality
! -----------------------------------------------------
if(nsites == 1) then
! One site version
! ................
do jj = 1, ne
! Step 1:E(a,i,b)= B(j)_{a,i,b'} L(j)%l(k+1) (b' b)
if(kk == Psibs(jj)%ll) then
call copy(Tmp, Psibs(jj)%Aa(kk))
else
call contr(Tmp, Psibs(jj)%Aa(kk), LRab(kk)%Li(kk + 1), &
[3], [1], errst=errst)
end if
! Step 2: rawpsiProjs(j)(a,i,b)=L(j)%l(k)%elem(a,a') E(a',i,b)
if(kk == 1) then
call copy(Rawpsiprojs(jj), Tmp)
else
call contr(Rawpsiprojs(jj), LRab(jj)%Li(kk - 1), Tmp, &
[2], [1], errst=errst)
end if
call destroy(Tmp)
end do
elseif(nsites == 2) then
! Two site version
! ................
do jj = 1, ne
! Contract left overlap
if(kk == 1) then
call copy(Tmp, Psibs(jj)%Aa(kk))
else
call contr(Tmp, LRab(jj)%Li(kk - 1), Psibs(jj)%Aa(kk), &
[2], [1], errst=errst)
end if
! Contract right overlap
if(kk + 1 == Psibs(jj)%ll) then
call copy(Tmpb, Psibs(jj)%Aa(kk + 1))
else
call contr(Tmpb, Psibs(jj)%Aa(kk + 1), LRab(jj)%Li(kk + 2), &
[3], [1], errst=errst)
end if
! Build two-site tensor
call contr(Rawpsiprojs(jj), Tmp, Tmpb, &
[3], [1], errst=errst)
call destroy(Tmp)
call destroy(Tmpb)
end do
else
stop 'Not implement nsites > 2'
end if
! Construct the Gram matrix
allocate(nmat(ne, ne), ev(ne))
do ii = 1, ne
! Diagonal element
nmat(ii, ii) = Dot(Rawpsiprojs(ii), Rawpsiprojs(ii))
do jj = (ii + 1), ne
! Upper triangular is enough for eigd
nmat(ii, jj) = Dot(Rawpsiprojs(ii), Rawpsiprojs(jj))
end do
end do
! Construct the pseudoinverse of the Gram matrix (default to upper)
call eigd(nmat, ev, ne, errst=errst)
!if(prop_error('constructprojectors_tensorc: eigd failed.', &
! 'MPSOps_include.f90:162', errst=errst)) return
! Tolerance for singular value inversion=NE*||N||_2 *eps
nkeep = 0
tol = ne * maxval(ev) * numzero
do ii = ne, 1, (-1)
if(ev(ii) > tol) nkeep = nkeep + 1
end do
! Copy the raw projectors to the final ones
allocate(Psiprojs(nkeep))
do ii = 1, nkeep
call copy(Psiprojs(ii), Rawpsiprojs(1))
! jj = 1
call scale(nmat(1, ne - ii + 1), Psiprojs(ii))
do jj = 2, ne
call gaxpy(Psiprojs(ii), nmat(jj, ne - ii + 1), Rawpsiprojs(jj))
end do
call scale(1.0_rKind / sqrt(ev(ne - ii + 1)), Psiprojs(ii))
end do
do ii = 1, ne
call destroy(Rawpsiprojs(ii))
end do
deallocate(Rawpsiprojs, ev, nmat)
end subroutine constructprojectors_tensorc
"""
return
[docs]def ConstructProjectors_qtensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Given a set of NE MPSs psiBs and their overlap propagators with a
variational state LRAB construct a set of at most NE on-site tensors
psiProjs which can be used to project the effective Hamiltonian into the
orthogonal space.
**Arguments**
kk : INTEGER, in
Build the projectors for site kk in the single site version
or for sites (kk, kk + 1) in the two site version.
Psibs : TYPE(qmps)(*), inout
??
LRAB : TYPE(qtensorlist)(*), inout
The left-right overlaps.
Psiprojs : TYPE(qtensor)(*), POINTER, inout
On output, the projectors.
nsites : INTEGER, in
Number of sites to build the projectors on. Either single site (1)
or two-sites (2).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ConstructProjectors_qtensor(kk, Psibs, LRab, Psiprojs, &
nsites, errst)
integer, intent(in) :: kk
type(qmps) :: Psibs(:)
type(qtensorlist) :: LRAB(:)
type(qtensor), pointer :: Psiprojs(:)
integer, intent(in) :: nsites
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! number of overlaps, Psibs
integer :: ne
! number of eigenvalues above tolerance
integer :: nkeep
! Projectors before pseudoinverse
type(qtensor), pointer :: Rawpsiprojs(:)
! Gram matrix and its eigenvalues
real(KIND=rKind), dimension(:, :), allocatable:: nmat
real(KIND=rKind), dimension(:), allocatable :: ev
! Temporary tensors
type(qtensor) :: Tmp, Tmpb
! tolerance singular value inversion
real(KIND=rKind) :: tol
ne = size(LRab)
allocate(Rawpsiprojs(ne))
! Construct the linear forms which impose orthogonality
! -----------------------------------------------------
if(nsites == 1) then
! One site version
! ................
do jj = 1, ne
! Step 1:E(a,i,b)= B(j)_{a,i,b'} L(j)%l(k+1) (b' b)
if(kk == Psibs(jj)%ll) then
call copy(Tmp, Psibs(jj)%Aa(kk))
else
call contr(Tmp, Psibs(jj)%Aa(kk), LRab(kk)%Li(kk + 1), &
[3], [1], errst=errst)
end if
! Step 2: rawpsiProjs(j)(a,i,b)=L(j)%l(k)%elem(a,a') E(a',i,b)
if(kk == 1) then
call copy(Rawpsiprojs(jj), Tmp)
else
call contr(Rawpsiprojs(jj), LRab(jj)%Li(kk - 1), Tmp, &
[2], [1], errst=errst)
end if
call destroy(Tmp)
end do
elseif(nsites == 2) then
! Two site version
! ................
do jj = 1, ne
! Contract left overlap
if(kk == 1) then
call copy(Tmp, Psibs(jj)%Aa(kk))
else
call contr(Tmp, LRab(jj)%Li(kk - 1), Psibs(jj)%Aa(kk), &
[2], [1], errst=errst)
end if
! Contract right overlap
if(kk + 1 == Psibs(jj)%ll) then
call copy(Tmpb, Psibs(jj)%Aa(kk + 1))
else
call contr(Tmpb, Psibs(jj)%Aa(kk + 1), LRab(jj)%Li(kk + 2), &
[3], [1], errst=errst)
end if
! Build two-site tensor
call contr(Rawpsiprojs(jj), Tmp, Tmpb, &
[3], [1], errst=errst)
call destroy(Tmp)
call destroy(Tmpb)
end do
else
stop 'Not implement nsites > 2'
end if
! Construct the Gram matrix
allocate(nmat(ne, ne), ev(ne))
do ii = 1, ne
! Diagonal element
nmat(ii, ii) = Dot(Rawpsiprojs(ii), Rawpsiprojs(ii))
do jj = (ii + 1), ne
! Upper triangular is enough for eigd
nmat(ii, jj) = Dot(Rawpsiprojs(ii), Rawpsiprojs(jj))
end do
end do
! Construct the pseudoinverse of the Gram matrix (default to upper)
call eigd(nmat, ev, ne, errst=errst)
!if(prop_error('constructprojectors_qtensor: eigd failed.', &
! 'MPSOps_include.f90:162', errst=errst)) return
! Tolerance for singular value inversion=NE*||N||_2 *eps
nkeep = 0
tol = ne * maxval(ev) * numzero
do ii = ne, 1, (-1)
if(ev(ii) > tol) nkeep = nkeep + 1
end do
! Copy the raw projectors to the final ones
allocate(Psiprojs(nkeep))
do ii = 1, nkeep
call copy(Psiprojs(ii), Rawpsiprojs(1))
! jj = 1
call scale(nmat(1, ne - ii + 1), Psiprojs(ii))
do jj = 2, ne
call gaxpy(Psiprojs(ii), nmat(jj, ne - ii + 1), Rawpsiprojs(jj))
end do
call scale(1.0_rKind / sqrt(ev(ne - ii + 1)), Psiprojs(ii))
end do
do ii = 1, ne
call destroy(Rawpsiprojs(ii))
end do
deallocate(Rawpsiprojs, ev, nmat)
end subroutine constructprojectors_qtensor
"""
return
[docs]def ConstructProjectors_qtensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Given a set of NE MPSs psiBs and their overlap propagators with a
variational state LRAB construct a set of at most NE on-site tensors
psiProjs which can be used to project the effective Hamiltonian into the
orthogonal space.
**Arguments**
kk : INTEGER, in
Build the projectors for site kk in the single site version
or for sites (kk, kk + 1) in the two site version.
Psibs : TYPE(qmpsc)(*), inout
??
LRAB : TYPE(qtensorclist)(*), inout
The left-right overlaps.
Psiprojs : TYPE(qtensorc)(*), POINTER, inout
On output, the projectors.
nsites : INTEGER, in
Number of sites to build the projectors on. Either single site (1)
or two-sites (2).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ConstructProjectors_qtensorc(kk, Psibs, LRab, Psiprojs, &
nsites, errst)
integer, intent(in) :: kk
type(qmpsc) :: Psibs(:)
type(qtensorclist) :: LRAB(:)
type(qtensorc), pointer :: Psiprojs(:)
integer, intent(in) :: nsites
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! number of overlaps, Psibs
integer :: ne
! number of eigenvalues above tolerance
integer :: nkeep
! Projectors before pseudoinverse
type(qtensorc), pointer :: Rawpsiprojs(:)
! Gram matrix and its eigenvalues
complex(KIND=rKind), dimension(:, :), allocatable:: nmat
real(KIND=rKind), dimension(:), allocatable :: ev
! Temporary tensors
type(qtensorc) :: Tmp, Tmpb
! tolerance singular value inversion
real(KIND=rKind) :: tol
ne = size(LRab)
allocate(Rawpsiprojs(ne))
! Construct the linear forms which impose orthogonality
! -----------------------------------------------------
if(nsites == 1) then
! One site version
! ................
do jj = 1, ne
! Step 1:E(a,i,b)= B(j)_{a,i,b'} L(j)%l(k+1) (b' b)
if(kk == Psibs(jj)%ll) then
call copy(Tmp, Psibs(jj)%Aa(kk))
else
call contr(Tmp, Psibs(jj)%Aa(kk), LRab(kk)%Li(kk + 1), &
[3], [1], errst=errst)
end if
! Step 2: rawpsiProjs(j)(a,i,b)=L(j)%l(k)%elem(a,a') E(a',i,b)
if(kk == 1) then
call copy(Rawpsiprojs(jj), Tmp)
else
call contr(Rawpsiprojs(jj), LRab(jj)%Li(kk - 1), Tmp, &
[2], [1], errst=errst)
end if
call destroy(Tmp)
end do
elseif(nsites == 2) then
! Two site version
! ................
do jj = 1, ne
! Contract left overlap
if(kk == 1) then
call copy(Tmp, Psibs(jj)%Aa(kk))
else
call contr(Tmp, LRab(jj)%Li(kk - 1), Psibs(jj)%Aa(kk), &
[2], [1], errst=errst)
end if
! Contract right overlap
if(kk + 1 == Psibs(jj)%ll) then
call copy(Tmpb, Psibs(jj)%Aa(kk + 1))
else
call contr(Tmpb, Psibs(jj)%Aa(kk + 1), LRab(jj)%Li(kk + 2), &
[3], [1], errst=errst)
end if
! Build two-site tensor
call contr(Rawpsiprojs(jj), Tmp, Tmpb, &
[3], [1], errst=errst)
call destroy(Tmp)
call destroy(Tmpb)
end do
else
stop 'Not implement nsites > 2'
end if
! Construct the Gram matrix
allocate(nmat(ne, ne), ev(ne))
do ii = 1, ne
! Diagonal element
nmat(ii, ii) = Dot(Rawpsiprojs(ii), Rawpsiprojs(ii))
do jj = (ii + 1), ne
! Upper triangular is enough for eigd
nmat(ii, jj) = Dot(Rawpsiprojs(ii), Rawpsiprojs(jj))
end do
end do
! Construct the pseudoinverse of the Gram matrix (default to upper)
call eigd(nmat, ev, ne, errst=errst)
!if(prop_error('constructprojectors_qtensorc: eigd failed.', &
! 'MPSOps_include.f90:162', errst=errst)) return
! Tolerance for singular value inversion=NE*||N||_2 *eps
nkeep = 0
tol = ne * maxval(ev) * numzero
do ii = ne, 1, (-1)
if(ev(ii) > tol) nkeep = nkeep + 1
end do
! Copy the raw projectors to the final ones
allocate(Psiprojs(nkeep))
do ii = 1, nkeep
call copy(Psiprojs(ii), Rawpsiprojs(1))
! jj = 1
call scale(nmat(1, ne - ii + 1), Psiprojs(ii))
do jj = 2, ne
call gaxpy(Psiprojs(ii), nmat(jj, ne - ii + 1), Rawpsiprojs(jj))
end do
call scale(1.0_rKind / sqrt(ev(ne - ii + 1)), Psiprojs(ii))
end do
do ii = 1, ne
call destroy(Rawpsiprojs(ii))
end do
deallocate(Rawpsiprojs, ev, nmat)
end subroutine constructprojectors_qtensorc
"""
return
[docs]def copy_mps_mps():
"""
fortran-subroutine - June 2017 (dj, updated)
Copy a Matrix Product State.
**Arguments**
PsiNew : TYPE(mps), out
Copy a MPS into this variable
PsiOld : TYPE(mps), in
Copy this MPS to `PsiNew`
scalar : real, OPTIONAL, in
Scale the MPS by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mps_mps(PsiNew, PsiOld, scalar, errst)
type(mps), intent(inout) :: PsiNew
type(mps), intent(in) :: PsiOld
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
PsiNew%ll = PsiOld%ll
PsiNew%oc = PsiOld%oc
allocate(PsiNew%Aa(PsiNew%ll), PsiNew%can(PsiNew%ll), &
PsiNew%haslambda(PsiNew%ll + 1), PsiNew%lambda(PsiNew%ll + 1))
!if(size(Psinew%can) /= size(Psiold%can)) then
! errst = raise_error('copy_mps_mps : '//&
! 'can mismatch.', 99, errst=errst)
! return
!end if
!if(size(Psinew%haslambda) /= size(Psiold%haslambda)) then
! errst = raise_error('copy_mps_mps : '//&
! 'haslambda mismatch.', 99, errst=errst)
! return
!end if
PsiNew%can = PsiOld%can
PsiNew%haslambda = PsiOld%haslambda
do ii = 1, PsiNew%ll
call copy(PsiNew%Aa(ii), PsiOld%Aa(ii), errst=errst)
!if(prop_error('copy_mps_mps : copy (1) '//&
! 'failed', errst=errst)) return
end do
do ii = 1, (Psinew%ll + 1)
if(PsiNew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(ii), errst=errst)
!if(prop_error('copy_mps_mps : copy '//&
! '(2) failed', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_mps_mps
"""
return
[docs]def copy_part_mps_mps():
"""
fortran-subroutine - November 2017 (dj, updated)
Copy parts of an MPS. Orthogonality center has to be within the
extracted part.
**Arguments**
PsiNew : TYPE(mps), out
Copy a part of an MPS into this variable
PsiOld : TYPE(mps), in
Copy part of this MPS to `PsiNew`
first : INTEGER, in
The first site of the old MPS to be copied.
last : INTEGER, in
The last site of the old MPS to be copied.
scalar : real, OPTIONAL, in
Scale the MPS by a factor.
**Details**
The copy of parts of an MPS only works on continuous
number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be
extracted with this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_part_mps_mps(Psinew, Psiold, first, last, &
scalar, errst)
type(mps), intent(inout) :: PsiNew
type(mps), intent(in) :: PsiOld
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(in) :: first, last
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! new system size
integer :: ll
!if(present(errst)) errst = 0
!if((Psiold%oc < first) .or. (Psiold%oc > last)) then
! errst = raise_error('copy_part_mps_mps'//&
! ': oc not within selected sites.', &
! 99, 'MPSOps_include.f90:353', errst=errst)
! return
!end if
! new system size
ll = last - first + 1
PsiNew%ll = ll
PsiNew%oc = Psiold%oc - first + 1
allocate(PsiNew%Aa(ll), PsiNew%can(ll), &
PsiNew%haslambda(ll + 1), PsiNew%lambda(ll + 1))
Psinew%can = Psiold%can(first:last)
Psinew%haslambda = Psiold%haslambda(first:last)
jj = first
do ii = 1, ll
call copy(Psinew%Aa(ii), Psiold%Aa(jj), errst=errst)
!if(prop_error('copy_part_mps_mps : copy '//&
! 'failed', 'MPSOps_include.f90:373', errst=errst)) return
jj = jj + 1
end do
jj = first
do ii = 1, ll + 1
if(Psinew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(jj), errst=errst)
!if(prop_error('copy_part_mps_mps : '//&
! 'copy failed', 'MPSOps_include.f90:383', &
! errst=errst)) return
end if
jj = jj + 1
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_part_mps_mps
"""
return
[docs]def copy_mpsc_mps():
"""
fortran-subroutine - June 2017 (dj, updated)
Copy a Matrix Product State.
**Arguments**
PsiNew : TYPE(mpsc), out
Copy a MPS into this variable
PsiOld : TYPE(mps), in
Copy this MPS to `PsiNew`
scalar : complex, OPTIONAL, in
Scale the MPS by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mpsc_mps(PsiNew, PsiOld, scalar, errst)
type(mpsc), intent(inout) :: PsiNew
type(mps), intent(in) :: PsiOld
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
PsiNew%ll = PsiOld%ll
PsiNew%oc = PsiOld%oc
allocate(PsiNew%Aa(PsiNew%ll), PsiNew%can(PsiNew%ll), &
PsiNew%haslambda(PsiNew%ll + 1), PsiNew%lambda(PsiNew%ll + 1))
!if(size(Psinew%can) /= size(Psiold%can)) then
! errst = raise_error('copy_mpsc_mps : '//&
! 'can mismatch.', 99, errst=errst)
! return
!end if
!if(size(Psinew%haslambda) /= size(Psiold%haslambda)) then
! errst = raise_error('copy_mpsc_mps : '//&
! 'haslambda mismatch.', 99, errst=errst)
! return
!end if
PsiNew%can = PsiOld%can
PsiNew%haslambda = PsiOld%haslambda
do ii = 1, PsiNew%ll
call copy(PsiNew%Aa(ii), PsiOld%Aa(ii), errst=errst)
!if(prop_error('copy_mpsc_mps : copy (1) '//&
! 'failed', errst=errst)) return
end do
do ii = 1, (Psinew%ll + 1)
if(PsiNew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(ii), errst=errst)
!if(prop_error('copy_mpsc_mps : copy '//&
! '(2) failed', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_mpsc_mps
"""
return
[docs]def copy_part_mpsc_mps():
"""
fortran-subroutine - November 2017 (dj, updated)
Copy parts of an MPS. Orthogonality center has to be within the
extracted part.
**Arguments**
PsiNew : TYPE(mpsc), out
Copy a part of an MPS into this variable
PsiOld : TYPE(mps), in
Copy part of this MPS to `PsiNew`
first : INTEGER, in
The first site of the old MPS to be copied.
last : INTEGER, in
The last site of the old MPS to be copied.
scalar : complex, OPTIONAL, in
Scale the MPS by a factor.
**Details**
The copy of parts of an MPS only works on continuous
number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be
extracted with this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_part_mpsc_mps(Psinew, Psiold, first, last, &
scalar, errst)
type(mpsc), intent(inout) :: PsiNew
type(mps), intent(in) :: PsiOld
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(in) :: first, last
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! new system size
integer :: ll
!if(present(errst)) errst = 0
!if((Psiold%oc < first) .or. (Psiold%oc > last)) then
! errst = raise_error('copy_part_mpsc_mps'//&
! ': oc not within selected sites.', &
! 99, 'MPSOps_include.f90:353', errst=errst)
! return
!end if
! new system size
ll = last - first + 1
PsiNew%ll = ll
PsiNew%oc = Psiold%oc - first + 1
allocate(PsiNew%Aa(ll), PsiNew%can(ll), &
PsiNew%haslambda(ll + 1), PsiNew%lambda(ll + 1))
Psinew%can = Psiold%can(first:last)
Psinew%haslambda = Psiold%haslambda(first:last)
jj = first
do ii = 1, ll
call copy(Psinew%Aa(ii), Psiold%Aa(jj), errst=errst)
!if(prop_error('copy_part_mpsc_mps : copy '//&
! 'failed', 'MPSOps_include.f90:373', errst=errst)) return
jj = jj + 1
end do
jj = first
do ii = 1, ll + 1
if(Psinew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(jj), errst=errst)
!if(prop_error('copy_part_mpsc_mps : '//&
! 'copy failed', 'MPSOps_include.f90:383', &
! errst=errst)) return
end if
jj = jj + 1
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_part_mpsc_mps
"""
return
[docs]def copy_mpsc_mpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Copy a Matrix Product State.
**Arguments**
PsiNew : TYPE(mpsc), out
Copy a MPS into this variable
PsiOld : TYPE(mpsc), in
Copy this MPS to `PsiNew`
scalar : complex, OPTIONAL, in
Scale the MPS by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mpsc_mpsc(PsiNew, PsiOld, scalar, errst)
type(mpsc), intent(inout) :: PsiNew
type(mpsc), intent(in) :: PsiOld
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
PsiNew%ll = PsiOld%ll
PsiNew%oc = PsiOld%oc
allocate(PsiNew%Aa(PsiNew%ll), PsiNew%can(PsiNew%ll), &
PsiNew%haslambda(PsiNew%ll + 1), PsiNew%lambda(PsiNew%ll + 1))
!if(size(Psinew%can) /= size(Psiold%can)) then
! errst = raise_error('copy_mpsc_mpsc : '//&
! 'can mismatch.', 99, errst=errst)
! return
!end if
!if(size(Psinew%haslambda) /= size(Psiold%haslambda)) then
! errst = raise_error('copy_mpsc_mpsc : '//&
! 'haslambda mismatch.', 99, errst=errst)
! return
!end if
PsiNew%can = PsiOld%can
PsiNew%haslambda = PsiOld%haslambda
do ii = 1, PsiNew%ll
call copy(PsiNew%Aa(ii), PsiOld%Aa(ii), errst=errst)
!if(prop_error('copy_mpsc_mpsc : copy (1) '//&
! 'failed', errst=errst)) return
end do
do ii = 1, (Psinew%ll + 1)
if(PsiNew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(ii), errst=errst)
!if(prop_error('copy_mpsc_mpsc : copy '//&
! '(2) failed', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_mpsc_mpsc
"""
return
[docs]def copy_part_mpsc_mpsc():
"""
fortran-subroutine - November 2017 (dj, updated)
Copy parts of an MPS. Orthogonality center has to be within the
extracted part.
**Arguments**
PsiNew : TYPE(mpsc), out
Copy a part of an MPS into this variable
PsiOld : TYPE(mpsc), in
Copy part of this MPS to `PsiNew`
first : INTEGER, in
The first site of the old MPS to be copied.
last : INTEGER, in
The last site of the old MPS to be copied.
scalar : complex, OPTIONAL, in
Scale the MPS by a factor.
**Details**
The copy of parts of an MPS only works on continuous
number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be
extracted with this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_part_mpsc_mpsc(Psinew, Psiold, first, last, &
scalar, errst)
type(mpsc), intent(inout) :: PsiNew
type(mpsc), intent(in) :: PsiOld
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(in) :: first, last
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! new system size
integer :: ll
!if(present(errst)) errst = 0
!if((Psiold%oc < first) .or. (Psiold%oc > last)) then
! errst = raise_error('copy_part_mpsc_mpsc'//&
! ': oc not within selected sites.', &
! 99, 'MPSOps_include.f90:353', errst=errst)
! return
!end if
! new system size
ll = last - first + 1
PsiNew%ll = ll
PsiNew%oc = Psiold%oc - first + 1
allocate(PsiNew%Aa(ll), PsiNew%can(ll), &
PsiNew%haslambda(ll + 1), PsiNew%lambda(ll + 1))
Psinew%can = Psiold%can(first:last)
Psinew%haslambda = Psiold%haslambda(first:last)
jj = first
do ii = 1, ll
call copy(Psinew%Aa(ii), Psiold%Aa(jj), errst=errst)
!if(prop_error('copy_part_mpsc_mpsc : copy '//&
! 'failed', 'MPSOps_include.f90:373', errst=errst)) return
jj = jj + 1
end do
jj = first
do ii = 1, ll + 1
if(Psinew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(jj), errst=errst)
!if(prop_error('copy_part_mpsc_mpsc : '//&
! 'copy failed', 'MPSOps_include.f90:383', &
! errst=errst)) return
end if
jj = jj + 1
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_part_mpsc_mpsc
"""
return
[docs]def copy_qmps_qmps():
"""
fortran-subroutine - June 2017 (dj, updated)
Copy a Matrix Product State.
**Arguments**
PsiNew : TYPE(qmps), out
Copy a MPS into this variable
PsiOld : TYPE(qmps), in
Copy this MPS to `PsiNew`
scalar : real, OPTIONAL, in
Scale the MPS by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmps_qmps(PsiNew, PsiOld, scalar, errst)
type(qmps), intent(inout) :: PsiNew
type(qmps), intent(in) :: PsiOld
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
PsiNew%ll = PsiOld%ll
PsiNew%oc = PsiOld%oc
allocate(PsiNew%Aa(PsiNew%ll), PsiNew%can(PsiNew%ll), &
PsiNew%haslambda(PsiNew%ll + 1), PsiNew%lambda(PsiNew%ll + 1))
!if(size(Psinew%can) /= size(Psiold%can)) then
! errst = raise_error('copy_qmps_qmps : '//&
! 'can mismatch.', 99, errst=errst)
! return
!end if
!if(size(Psinew%haslambda) /= size(Psiold%haslambda)) then
! errst = raise_error('copy_qmps_qmps : '//&
! 'haslambda mismatch.', 99, errst=errst)
! return
!end if
PsiNew%can = PsiOld%can
PsiNew%haslambda = PsiOld%haslambda
do ii = 1, PsiNew%ll
call copy(PsiNew%Aa(ii), PsiOld%Aa(ii), errst=errst)
!if(prop_error('copy_qmps_qmps : copy (1) '//&
! 'failed', errst=errst)) return
end do
do ii = 1, (Psinew%ll + 1)
if(PsiNew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(ii), errst=errst)
!if(prop_error('copy_qmps_qmps : copy '//&
! '(2) failed', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_qmps_qmps
"""
return
[docs]def copy_part_qmps_qmps():
"""
fortran-subroutine - November 2017 (dj, updated)
Copy parts of an MPS. Orthogonality center has to be within the
extracted part.
**Arguments**
PsiNew : TYPE(qmps), out
Copy a part of an MPS into this variable
PsiOld : TYPE(qmps), in
Copy part of this MPS to `PsiNew`
first : INTEGER, in
The first site of the old MPS to be copied.
last : INTEGER, in
The last site of the old MPS to be copied.
scalar : real, OPTIONAL, in
Scale the MPS by a factor.
**Details**
The copy of parts of an MPS only works on continuous
number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be
extracted with this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_part_qmps_qmps(Psinew, Psiold, first, last, &
scalar, errst)
type(qmps), intent(inout) :: PsiNew
type(qmps), intent(in) :: PsiOld
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(in) :: first, last
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! new system size
integer :: ll
!if(present(errst)) errst = 0
!if((Psiold%oc < first) .or. (Psiold%oc > last)) then
! errst = raise_error('copy_part_qmps_qmps'//&
! ': oc not within selected sites.', &
! 99, 'MPSOps_include.f90:353', errst=errst)
! return
!end if
! new system size
ll = last - first + 1
PsiNew%ll = ll
PsiNew%oc = Psiold%oc - first + 1
allocate(PsiNew%Aa(ll), PsiNew%can(ll), &
PsiNew%haslambda(ll + 1), PsiNew%lambda(ll + 1))
Psinew%can = Psiold%can(first:last)
Psinew%haslambda = Psiold%haslambda(first:last)
jj = first
do ii = 1, ll
call copy(Psinew%Aa(ii), Psiold%Aa(jj), errst=errst)
!if(prop_error('copy_part_qmps_qmps : copy '//&
! 'failed', 'MPSOps_include.f90:373', errst=errst)) return
jj = jj + 1
end do
jj = first
do ii = 1, ll + 1
if(Psinew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(jj), errst=errst)
!if(prop_error('copy_part_qmps_qmps : '//&
! 'copy failed', 'MPSOps_include.f90:383', &
! errst=errst)) return
end if
jj = jj + 1
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_part_qmps_qmps
"""
return
[docs]def copy_qmpsc_qmps():
"""
fortran-subroutine - June 2017 (dj, updated)
Copy a Matrix Product State.
**Arguments**
PsiNew : TYPE(qmpsc), out
Copy a MPS into this variable
PsiOld : TYPE(qmps), in
Copy this MPS to `PsiNew`
scalar : complex, OPTIONAL, in
Scale the MPS by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmpsc_qmps(PsiNew, PsiOld, scalar, errst)
type(qmpsc), intent(inout) :: PsiNew
type(qmps), intent(in) :: PsiOld
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
PsiNew%ll = PsiOld%ll
PsiNew%oc = PsiOld%oc
allocate(PsiNew%Aa(PsiNew%ll), PsiNew%can(PsiNew%ll), &
PsiNew%haslambda(PsiNew%ll + 1), PsiNew%lambda(PsiNew%ll + 1))
!if(size(Psinew%can) /= size(Psiold%can)) then
! errst = raise_error('copy_qmpsc_qmps : '//&
! 'can mismatch.', 99, errst=errst)
! return
!end if
!if(size(Psinew%haslambda) /= size(Psiold%haslambda)) then
! errst = raise_error('copy_qmpsc_qmps : '//&
! 'haslambda mismatch.', 99, errst=errst)
! return
!end if
PsiNew%can = PsiOld%can
PsiNew%haslambda = PsiOld%haslambda
do ii = 1, PsiNew%ll
call copy(PsiNew%Aa(ii), PsiOld%Aa(ii), errst=errst)
!if(prop_error('copy_qmpsc_qmps : copy (1) '//&
! 'failed', errst=errst)) return
end do
do ii = 1, (Psinew%ll + 1)
if(PsiNew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(ii), errst=errst)
!if(prop_error('copy_qmpsc_qmps : copy '//&
! '(2) failed', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_qmpsc_qmps
"""
return
[docs]def copy_part_qmpsc_qmps():
"""
fortran-subroutine - November 2017 (dj, updated)
Copy parts of an MPS. Orthogonality center has to be within the
extracted part.
**Arguments**
PsiNew : TYPE(qmpsc), out
Copy a part of an MPS into this variable
PsiOld : TYPE(qmps), in
Copy part of this MPS to `PsiNew`
first : INTEGER, in
The first site of the old MPS to be copied.
last : INTEGER, in
The last site of the old MPS to be copied.
scalar : complex, OPTIONAL, in
Scale the MPS by a factor.
**Details**
The copy of parts of an MPS only works on continuous
number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be
extracted with this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_part_qmpsc_qmps(Psinew, Psiold, first, last, &
scalar, errst)
type(qmpsc), intent(inout) :: PsiNew
type(qmps), intent(in) :: PsiOld
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(in) :: first, last
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! new system size
integer :: ll
!if(present(errst)) errst = 0
!if((Psiold%oc < first) .or. (Psiold%oc > last)) then
! errst = raise_error('copy_part_qmpsc_qmps'//&
! ': oc not within selected sites.', &
! 99, 'MPSOps_include.f90:353', errst=errst)
! return
!end if
! new system size
ll = last - first + 1
PsiNew%ll = ll
PsiNew%oc = Psiold%oc - first + 1
allocate(PsiNew%Aa(ll), PsiNew%can(ll), &
PsiNew%haslambda(ll + 1), PsiNew%lambda(ll + 1))
Psinew%can = Psiold%can(first:last)
Psinew%haslambda = Psiold%haslambda(first:last)
jj = first
do ii = 1, ll
call copy(Psinew%Aa(ii), Psiold%Aa(jj), errst=errst)
!if(prop_error('copy_part_qmpsc_qmps : copy '//&
! 'failed', 'MPSOps_include.f90:373', errst=errst)) return
jj = jj + 1
end do
jj = first
do ii = 1, ll + 1
if(Psinew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(jj), errst=errst)
!if(prop_error('copy_part_qmpsc_qmps : '//&
! 'copy failed', 'MPSOps_include.f90:383', &
! errst=errst)) return
end if
jj = jj + 1
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_part_qmpsc_qmps
"""
return
[docs]def copy_qmpsc_qmpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Copy a Matrix Product State.
**Arguments**
PsiNew : TYPE(qmpsc), out
Copy a MPS into this variable
PsiOld : TYPE(qmpsc), in
Copy this MPS to `PsiNew`
scalar : complex, OPTIONAL, in
Scale the MPS by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmpsc_qmpsc(PsiNew, PsiOld, scalar, errst)
type(qmpsc), intent(inout) :: PsiNew
type(qmpsc), intent(in) :: PsiOld
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
PsiNew%ll = PsiOld%ll
PsiNew%oc = PsiOld%oc
allocate(PsiNew%Aa(PsiNew%ll), PsiNew%can(PsiNew%ll), &
PsiNew%haslambda(PsiNew%ll + 1), PsiNew%lambda(PsiNew%ll + 1))
!if(size(Psinew%can) /= size(Psiold%can)) then
! errst = raise_error('copy_qmpsc_qmpsc : '//&
! 'can mismatch.', 99, errst=errst)
! return
!end if
!if(size(Psinew%haslambda) /= size(Psiold%haslambda)) then
! errst = raise_error('copy_qmpsc_qmpsc : '//&
! 'haslambda mismatch.', 99, errst=errst)
! return
!end if
PsiNew%can = PsiOld%can
PsiNew%haslambda = PsiOld%haslambda
do ii = 1, PsiNew%ll
call copy(PsiNew%Aa(ii), PsiOld%Aa(ii), errst=errst)
!if(prop_error('copy_qmpsc_qmpsc : copy (1) '//&
! 'failed', errst=errst)) return
end do
do ii = 1, (Psinew%ll + 1)
if(PsiNew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(ii), errst=errst)
!if(prop_error('copy_qmpsc_qmpsc : copy '//&
! '(2) failed', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_qmpsc_qmpsc
"""
return
[docs]def copy_part_qmpsc_qmpsc():
"""
fortran-subroutine - November 2017 (dj, updated)
Copy parts of an MPS. Orthogonality center has to be within the
extracted part.
**Arguments**
PsiNew : TYPE(qmpsc), out
Copy a part of an MPS into this variable
PsiOld : TYPE(qmpsc), in
Copy part of this MPS to `PsiNew`
first : INTEGER, in
The first site of the old MPS to be copied.
last : INTEGER, in
The last site of the old MPS to be copied.
scalar : complex, OPTIONAL, in
Scale the MPS by a factor.
**Details**
The copy of parts of an MPS only works on continuous
number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be
extracted with this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_part_qmpsc_qmpsc(Psinew, Psiold, first, last, &
scalar, errst)
type(qmpsc), intent(inout) :: PsiNew
type(qmpsc), intent(in) :: PsiOld
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(in) :: first, last
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! new system size
integer :: ll
!if(present(errst)) errst = 0
!if((Psiold%oc < first) .or. (Psiold%oc > last)) then
! errst = raise_error('copy_part_qmpsc_qmpsc'//&
! ': oc not within selected sites.', &
! 99, 'MPSOps_include.f90:353', errst=errst)
! return
!end if
! new system size
ll = last - first + 1
PsiNew%ll = ll
PsiNew%oc = Psiold%oc - first + 1
allocate(PsiNew%Aa(ll), PsiNew%can(ll), &
PsiNew%haslambda(ll + 1), PsiNew%lambda(ll + 1))
Psinew%can = Psiold%can(first:last)
Psinew%haslambda = Psiold%haslambda(first:last)
jj = first
do ii = 1, ll
call copy(Psinew%Aa(ii), Psiold%Aa(jj), errst=errst)
!if(prop_error('copy_part_qmpsc_qmpsc : copy '//&
! 'failed', 'MPSOps_include.f90:373', errst=errst)) return
jj = jj + 1
end do
jj = first
do ii = 1, ll + 1
if(Psinew%haslambda(ii)) then
call copy(PsiNew%Lambda(ii), PsiOld%Lambda(jj), errst=errst)
!if(prop_error('copy_part_qmpsc_qmpsc : '//&
! 'copy failed', 'MPSOps_include.f90:383', &
! errst=errst)) return
end if
jj = jj + 1
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Psinew)
end if
end subroutine copy_part_qmpsc_qmpsc
"""
return
[docs]def canonize_mps():
"""
fortran-subroutine - June 2017 (dj, updated)
Canonize the MPS with gauged matrices.
**Arguments**
Psi : TYPE(mps), inout
Bring this MPS into a canonical form using QR decompositions.
k0 : INTEGER, in
This is the new orthogonality center for the MPS.
kl : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the MPS from the left side of the MPS. If
not given, the maximum of the 1 and the present orthogonality
center is choosen.
kr : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the MPS from the right side of the MPS. If
not given, the minimum of the system size and the present
orthogonality center is choosen.
**Details**
Put the MPS into the canonical form where all matrices to the
left of :math:`k_0` (optionally down to :math:`k_l`) are gauged according
to the left-handed condition :math:`\sum_i A_i^T A_i=I` and all matrices
to the right of :math:`k_0` (optionally up to :math:`k_r`) are gauged
according to the right-handed condition :math:`\sum_i A_i A_i^T=I` for OBC.
This routine uses the QR decomposition - the fastest method - but it is not
rank revealing and so inappropriate for compression. Additionally, the
Schmidt coefficients are not returned and so entropies cannot be computed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine canonize_mps(Psi, k0, kl, kr, errst)
type(mps), intent(inout) :: Psi
integer, intent(in) :: k0
integer, intent(in), optional :: kl, kr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Start of the loop from the left and right
integer :: kleft, kright
!if((k0 < 1) .or. (k0 > Psi%ll)) then
! print *, 'k0, L', k0, Psi%ll
! errst = raise_error('canonize_mps : k0 not valid ', &
! 99, 'MPSOps_include.f90:470', errst=errst)
! return
!end if
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Psi%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Psi%ll, Psi%oc)
end if
!if(kleft < 1) then
! errst = raise_error('canonize_mps : kl < 1', &
! 99, errst=errst)
! return
!end if
!if(kright > Psi%ll) then
! errst = raise_error('canonize_mps : kr > ll', &
! 99, errst=errst)
! return
!end if
do ii = kleft, (k0 - 1)
call gaugesite_qr(Psi%Aa(ii), Psi%Aa(ii + 1), errst=errst)
!if(prop_error('canonize_mps: qr failed', &
! errst=errst)) return
Psi%can(ii) = 'l'
Psi%can(ii + 1) = 'c'
end do
do ii = kright, (k0 + 1), (-1)
call gaugesite_rq(Psi%Aa(ii - 1), Psi%Aa(ii), errst=errst)
!if(prop_error('canonize_mps: rq failed', &
! errst=errst)) return
Psi%can(ii - 1) = 'c'
Psi%can(ii) = 'r'
end do
Psi%oc = k0
end subroutine canonize_mps
"""
return
[docs]def canonize_svd_mps():
"""
fortran-subroutine - June 2017 (dj, updated)
Put the MPS into a canonical form using SVD.
**Arguments**
Psi : TYPE(mps), inout
MPS to be canonized with SVDs. Updated on exit.
k0 : INTEGER, in
The new orthogonality center on exit is at the site k0.
All matrices to the left and right are gauged accordingly.
kl : INTEGER, OPTIONAL, in
start SVD from the left on this site. If not present
SVD start at site 1 or the ortogonality center.
kr : INTEGER, OPTIONAL, in
start SVD from the right on this site. If not present, SVD starts
on the last site or the orthogonality center.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Details**
Put the MPS into the canonical form where all matrices to the left
of :math:`k_0` (optionally down to :math:`k_l`) are gauged according to the
left-handed condition :math:`\sum_i A_i^T A_i=I` and all matrices to the
right of :math:`k_0` (optionally up to :math:`k_r`) are gauged according to
the right-handed condition :math:`\sum_i A_i A_i^T=I` for OBC. This routine
uses the SVD decomposition, which is rank revealing and so appropriate for
compression. Additionally, the Schmidt coefficients are returned and so
entropies can be computed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine canonize_svd_mps(Psi, k0, kl, kr, trunc, ncut, errst)
type(mps), intent(inout) :: Psi
integer , intent(in) :: k0
integer, intent(in), optional :: kl, kr
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Start of the loop from the left and right
integer :: kleft, kright
!if(present(errst)) errst = 0
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Psi%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Psi%ll, Psi%oc)
end if
do ii = kleft, (k0 - 1)
call gaugesite_rsvd(Psi%Aa(ii), Psi%Lambda(ii), Psi%Aa(ii + 1), &
Psi%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_mps: gaugesite_rsvd failed', &
! errst=errst)) return
Psi%can(ii) = 'l'
Psi%can(ii + 1) = 'c'
end do
do ii = kright, (k0 + 1), (-1)
call gaugesite_lsvd(Psi%Aa(ii - 1), Psi%Lambda(ii), Psi%Aa(ii), &
Psi%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_mps: gaugesite_lsvd failed', &
! errst=errst)) return
Psi%can(ii - 1) = 'c'
Psi%can(ii) = 'r'
end do
Psi%oc = k0
end subroutine canonize_svd_mps
"""
return
[docs]def canonize_mpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Canonize the MPS with gauged matrices.
**Arguments**
Psi : TYPE(mpsc), inout
Bring this MPS into a canonical form using QR decompositions.
k0 : INTEGER, in
This is the new orthogonality center for the MPS.
kl : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the MPS from the left side of the MPS. If
not given, the maximum of the 1 and the present orthogonality
center is choosen.
kr : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the MPS from the right side of the MPS. If
not given, the minimum of the system size and the present
orthogonality center is choosen.
**Details**
Put the MPS into the canonical form where all matrices to the
left of :math:`k_0` (optionally down to :math:`k_l`) are gauged according
to the left-handed condition :math:`\sum_i A_i^T A_i=I` and all matrices
to the right of :math:`k_0` (optionally up to :math:`k_r`) are gauged
according to the right-handed condition :math:`\sum_i A_i A_i^T=I` for OBC.
This routine uses the QR decomposition - the fastest method - but it is not
rank revealing and so inappropriate for compression. Additionally, the
Schmidt coefficients are not returned and so entropies cannot be computed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine canonize_mpsc(Psi, k0, kl, kr, errst)
type(mpsc), intent(inout) :: Psi
integer, intent(in) :: k0
integer, intent(in), optional :: kl, kr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Start of the loop from the left and right
integer :: kleft, kright
!if((k0 < 1) .or. (k0 > Psi%ll)) then
! print *, 'k0, L', k0, Psi%ll
! errst = raise_error('canonize_mpsc : k0 not valid ', &
! 99, 'MPSOps_include.f90:470', errst=errst)
! return
!end if
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Psi%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Psi%ll, Psi%oc)
end if
!if(kleft < 1) then
! errst = raise_error('canonize_mpsc : kl < 1', &
! 99, errst=errst)
! return
!end if
!if(kright > Psi%ll) then
! errst = raise_error('canonize_mpsc : kr > ll', &
! 99, errst=errst)
! return
!end if
do ii = kleft, (k0 - 1)
call gaugesite_qr(Psi%Aa(ii), Psi%Aa(ii + 1), errst=errst)
!if(prop_error('canonize_mpsc: qr failed', &
! errst=errst)) return
Psi%can(ii) = 'l'
Psi%can(ii + 1) = 'c'
end do
do ii = kright, (k0 + 1), (-1)
call gaugesite_rq(Psi%Aa(ii - 1), Psi%Aa(ii), errst=errst)
!if(prop_error('canonize_mpsc: rq failed', &
! errst=errst)) return
Psi%can(ii - 1) = 'c'
Psi%can(ii) = 'r'
end do
Psi%oc = k0
end subroutine canonize_mpsc
"""
return
[docs]def canonize_svd_mpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Put the MPS into a canonical form using SVD.
**Arguments**
Psi : TYPE(mpsc), inout
MPS to be canonized with SVDs. Updated on exit.
k0 : INTEGER, in
The new orthogonality center on exit is at the site k0.
All matrices to the left and right are gauged accordingly.
kl : INTEGER, OPTIONAL, in
start SVD from the left on this site. If not present
SVD start at site 1 or the ortogonality center.
kr : INTEGER, OPTIONAL, in
start SVD from the right on this site. If not present, SVD starts
on the last site or the orthogonality center.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Details**
Put the MPS into the canonical form where all matrices to the left
of :math:`k_0` (optionally down to :math:`k_l`) are gauged according to the
left-handed condition :math:`\sum_i A_i^T A_i=I` and all matrices to the
right of :math:`k_0` (optionally up to :math:`k_r`) are gauged according to
the right-handed condition :math:`\sum_i A_i A_i^T=I` for OBC. This routine
uses the SVD decomposition, which is rank revealing and so appropriate for
compression. Additionally, the Schmidt coefficients are returned and so
entropies can be computed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine canonize_svd_mpsc(Psi, k0, kl, kr, trunc, ncut, errst)
type(mpsc), intent(inout) :: Psi
integer , intent(in) :: k0
integer, intent(in), optional :: kl, kr
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Start of the loop from the left and right
integer :: kleft, kright
!if(present(errst)) errst = 0
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Psi%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Psi%ll, Psi%oc)
end if
do ii = kleft, (k0 - 1)
call gaugesite_rsvd(Psi%Aa(ii), Psi%Lambda(ii), Psi%Aa(ii + 1), &
Psi%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_mpsc: gaugesite_rsvd failed', &
! errst=errst)) return
Psi%can(ii) = 'l'
Psi%can(ii + 1) = 'c'
end do
do ii = kright, (k0 + 1), (-1)
call gaugesite_lsvd(Psi%Aa(ii - 1), Psi%Lambda(ii), Psi%Aa(ii), &
Psi%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_mpsc: gaugesite_lsvd failed', &
! errst=errst)) return
Psi%can(ii - 1) = 'c'
Psi%can(ii) = 'r'
end do
Psi%oc = k0
end subroutine canonize_svd_mpsc
"""
return
[docs]def canonize_qmps():
"""
fortran-subroutine - June 2017 (dj, updated)
Canonize the MPS with gauged matrices.
**Arguments**
Psi : TYPE(qmps), inout
Bring this MPS into a canonical form using QR decompositions.
k0 : INTEGER, in
This is the new orthogonality center for the MPS.
kl : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the MPS from the left side of the MPS. If
not given, the maximum of the 1 and the present orthogonality
center is choosen.
kr : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the MPS from the right side of the MPS. If
not given, the minimum of the system size and the present
orthogonality center is choosen.
**Details**
Put the MPS into the canonical form where all matrices to the
left of :math:`k_0` (optionally down to :math:`k_l`) are gauged according
to the left-handed condition :math:`\sum_i A_i^T A_i=I` and all matrices
to the right of :math:`k_0` (optionally up to :math:`k_r`) are gauged
according to the right-handed condition :math:`\sum_i A_i A_i^T=I` for OBC.
This routine uses the QR decomposition - the fastest method - but it is not
rank revealing and so inappropriate for compression. Additionally, the
Schmidt coefficients are not returned and so entropies cannot be computed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine canonize_qmps(Psi, k0, kl, kr, errst)
type(qmps), intent(inout) :: Psi
integer, intent(in) :: k0
integer, intent(in), optional :: kl, kr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Start of the loop from the left and right
integer :: kleft, kright
!if((k0 < 1) .or. (k0 > Psi%ll)) then
! print *, 'k0, L', k0, Psi%ll
! errst = raise_error('canonize_qmps : k0 not valid ', &
! 99, 'MPSOps_include.f90:470', errst=errst)
! return
!end if
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Psi%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Psi%ll, Psi%oc)
end if
!if(kleft < 1) then
! errst = raise_error('canonize_qmps : kl < 1', &
! 99, errst=errst)
! return
!end if
!if(kright > Psi%ll) then
! errst = raise_error('canonize_qmps : kr > ll', &
! 99, errst=errst)
! return
!end if
do ii = kleft, (k0 - 1)
call gaugesite_qr(Psi%Aa(ii), Psi%Aa(ii + 1), errst=errst)
!if(prop_error('canonize_qmps: qr failed', &
! errst=errst)) return
Psi%can(ii) = 'l'
Psi%can(ii + 1) = 'c'
end do
do ii = kright, (k0 + 1), (-1)
call gaugesite_rq(Psi%Aa(ii - 1), Psi%Aa(ii), errst=errst)
!if(prop_error('canonize_qmps: rq failed', &
! errst=errst)) return
Psi%can(ii - 1) = 'c'
Psi%can(ii) = 'r'
end do
Psi%oc = k0
end subroutine canonize_qmps
"""
return
[docs]def canonize_svd_qmps():
"""
fortran-subroutine - June 2017 (dj, updated)
Put the MPS into a canonical form using SVD.
**Arguments**
Psi : TYPE(qmps), inout
MPS to be canonized with SVDs. Updated on exit.
k0 : INTEGER, in
The new orthogonality center on exit is at the site k0.
All matrices to the left and right are gauged accordingly.
kl : INTEGER, OPTIONAL, in
start SVD from the left on this site. If not present
SVD start at site 1 or the ortogonality center.
kr : INTEGER, OPTIONAL, in
start SVD from the right on this site. If not present, SVD starts
on the last site or the orthogonality center.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Details**
Put the MPS into the canonical form where all matrices to the left
of :math:`k_0` (optionally down to :math:`k_l`) are gauged according to the
left-handed condition :math:`\sum_i A_i^T A_i=I` and all matrices to the
right of :math:`k_0` (optionally up to :math:`k_r`) are gauged according to
the right-handed condition :math:`\sum_i A_i A_i^T=I` for OBC. This routine
uses the SVD decomposition, which is rank revealing and so appropriate for
compression. Additionally, the Schmidt coefficients are returned and so
entropies can be computed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine canonize_svd_qmps(Psi, k0, kl, kr, trunc, ncut, errst)
type(qmps), intent(inout) :: Psi
integer , intent(in) :: k0
integer, intent(in), optional :: kl, kr
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Start of the loop from the left and right
integer :: kleft, kright
!if(present(errst)) errst = 0
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Psi%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Psi%ll, Psi%oc)
end if
do ii = kleft, (k0 - 1)
call gaugesite_rsvd(Psi%Aa(ii), Psi%Lambda(ii), Psi%Aa(ii + 1), &
Psi%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_qmps: gaugesite_rsvd failed', &
! errst=errst)) return
Psi%can(ii) = 'l'
Psi%can(ii + 1) = 'c'
end do
do ii = kright, (k0 + 1), (-1)
call gaugesite_lsvd(Psi%Aa(ii - 1), Psi%Lambda(ii), Psi%Aa(ii), &
Psi%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_qmps: gaugesite_lsvd failed', &
! errst=errst)) return
Psi%can(ii - 1) = 'c'
Psi%can(ii) = 'r'
end do
Psi%oc = k0
end subroutine canonize_svd_qmps
"""
return
[docs]def canonize_qmpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Canonize the MPS with gauged matrices.
**Arguments**
Psi : TYPE(qmpsc), inout
Bring this MPS into a canonical form using QR decompositions.
k0 : INTEGER, in
This is the new orthogonality center for the MPS.
kl : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the MPS from the left side of the MPS. If
not given, the maximum of the 1 and the present orthogonality
center is choosen.
kr : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the MPS from the right side of the MPS. If
not given, the minimum of the system size and the present
orthogonality center is choosen.
**Details**
Put the MPS into the canonical form where all matrices to the
left of :math:`k_0` (optionally down to :math:`k_l`) are gauged according
to the left-handed condition :math:`\sum_i A_i^T A_i=I` and all matrices
to the right of :math:`k_0` (optionally up to :math:`k_r`) are gauged
according to the right-handed condition :math:`\sum_i A_i A_i^T=I` for OBC.
This routine uses the QR decomposition - the fastest method - but it is not
rank revealing and so inappropriate for compression. Additionally, the
Schmidt coefficients are not returned and so entropies cannot be computed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine canonize_qmpsc(Psi, k0, kl, kr, errst)
type(qmpsc), intent(inout) :: Psi
integer, intent(in) :: k0
integer, intent(in), optional :: kl, kr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Start of the loop from the left and right
integer :: kleft, kright
!if((k0 < 1) .or. (k0 > Psi%ll)) then
! print *, 'k0, L', k0, Psi%ll
! errst = raise_error('canonize_qmpsc : k0 not valid ', &
! 99, 'MPSOps_include.f90:470', errst=errst)
! return
!end if
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Psi%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Psi%ll, Psi%oc)
end if
!if(kleft < 1) then
! errst = raise_error('canonize_qmpsc : kl < 1', &
! 99, errst=errst)
! return
!end if
!if(kright > Psi%ll) then
! errst = raise_error('canonize_qmpsc : kr > ll', &
! 99, errst=errst)
! return
!end if
do ii = kleft, (k0 - 1)
call gaugesite_qr(Psi%Aa(ii), Psi%Aa(ii + 1), errst=errst)
!if(prop_error('canonize_qmpsc: qr failed', &
! errst=errst)) return
Psi%can(ii) = 'l'
Psi%can(ii + 1) = 'c'
end do
do ii = kright, (k0 + 1), (-1)
call gaugesite_rq(Psi%Aa(ii - 1), Psi%Aa(ii), errst=errst)
!if(prop_error('canonize_qmpsc: rq failed', &
! errst=errst)) return
Psi%can(ii - 1) = 'c'
Psi%can(ii) = 'r'
end do
Psi%oc = k0
end subroutine canonize_qmpsc
"""
return
[docs]def canonize_svd_qmpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Put the MPS into a canonical form using SVD.
**Arguments**
Psi : TYPE(qmpsc), inout
MPS to be canonized with SVDs. Updated on exit.
k0 : INTEGER, in
The new orthogonality center on exit is at the site k0.
All matrices to the left and right are gauged accordingly.
kl : INTEGER, OPTIONAL, in
start SVD from the left on this site. If not present
SVD start at site 1 or the ortogonality center.
kr : INTEGER, OPTIONAL, in
start SVD from the right on this site. If not present, SVD starts
on the last site or the orthogonality center.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Details**
Put the MPS into the canonical form where all matrices to the left
of :math:`k_0` (optionally down to :math:`k_l`) are gauged according to the
left-handed condition :math:`\sum_i A_i^T A_i=I` and all matrices to the
right of :math:`k_0` (optionally up to :math:`k_r`) are gauged according to
the right-handed condition :math:`\sum_i A_i A_i^T=I` for OBC. This routine
uses the SVD decomposition, which is rank revealing and so appropriate for
compression. Additionally, the Schmidt coefficients are returned and so
entropies can be computed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine canonize_svd_qmpsc(Psi, k0, kl, kr, trunc, ncut, errst)
type(qmpsc), intent(inout) :: Psi
integer , intent(in) :: k0
integer, intent(in), optional :: kl, kr
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Start of the loop from the left and right
integer :: kleft, kright
!if(present(errst)) errst = 0
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Psi%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Psi%ll, Psi%oc)
end if
do ii = kleft, (k0 - 1)
call gaugesite_rsvd(Psi%Aa(ii), Psi%Lambda(ii), Psi%Aa(ii + 1), &
Psi%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_qmpsc: gaugesite_rsvd failed', &
! errst=errst)) return
Psi%can(ii) = 'l'
Psi%can(ii + 1) = 'c'
end do
do ii = kright, (k0 + 1), (-1)
call gaugesite_lsvd(Psi%Aa(ii - 1), Psi%Lambda(ii), Psi%Aa(ii), &
Psi%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_qmpsc: gaugesite_lsvd failed', &
! errst=errst)) return
Psi%can(ii - 1) = 'c'
Psi%can(ii) = 'r'
end do
Psi%oc = k0
end subroutine canonize_svd_qmpsc
"""
return
[docs]def check_mps():
"""
fortran-subroutine - August 2017 (dj)
Run basic checks on MPS, such as left-right unitary and normed.
**Arguments**
Psi : TYPE(mps), in
Run checks on this MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_mps(Psi, errst)
type(mps), intent(in) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Check norm of orthgonality center
real(KIND=rKind) :: normoc
! temporary tensor to guarantee intent(in)
type(tensor) :: Tmp
! tensor to check if tensor are left/right unitary
type(tensor) :: Tens
! string to store more information
character(len=64) :: info
normoc = norm(Psi%Aa(Psi%oc))
!if(abs(normoc - 1.0_rKind) > 1e-14_rKind) then
! print *, 'failed norm', normoc
!CHEK_ write(info, '(1E30.15)') normoc
! errst = raise_error('check_mps : norm failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(abs(normoc - 1.0_rKind) > 1e-14_rKind) stop 'check_mps: norm.'
do ii = (Psi%oc + 1), Psi%ll
call copy(Tmp, Psi%Aa(ii))
call contr(Tens, Tmp, Tmp, [2, 3], [2, 3], &
transr='C', errst=errst)
!if(prop_error('check_mps : contr (1) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_mps : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_mps: unitary failed (1).'
call destroy(Tmp)
call destroy(Tens)
end do
do ii = 1, (Psi%oc - 1)
call copy(Tmp, Psi%Aa(ii))
call contr(Tens, Tmp, Tmp, [1, 2], [1, 2], &
transr='C', errst=errst)
!if(prop_error('check_mps : contr (2) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_mps : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_mps: unitary failed (2).'
call destroy(Tmp)
call destroy(Tens)
end do
end subroutine check_mps
"""
return
[docs]def check_mpsc():
"""
fortran-subroutine - August 2017 (dj)
Run basic checks on MPS, such as left-right unitary and normed.
**Arguments**
Psi : TYPE(mpsc), in
Run checks on this MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_mpsc(Psi, errst)
type(mpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Check norm of orthgonality center
real(KIND=rKind) :: normoc
! temporary tensor to guarantee intent(in)
type(tensorc) :: Tmp
! tensor to check if tensor are left/right unitary
type(tensorc) :: Tens
! string to store more information
character(len=64) :: info
normoc = norm(Psi%Aa(Psi%oc))
!if(abs(normoc - 1.0_rKind) > 1e-14_rKind) then
! print *, 'failed norm', normoc
!CHEK_ write(info, '(1E30.15)') normoc
! errst = raise_error('check_mpsc : norm failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(abs(normoc - 1.0_rKind) > 1e-14_rKind) stop 'check_mpsc: norm.'
do ii = (Psi%oc + 1), Psi%ll
call copy(Tmp, Psi%Aa(ii))
call contr(Tens, Tmp, Tmp, [2, 3], [2, 3], &
transr='C', errst=errst)
!if(prop_error('check_mpsc : contr (1) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_mpsc : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_mpsc: unitary failed (1).'
call destroy(Tmp)
call destroy(Tens)
end do
do ii = 1, (Psi%oc - 1)
call copy(Tmp, Psi%Aa(ii))
call contr(Tens, Tmp, Tmp, [1, 2], [1, 2], &
transr='C', errst=errst)
!if(prop_error('check_mpsc : contr (2) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_mpsc : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_mpsc: unitary failed (2).'
call destroy(Tmp)
call destroy(Tens)
end do
end subroutine check_mpsc
"""
return
[docs]def check_qmps():
"""
fortran-subroutine - August 2017 (dj)
Run basic checks on MPS, such as left-right unitary and normed.
**Arguments**
Psi : TYPE(qmps), in
Run checks on this MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_qmps(Psi, errst)
type(qmps), intent(in) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Check norm of orthgonality center
real(KIND=rKind) :: normoc
! temporary tensor to guarantee intent(in)
type(qtensor) :: Tmp
! tensor to check if tensor are left/right unitary
type(qtensor) :: Tens
! string to store more information
character(len=64) :: info
normoc = norm(Psi%Aa(Psi%oc))
!if(abs(normoc - 1.0_rKind) > 1e-14_rKind) then
! print *, 'failed norm', normoc
!CHEK_ write(info, '(1E30.15)') normoc
! errst = raise_error('check_qmps : norm failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(abs(normoc - 1.0_rKind) > 1e-14_rKind) stop 'check_qmps: norm.'
do ii = (Psi%oc + 1), Psi%ll
call copy(Tmp, Psi%Aa(ii))
call contr(Tens, Tmp, Tmp, [2, 3], [2, 3], &
transr='C', errst=errst)
!if(prop_error('check_qmps : contr (1) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_qmps : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_qmps: unitary failed (1).'
call destroy(Tmp)
call destroy(Tens)
end do
do ii = 1, (Psi%oc - 1)
call copy(Tmp, Psi%Aa(ii))
call contr(Tens, Tmp, Tmp, [1, 2], [1, 2], &
transr='C', errst=errst)
!if(prop_error('check_qmps : contr (2) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_qmps : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_qmps: unitary failed (2).'
call destroy(Tmp)
call destroy(Tens)
end do
end subroutine check_qmps
"""
return
[docs]def check_qmpsc():
"""
fortran-subroutine - August 2017 (dj)
Run basic checks on MPS, such as left-right unitary and normed.
**Arguments**
Psi : TYPE(qmpsc), in
Run checks on this MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_qmpsc(Psi, errst)
type(qmpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Check norm of orthgonality center
real(KIND=rKind) :: normoc
! temporary tensor to guarantee intent(in)
type(qtensorc) :: Tmp
! tensor to check if tensor are left/right unitary
type(qtensorc) :: Tens
! string to store more information
character(len=64) :: info
normoc = norm(Psi%Aa(Psi%oc))
!if(abs(normoc - 1.0_rKind) > 1e-14_rKind) then
! print *, 'failed norm', normoc
!CHEK_ write(info, '(1E30.15)') normoc
! errst = raise_error('check_qmpsc : norm failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(abs(normoc - 1.0_rKind) > 1e-14_rKind) stop 'check_qmpsc: norm.'
do ii = (Psi%oc + 1), Psi%ll
call copy(Tmp, Psi%Aa(ii))
call contr(Tens, Tmp, Tmp, [2, 3], [2, 3], &
transr='C', errst=errst)
!if(prop_error('check_qmpsc : contr (1) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_qmpsc : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_qmpsc: unitary failed (1).'
call destroy(Tmp)
call destroy(Tens)
end do
do ii = 1, (Psi%oc - 1)
call copy(Tmp, Psi%Aa(ii))
call contr(Tens, Tmp, Tmp, [1, 2], [1, 2], &
transr='C', errst=errst)
!if(prop_error('check_qmpsc : contr (2) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_qmpsc : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_qmpsc: unitary failed (2).'
call destroy(Tmp)
call destroy(Tens)
end do
end subroutine check_qmpsc
"""
return
[docs]def destroy_mps():
"""
fortran-subroutine - June 2017 (dj, update)
Deallocate the MPS representing the wave function.
**Arguments**
Psi : TYPE(mps), inout
Deallocate MPS including all tensors and vectors contained in the
structure.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_mps(Psi)
type(mps) :: Psi
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Psi%ll
call destroy(Psi%Aa(ii))
if(Psi%haslambda(ii)) call destroy(Psi%Lambda(ii))
end do
if(Psi%haslambda(Psi%ll + 1)) call destroy(Psi%Lambda(Psi%ll + 1))
deallocate(Psi%Aa, Psi%haslambda, Psi%Lambda, Psi%can)
Psi%ll = -1
end subroutine destroy_mps
"""
return
[docs]def destroy_mpsc():
"""
fortran-subroutine - June 2017 (dj, update)
Deallocate the MPS representing the wave function.
**Arguments**
Psi : TYPE(mpsc), inout
Deallocate MPS including all tensors and vectors contained in the
structure.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_mpsc(Psi)
type(mpsc) :: Psi
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Psi%ll
call destroy(Psi%Aa(ii))
if(Psi%haslambda(ii)) call destroy(Psi%Lambda(ii))
end do
if(Psi%haslambda(Psi%ll + 1)) call destroy(Psi%Lambda(Psi%ll + 1))
deallocate(Psi%Aa, Psi%haslambda, Psi%Lambda, Psi%can)
Psi%ll = -1
end subroutine destroy_mpsc
"""
return
[docs]def destroy_qmps():
"""
fortran-subroutine - June 2017 (dj, update)
Deallocate the MPS representing the wave function.
**Arguments**
Psi : TYPE(qmps), inout
Deallocate MPS including all tensors and vectors contained in the
structure.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qmps(Psi)
type(qmps) :: Psi
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Psi%ll
call destroy(Psi%Aa(ii))
if(Psi%haslambda(ii)) call destroy(Psi%Lambda(ii))
end do
if(Psi%haslambda(Psi%ll + 1)) call destroy(Psi%Lambda(Psi%ll + 1))
deallocate(Psi%Aa, Psi%haslambda, Psi%Lambda, Psi%can)
Psi%ll = -1
end subroutine destroy_qmps
"""
return
[docs]def destroy_qmpsc():
"""
fortran-subroutine - June 2017 (dj, update)
Deallocate the MPS representing the wave function.
**Arguments**
Psi : TYPE(qmpsc), inout
Deallocate MPS including all tensors and vectors contained in the
structure.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qmpsc(Psi)
type(qmpsc) :: Psi
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Psi%ll
call destroy(Psi%Aa(ii))
if(Psi%haslambda(ii)) call destroy(Psi%Lambda(ii))
end do
if(Psi%haslambda(Psi%ll + 1)) call destroy(Psi%Lambda(Psi%ll + 1))
deallocate(Psi%Aa, Psi%haslambda, Psi%Lambda, Psi%can)
Psi%ll = -1
end subroutine destroy_qmpsc
"""
return
[docs]def distance_mps_mps():
"""
fortran-function - September 2017 (dj)
Measure the distance between two MPSs.
**Arguments**
PsiA : TYPE(mps), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(mps), in
Second quantum state to calculate a fidelity.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Option are
'F' (fidelity) and 'O' (overlap, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_mps_mps(Psia, Psib, dist_type, &
errst) result(dist)
type(mps), intent(inout) :: Psia
type(mps), intent(inout) :: Psib
character, intent(in), optional :: dist_type
integer, intent(out), optional :: errst
real(KIND=rKind) :: dist
! Local variables
! ---------------
! duplette for optional argument
character :: dtype
!if(present(errst)) errst = 0
dtype = 'O'
if(present(dist_type)) dtype = dist_type
if(dtype == 'O') then
dist = dot(Psia, Psib)
elseif(dtype == 'F') then
dist = abs(dot(Psia, Psib))
else
errst = raise_error('distance_mps_mps : unkown '//&
'dist_type.', 99, errst=errst)
end if
end function distance_mps_mps
"""
return
[docs]def distance_mps_mpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between two MPSs.
**Arguments**
PsiA : TYPE(mps), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(mpsc), in
Second quantum state to calculate a fidelity.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Option are
'F' (fidelity) and 'O' (overlap, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_mps_mpsc(Psia, Psib, dist_type, &
errst) result(dist)
type(mps), intent(inout) :: Psia
type(mpsc), intent(inout) :: Psib
character, intent(in), optional :: dist_type
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dist
! Local variables
! ---------------
! duplette for optional argument
character :: dtype
!if(present(errst)) errst = 0
dtype = 'O'
if(present(dist_type)) dtype = dist_type
if(dtype == 'O') then
dist = dot(Psia, Psib)
elseif(dtype == 'F') then
dist = abs(dot(Psia, Psib))
else
errst = raise_error('distance_mps_mpsc : unkown '//&
'dist_type.', 99, errst=errst)
end if
end function distance_mps_mpsc
"""
return
[docs]def distance_mpsc_mps():
"""
fortran-function - September 2017 (dj)
Measure the distance between two MPSs.
**Arguments**
PsiA : TYPE(mpsc), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(mps), in
Second quantum state to calculate a fidelity.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Option are
'F' (fidelity) and 'O' (overlap, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_mpsc_mps(Psia, Psib, dist_type, &
errst) result(dist)
type(mpsc), intent(inout) :: Psia
type(mps), intent(inout) :: Psib
character, intent(in), optional :: dist_type
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dist
! Local variables
! ---------------
! duplette for optional argument
character :: dtype
!if(present(errst)) errst = 0
dtype = 'O'
if(present(dist_type)) dtype = dist_type
if(dtype == 'O') then
dist = dot(Psia, Psib)
elseif(dtype == 'F') then
dist = abs(dot(Psia, Psib))
else
errst = raise_error('distance_mpsc_mps : unkown '//&
'dist_type.', 99, errst=errst)
end if
end function distance_mpsc_mps
"""
return
[docs]def distance_mpsc_mpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between two MPSs.
**Arguments**
PsiA : TYPE(mpsc), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(mpsc), in
Second quantum state to calculate a fidelity.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Option are
'F' (fidelity) and 'O' (overlap, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_mpsc_mpsc(Psia, Psib, dist_type, &
errst) result(dist)
type(mpsc), intent(inout) :: Psia
type(mpsc), intent(inout) :: Psib
character, intent(in), optional :: dist_type
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dist
! Local variables
! ---------------
! duplette for optional argument
character :: dtype
!if(present(errst)) errst = 0
dtype = 'O'
if(present(dist_type)) dtype = dist_type
if(dtype == 'O') then
dist = dot(Psia, Psib)
elseif(dtype == 'F') then
dist = abs(dot(Psia, Psib))
else
errst = raise_error('distance_mpsc_mpsc : unkown '//&
'dist_type.', 99, errst=errst)
end if
end function distance_mpsc_mpsc
"""
return
[docs]def distance_qmps_qmps():
"""
fortran-function - September 2017 (dj)
Measure the distance between two MPSs.
**Arguments**
PsiA : TYPE(qmps), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(qmps), in
Second quantum state to calculate a fidelity.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Option are
'F' (fidelity) and 'O' (overlap, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_qmps_qmps(Psia, Psib, dist_type, &
errst) result(dist)
type(qmps), intent(inout) :: Psia
type(qmps), intent(inout) :: Psib
character, intent(in), optional :: dist_type
integer, intent(out), optional :: errst
real(KIND=rKind) :: dist
! Local variables
! ---------------
! duplette for optional argument
character :: dtype
!if(present(errst)) errst = 0
dtype = 'O'
if(present(dist_type)) dtype = dist_type
if(dtype == 'O') then
dist = dot(Psia, Psib)
elseif(dtype == 'F') then
dist = abs(dot(Psia, Psib))
else
errst = raise_error('distance_qmps_qmps : unkown '//&
'dist_type.', 99, errst=errst)
end if
end function distance_qmps_qmps
"""
return
[docs]def distance_qmps_qmpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between two MPSs.
**Arguments**
PsiA : TYPE(qmps), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(qmpsc), in
Second quantum state to calculate a fidelity.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Option are
'F' (fidelity) and 'O' (overlap, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_qmps_qmpsc(Psia, Psib, dist_type, &
errst) result(dist)
type(qmps), intent(inout) :: Psia
type(qmpsc), intent(inout) :: Psib
character, intent(in), optional :: dist_type
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dist
! Local variables
! ---------------
! duplette for optional argument
character :: dtype
!if(present(errst)) errst = 0
dtype = 'O'
if(present(dist_type)) dtype = dist_type
if(dtype == 'O') then
dist = dot(Psia, Psib)
elseif(dtype == 'F') then
dist = abs(dot(Psia, Psib))
else
errst = raise_error('distance_qmps_qmpsc : unkown '//&
'dist_type.', 99, errst=errst)
end if
end function distance_qmps_qmpsc
"""
return
[docs]def distance_qmpsc_qmps():
"""
fortran-function - September 2017 (dj)
Measure the distance between two MPSs.
**Arguments**
PsiA : TYPE(qmpsc), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(qmps), in
Second quantum state to calculate a fidelity.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Option are
'F' (fidelity) and 'O' (overlap, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_qmpsc_qmps(Psia, Psib, dist_type, &
errst) result(dist)
type(qmpsc), intent(inout) :: Psia
type(qmps), intent(inout) :: Psib
character, intent(in), optional :: dist_type
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dist
! Local variables
! ---------------
! duplette for optional argument
character :: dtype
!if(present(errst)) errst = 0
dtype = 'O'
if(present(dist_type)) dtype = dist_type
if(dtype == 'O') then
dist = dot(Psia, Psib)
elseif(dtype == 'F') then
dist = abs(dot(Psia, Psib))
else
errst = raise_error('distance_qmpsc_qmps : unkown '//&
'dist_type.', 99, errst=errst)
end if
end function distance_qmpsc_qmps
"""
return
[docs]def distance_qmpsc_qmpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between two MPSs.
**Arguments**
PsiA : TYPE(qmpsc), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(qmpsc), in
Second quantum state to calculate a fidelity.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Option are
'F' (fidelity) and 'O' (overlap, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_qmpsc_qmpsc(Psia, Psib, dist_type, &
errst) result(dist)
type(qmpsc), intent(inout) :: Psia
type(qmpsc), intent(inout) :: Psib
character, intent(in), optional :: dist_type
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dist
! Local variables
! ---------------
! duplette for optional argument
character :: dtype
!if(present(errst)) errst = 0
dtype = 'O'
if(present(dist_type)) dtype = dist_type
if(dtype == 'O') then
dist = dot(Psia, Psib)
elseif(dtype == 'F') then
dist = abs(dot(Psia, Psib))
else
errst = raise_error('distance_qmpsc_qmpsc : unkown '//&
'dist_type.', 99, errst=errst)
end if
end function distance_qmpsc_qmpsc
"""
return
[docs]def dot_mps_mps():
"""
fortran-function - June 2017 (dj)
Compute the fidelity / inner product <A,B> between two quantum states.
**Arguments**
PsiA : TYPE(mps), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(mps), in
Second quantum state to calculate a fidelity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_mps_mps(Psia, Psib, errst) result(dotab)
type(mps), intent(inout) :: Psia
type(mps), intent(inout) :: Psib
integer, intent(out), optional :: errst
real(KIND=rKind) :: dotab
! Local variables
! ---------------
! for looping
integer :: ii
! Transfer matrix
type(tensor) :: Mat
do ii = 1, Psia%ll
call ptm_right_state(Mat, Psia%Aa(ii), Psib%Aa(ii), (ii == 1), &
errst=errst)
!if(prop_error('dot_MPS_TYPE: ptm_right_state failed.', &
! errst=errst)) return
end do
dotab = trace(Mat)
call destroy(Mat)
end function dot_mps_mps
"""
return
[docs]def dot_mps_mpsc():
"""
fortran-function - June 2017 (dj)
Compute the fidelity / inner product <A,B> between two quantum states.
**Arguments**
PsiA : TYPE(mps), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(mpsc), in
Second quantum state to calculate a fidelity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_mps_mpsc(Psia, Psib, errst) result(dotab)
type(mps), intent(inout) :: Psia
type(mpsc), intent(inout) :: Psib
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dotab
! Local variables
! ---------------
! for looping
integer :: ii
! Transfer matrix
type(tensorc) :: Mat
do ii = 1, Psia%ll
call ptm_right_state(Mat, Psia%Aa(ii), Psib%Aa(ii), (ii == 1), &
errst=errst)
!if(prop_error('dot_MPS_TYPE: ptm_right_state failed.', &
! errst=errst)) return
end do
dotab = trace(Mat)
call destroy(Mat)
end function dot_mps_mpsc
"""
return
[docs]def dot_mpsc_mps():
"""
fortran-function - June 2017 (dj)
Compute the fidelity / inner product <A,B> between two quantum states.
**Arguments**
PsiA : TYPE(mpsc), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(mps), in
Second quantum state to calculate a fidelity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_mpsc_mps(Psia, Psib, errst) result(dotab)
type(mpsc), intent(inout) :: Psia
type(mps), intent(inout) :: Psib
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dotab
! Local variables
! ---------------
! for looping
integer :: ii
! Transfer matrix
type(tensorc) :: Mat
do ii = 1, Psia%ll
call ptm_right_state(Mat, Psia%Aa(ii), Psib%Aa(ii), (ii == 1), &
errst=errst)
!if(prop_error('dot_MPS_TYPE: ptm_right_state failed.', &
! errst=errst)) return
end do
dotab = trace(Mat)
call destroy(Mat)
end function dot_mpsc_mps
"""
return
[docs]def dot_mpsc_mpsc():
"""
fortran-function - June 2017 (dj)
Compute the fidelity / inner product <A,B> between two quantum states.
**Arguments**
PsiA : TYPE(mpsc), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(mpsc), in
Second quantum state to calculate a fidelity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_mpsc_mpsc(Psia, Psib, errst) result(dotab)
type(mpsc), intent(inout) :: Psia
type(mpsc), intent(inout) :: Psib
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dotab
! Local variables
! ---------------
! for looping
integer :: ii
! Transfer matrix
type(tensorc) :: Mat
do ii = 1, Psia%ll
call ptm_right_state(Mat, Psia%Aa(ii), Psib%Aa(ii), (ii == 1), &
errst=errst)
!if(prop_error('dot_MPS_TYPE: ptm_right_state failed.', &
! errst=errst)) return
end do
dotab = trace(Mat)
call destroy(Mat)
end function dot_mpsc_mpsc
"""
return
[docs]def dot_qmps_qmps():
"""
fortran-function - June 2017 (dj)
Compute the fidelity / inner product <A,B> between two quantum states.
**Arguments**
PsiA : TYPE(qmps), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(qmps), in
Second quantum state to calculate a fidelity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_qmps_qmps(Psia, Psib, errst) result(dotab)
type(qmps), intent(inout) :: Psia
type(qmps), intent(inout) :: Psib
integer, intent(out), optional :: errst
real(KIND=rKind) :: dotab
! Local variables
! ---------------
! for looping
integer :: ii
! Transfer matrix
type(qtensor) :: Mat
do ii = 1, Psia%ll
call ptm_right_state(Mat, Psia%Aa(ii), Psib%Aa(ii), (ii == 1), &
errst=errst)
!if(prop_error('dot_MPS_TYPE: ptm_right_state failed.', &
! errst=errst)) return
end do
dotab = trace(Mat)
call destroy(Mat)
end function dot_qmps_qmps
"""
return
[docs]def dot_qmps_qmpsc():
"""
fortran-function - June 2017 (dj)
Compute the fidelity / inner product <A,B> between two quantum states.
**Arguments**
PsiA : TYPE(qmps), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(qmpsc), in
Second quantum state to calculate a fidelity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_qmps_qmpsc(Psia, Psib, errst) result(dotab)
type(qmps), intent(inout) :: Psia
type(qmpsc), intent(inout) :: Psib
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dotab
! Local variables
! ---------------
! for looping
integer :: ii
! Transfer matrix
type(qtensorc) :: Mat
do ii = 1, Psia%ll
call ptm_right_state(Mat, Psia%Aa(ii), Psib%Aa(ii), (ii == 1), &
errst=errst)
!if(prop_error('dot_MPS_TYPE: ptm_right_state failed.', &
! errst=errst)) return
end do
dotab = trace(Mat)
call destroy(Mat)
end function dot_qmps_qmpsc
"""
return
[docs]def dot_qmpsc_qmps():
"""
fortran-function - June 2017 (dj)
Compute the fidelity / inner product <A,B> between two quantum states.
**Arguments**
PsiA : TYPE(qmpsc), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(qmps), in
Second quantum state to calculate a fidelity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_qmpsc_qmps(Psia, Psib, errst) result(dotab)
type(qmpsc), intent(inout) :: Psia
type(qmps), intent(inout) :: Psib
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dotab
! Local variables
! ---------------
! for looping
integer :: ii
! Transfer matrix
type(qtensorc) :: Mat
do ii = 1, Psia%ll
call ptm_right_state(Mat, Psia%Aa(ii), Psib%Aa(ii), (ii == 1), &
errst=errst)
!if(prop_error('dot_MPS_TYPE: ptm_right_state failed.', &
! errst=errst)) return
end do
dotab = trace(Mat)
call destroy(Mat)
end function dot_qmpsc_qmps
"""
return
[docs]def dot_qmpsc_qmpsc():
"""
fortran-function - June 2017 (dj)
Compute the fidelity / inner product <A,B> between two quantum states.
**Arguments**
PsiA : TYPE(qmpsc), inout
First quantum state to calculate a fidelity.
PsiB : TYPE(qmpsc), in
Second quantum state to calculate a fidelity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_qmpsc_qmpsc(Psia, Psib, errst) result(dotab)
type(qmpsc), intent(inout) :: Psia
type(qmpsc), intent(inout) :: Psib
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dotab
! Local variables
! ---------------
! for looping
integer :: ii
! Transfer matrix
type(qtensorc) :: Mat
do ii = 1, Psia%ll
call ptm_right_state(Mat, Psia%Aa(ii), Psib%Aa(ii), (ii == 1), &
errst=errst)
!if(prop_error('dot_MPS_TYPE: ptm_right_state failed.', &
! errst=errst)) return
end do
dotab = trace(Mat)
call destroy(Mat)
end function dot_qmpsc_qmpsc
"""
return
[docs]def gaugesite_qr_tensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift gauge for two tensor to the right with a QR-decomposition.
**Arguments**
Tl : TYPE(tensor), inout
Run QR decomposition on last index vs the other ones.
Tr : TYPE(tensor), inout
On exit, this tensor is the new orhtogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_qr_tensor(Tl, Tr, errst)
type(tensor), intent(inout) :: Tl, Tr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary tensor for R-matrix
type(tensor) :: Tmp
!if(present(errst)) errst = 0
call qr(Tl, Tmp, [1, 2], [3], errst=errst)
!if(prop_error('gaugesite_qr_tensor: qr failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tr, [2], [1], errst=errst)
!if(prop_error('gaugesite_qr_tensor: contr failed', &
! errst=errst)) return
call destroy(Tmp)
end subroutine gaugesite_qr_tensor
"""
return
[docs]def gaugesite_rq_tensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift gauge for two tensors to the left with a RQ-decompistion.
**Arguments**
Tl : TYPE(tensor), inout
On exit, this tensor is the new orhtogonality center.
Tr : TYPE(tensor), inout
Run RQ decomposition on first index vs the other ones.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_rq_tensor(Tl, Tr, errst)
type(tensor), intent(inout) :: Tl, Tr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary tensor for R-matrix
type(tensor) :: Tmp
!if(present(errst)) errst = 0
call rq(Tr, Tmp, [1], [2, 3], errst=errst)
!if(prop_error('gaugesite_rq_tensor: rq failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tl, [1], [3], errst=errst)
!if(prop_error('gaugesite_rq_tensor: contr failed', &
! errst=errst)) return
call destroy(Tmp)
end subroutine gaugesite_rq_tensor
"""
return
[docs]def gaugesite_qr_tensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift gauge for two tensor to the right with a QR-decomposition.
**Arguments**
Tl : TYPE(tensorc), inout
Run QR decomposition on last index vs the other ones.
Tr : TYPE(tensorc), inout
On exit, this tensor is the new orhtogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_qr_tensorc(Tl, Tr, errst)
type(tensorc), intent(inout) :: Tl, Tr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary tensor for R-matrix
type(tensorc) :: Tmp
!if(present(errst)) errst = 0
call qr(Tl, Tmp, [1, 2], [3], errst=errst)
!if(prop_error('gaugesite_qr_tensorc: qr failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tr, [2], [1], errst=errst)
!if(prop_error('gaugesite_qr_tensorc: contr failed', &
! errst=errst)) return
call destroy(Tmp)
end subroutine gaugesite_qr_tensorc
"""
return
[docs]def gaugesite_rq_tensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift gauge for two tensors to the left with a RQ-decompistion.
**Arguments**
Tl : TYPE(tensorc), inout
On exit, this tensor is the new orhtogonality center.
Tr : TYPE(tensorc), inout
Run RQ decomposition on first index vs the other ones.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_rq_tensorc(Tl, Tr, errst)
type(tensorc), intent(inout) :: Tl, Tr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary tensor for R-matrix
type(tensorc) :: Tmp
!if(present(errst)) errst = 0
call rq(Tr, Tmp, [1], [2, 3], errst=errst)
!if(prop_error('gaugesite_rq_tensorc: rq failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tl, [1], [3], errst=errst)
!if(prop_error('gaugesite_rq_tensorc: contr failed', &
! errst=errst)) return
call destroy(Tmp)
end subroutine gaugesite_rq_tensorc
"""
return
[docs]def gaugesite_qr_qtensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift gauge for two tensor to the right with a QR-decomposition.
**Arguments**
Tl : TYPE(qtensor), inout
Run QR decomposition on last index vs the other ones.
Tr : TYPE(qtensor), inout
On exit, this tensor is the new orhtogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_qr_qtensor(Tl, Tr, errst)
type(qtensor), intent(inout) :: Tl, Tr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary tensor for R-matrix
type(qtensor) :: Tmp
!if(present(errst)) errst = 0
call qr(Tl, Tmp, [1, 2], [3], errst=errst)
!if(prop_error('gaugesite_qr_qtensor: qr failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tr, [2], [1], errst=errst)
!if(prop_error('gaugesite_qr_qtensor: contr failed', &
! errst=errst)) return
call destroy(Tmp)
end subroutine gaugesite_qr_qtensor
"""
return
[docs]def gaugesite_rq_qtensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift gauge for two tensors to the left with a RQ-decompistion.
**Arguments**
Tl : TYPE(qtensor), inout
On exit, this tensor is the new orhtogonality center.
Tr : TYPE(qtensor), inout
Run RQ decomposition on first index vs the other ones.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_rq_qtensor(Tl, Tr, errst)
type(qtensor), intent(inout) :: Tl, Tr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary tensor for R-matrix
type(qtensor) :: Tmp
!if(present(errst)) errst = 0
call rq(Tr, Tmp, [1], [2, 3], errst=errst)
!if(prop_error('gaugesite_rq_qtensor: rq failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tl, [1], [3], errst=errst)
!if(prop_error('gaugesite_rq_qtensor: contr failed', &
! errst=errst)) return
call destroy(Tmp)
end subroutine gaugesite_rq_qtensor
"""
return
[docs]def gaugesite_qr_qtensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift gauge for two tensor to the right with a QR-decomposition.
**Arguments**
Tl : TYPE(qtensorc), inout
Run QR decomposition on last index vs the other ones.
Tr : TYPE(qtensorc), inout
On exit, this tensor is the new orhtogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_qr_qtensorc(Tl, Tr, errst)
type(qtensorc), intent(inout) :: Tl, Tr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary tensor for R-matrix
type(qtensorc) :: Tmp
!if(present(errst)) errst = 0
call qr(Tl, Tmp, [1, 2], [3], errst=errst)
!if(prop_error('gaugesite_qr_qtensorc: qr failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tr, [2], [1], errst=errst)
!if(prop_error('gaugesite_qr_qtensorc: contr failed', &
! errst=errst)) return
call destroy(Tmp)
end subroutine gaugesite_qr_qtensorc
"""
return
[docs]def gaugesite_rq_qtensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift gauge for two tensors to the left with a RQ-decompistion.
**Arguments**
Tl : TYPE(qtensorc), inout
On exit, this tensor is the new orhtogonality center.
Tr : TYPE(qtensorc), inout
Run RQ decomposition on first index vs the other ones.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_rq_qtensorc(Tl, Tr, errst)
type(qtensorc), intent(inout) :: Tl, Tr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary tensor for R-matrix
type(qtensorc) :: Tmp
!if(present(errst)) errst = 0
call rq(Tr, Tmp, [1], [2, 3], errst=errst)
!if(prop_error('gaugesite_rq_qtensorc: rq failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tl, [1], [3], errst=errst)
!if(prop_error('gaugesite_rq_qtensorc: contr failed', &
! errst=errst)) return
call destroy(Tmp)
end subroutine gaugesite_rq_qtensorc
"""
return
[docs]def gaugesite_rsvd_tensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift the gauge from the left site to the right running
an SVD.
**Arguments**
Tl : TYPE(tensor), inout
SVD decompose this tensor between the last index and the
other ones.
Lamb : TYPE(tensor), inout
Contains the singular values on exit.
Tr : TYPE(tensor), inout
On exit, this tensor is the new orthogonality center.
haslambda : LOGICAL, inout
Flag if singular values are already allocated.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_rsvd_tensor(Tl, Lamb, Tr, haslambda, &
trunc, ncut, errst)
type(tensor), intent(inout) :: Tl, Tr
type(tensor), intent(inout) :: Lamb
logical, intent(inout) :: haslambda
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors for split and contractions
type(tensor) :: Tmp, Tl2, Tr2
!if(present(errst)) errst = 0
if(haslambda) call destroy(Lamb)
haslambda = .true.
call split(Tl2, Lamb, Tmp, Tl, [1, 2], [3], multlr=1, trunc=trunc, &
ncut=ncut, method='Y', errst=errst)
!if(prop_error('gaugesite_rsvd_tensor: split failed', &
! errst=errst)) return
call destroy(Tl)
call pointto(Tl, Tl2)
!call destroy(Tl2)
call contr(Tr2, Tmp, Tr, [2], [1], errst=errst)
!if(prop_error('gaugesite_rsvd_tensor: contr failed', &
! errst=errst)) return
call destroy(Tr)
call pointto(Tr, Tr2)
!call destroy(Tr2)
call destroy(Tmp)
end subroutine gaugesite_rsvd_tensor
"""
return
[docs]def gaugesite_lsvd_tensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift the gauge from the right site to the left running
an SVD.
**Arguments**
Tl : TYPE(tensor), inout
This tensor will be the new orthogonality center on exit.
Lamb : TYPE(tensor), inout
Contains the singular values on exit.
Tr : TYPE(tensor), inout
SVD decompose this tensor between the first index and
the other ones.
haslambda : LOGICAL, inout
Flag if singular values are already allocated.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_lsvd_tensor(Tl, Lamb, Tr, haslambda, &
trunc, ncut, errst)
type(tensor), intent(inout) :: Tl, Tr
type(tensor), intent(inout) :: Lamb
logical, intent(inout) :: haslambda
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors for split and contractions
type(tensor) :: Tmp, Tl2, Tr2
!if(present(errst)) errst = 0
if(haslambda) call destroy(Lamb)
haslambda = .true.
call split(Tmp, Lamb, Tr2, Tr, [1], [2, 3], multlr=-1, trunc=trunc, &
ncut=ncut, method='Y', errst=errst)
!if(prop_error('gaugesite_lsvd_tensor: split failed', &
! errst=errst)) return
call destroy(Tr)
call pointto(Tr, Tr2)
!call destroy(Tr2)
call contr(Tl2, Tl, Tmp, [3], [1], errst=errst)
!if(prop_error('gaugesite_lsvd_tensor: contr failed', &
! errst=errst)) return
call destroy(Tl)
call pointto(Tl, Tl2)
!call destroy(Tl2)
call destroy(Tmp)
end subroutine gaugesite_lsvd_tensor
"""
return
[docs]def gaugesite_rsvd_tensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift the gauge from the left site to the right running
an SVD.
**Arguments**
Tl : TYPE(tensorc), inout
SVD decompose this tensor between the last index and the
other ones.
Lamb : TYPE(tensor), inout
Contains the singular values on exit.
Tr : TYPE(tensorc), inout
On exit, this tensor is the new orthogonality center.
haslambda : LOGICAL, inout
Flag if singular values are already allocated.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_rsvd_tensorc(Tl, Lamb, Tr, haslambda, &
trunc, ncut, errst)
type(tensorc), intent(inout) :: Tl, Tr
type(tensor), intent(inout) :: Lamb
logical, intent(inout) :: haslambda
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors for split and contractions
type(tensorc) :: Tmp, Tl2, Tr2
!if(present(errst)) errst = 0
if(haslambda) call destroy(Lamb)
haslambda = .true.
call split(Tl2, Lamb, Tmp, Tl, [1, 2], [3], multlr=1, trunc=trunc, &
ncut=ncut, method='Y', errst=errst)
!if(prop_error('gaugesite_rsvd_tensorc: split failed', &
! errst=errst)) return
call destroy(Tl)
call pointto(Tl, Tl2)
!call destroy(Tl2)
call contr(Tr2, Tmp, Tr, [2], [1], errst=errst)
!if(prop_error('gaugesite_rsvd_tensorc: contr failed', &
! errst=errst)) return
call destroy(Tr)
call pointto(Tr, Tr2)
!call destroy(Tr2)
call destroy(Tmp)
end subroutine gaugesite_rsvd_tensorc
"""
return
[docs]def gaugesite_lsvd_tensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift the gauge from the right site to the left running
an SVD.
**Arguments**
Tl : TYPE(tensorc), inout
This tensor will be the new orthogonality center on exit.
Lamb : TYPE(tensor), inout
Contains the singular values on exit.
Tr : TYPE(tensorc), inout
SVD decompose this tensor between the first index and
the other ones.
haslambda : LOGICAL, inout
Flag if singular values are already allocated.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_lsvd_tensorc(Tl, Lamb, Tr, haslambda, &
trunc, ncut, errst)
type(tensorc), intent(inout) :: Tl, Tr
type(tensor), intent(inout) :: Lamb
logical, intent(inout) :: haslambda
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors for split and contractions
type(tensorc) :: Tmp, Tl2, Tr2
!if(present(errst)) errst = 0
if(haslambda) call destroy(Lamb)
haslambda = .true.
call split(Tmp, Lamb, Tr2, Tr, [1], [2, 3], multlr=-1, trunc=trunc, &
ncut=ncut, method='Y', errst=errst)
!if(prop_error('gaugesite_lsvd_tensorc: split failed', &
! errst=errst)) return
call destroy(Tr)
call pointto(Tr, Tr2)
!call destroy(Tr2)
call contr(Tl2, Tl, Tmp, [3], [1], errst=errst)
!if(prop_error('gaugesite_lsvd_tensorc: contr failed', &
! errst=errst)) return
call destroy(Tl)
call pointto(Tl, Tl2)
!call destroy(Tl2)
call destroy(Tmp)
end subroutine gaugesite_lsvd_tensorc
"""
return
[docs]def gaugesite_rsvd_qtensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift the gauge from the left site to the right running
an SVD.
**Arguments**
Tl : TYPE(qtensor), inout
SVD decompose this tensor between the last index and the
other ones.
Lamb : TYPE(qtensor), inout
Contains the singular values on exit.
Tr : TYPE(qtensor), inout
On exit, this tensor is the new orthogonality center.
haslambda : LOGICAL, inout
Flag if singular values are already allocated.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_rsvd_qtensor(Tl, Lamb, Tr, haslambda, &
trunc, ncut, errst)
type(qtensor), intent(inout) :: Tl, Tr
type(qtensor), intent(inout) :: Lamb
logical, intent(inout) :: haslambda
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors for split and contractions
type(qtensor) :: Tmp, Tl2, Tr2
!if(present(errst)) errst = 0
if(haslambda) call destroy(Lamb)
haslambda = .true.
call split(Tl2, Lamb, Tmp, Tl, [1, 2], [3], multlr=1, trunc=trunc, &
ncut=ncut, method='Y', errst=errst)
!if(prop_error('gaugesite_rsvd_qtensor: split failed', &
! errst=errst)) return
call destroy(Tl)
call pointto(Tl, Tl2)
!call destroy(Tl2)
call contr(Tr2, Tmp, Tr, [2], [1], errst=errst)
!if(prop_error('gaugesite_rsvd_qtensor: contr failed', &
! errst=errst)) return
call destroy(Tr)
call pointto(Tr, Tr2)
!call destroy(Tr2)
call destroy(Tmp)
end subroutine gaugesite_rsvd_qtensor
"""
return
[docs]def gaugesite_lsvd_qtensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift the gauge from the right site to the left running
an SVD.
**Arguments**
Tl : TYPE(qtensor), inout
This tensor will be the new orthogonality center on exit.
Lamb : TYPE(qtensor), inout
Contains the singular values on exit.
Tr : TYPE(qtensor), inout
SVD decompose this tensor between the first index and
the other ones.
haslambda : LOGICAL, inout
Flag if singular values are already allocated.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_lsvd_qtensor(Tl, Lamb, Tr, haslambda, &
trunc, ncut, errst)
type(qtensor), intent(inout) :: Tl, Tr
type(qtensor), intent(inout) :: Lamb
logical, intent(inout) :: haslambda
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors for split and contractions
type(qtensor) :: Tmp, Tl2, Tr2
!if(present(errst)) errst = 0
if(haslambda) call destroy(Lamb)
haslambda = .true.
call split(Tmp, Lamb, Tr2, Tr, [1], [2, 3], multlr=-1, trunc=trunc, &
ncut=ncut, method='Y', errst=errst)
!if(prop_error('gaugesite_lsvd_qtensor: split failed', &
! errst=errst)) return
call destroy(Tr)
call pointto(Tr, Tr2)
!call destroy(Tr2)
call contr(Tl2, Tl, Tmp, [3], [1], errst=errst)
!if(prop_error('gaugesite_lsvd_qtensor: contr failed', &
! errst=errst)) return
call destroy(Tl)
call pointto(Tl, Tl2)
!call destroy(Tl2)
call destroy(Tmp)
end subroutine gaugesite_lsvd_qtensor
"""
return
[docs]def gaugesite_rsvd_qtensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift the gauge from the left site to the right running
an SVD.
**Arguments**
Tl : TYPE(qtensorc), inout
SVD decompose this tensor between the last index and the
other ones.
Lamb : TYPE(qtensor), inout
Contains the singular values on exit.
Tr : TYPE(qtensorc), inout
On exit, this tensor is the new orthogonality center.
haslambda : LOGICAL, inout
Flag if singular values are already allocated.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_rsvd_qtensorc(Tl, Lamb, Tr, haslambda, &
trunc, ncut, errst)
type(qtensorc), intent(inout) :: Tl, Tr
type(qtensor), intent(inout) :: Lamb
logical, intent(inout) :: haslambda
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors for split and contractions
type(qtensorc) :: Tmp, Tl2, Tr2
!if(present(errst)) errst = 0
if(haslambda) call destroy(Lamb)
haslambda = .true.
call split(Tl2, Lamb, Tmp, Tl, [1, 2], [3], multlr=1, trunc=trunc, &
ncut=ncut, method='Y', errst=errst)
!if(prop_error('gaugesite_rsvd_qtensorc: split failed', &
! errst=errst)) return
call destroy(Tl)
call pointto(Tl, Tl2)
!call destroy(Tl2)
call contr(Tr2, Tmp, Tr, [2], [1], errst=errst)
!if(prop_error('gaugesite_rsvd_qtensorc: contr failed', &
! errst=errst)) return
call destroy(Tr)
call pointto(Tr, Tr2)
!call destroy(Tr2)
call destroy(Tmp)
end subroutine gaugesite_rsvd_qtensorc
"""
return
[docs]def gaugesite_lsvd_qtensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Shift the gauge from the right site to the left running
an SVD.
**Arguments**
Tl : TYPE(qtensorc), inout
This tensor will be the new orthogonality center on exit.
Lamb : TYPE(qtensor), inout
Contains the singular values on exit.
Tr : TYPE(qtensorc), inout
SVD decompose this tensor between the first index and
the other ones.
haslambda : LOGICAL, inout
Flag if singular values are already allocated.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaugesite_lsvd_qtensorc(Tl, Lamb, Tr, haslambda, &
trunc, ncut, errst)
type(qtensorc), intent(inout) :: Tl, Tr
type(qtensor), intent(inout) :: Lamb
logical, intent(inout) :: haslambda
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors for split and contractions
type(qtensorc) :: Tmp, Tl2, Tr2
!if(present(errst)) errst = 0
if(haslambda) call destroy(Lamb)
haslambda = .true.
call split(Tmp, Lamb, Tr2, Tr, [1], [2, 3], multlr=-1, trunc=trunc, &
ncut=ncut, method='Y', errst=errst)
!if(prop_error('gaugesite_lsvd_qtensorc: split failed', &
! errst=errst)) return
call destroy(Tr)
call pointto(Tr, Tr2)
!call destroy(Tr2)
call contr(Tl2, Tl, Tmp, [3], [1], errst=errst)
!if(prop_error('gaugesite_lsvd_qtensorc: contr failed', &
! errst=errst)) return
call destroy(Tl)
call pointto(Tl, Tl2)
!call destroy(Tl2)
call destroy(Tmp)
end subroutine gaugesite_lsvd_qtensorc
"""
return
[docs]def maxchi_mps():
"""
fortran-function - July 2017 (dj, updated)
Get the maximal bond dimension of the MPS.
**Arguments**
Psi : TYPE(mps), in
Get the maximal bond dimension present in the MPS
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxchi_mps(Psi) result(chi)
type(mps), intent(in) :: Psi
integer :: chi
! Local variables
! ---------------
! for looping
integer :: ii
chi = 0
do ii = 1, Psi%ll
chi = max(chi, maxlineardim(Psi%Aa(ii), idx=[1, 3]))
end do
end function maxchi_mps
"""
return
[docs]def maxchi_mpsc():
"""
fortran-function - July 2017 (dj, updated)
Get the maximal bond dimension of the MPS.
**Arguments**
Psi : TYPE(mpsc), in
Get the maximal bond dimension present in the MPS
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxchi_mpsc(Psi) result(chi)
type(mpsc), intent(in) :: Psi
integer :: chi
! Local variables
! ---------------
! for looping
integer :: ii
chi = 0
do ii = 1, Psi%ll
chi = max(chi, maxlineardim(Psi%Aa(ii), idx=[1, 3]))
end do
end function maxchi_mpsc
"""
return
[docs]def maxchi_qmps():
"""
fortran-function - July 2017 (dj, updated)
Get the maximal bond dimension of the MPS.
**Arguments**
Psi : TYPE(qmps), in
Get the maximal bond dimension present in the MPS
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxchi_qmps(Psi) result(chi)
type(qmps), intent(in) :: Psi
integer :: chi
! Local variables
! ---------------
! for looping
integer :: ii
chi = 0
do ii = 1, Psi%ll
chi = max(chi, maxlineardim(Psi%Aa(ii), idx=[1, 3]))
end do
end function maxchi_qmps
"""
return
[docs]def maxchi_qmpsc():
"""
fortran-function - July 2017 (dj, updated)
Get the maximal bond dimension of the MPS.
**Arguments**
Psi : TYPE(qmpsc), in
Get the maximal bond dimension present in the MPS
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxchi_qmpsc(Psi) result(chi)
type(qmpsc), intent(in) :: Psi
integer :: chi
! Local variables
! ---------------
! for looping
integer :: ii
chi = 0
do ii = 1, Psi%ll
chi = max(chi, maxlineardim(Psi%Aa(ii), idx=[1, 3]))
end do
end function maxchi_qmpsc
"""
return
[docs]def maxkappa_mps():
"""
fortran-function - September 2017 (dj)
Get the maximal bond dimension to conjugate tensor of MPS.
MPS is a pure state, therefore always 1.
**Arguments**
Psi : TYPE(mps), in
Maximal bond dimension kappa is always 1 for a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxkappa_mps(Psi) result(kappa)
type(mps), intent(in) :: Psi
integer :: kappa
! No local variables
! ------------------
kappa = 1
end function maxkappa_mps
"""
return
[docs]def maxkappa_mpsc():
"""
fortran-function - September 2017 (dj)
Get the maximal bond dimension to conjugate tensor of MPS.
MPS is a pure state, therefore always 1.
**Arguments**
Psi : TYPE(mpsc), in
Maximal bond dimension kappa is always 1 for a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxkappa_mpsc(Psi) result(kappa)
type(mpsc), intent(in) :: Psi
integer :: kappa
! No local variables
! ------------------
kappa = 1
end function maxkappa_mpsc
"""
return
[docs]def maxkappa_qmps():
"""
fortran-function - September 2017 (dj)
Get the maximal bond dimension to conjugate tensor of MPS.
MPS is a pure state, therefore always 1.
**Arguments**
Psi : TYPE(qmps), in
Maximal bond dimension kappa is always 1 for a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxkappa_qmps(Psi) result(kappa)
type(qmps), intent(in) :: Psi
integer :: kappa
! No local variables
! ------------------
kappa = 1
end function maxkappa_qmps
"""
return
[docs]def maxkappa_qmpsc():
"""
fortran-function - September 2017 (dj)
Get the maximal bond dimension to conjugate tensor of MPS.
MPS is a pure state, therefore always 1.
**Arguments**
Psi : TYPE(qmpsc), in
Maximal bond dimension kappa is always 1 for a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxkappa_qmpsc(Psi) result(kappa)
type(qmpsc), intent(in) :: Psi
integer :: kappa
! No local variables
! ------------------
kappa = 1
end function maxkappa_qmpsc
"""
return
[docs]def mpo_dot_psi_tensor_tensor():
"""
fortran-subroutine - April 2016 (dj)
Compute :math:`| \phi \\rangle = H | \psi \\rangle`.
**Arguments**
Phi : TYPE(FOURtensor), out
On exit it contains :math:`H | \psi \\rangle`.
Lc : TYPE(tensorlist), in
Contains the contraction of Psi with H left of the sites considered
in this subroutine.
Wl : TYPE(tensor), in
The MPO-matrix for the left of the two sites.
Wr : TYPE(tensor), in
The MPO-matrix for the right of the two sites.
Rc : TYPE(tensorlist), in
Contains the contraction of Psi with H right of the sites considered
in this subroutine.
Psil : TYPE(tensor), in
Left site of the two sites considered in Psi.
Psir : TYPE(tensor), in
Right site of the two sites considered in Psi.
**Details**
(template defined in MPSOps_include_transfer.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_tensor_tensor(Phi, Lc, Wl, Wr, Rc, &
Psil, Psir, leftmost, &
rightmost, errst)
type(tensor), intent(inout) :: Phi
type(tensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_tensor), intent(inout) :: Wl, Wr
type(tensor), intent(inout) :: Psil, Psir
logical, intent(in) :: leftmost, rightmost
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrices
integer :: k1, k2, k3
! Result of contractions Psil-Lc / Psir-Rc
type(tensor), dimension(:), allocatable :: Fl(:), Fr(:)
! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
type(tensor), dimension(:), allocatable :: El(:), Er(:)
! temporary tensor
type(tensor) :: Tmp
! Get bond dimensions MPO-matrices
k1 = Wl%rbd
k2 = Wl%cbd
k3 = Wr%cbd
allocate(Fl(k1), Fr(k3), El(k2), Er(k2))
! 1) Contractions on left tensor
! ------------------------------
!
! a) Contract left transfer matrix with Psil.
! b) MPO matrix for the left site to result of previous step.
if(leftmost) then
! Initialize
do ii = 1, k2
call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
! 'contractmporone failed.', &
! errst=errst)) return
end do
else
! Propagate
do ii = 1, k1
call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
! 'contr (1) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
! 'contractmpor failed.', &
! errst=errst)) return
end do
do ii = 1, k2
call destroy(Fl(ii))
end do
end if
! 2) Contractions on right tensor
! -------------------------------
!
! a) Contract right transfer matrix with Psir.
! b) MPO matrix for the right site to result of previous step.
if(rightmost) then
! Initialize
do ii = 1, k2
call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
! 'mcontr (1) failed.', errst=errst)) return
!call copy(Tmp, Psir)
!call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
! errst=errst)
!!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
!! 'contr (2) failed.', errst=errst)) return
!call destroy(Tmp)
end do
else
! Propagate
do ii = 1, k3
call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
! 'contr (3) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
! 'contractmpol failed.', &
! errst=errst)) return
end do
do ii = 1, k3
call destroy(Fr(ii))
end do
end if
deallocate(Fl, Fr)
! 3) Contract the two sides together
! ----------------------------------
! First index
call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
!call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
! 'contr (4) failed.', errst=errst)) return
call destroy(El(1))
call destroy(Er(1))
! Add remaining indices
do ii = 2, k2
call contr(Phi, El(ii), Er(ii), [3], [1], beta=done, errst=errst)
!call contr(Phi, El(ii), Er(ii), [2], [2], beta=done, errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
! 'contr (5) failed.', errst=errst)) return
call destroy(El(ii))
call destroy(Er(ii))
end do
deallocate(El, Er)
end subroutine mpo_dot_psi_tensor_tensor
"""
return
[docs]def mpo_dot_psi_tensor_tensorc():
"""
fortran-subroutine - April 2016 (dj)
Compute :math:`| \phi \\rangle = H | \psi \\rangle`.
**Arguments**
Phi : TYPE(FOURtensorc), out
On exit it contains :math:`H | \psi \\rangle`.
Lc : TYPE(tensorlistc), in
Contains the contraction of Psi with H left of the sites considered
in this subroutine.
Wl : TYPE(tensor), in
The MPO-matrix for the left of the two sites.
Wr : TYPE(tensor), in
The MPO-matrix for the right of the two sites.
Rc : TYPE(tensorlistc), in
Contains the contraction of Psi with H right of the sites considered
in this subroutine.
Psil : TYPE(tensorc), in
Left site of the two sites considered in Psi.
Psir : TYPE(tensorc), in
Right site of the two sites considered in Psi.
**Details**
(template defined in MPSOps_include_transfer.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_tensor_tensorc(Phi, Lc, Wl, Wr, Rc, &
Psil, Psir, leftmost, &
rightmost, errst)
type(tensorc), intent(inout) :: Phi
type(tensorlistc), intent(inout) :: Lc, Rc
type(sr_matrix_tensor), intent(inout) :: Wl, Wr
type(tensorc), intent(inout) :: Psil, Psir
logical, intent(in) :: leftmost, rightmost
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrices
integer :: k1, k2, k3
! Result of contractions Psil-Lc / Psir-Rc
type(tensorc), dimension(:), allocatable :: Fl(:), Fr(:)
! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
type(tensorc), dimension(:), allocatable :: El(:), Er(:)
! temporary tensor
type(tensorc) :: Tmp
! Get bond dimensions MPO-matrices
k1 = Wl%rbd
k2 = Wl%cbd
k3 = Wr%cbd
allocate(Fl(k1), Fr(k3), El(k2), Er(k2))
! 1) Contractions on left tensor
! ------------------------------
!
! a) Contract left transfer matrix with Psil.
! b) MPO matrix for the left site to result of previous step.
if(leftmost) then
! Initialize
do ii = 1, k2
call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
! 'contractmporone failed.', &
! errst=errst)) return
end do
else
! Propagate
do ii = 1, k1
call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
! 'contr (1) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
! 'contractmpor failed.', &
! errst=errst)) return
end do
do ii = 1, k2
call destroy(Fl(ii))
end do
end if
! 2) Contractions on right tensor
! -------------------------------
!
! a) Contract right transfer matrix with Psir.
! b) MPO matrix for the right site to result of previous step.
if(rightmost) then
! Initialize
do ii = 1, k2
call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
! 'mcontr (1) failed.', errst=errst)) return
!call copy(Tmp, Psir)
!call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
! errst=errst)
!!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
!! 'contr (2) failed.', errst=errst)) return
!call destroy(Tmp)
end do
else
! Propagate
do ii = 1, k3
call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
! 'contr (3) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
! 'contractmpol failed.', &
! errst=errst)) return
end do
do ii = 1, k3
call destroy(Fr(ii))
end do
end if
deallocate(Fl, Fr)
! 3) Contract the two sides together
! ----------------------------------
! First index
call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
!call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
! 'contr (4) failed.', errst=errst)) return
call destroy(El(1))
call destroy(Er(1))
! Add remaining indices
do ii = 2, k2
call contr(Phi, El(ii), Er(ii), [3], [1], beta=zone, errst=errst)
!call contr(Phi, El(ii), Er(ii), [2], [2], beta=zone, errst=errst)
!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
! 'contr (5) failed.', errst=errst)) return
call destroy(El(ii))
call destroy(Er(ii))
end do
deallocate(El, Er)
end subroutine mpo_dot_psi_tensor_tensorc
"""
return
[docs]def mpo_dot_psi_tensorc_tensorc():
"""
fortran-subroutine - April 2016 (dj)
Compute :math:`| \phi \\rangle = H | \psi \\rangle`.
**Arguments**
Phi : TYPE(FOURtensorc), out
On exit it contains :math:`H | \psi \\rangle`.
Lc : TYPE(tensorlistc), in
Contains the contraction of Psi with H left of the sites considered
in this subroutine.
Wl : TYPE(tensorc), in
The MPO-matrix for the left of the two sites.
Wr : TYPE(tensorc), in
The MPO-matrix for the right of the two sites.
Rc : TYPE(tensorlistc), in
Contains the contraction of Psi with H right of the sites considered
in this subroutine.
Psil : TYPE(tensorc), in
Left site of the two sites considered in Psi.
Psir : TYPE(tensorc), in
Right site of the two sites considered in Psi.
**Details**
(template defined in MPSOps_include_transfer.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_tensorc_tensorc(Phi, Lc, Wl, Wr, Rc, &
Psil, Psir, leftmost, &
rightmost, errst)
type(tensorc), intent(inout) :: Phi
type(tensorlistc), intent(inout) :: Lc, Rc
type(sr_matrix_tensorc), intent(inout) :: Wl, Wr
type(tensorc), intent(inout) :: Psil, Psir
logical, intent(in) :: leftmost, rightmost
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrices
integer :: k1, k2, k3
! Result of contractions Psil-Lc / Psir-Rc
type(tensorc), dimension(:), allocatable :: Fl(:), Fr(:)
! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
type(tensorc), dimension(:), allocatable :: El(:), Er(:)
! temporary tensor
type(tensorc) :: Tmp
! Get bond dimensions MPO-matrices
k1 = Wl%rbd
k2 = Wl%cbd
k3 = Wr%cbd
allocate(Fl(k1), Fr(k3), El(k2), Er(k2))
! 1) Contractions on left tensor
! ------------------------------
!
! a) Contract left transfer matrix with Psil.
! b) MPO matrix for the left site to result of previous step.
if(leftmost) then
! Initialize
do ii = 1, k2
call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
! 'contractmporone failed.', &
! errst=errst)) return
end do
else
! Propagate
do ii = 1, k1
call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
! 'contr (1) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
! 'contractmpor failed.', &
! errst=errst)) return
end do
do ii = 1, k2
call destroy(Fl(ii))
end do
end if
! 2) Contractions on right tensor
! -------------------------------
!
! a) Contract right transfer matrix with Psir.
! b) MPO matrix for the right site to result of previous step.
if(rightmost) then
! Initialize
do ii = 1, k2
call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
errst=errst)
!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
! 'mcontr (1) failed.', errst=errst)) return
!call copy(Tmp, Psir)
!call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
! errst=errst)
!!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
!! 'contr (2) failed.', errst=errst)) return
!call destroy(Tmp)
end do
else
! Propagate
do ii = 1, k3
call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
! 'contr (3) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
! 'contractmpol failed.', &
! errst=errst)) return
end do
do ii = 1, k3
call destroy(Fr(ii))
end do
end if
deallocate(Fl, Fr)
! 3) Contract the two sides together
! ----------------------------------
! First index
call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
!call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
! 'contr (4) failed.', errst=errst)) return
call destroy(El(1))
call destroy(Er(1))
! Add remaining indices
do ii = 2, k2
call contr(Phi, El(ii), Er(ii), [3], [1], beta=zone, errst=errst)
!call contr(Phi, El(ii), Er(ii), [2], [2], beta=zone, errst=errst)
!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
! 'contr (5) failed.', errst=errst)) return
call destroy(El(ii))
call destroy(Er(ii))
end do
deallocate(El, Er)
end subroutine mpo_dot_psi_tensorc_tensorc
"""
return
[docs]def mpo_dot_psi_qtensor_qtensor():
"""
fortran-subroutine - April 2016 (dj)
Compute :math:`| \phi \\rangle = H | \psi \\rangle`.
**Arguments**
Phi : TYPE(FOURqtensor), out
On exit it contains :math:`H | \psi \\rangle`.
Lc : TYPE(qtensorlist), in
Contains the contraction of Psi with H left of the sites considered
in this subroutine.
Wl : TYPE(qtensor), in
The MPO-matrix for the left of the two sites.
Wr : TYPE(qtensor), in
The MPO-matrix for the right of the two sites.
Rc : TYPE(qtensorlist), in
Contains the contraction of Psi with H right of the sites considered
in this subroutine.
Psil : TYPE(qtensor), in
Left site of the two sites considered in Psi.
Psir : TYPE(qtensor), in
Right site of the two sites considered in Psi.
**Details**
(template defined in MPSOps_include_transfer.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_qtensor_qtensor(Phi, Lc, Wl, Wr, Rc, &
Psil, Psir, leftmost, &
rightmost, errst)
type(qtensor), intent(inout) :: Phi
type(qtensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensor), intent(inout) :: Wl, Wr
type(qtensor), intent(inout) :: Psil, Psir
logical, intent(in) :: leftmost, rightmost
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrices
integer :: k1, k2, k3
! Result of contractions Psil-Lc / Psir-Rc
type(qtensor), dimension(:), allocatable :: Fl(:), Fr(:)
! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
type(qtensor), dimension(:), allocatable :: El(:), Er(:)
! temporary tensor
type(qtensor) :: Tmp
! Get bond dimensions MPO-matrices
k1 = Wl%rbd
k2 = Wl%cbd
k3 = Wr%cbd
allocate(Fl(k1), Fr(k3), El(k2), Er(k2))
! 1) Contractions on left tensor
! ------------------------------
!
! a) Contract left transfer matrix with Psil.
! b) MPO matrix for the left site to result of previous step.
if(leftmost) then
! Initialize
do ii = 1, k2
call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
! 'contractmporone failed.', &
! errst=errst)) return
end do
else
! Propagate
do ii = 1, k1
call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
! 'contr (1) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
! 'contractmpor failed.', &
! errst=errst)) return
end do
do ii = 1, k2
call destroy(Fl(ii))
end do
end if
! 2) Contractions on right tensor
! -------------------------------
!
! a) Contract right transfer matrix with Psir.
! b) MPO matrix for the right site to result of previous step.
if(rightmost) then
! Initialize
do ii = 1, k2
call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
! 'mcontr (1) failed.', errst=errst)) return
!call copy(Tmp, Psir)
!call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
! errst=errst)
!!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
!! 'contr (2) failed.', errst=errst)) return
!call destroy(Tmp)
end do
else
! Propagate
do ii = 1, k3
call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
! 'contr (3) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
! 'contractmpol failed.', &
! errst=errst)) return
end do
do ii = 1, k3
call destroy(Fr(ii))
end do
end if
deallocate(Fl, Fr)
! 3) Contract the two sides together
! ----------------------------------
! First index
call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
!call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
! 'contr (4) failed.', errst=errst)) return
call destroy(El(1))
call destroy(Er(1))
! Add remaining indices
do ii = 2, k2
call contr(Phi, El(ii), Er(ii), [3], [1], beta=done, errst=errst)
!call contr(Phi, El(ii), Er(ii), [2], [2], beta=done, errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
! 'contr (5) failed.', errst=errst)) return
call destroy(El(ii))
call destroy(Er(ii))
end do
deallocate(El, Er)
end subroutine mpo_dot_psi_qtensor_qtensor
"""
return
[docs]def mpo_dot_psi_qtensor_qtensorc():
"""
fortran-subroutine - April 2016 (dj)
Compute :math:`| \phi \\rangle = H | \psi \\rangle`.
**Arguments**
Phi : TYPE(FOURqtensorc), out
On exit it contains :math:`H | \psi \\rangle`.
Lc : TYPE(qtensorclist), in
Contains the contraction of Psi with H left of the sites considered
in this subroutine.
Wl : TYPE(qtensor), in
The MPO-matrix for the left of the two sites.
Wr : TYPE(qtensor), in
The MPO-matrix for the right of the two sites.
Rc : TYPE(qtensorclist), in
Contains the contraction of Psi with H right of the sites considered
in this subroutine.
Psil : TYPE(qtensorc), in
Left site of the two sites considered in Psi.
Psir : TYPE(qtensorc), in
Right site of the two sites considered in Psi.
**Details**
(template defined in MPSOps_include_transfer.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_qtensor_qtensorc(Phi, Lc, Wl, Wr, Rc, &
Psil, Psir, leftmost, &
rightmost, errst)
type(qtensorc), intent(inout) :: Phi
type(qtensorclist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensor), intent(inout) :: Wl, Wr
type(qtensorc), intent(inout) :: Psil, Psir
logical, intent(in) :: leftmost, rightmost
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrices
integer :: k1, k2, k3
! Result of contractions Psil-Lc / Psir-Rc
type(qtensorc), dimension(:), allocatable :: Fl(:), Fr(:)
! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
type(qtensorc), dimension(:), allocatable :: El(:), Er(:)
! temporary tensor
type(qtensorc) :: Tmp
! Get bond dimensions MPO-matrices
k1 = Wl%rbd
k2 = Wl%cbd
k3 = Wr%cbd
allocate(Fl(k1), Fr(k3), El(k2), Er(k2))
! 1) Contractions on left tensor
! ------------------------------
!
! a) Contract left transfer matrix with Psil.
! b) MPO matrix for the left site to result of previous step.
if(leftmost) then
! Initialize
do ii = 1, k2
call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
! 'contractmporone failed.', &
! errst=errst)) return
end do
else
! Propagate
do ii = 1, k1
call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
! 'contr (1) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
! 'contractmpor failed.', &
! errst=errst)) return
end do
do ii = 1, k2
call destroy(Fl(ii))
end do
end if
! 2) Contractions on right tensor
! -------------------------------
!
! a) Contract right transfer matrix with Psir.
! b) MPO matrix for the right site to result of previous step.
if(rightmost) then
! Initialize
do ii = 1, k2
call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
! 'mcontr (1) failed.', errst=errst)) return
!call copy(Tmp, Psir)
!call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
! errst=errst)
!!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
!! 'contr (2) failed.', errst=errst)) return
!call destroy(Tmp)
end do
else
! Propagate
do ii = 1, k3
call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
! 'contr (3) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
! 'contractmpol failed.', &
! errst=errst)) return
end do
do ii = 1, k3
call destroy(Fr(ii))
end do
end if
deallocate(Fl, Fr)
! 3) Contract the two sides together
! ----------------------------------
! First index
call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
!call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
! 'contr (4) failed.', errst=errst)) return
call destroy(El(1))
call destroy(Er(1))
! Add remaining indices
do ii = 2, k2
call contr(Phi, El(ii), Er(ii), [3], [1], beta=zone, errst=errst)
!call contr(Phi, El(ii), Er(ii), [2], [2], beta=zone, errst=errst)
!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
! 'contr (5) failed.', errst=errst)) return
call destroy(El(ii))
call destroy(Er(ii))
end do
deallocate(El, Er)
end subroutine mpo_dot_psi_qtensor_qtensorc
"""
return
[docs]def mpo_dot_psi_qtensorc_qtensorc():
"""
fortran-subroutine - April 2016 (dj)
Compute :math:`| \phi \\rangle = H | \psi \\rangle`.
**Arguments**
Phi : TYPE(FOURqtensorc), out
On exit it contains :math:`H | \psi \\rangle`.
Lc : TYPE(qtensorclist), in
Contains the contraction of Psi with H left of the sites considered
in this subroutine.
Wl : TYPE(qtensorc), in
The MPO-matrix for the left of the two sites.
Wr : TYPE(qtensorc), in
The MPO-matrix for the right of the two sites.
Rc : TYPE(qtensorclist), in
Contains the contraction of Psi with H right of the sites considered
in this subroutine.
Psil : TYPE(qtensorc), in
Left site of the two sites considered in Psi.
Psir : TYPE(qtensorc), in
Right site of the two sites considered in Psi.
**Details**
(template defined in MPSOps_include_transfer.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_qtensorc_qtensorc(Phi, Lc, Wl, Wr, Rc, &
Psil, Psir, leftmost, &
rightmost, errst)
type(qtensorc), intent(inout) :: Phi
type(qtensorclist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensorc), intent(inout) :: Wl, Wr
type(qtensorc), intent(inout) :: Psil, Psir
logical, intent(in) :: leftmost, rightmost
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrices
integer :: k1, k2, k3
! Result of contractions Psil-Lc / Psir-Rc
type(qtensorc), dimension(:), allocatable :: Fl(:), Fr(:)
! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
type(qtensorc), dimension(:), allocatable :: El(:), Er(:)
! temporary tensor
type(qtensorc) :: Tmp
! Get bond dimensions MPO-matrices
k1 = Wl%rbd
k2 = Wl%cbd
k3 = Wr%cbd
allocate(Fl(k1), Fr(k3), El(k2), Er(k2))
! 1) Contractions on left tensor
! ------------------------------
!
! a) Contract left transfer matrix with Psil.
! b) MPO matrix for the left site to result of previous step.
if(leftmost) then
! Initialize
do ii = 1, k2
call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
! 'contractmporone failed.', &
! errst=errst)) return
end do
else
! Propagate
do ii = 1, k1
call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
! 'contr (1) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
! 'contractmpor failed.', &
! errst=errst)) return
end do
do ii = 1, k2
call destroy(Fl(ii))
end do
end if
! 2) Contractions on right tensor
! -------------------------------
!
! a) Contract right transfer matrix with Psir.
! b) MPO matrix for the right site to result of previous step.
if(rightmost) then
! Initialize
do ii = 1, k2
call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
errst=errst)
!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
! 'mcontr (1) failed.', errst=errst)) return
!call copy(Tmp, Psir)
!call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
! errst=errst)
!!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
!! 'contr (2) failed.', errst=errst)) return
!call destroy(Tmp)
end do
else
! Propagate
do ii = 1, k3
call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
! 'contr (3) failed.', errst=errst)) return
end do
do ii = 1, k2
call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
! 'contractmpol failed.', &
! errst=errst)) return
end do
do ii = 1, k3
call destroy(Fr(ii))
end do
end if
deallocate(Fl, Fr)
! 3) Contract the two sides together
! ----------------------------------
! First index
call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
!call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
! 'contr (4) failed.', errst=errst)) return
call destroy(El(1))
call destroy(Er(1))
! Add remaining indices
do ii = 2, k2
call contr(Phi, El(ii), Er(ii), [3], [1], beta=zone, errst=errst)
!call contr(Phi, El(ii), Er(ii), [2], [2], beta=zone, errst=errst)
!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
! 'contr (5) failed.', errst=errst)) return
call destroy(El(ii))
call destroy(Er(ii))
end do
deallocate(El, Er)
end subroutine mpo_dot_psi_qtensorc_qtensorc
"""
return
[docs]def mpo_dot_psi_n_tensor_tensor():
"""
fortran-subroutine - June 2017 (dj)
Contract local MPO amtrices for n-sites with wave function
represented on n-sites and the left right overlap.
**Details**
Subroutine has both, a 1 site and a 2 site version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_n_tensor_tensor(Phi, Lc, Wn, Rc, Psin, &
leftmost, rightmost, beta, &
errst)
type(tensor), intent(inout) :: Phi
type(tensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_tensor), intent(inout) :: Wn
type(tensor), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
real(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimension
integer :: cbd
! rank of the tensor
integer :: rnk
! control action of contr, = or +=
real(KIND=rKind) :: beta_
! intermediate result - contract with right overlap
type(tensor), dimension(:), allocatable :: Fs
! intermediate tensor
type(tensor) :: Tens
!CHEK_if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = dzero
end if
rnk = rank(Psin)
cbd = Wn%cbd
allocate(Fs(cbd))
if(rightmost) then
! Just copy the Psin equal to contracting with the identity
call copy(Fs(1), Psin, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_tensor : '// &
! 'copy (1).', errst=errst)) return
else
! Contract the right overlap with Psi
do ii = 1, cbd
call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_tensor : '//&
! 'contr (1).', errst=errst)) return
end do
end if
if(leftmost) then
do ii = 1, Wn%rbd
! Contract the MPO matrix with Psi-Rc
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
if(beta_ == 0.0_rKind) then
call copy(Phi, Tens, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
! 'TYPE : copy (2).', errst=errst)) return
else
call gaxpy(Phi, done, Tens)
end if
call destroy(Tens)
end do
else
do ii = 1, Wn%rbd
! Contract the MPO matrix with (Psi-Rc)
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
! Contract the left overlap with (Wn-Psi-Rc)
call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_tensor : '//&
! 'contr (2).', errst=errst)) return
call destroy(Tens)
beta_ = done
end do
end if
do ii = 1, Wn%cbd
call destroy(Fs(ii))
end do
deallocate(Fs)
end subroutine mpo_dot_psi_n_tensor_tensor
"""
return
[docs]def mpo_dot_psi_n_tensor_tensorc():
"""
fortran-subroutine - June 2017 (dj)
Contract local MPO amtrices for n-sites with wave function
represented on n-sites and the left right overlap.
**Details**
Subroutine has both, a 1 site and a 2 site version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_n_tensor_tensorc(Phi, Lc, Wn, Rc, Psin, &
leftmost, rightmost, beta, &
errst)
type(tensorc), intent(inout) :: Phi
type(tensorlistc), intent(inout) :: Lc, Rc
type(sr_matrix_tensor), intent(inout) :: Wn
type(tensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
complex(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimension
integer :: cbd
! rank of the tensor
integer :: rnk
! control action of contr, = or +=
complex(KIND=rKind) :: beta_
! intermediate result - contract with right overlap
type(tensorc), dimension(:), allocatable :: Fs
! intermediate tensor
type(tensorc) :: Tens
!CHEK_if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = zzero
end if
rnk = rank(Psin)
cbd = Wn%cbd
allocate(Fs(cbd))
if(rightmost) then
! Just copy the Psin equal to contracting with the identity
call copy(Fs(1), Psin, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_tensorc : '// &
! 'copy (1).', errst=errst)) return
else
! Contract the right overlap with Psi
do ii = 1, cbd
call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_tensorc : '//&
! 'contr (1).', errst=errst)) return
end do
end if
if(leftmost) then
do ii = 1, Wn%rbd
! Contract the MPO matrix with Psi-Rc
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
if(beta_ == 0.0_rKind) then
call copy(Phi, Tens, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
! 'TYPE : copy (2).', errst=errst)) return
else
call gaxpy(Phi, zone, Tens)
end if
call destroy(Tens)
end do
else
do ii = 1, Wn%rbd
! Contract the MPO matrix with (Psi-Rc)
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
! Contract the left overlap with (Wn-Psi-Rc)
call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
errst=errst)
!if(prop_error('mpo_dot_psi_n_tensor_tensorc : '//&
! 'contr (2).', errst=errst)) return
call destroy(Tens)
beta_ = zone
end do
end if
do ii = 1, Wn%cbd
call destroy(Fs(ii))
end do
deallocate(Fs)
end subroutine mpo_dot_psi_n_tensor_tensorc
"""
return
[docs]def mpo_dot_psi_n_tensorc_tensorc():
"""
fortran-subroutine - June 2017 (dj)
Contract local MPO amtrices for n-sites with wave function
represented on n-sites and the left right overlap.
**Details**
Subroutine has both, a 1 site and a 2 site version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_n_tensorc_tensorc(Phi, Lc, Wn, Rc, Psin, &
leftmost, rightmost, beta, &
errst)
type(tensorc), intent(inout) :: Phi
type(tensorlistc), intent(inout) :: Lc, Rc
type(sr_matrix_tensorc), intent(inout) :: Wn
type(tensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
complex(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimension
integer :: cbd
! rank of the tensor
integer :: rnk
! control action of contr, = or +=
complex(KIND=rKind) :: beta_
! intermediate result - contract with right overlap
type(tensorc), dimension(:), allocatable :: Fs
! intermediate tensor
type(tensorc) :: Tens
!CHEK_if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = zzero
end if
rnk = rank(Psin)
cbd = Wn%cbd
allocate(Fs(cbd))
if(rightmost) then
! Just copy the Psin equal to contracting with the identity
call copy(Fs(1), Psin, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensorc_tensorc : '// &
! 'copy (1).', errst=errst)) return
else
! Contract the right overlap with Psi
do ii = 1, cbd
call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('mpo_dot_psi_n_tensorc_tensorc : '//&
! 'contr (1).', errst=errst)) return
end do
end if
if(leftmost) then
do ii = 1, Wn%rbd
! Contract the MPO matrix with Psi-Rc
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensorc_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
if(beta_ == 0.0_rKind) then
call copy(Phi, Tens, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensorc_TENSOR_'// &
! 'TYPE : copy (2).', errst=errst)) return
else
call gaxpy(Phi, zone, Tens)
end if
call destroy(Tens)
end do
else
do ii = 1, Wn%rbd
! Contract the MPO matrix with (Psi-Rc)
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_tensorc_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
! Contract the left overlap with (Wn-Psi-Rc)
call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
errst=errst)
!if(prop_error('mpo_dot_psi_n_tensorc_tensorc : '//&
! 'contr (2).', errst=errst)) return
call destroy(Tens)
beta_ = zone
end do
end if
do ii = 1, Wn%cbd
call destroy(Fs(ii))
end do
deallocate(Fs)
end subroutine mpo_dot_psi_n_tensorc_tensorc
"""
return
[docs]def mpo_dot_psi_n_qtensor_qtensor():
"""
fortran-subroutine - June 2017 (dj)
Contract local MPO amtrices for n-sites with wave function
represented on n-sites and the left right overlap.
**Details**
Subroutine has both, a 1 site and a 2 site version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_n_qtensor_qtensor(Phi, Lc, Wn, Rc, Psin, &
leftmost, rightmost, beta, &
errst)
type(qtensor), intent(inout) :: Phi
type(qtensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensor), intent(inout) :: Wn
type(qtensor), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
real(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimension
integer :: cbd
! rank of the tensor
integer :: rnk
! control action of contr, = or +=
real(KIND=rKind) :: beta_
! intermediate result - contract with right overlap
type(qtensor), dimension(:), allocatable :: Fs
! intermediate tensor
type(qtensor) :: Tens
!CHEK_if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = dzero
end if
rnk = rank(Psin)
cbd = Wn%cbd
allocate(Fs(cbd))
if(rightmost) then
! Just copy the Psin equal to contracting with the identity
call copy(Fs(1), Psin, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_qtensor : '// &
! 'copy (1).', errst=errst)) return
else
! Contract the right overlap with Psi
do ii = 1, cbd
call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_qtensor : '//&
! 'contr (1).', errst=errst)) return
end do
end if
if(leftmost) then
do ii = 1, Wn%rbd
! Contract the MPO matrix with Psi-Rc
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
if(beta_ == 0.0_rKind) then
call copy(Phi, Tens, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
! 'TYPE : copy (2).', errst=errst)) return
else
call gaxpy(Phi, done, Tens)
end if
call destroy(Tens)
end do
else
do ii = 1, Wn%rbd
! Contract the MPO matrix with (Psi-Rc)
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
! Contract the left overlap with (Wn-Psi-Rc)
call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_qtensor : '//&
! 'contr (2).', errst=errst)) return
call destroy(Tens)
beta_ = done
end do
end if
do ii = 1, Wn%cbd
call destroy(Fs(ii))
end do
deallocate(Fs)
end subroutine mpo_dot_psi_n_qtensor_qtensor
"""
return
[docs]def mpo_dot_psi_n_qtensor_qtensorc():
"""
fortran-subroutine - June 2017 (dj)
Contract local MPO amtrices for n-sites with wave function
represented on n-sites and the left right overlap.
**Details**
Subroutine has both, a 1 site and a 2 site version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_n_qtensor_qtensorc(Phi, Lc, Wn, Rc, Psin, &
leftmost, rightmost, beta, &
errst)
type(qtensorc), intent(inout) :: Phi
type(qtensorclist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensor), intent(inout) :: Wn
type(qtensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
complex(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimension
integer :: cbd
! rank of the tensor
integer :: rnk
! control action of contr, = or +=
complex(KIND=rKind) :: beta_
! intermediate result - contract with right overlap
type(qtensorc), dimension(:), allocatable :: Fs
! intermediate tensor
type(qtensorc) :: Tens
!CHEK_if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = zzero
end if
rnk = rank(Psin)
cbd = Wn%cbd
allocate(Fs(cbd))
if(rightmost) then
! Just copy the Psin equal to contracting with the identity
call copy(Fs(1), Psin, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_qtensorc : '// &
! 'copy (1).', errst=errst)) return
else
! Contract the right overlap with Psi
do ii = 1, cbd
call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_qtensorc : '//&
! 'contr (1).', errst=errst)) return
end do
end if
if(leftmost) then
do ii = 1, Wn%rbd
! Contract the MPO matrix with Psi-Rc
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
if(beta_ == 0.0_rKind) then
call copy(Phi, Tens, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
! 'TYPE : copy (2).', errst=errst)) return
else
call gaxpy(Phi, zone, Tens)
end if
call destroy(Tens)
end do
else
do ii = 1, Wn%rbd
! Contract the MPO matrix with (Psi-Rc)
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
! Contract the left overlap with (Wn-Psi-Rc)
call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensor_qtensorc : '//&
! 'contr (2).', errst=errst)) return
call destroy(Tens)
beta_ = zone
end do
end if
do ii = 1, Wn%cbd
call destroy(Fs(ii))
end do
deallocate(Fs)
end subroutine mpo_dot_psi_n_qtensor_qtensorc
"""
return
[docs]def mpo_dot_psi_n_qtensorc_qtensorc():
"""
fortran-subroutine - June 2017 (dj)
Contract local MPO amtrices for n-sites with wave function
represented on n-sites and the left right overlap.
**Details**
Subroutine has both, a 1 site and a 2 site version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo_dot_psi_n_qtensorc_qtensorc(Phi, Lc, Wn, Rc, Psin, &
leftmost, rightmost, beta, &
errst)
type(qtensorc), intent(inout) :: Phi
type(qtensorclist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensorc), intent(inout) :: Wn
type(qtensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
complex(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimension
integer :: cbd
! rank of the tensor
integer :: rnk
! control action of contr, = or +=
complex(KIND=rKind) :: beta_
! intermediate result - contract with right overlap
type(qtensorc), dimension(:), allocatable :: Fs
! intermediate tensor
type(qtensorc) :: Tens
!CHEK_if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = zzero
end if
rnk = rank(Psin)
cbd = Wn%cbd
allocate(Fs(cbd))
if(rightmost) then
! Just copy the Psin equal to contracting with the identity
call copy(Fs(1), Psin, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensorc_qtensorc : '// &
! 'copy (1).', errst=errst)) return
else
! Contract the right overlap with Psi
do ii = 1, cbd
call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensorc_qtensorc : '//&
! 'contr (1).', errst=errst)) return
end do
end if
if(leftmost) then
do ii = 1, Wn%rbd
! Contract the MPO matrix with Psi-Rc
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensorc_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
if(beta_ == 0.0_rKind) then
call copy(Phi, Tens, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensorc_TENSOR_'// &
! 'TYPE : copy (2).', errst=errst)) return
else
call gaxpy(Phi, zone, Tens)
end if
call destroy(Tens)
end do
else
do ii = 1, Wn%rbd
! Contract the MPO matrix with (Psi-Rc)
call contractmpol(Tens, ii, Wn, Fs, errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensorc_TENSOR_'// &
! 'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
! errst=errst)) return
!if(rnk == 3) then
! call transposed(Tens, [2, 1, 3], doperm=.true.)
!elseif(rnk == 4) then
! call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
!end if
! Contract the left overlap with (Wn-Psi-Rc)
call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
errst=errst)
!if(prop_error('mpo_dot_psi_n_qtensorc_qtensorc : '//&
! 'contr (2).', errst=errst)) return
call destroy(Tens)
beta_ = zone
end do
end if
do ii = 1, Wn%cbd
call destroy(Fs(ii))
end do
deallocate(Fs)
end subroutine mpo_dot_psi_n_qtensorc_qtensorc
"""
return
[docs]def mpo2_dot_psi_tensor_tensor():
"""
fortran-subroutine - June 2017 (dj)
Multiply two-site Hamiltonian with two-site Psi.
**Arguments**
HPsi : TYPE(tensor), inout
Contraction of 2-site Hamiltonian with 2-site Psi.
Ham : TYPE(tensor), inout
Contains the two-site Hamiltonian as rank-4 tensor.
Psi : TYPE(tensor), inout
Rank-4 tensor representing the two sites.
**Details**
This it the version building the two site Hamiltonian
first. The default scaling is :math:`d^4 \kappa + \chi^2 d^4`
and avoids any step building the actual MPO. In comparison,
contracting the MPO matrices should result in a scaling of
:math:`2 \kappa \chi^2 d^3`. For large local dimension it could
be worth implementing the contraction based on MPO matrices.
Moreover, the cost :math:`d^4 \kappa` can be done beforehand
and occurs only once for each Trotter step and site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo2_dot_psi_tensor_tensor(HPsi, Ham, Psi, errst)
type(tensor), intent(inout) :: Hpsi, Psi
type(tensor), intent(inout) :: Ham
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Copy for Psi - it will be permuted
type(tensor) :: Psic
!if(present(errst)) errst = 0
call copy(Psic, Psi, errst=errst)
!if(prop_error('mpo2_dot_psi_tensor_tensor : '//&
! 'copy failed.', errst=errst)) return
! Contract it to the tensor permout=[3, 1, 2, 4], &
call contr(Hpsi, Ham, Psic, [3, 4], [2, 3], &
errst=errst)
!if(prop_error('mpo2_dot_psi_tensor_tensor : '//&
! 'contr failed.', errst=errst)) return
call transposed(Hpsi, [3, 1, 2, 4], doperm=.true.)
call destroy(Psic)
end subroutine mpo2_dot_psi_tensor_tensor
"""
return
[docs]def mpo2_dot_psi_tensor_tensorc():
"""
fortran-subroutine - June 2017 (dj)
Multiply two-site Hamiltonian with two-site Psi.
**Arguments**
HPsi : TYPE(tensorc), inout
Contraction of 2-site Hamiltonian with 2-site Psi.
Ham : TYPE(tensor), inout
Contains the two-site Hamiltonian as rank-4 tensor.
Psi : TYPE(tensorc), inout
Rank-4 tensor representing the two sites.
**Details**
This it the version building the two site Hamiltonian
first. The default scaling is :math:`d^4 \kappa + \chi^2 d^4`
and avoids any step building the actual MPO. In comparison,
contracting the MPO matrices should result in a scaling of
:math:`2 \kappa \chi^2 d^3`. For large local dimension it could
be worth implementing the contraction based on MPO matrices.
Moreover, the cost :math:`d^4 \kappa` can be done beforehand
and occurs only once for each Trotter step and site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo2_dot_psi_tensor_tensorc(HPsi, Ham, Psi, errst)
type(tensorc), intent(inout) :: Hpsi, Psi
type(tensor), intent(inout) :: Ham
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Copy for Psi - it will be permuted
type(tensorc) :: Psic
!if(present(errst)) errst = 0
call copy(Psic, Psi, errst=errst)
!if(prop_error('mpo2_dot_psi_tensor_tensorc : '//&
! 'copy failed.', errst=errst)) return
! Contract it to the tensor permout=[3, 1, 2, 4], &
call contr(Hpsi, Ham, Psic, [3, 4], [2, 3], &
errst=errst)
!if(prop_error('mpo2_dot_psi_tensor_tensorc : '//&
! 'contr failed.', errst=errst)) return
call transposed(Hpsi, [3, 1, 2, 4], doperm=.true.)
call destroy(Psic)
end subroutine mpo2_dot_psi_tensor_tensorc
"""
return
[docs]def mpo2_dot_psi_tensorc_tensorc():
"""
fortran-subroutine - June 2017 (dj)
Multiply two-site Hamiltonian with two-site Psi.
**Arguments**
HPsi : TYPE(tensorc), inout
Contraction of 2-site Hamiltonian with 2-site Psi.
Ham : TYPE(tensorc), inout
Contains the two-site Hamiltonian as rank-4 tensor.
Psi : TYPE(tensorc), inout
Rank-4 tensor representing the two sites.
**Details**
This it the version building the two site Hamiltonian
first. The default scaling is :math:`d^4 \kappa + \chi^2 d^4`
and avoids any step building the actual MPO. In comparison,
contracting the MPO matrices should result in a scaling of
:math:`2 \kappa \chi^2 d^3`. For large local dimension it could
be worth implementing the contraction based on MPO matrices.
Moreover, the cost :math:`d^4 \kappa` can be done beforehand
and occurs only once for each Trotter step and site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo2_dot_psi_tensorc_tensorc(HPsi, Ham, Psi, errst)
type(tensorc), intent(inout) :: Hpsi, Psi
type(tensorc), intent(inout) :: Ham
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Copy for Psi - it will be permuted
type(tensorc) :: Psic
!if(present(errst)) errst = 0
call copy(Psic, Psi, errst=errst)
!if(prop_error('mpo2_dot_psi_tensorc_tensorc : '//&
! 'copy failed.', errst=errst)) return
! Contract it to the tensor permout=[3, 1, 2, 4], &
call contr(Hpsi, Ham, Psic, [3, 4], [2, 3], &
errst=errst)
!if(prop_error('mpo2_dot_psi_tensorc_tensorc : '//&
! 'contr failed.', errst=errst)) return
call transposed(Hpsi, [3, 1, 2, 4], doperm=.true.)
call destroy(Psic)
end subroutine mpo2_dot_psi_tensorc_tensorc
"""
return
[docs]def mpo2_dot_psi_qtensor_qtensor():
"""
fortran-subroutine - June 2017 (dj)
Multiply two-site Hamiltonian with two-site Psi.
**Arguments**
HPsi : TYPE(qtensor), inout
Contraction of 2-site Hamiltonian with 2-site Psi.
Ham : TYPE(qtensor), inout
Contains the two-site Hamiltonian as rank-4 tensor.
Psi : TYPE(qtensor), inout
Rank-4 tensor representing the two sites.
**Details**
This it the version building the two site Hamiltonian
first. The default scaling is :math:`d^4 \kappa + \chi^2 d^4`
and avoids any step building the actual MPO. In comparison,
contracting the MPO matrices should result in a scaling of
:math:`2 \kappa \chi^2 d^3`. For large local dimension it could
be worth implementing the contraction based on MPO matrices.
Moreover, the cost :math:`d^4 \kappa` can be done beforehand
and occurs only once for each Trotter step and site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo2_dot_psi_qtensor_qtensor(HPsi, Ham, Psi, errst)
type(qtensor), intent(inout) :: Hpsi, Psi
type(qtensor), intent(inout) :: Ham
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Copy for Psi - it will be permuted
type(qtensor) :: Psic
!if(present(errst)) errst = 0
call copy(Psic, Psi, errst=errst)
!if(prop_error('mpo2_dot_psi_qtensor_qtensor : '//&
! 'copy failed.', errst=errst)) return
! Contract it to the tensor permout=[3, 1, 2, 4], &
call contr(Hpsi, Ham, Psic, [3, 4], [2, 3], &
errst=errst)
!if(prop_error('mpo2_dot_psi_qtensor_qtensor : '//&
! 'contr failed.', errst=errst)) return
call transposed(Hpsi, [3, 1, 2, 4], doperm=.true.)
call destroy(Psic)
end subroutine mpo2_dot_psi_qtensor_qtensor
"""
return
[docs]def mpo2_dot_psi_qtensor_qtensorc():
"""
fortran-subroutine - June 2017 (dj)
Multiply two-site Hamiltonian with two-site Psi.
**Arguments**
HPsi : TYPE(qtensorc), inout
Contraction of 2-site Hamiltonian with 2-site Psi.
Ham : TYPE(qtensor), inout
Contains the two-site Hamiltonian as rank-4 tensor.
Psi : TYPE(qtensorc), inout
Rank-4 tensor representing the two sites.
**Details**
This it the version building the two site Hamiltonian
first. The default scaling is :math:`d^4 \kappa + \chi^2 d^4`
and avoids any step building the actual MPO. In comparison,
contracting the MPO matrices should result in a scaling of
:math:`2 \kappa \chi^2 d^3`. For large local dimension it could
be worth implementing the contraction based on MPO matrices.
Moreover, the cost :math:`d^4 \kappa` can be done beforehand
and occurs only once for each Trotter step and site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo2_dot_psi_qtensor_qtensorc(HPsi, Ham, Psi, errst)
type(qtensorc), intent(inout) :: Hpsi, Psi
type(qtensor), intent(inout) :: Ham
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Copy for Psi - it will be permuted
type(qtensorc) :: Psic
!if(present(errst)) errst = 0
call copy(Psic, Psi, errst=errst)
!if(prop_error('mpo2_dot_psi_qtensor_qtensorc : '//&
! 'copy failed.', errst=errst)) return
! Contract it to the tensor permout=[3, 1, 2, 4], &
call contr(Hpsi, Ham, Psic, [3, 4], [2, 3], &
errst=errst)
!if(prop_error('mpo2_dot_psi_qtensor_qtensorc : '//&
! 'contr failed.', errst=errst)) return
call transposed(Hpsi, [3, 1, 2, 4], doperm=.true.)
call destroy(Psic)
end subroutine mpo2_dot_psi_qtensor_qtensorc
"""
return
[docs]def mpo2_dot_psi_qtensorc_qtensorc():
"""
fortran-subroutine - June 2017 (dj)
Multiply two-site Hamiltonian with two-site Psi.
**Arguments**
HPsi : TYPE(qtensorc), inout
Contraction of 2-site Hamiltonian with 2-site Psi.
Ham : TYPE(qtensorc), inout
Contains the two-site Hamiltonian as rank-4 tensor.
Psi : TYPE(qtensorc), inout
Rank-4 tensor representing the two sites.
**Details**
This it the version building the two site Hamiltonian
first. The default scaling is :math:`d^4 \kappa + \chi^2 d^4`
and avoids any step building the actual MPO. In comparison,
contracting the MPO matrices should result in a scaling of
:math:`2 \kappa \chi^2 d^3`. For large local dimension it could
be worth implementing the contraction based on MPO matrices.
Moreover, the cost :math:`d^4 \kappa` can be done beforehand
and occurs only once for each Trotter step and site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mpo2_dot_psi_qtensorc_qtensorc(HPsi, Ham, Psi, errst)
type(qtensorc), intent(inout) :: Hpsi, Psi
type(qtensorc), intent(inout) :: Ham
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Copy for Psi - it will be permuted
type(qtensorc) :: Psic
!if(present(errst)) errst = 0
call copy(Psic, Psi, errst=errst)
!if(prop_error('mpo2_dot_psi_qtensorc_qtensorc : '//&
! 'copy failed.', errst=errst)) return
! Contract it to the tensor permout=[3, 1, 2, 4], &
call contr(Hpsi, Ham, Psic, [3, 4], [2, 3], &
errst=errst)
!if(prop_error('mpo2_dot_psi_qtensorc_qtensorc : '//&
! 'contr failed.', errst=errst)) return
call transposed(Hpsi, [3, 1, 2, 4], doperm=.true.)
call destroy(Psic)
end subroutine mpo2_dot_psi_qtensorc_qtensorc
"""
return
[docs]def norm_mps():
"""
fortran-function - June 2017 (dj, updated)
Compute the norm of Psi, assumed to have an orthogonality center.
**Arguments**
Psi : TYPE(mps), inout
Compute the norm of this MPS with orthogonality center. If no
orthogonality is installed, subroutine will crash accessing element
-1)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_mps(Psi, errst) result(psinorm)
type(mps), intent(inout) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: psinorm
! No local variables
! ------------------
!if(present(errst)) errst = 0
!if(Psi%oc < 0) then
!errst = raise_error('norm_mps : oc not valid.', &
! 99, errst=errst)
!return
!end if
psinorm = norm(Psi%Aa(Psi%oc))
end function norm_mps
"""
return
[docs]def norm_mpsc():
"""
fortran-function - June 2017 (dj, updated)
Compute the norm of Psi, assumed to have an orthogonality center.
**Arguments**
Psi : TYPE(mpsc), inout
Compute the norm of this MPS with orthogonality center. If no
orthogonality is installed, subroutine will crash accessing element
-1)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_mpsc(Psi, errst) result(psinorm)
type(mpsc), intent(inout) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: psinorm
! No local variables
! ------------------
!if(present(errst)) errst = 0
!if(Psi%oc < 0) then
!errst = raise_error('norm_mpsc : oc not valid.', &
! 99, errst=errst)
!return
!end if
psinorm = norm(Psi%Aa(Psi%oc))
end function norm_mpsc
"""
return
[docs]def norm_qmps():
"""
fortran-function - June 2017 (dj, updated)
Compute the norm of Psi, assumed to have an orthogonality center.
**Arguments**
Psi : TYPE(qmps), inout
Compute the norm of this MPS with orthogonality center. If no
orthogonality is installed, subroutine will crash accessing element
-1)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_qmps(Psi, errst) result(psinorm)
type(qmps), intent(inout) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: psinorm
! No local variables
! ------------------
!if(present(errst)) errst = 0
!if(Psi%oc < 0) then
!errst = raise_error('norm_qmps : oc not valid.', &
! 99, errst=errst)
!return
!end if
psinorm = norm(Psi%Aa(Psi%oc))
end function norm_qmps
"""
return
[docs]def norm_qmpsc():
"""
fortran-function - June 2017 (dj, updated)
Compute the norm of Psi, assumed to have an orthogonality center.
**Arguments**
Psi : TYPE(qmpsc), inout
Compute the norm of this MPS with orthogonality center. If no
orthogonality is installed, subroutine will crash accessing element
-1)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_qmpsc(Psi, errst) result(psinorm)
type(qmpsc), intent(inout) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: psinorm
! No local variables
! ------------------
!if(present(errst)) errst = 0
!if(Psi%oc < 0) then
!errst = raise_error('norm_qmpsc : oc not valid.', &
! 99, errst=errst)
!return
!end if
psinorm = norm(Psi%Aa(Psi%oc))
end function norm_qmpsc
"""
return
[docs]def orthonormalize_mps():
"""
fortran-subroutine - June 2017 (dj, updated)
Put psi into mixed canonical form at site k0 and normalize it.
**Arguments**
Psi : TYPE(mps), inout
Gauge this MPS with QR, get the norm and rescale it such
that it has trace 1.
k0 : INTEGER, in
The new orthogonality center on exit is at the site k0.
All matrices to the left and right are gauged accordingly.
kl : INTEGER, OPTIONAL, in
start SVD from the left on this site. If not present
SVD start at site 1 or the ortogonality center.
kr : INTEGER, OPTIONAL, in
start SVD from the right on this site. If not present, SVD starts
on the last site or the orthogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine orthonormalize_mps(Psi, k0, kl, kr, errst)
type(mps), intent(inout) :: Psi
integer , intent(in) :: k0
integer, intent(in), optional :: kl, kr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Start of the loop from the left and right
integer :: kleft, kright
! Norm of the MPS
real(KIND=rKind) :: mynorm
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = 1
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = Psi%ll
end if
call canonize(Psi, k0, kleft, kright, errst=errst)
!if(prop_error('orthonormalize_mps : canonize failed.', &
! errst=errst)) return
mynorm = 1.0_rKind / sqrt(norm(Psi))
call scale(mynorm, Psi)
end subroutine orthonormalize_mps
"""
return
[docs]def orthonormalize_mpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Put psi into mixed canonical form at site k0 and normalize it.
**Arguments**
Psi : TYPE(mpsc), inout
Gauge this MPS with QR, get the norm and rescale it such
that it has trace 1.
k0 : INTEGER, in
The new orthogonality center on exit is at the site k0.
All matrices to the left and right are gauged accordingly.
kl : INTEGER, OPTIONAL, in
start SVD from the left on this site. If not present
SVD start at site 1 or the ortogonality center.
kr : INTEGER, OPTIONAL, in
start SVD from the right on this site. If not present, SVD starts
on the last site or the orthogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine orthonormalize_mpsc(Psi, k0, kl, kr, errst)
type(mpsc), intent(inout) :: Psi
integer , intent(in) :: k0
integer, intent(in), optional :: kl, kr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Start of the loop from the left and right
integer :: kleft, kright
! Norm of the MPS
real(KIND=rKind) :: mynorm
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = 1
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = Psi%ll
end if
call canonize(Psi, k0, kleft, kright, errst=errst)
!if(prop_error('orthonormalize_mpsc : canonize failed.', &
! errst=errst)) return
mynorm = 1.0_rKind / sqrt(norm(Psi))
call scale(mynorm, Psi)
end subroutine orthonormalize_mpsc
"""
return
[docs]def orthonormalize_qmps():
"""
fortran-subroutine - June 2017 (dj, updated)
Put psi into mixed canonical form at site k0 and normalize it.
**Arguments**
Psi : TYPE(qmps), inout
Gauge this MPS with QR, get the norm and rescale it such
that it has trace 1.
k0 : INTEGER, in
The new orthogonality center on exit is at the site k0.
All matrices to the left and right are gauged accordingly.
kl : INTEGER, OPTIONAL, in
start SVD from the left on this site. If not present
SVD start at site 1 or the ortogonality center.
kr : INTEGER, OPTIONAL, in
start SVD from the right on this site. If not present, SVD starts
on the last site or the orthogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine orthonormalize_qmps(Psi, k0, kl, kr, errst)
type(qmps), intent(inout) :: Psi
integer , intent(in) :: k0
integer, intent(in), optional :: kl, kr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Start of the loop from the left and right
integer :: kleft, kright
! Norm of the MPS
real(KIND=rKind) :: mynorm
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = 1
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = Psi%ll
end if
call canonize(Psi, k0, kleft, kright, errst=errst)
!if(prop_error('orthonormalize_qmps : canonize failed.', &
! errst=errst)) return
mynorm = 1.0_rKind / sqrt(norm(Psi))
call scale(mynorm, Psi)
end subroutine orthonormalize_qmps
"""
return
[docs]def orthonormalize_qmpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Put psi into mixed canonical form at site k0 and normalize it.
**Arguments**
Psi : TYPE(qmpsc), inout
Gauge this MPS with QR, get the norm and rescale it such
that it has trace 1.
k0 : INTEGER, in
The new orthogonality center on exit is at the site k0.
All matrices to the left and right are gauged accordingly.
kl : INTEGER, OPTIONAL, in
start SVD from the left on this site. If not present
SVD start at site 1 or the ortogonality center.
kr : INTEGER, OPTIONAL, in
start SVD from the right on this site. If not present, SVD starts
on the last site or the orthogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine orthonormalize_qmpsc(Psi, k0, kl, kr, errst)
type(qmpsc), intent(inout) :: Psi
integer , intent(in) :: k0
integer, intent(in), optional :: kl, kr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Start of the loop from the left and right
integer :: kleft, kright
! Norm of the MPS
real(KIND=rKind) :: mynorm
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = 1
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = Psi%ll
end if
call canonize(Psi, k0, kleft, kright, errst=errst)
!if(prop_error('orthonormalize_qmpsc : canonize failed.', &
! errst=errst)) return
mynorm = 1.0_rKind / sqrt(norm(Psi))
call scale(mynorm, Psi)
end subroutine orthonormalize_qmpsc
"""
return
[docs]def perturb_mps():
"""
fortran-subroutine - December 2018 (dj)
Perturbate a MPS via a perturbation of each entry of each tensor.
**Arguments**
Psi : TYPE(mps), inout
MPS to be perturbed.
epsilon : real, OPTIONAL, in
Scale a randomized tensor by epsilon and add to original tensor.
Default to 1e-8
reorth : LOGICAL, in
Re-orhtogonalize to the original oc center if true, otherwise, skip
canonization.
Default to no orthogonalization.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine perturb_mps(Psi, epsilon, reorth, errst)
type(mps), intent(inout) :: Psi
real(KIND=rKind), intent(in), optional :: epsilon
logical, intent(in), optional :: reorth
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! save original oc center
integer :: ocsave
!if(present(errst)) errst = 0
ocsave = Psi%oc
do ii = 1, Psi%ll
call perturb(Psi%Aa(ii), epsilon, errst=errst)
!if(prop_error('perturb_mps : perturb failed.', &
! 'MPSOps_include.f90:1852', errst=errst)) return
if(Psi%haslambda(ii)) then
Psi%haslambda(ii) = .false.
call destroy(Psi%Lambda(ii))
end if
end do
if(present(reorth)) then
if(reorth .and. (ocsave > 0)) then
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('perturb_mps : canonize failed.', &
! 'MPSOps_include.f90:1865', errst=errst)) return
end if
end if
end subroutine perturb_mps
"""
return
[docs]def perturb_mpsc():
"""
fortran-subroutine - December 2018 (dj)
Perturbate a MPS via a perturbation of each entry of each tensor.
**Arguments**
Psi : TYPE(mpsc), inout
MPS to be perturbed.
epsilon : real, OPTIONAL, in
Scale a randomized tensor by epsilon and add to original tensor.
Default to 1e-8
reorth : LOGICAL, in
Re-orhtogonalize to the original oc center if true, otherwise, skip
canonization.
Default to no orthogonalization.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine perturb_mpsc(Psi, epsilon, reorth, errst)
type(mpsc), intent(inout) :: Psi
real(KIND=rKind), intent(in), optional :: epsilon
logical, intent(in), optional :: reorth
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! save original oc center
integer :: ocsave
!if(present(errst)) errst = 0
ocsave = Psi%oc
do ii = 1, Psi%ll
call perturb(Psi%Aa(ii), epsilon, errst=errst)
!if(prop_error('perturb_mpsc : perturb failed.', &
! 'MPSOps_include.f90:1852', errst=errst)) return
if(Psi%haslambda(ii)) then
Psi%haslambda(ii) = .false.
call destroy(Psi%Lambda(ii))
end if
end do
if(present(reorth)) then
if(reorth .and. (ocsave > 0)) then
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('perturb_mpsc : canonize failed.', &
! 'MPSOps_include.f90:1865', errst=errst)) return
end if
end if
end subroutine perturb_mpsc
"""
return
[docs]def perturb_qmps():
"""
fortran-subroutine - December 2018 (dj)
Perturbate a MPS via a perturbation of each entry of each tensor.
**Arguments**
Psi : TYPE(qmps), inout
MPS to be perturbed.
epsilon : real, OPTIONAL, in
Scale a randomized tensor by epsilon and add to original tensor.
Default to 1e-8
reorth : LOGICAL, in
Re-orhtogonalize to the original oc center if true, otherwise, skip
canonization.
Default to no orthogonalization.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine perturb_qmps(Psi, epsilon, reorth, errst)
type(qmps), intent(inout) :: Psi
real(KIND=rKind), intent(in), optional :: epsilon
logical, intent(in), optional :: reorth
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! save original oc center
integer :: ocsave
!if(present(errst)) errst = 0
ocsave = Psi%oc
do ii = 1, Psi%ll
call perturb(Psi%Aa(ii), epsilon, errst=errst)
!if(prop_error('perturb_qmps : perturb failed.', &
! 'MPSOps_include.f90:1852', errst=errst)) return
if(Psi%haslambda(ii)) then
Psi%haslambda(ii) = .false.
call destroy(Psi%Lambda(ii))
end if
end do
if(present(reorth)) then
if(reorth .and. (ocsave > 0)) then
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('perturb_qmps : canonize failed.', &
! 'MPSOps_include.f90:1865', errst=errst)) return
end if
end if
end subroutine perturb_qmps
"""
return
[docs]def perturb_qmpsc():
"""
fortran-subroutine - December 2018 (dj)
Perturbate a MPS via a perturbation of each entry of each tensor.
**Arguments**
Psi : TYPE(qmpsc), inout
MPS to be perturbed.
epsilon : real, OPTIONAL, in
Scale a randomized tensor by epsilon and add to original tensor.
Default to 1e-8
reorth : LOGICAL, in
Re-orhtogonalize to the original oc center if true, otherwise, skip
canonization.
Default to no orthogonalization.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine perturb_qmpsc(Psi, epsilon, reorth, errst)
type(qmpsc), intent(inout) :: Psi
real(KIND=rKind), intent(in), optional :: epsilon
logical, intent(in), optional :: reorth
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! save original oc center
integer :: ocsave
!if(present(errst)) errst = 0
ocsave = Psi%oc
do ii = 1, Psi%ll
call perturb(Psi%Aa(ii), epsilon, errst=errst)
!if(prop_error('perturb_qmpsc : perturb failed.', &
! 'MPSOps_include.f90:1852', errst=errst)) return
if(Psi%haslambda(ii)) then
Psi%haslambda(ii) = .false.
call destroy(Psi%Lambda(ii))
end if
end do
if(present(reorth)) then
if(reorth .and. (ocsave > 0)) then
call canonize(Psi, ocsave, errst=errst)
!if(prop_error('perturb_qmpsc : canonize failed.', &
! 'MPSOps_include.f90:1865', errst=errst)) return
end if
end if
end subroutine perturb_qmpsc
"""
return
[docs]def print_mps():
"""
fortran-subroutine - June 2016 (dj, updated)
Write out all MPS data.
**Arguments**
Psi : TYPE(mps), in
Print all information about the MPS.
**Details**
The information is written to the standard output with the
following formatting:
1) infostring, Size of MPS, orthogonality center (both integers)
In a loop for each site is written
2) infostring, number of the site (integer)
3) infostring, canonization (character)
4) infostring, haslambda (logical)
5) Depending on logical haslambda, lambda is printed with according
function.
6) Tensor is printed with according function.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine print_mps(Psi, errst)
type(mps), intent(in) :: Psi
integer, intent(out), optional :: errst
call write(Psi, 6, "6", errst=errst)
!if(prop_error('print_mps: write failed', &
! errst=errst)) return
end subroutine print_mps
"""
return
[docs]def print_mpsc():
"""
fortran-subroutine - June 2016 (dj, updated)
Write out all MPS data.
**Arguments**
Psi : TYPE(mpsc), in
Print all information about the MPS.
**Details**
The information is written to the standard output with the
following formatting:
1) infostring, Size of MPS, orthogonality center (both integers)
In a loop for each site is written
2) infostring, number of the site (integer)
3) infostring, canonization (character)
4) infostring, haslambda (logical)
5) Depending on logical haslambda, lambda is printed with according
function.
6) Tensor is printed with according function.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine print_mpsc(Psi, errst)
type(mpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
call write(Psi, 6, "6", errst=errst)
!if(prop_error('print_mpsc: write failed', &
! errst=errst)) return
end subroutine print_mpsc
"""
return
[docs]def print_qmps():
"""
fortran-subroutine - June 2016 (dj, updated)
Write out all MPS data.
**Arguments**
Psi : TYPE(qmps), in
Print all information about the MPS.
**Details**
The information is written to the standard output with the
following formatting:
1) infostring, Size of MPS, orthogonality center (both integers)
In a loop for each site is written
2) infostring, number of the site (integer)
3) infostring, canonization (character)
4) infostring, haslambda (logical)
5) Depending on logical haslambda, lambda is printed with according
function.
6) Tensor is printed with according function.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine print_qmps(Psi, errst)
type(qmps), intent(in) :: Psi
integer, intent(out), optional :: errst
call write(Psi, 6, "6", errst=errst)
!if(prop_error('print_qmps: write failed', &
! errst=errst)) return
end subroutine print_qmps
"""
return
[docs]def print_qmpsc():
"""
fortran-subroutine - June 2016 (dj, updated)
Write out all MPS data.
**Arguments**
Psi : TYPE(qmpsc), in
Print all information about the MPS.
**Details**
The information is written to the standard output with the
following formatting:
1) infostring, Size of MPS, orthogonality center (both integers)
In a loop for each site is written
2) infostring, number of the site (integer)
3) infostring, canonization (character)
4) infostring, haslambda (logical)
5) Depending on logical haslambda, lambda is printed with according
function.
6) Tensor is printed with according function.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine print_qmpsc(Psi, errst)
type(qmpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
call write(Psi, 6, "6", errst=errst)
!if(prop_error('print_qmpsc: write failed', &
! errst=errst)) return
end subroutine print_qmpsc
"""
return
[docs]def projected_mpo_dot_psi_n_tensor_tensor():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute the projection of Phi = H * psi, where H=L.W.R
**Details**
Since we need the projectors from the two site tensor, the
two site algorithm is implemented.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projected_mpo_dot_psi_n_tensor_tensor(Phi, Lc, Hts, Rc, &
Psin, leftmost, rightmost, Psiprojs, beta, errst)
type(tensor), intent(inout) :: Phi
type(tensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_tensor), intent(inout) :: Hts
type(tensor), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
type(tensor), pointer, intent(inout) :: Psiprojs(:)
real(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrix
integer :: k1, k2
! rank of the tensor necessary to know contraction index
integer :: rnk
! control action of contr, = or +=
real(KIND=rKind) :: beta_
! Temporary tensor with projection
type(tensor) :: Gt, Tmp
! Temporary array of tensors
type(tensor), dimension(:), allocatable :: Fts
!if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = dzero
end if
rnk = rank(Psin)
! Build two-site tensor and the projections
call project(Gt, Psin, Psiprojs)
k1 = Hts%rbd
k2 = Hts%cbd
! 1) Contractions of the right overlap
! ------------------------------------
!
! !F^k_{a i j b}= A_{a i b'} R^k_{b' b}
allocate(Fts(k2))
if(rightmost) then
! Initialize
do ii = 1, k2
call copy(Fts(ii), Gt)
end do
else
! Propagate
do ii = 1, k2
call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('projected_mpo_dot_psi_n_tensor_'//&
! 'tensor: contr failed.', &
! 'MPSOps_include.f90:2002', errst=errst)) return
end do
end if
call destroy(Gt)
! 2) Contract MPO and left transfer matrix
! -----------------------------------------
call contractmpol(Gt, 1, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(1), Gt, [2], [1])
end if
if(beta_ == 0.0_rKind) then
call project(Phi, Tmp, Psiprojs)
else
if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
call addproject(Phi, Tmp, Psiprojs)
end if
call destroy(Gt)
call destroy(Tmp)
do ii = 2, k1
call contractmpol(Gt, ii, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
end if
call addproject(Phi, Tmp, Psiprojs)
call destroy(Gt)
call destroy(Tmp)
end do
do ii = 1, k2
call destroy(Fts(ii))
end do
deallocate(Fts)
end subroutine projected_mpo_dot_psi_n_tensor_tensor
"""
return
[docs]def projected_mpo_dot_psi_n_tensor_tensorc():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute the projection of Phi = H * psi, where H=L.W.R
**Details**
Since we need the projectors from the two site tensor, the
two site algorithm is implemented.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projected_mpo_dot_psi_n_tensor_tensorc(Phi, Lc, Hts, Rc, &
Psin, leftmost, rightmost, Psiprojs, beta, errst)
type(tensorc), intent(inout) :: Phi
type(tensorlistc), intent(inout) :: Lc, Rc
type(sr_matrix_tensor), intent(inout) :: Hts
type(tensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
type(tensorc), pointer, intent(inout) :: Psiprojs(:)
complex(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrix
integer :: k1, k2
! rank of the tensor necessary to know contraction index
integer :: rnk
! control action of contr, = or +=
complex(KIND=rKind) :: beta_
! Temporary tensor with projection
type(tensorc) :: Gt, Tmp
! Temporary array of tensors
type(tensorc), dimension(:), allocatable :: Fts
!if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = zzero
end if
rnk = rank(Psin)
! Build two-site tensor and the projections
call project(Gt, Psin, Psiprojs)
k1 = Hts%rbd
k2 = Hts%cbd
! 1) Contractions of the right overlap
! ------------------------------------
!
! !F^k_{a i j b}= A_{a i b'} R^k_{b' b}
allocate(Fts(k2))
if(rightmost) then
! Initialize
do ii = 1, k2
call copy(Fts(ii), Gt)
end do
else
! Propagate
do ii = 1, k2
call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('projected_mpo_dot_psi_n_tensor_'//&
! 'tensorc: contr failed.', &
! 'MPSOps_include.f90:2002', errst=errst)) return
end do
end if
call destroy(Gt)
! 2) Contract MPO and left transfer matrix
! -----------------------------------------
call contractmpol(Gt, 1, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(1), Gt, [2], [1])
end if
if(beta_ == 0.0_rKind) then
call project(Phi, Tmp, Psiprojs)
else
if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
call addproject(Phi, Tmp, Psiprojs)
end if
call destroy(Gt)
call destroy(Tmp)
do ii = 2, k1
call contractmpol(Gt, ii, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
end if
call addproject(Phi, Tmp, Psiprojs)
call destroy(Gt)
call destroy(Tmp)
end do
do ii = 1, k2
call destroy(Fts(ii))
end do
deallocate(Fts)
end subroutine projected_mpo_dot_psi_n_tensor_tensorc
"""
return
[docs]def projected_mpo_dot_psi_n_tensorc_tensorc():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute the projection of Phi = H * psi, where H=L.W.R
**Details**
Since we need the projectors from the two site tensor, the
two site algorithm is implemented.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projected_mpo_dot_psi_n_tensorc_tensorc(Phi, Lc, Hts, Rc, &
Psin, leftmost, rightmost, Psiprojs, beta, errst)
type(tensorc), intent(inout) :: Phi
type(tensorlistc), intent(inout) :: Lc, Rc
type(sr_matrix_tensorc), intent(inout) :: Hts
type(tensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
type(tensorc), pointer, intent(inout) :: Psiprojs(:)
complex(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrix
integer :: k1, k2
! rank of the tensor necessary to know contraction index
integer :: rnk
! control action of contr, = or +=
complex(KIND=rKind) :: beta_
! Temporary tensor with projection
type(tensorc) :: Gt, Tmp
! Temporary array of tensors
type(tensorc), dimension(:), allocatable :: Fts
!if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = zzero
end if
rnk = rank(Psin)
! Build two-site tensor and the projections
call project(Gt, Psin, Psiprojs)
k1 = Hts%rbd
k2 = Hts%cbd
! 1) Contractions of the right overlap
! ------------------------------------
!
! !F^k_{a i j b}= A_{a i b'} R^k_{b' b}
allocate(Fts(k2))
if(rightmost) then
! Initialize
do ii = 1, k2
call copy(Fts(ii), Gt)
end do
else
! Propagate
do ii = 1, k2
call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('projected_mpo_dot_psi_n_tensorc_'//&
! 'tensorc: contr failed.', &
! 'MPSOps_include.f90:2002', errst=errst)) return
end do
end if
call destroy(Gt)
! 2) Contract MPO and left transfer matrix
! -----------------------------------------
call contractmpol(Gt, 1, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(1), Gt, [2], [1])
end if
if(beta_ == 0.0_rKind) then
call project(Phi, Tmp, Psiprojs)
else
if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
call addproject(Phi, Tmp, Psiprojs)
end if
call destroy(Gt)
call destroy(Tmp)
do ii = 2, k1
call contractmpol(Gt, ii, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
end if
call addproject(Phi, Tmp, Psiprojs)
call destroy(Gt)
call destroy(Tmp)
end do
do ii = 1, k2
call destroy(Fts(ii))
end do
deallocate(Fts)
end subroutine projected_mpo_dot_psi_n_tensorc_tensorc
"""
return
[docs]def projected_mpo_dot_psi_n_qtensor_qtensor():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute the projection of Phi = H * psi, where H=L.W.R
**Details**
Since we need the projectors from the two site tensor, the
two site algorithm is implemented.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projected_mpo_dot_psi_n_qtensor_qtensor(Phi, Lc, Hts, Rc, &
Psin, leftmost, rightmost, Psiprojs, beta, errst)
type(qtensor), intent(inout) :: Phi
type(qtensorlist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensor), intent(inout) :: Hts
type(qtensor), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
type(qtensor), pointer, intent(inout) :: Psiprojs(:)
real(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrix
integer :: k1, k2
! rank of the tensor necessary to know contraction index
integer :: rnk
! control action of contr, = or +=
real(KIND=rKind) :: beta_
! Temporary tensor with projection
type(qtensor) :: Gt, Tmp
! Temporary array of tensors
type(qtensor), dimension(:), allocatable :: Fts
!if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = dzero
end if
rnk = rank(Psin)
! Build two-site tensor and the projections
call project(Gt, Psin, Psiprojs)
k1 = Hts%rbd
k2 = Hts%cbd
! 1) Contractions of the right overlap
! ------------------------------------
!
! !F^k_{a i j b}= A_{a i b'} R^k_{b' b}
allocate(Fts(k2))
if(rightmost) then
! Initialize
do ii = 1, k2
call copy(Fts(ii), Gt)
end do
else
! Propagate
do ii = 1, k2
call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('projected_mpo_dot_psi_n_qtensor_'//&
! 'qtensor: contr failed.', &
! 'MPSOps_include.f90:2002', errst=errst)) return
end do
end if
call destroy(Gt)
! 2) Contract MPO and left transfer matrix
! -----------------------------------------
call contractmpol(Gt, 1, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(1), Gt, [2], [1])
end if
if(beta_ == 0.0_rKind) then
call project(Phi, Tmp, Psiprojs)
else
if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
call addproject(Phi, Tmp, Psiprojs)
end if
call destroy(Gt)
call destroy(Tmp)
do ii = 2, k1
call contractmpol(Gt, ii, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
end if
call addproject(Phi, Tmp, Psiprojs)
call destroy(Gt)
call destroy(Tmp)
end do
do ii = 1, k2
call destroy(Fts(ii))
end do
deallocate(Fts)
end subroutine projected_mpo_dot_psi_n_qtensor_qtensor
"""
return
[docs]def projected_mpo_dot_psi_n_qtensor_qtensorc():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute the projection of Phi = H * psi, where H=L.W.R
**Details**
Since we need the projectors from the two site tensor, the
two site algorithm is implemented.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projected_mpo_dot_psi_n_qtensor_qtensorc(Phi, Lc, Hts, Rc, &
Psin, leftmost, rightmost, Psiprojs, beta, errst)
type(qtensorc), intent(inout) :: Phi
type(qtensorclist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensor), intent(inout) :: Hts
type(qtensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
type(qtensorc), pointer, intent(inout) :: Psiprojs(:)
complex(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrix
integer :: k1, k2
! rank of the tensor necessary to know contraction index
integer :: rnk
! control action of contr, = or +=
complex(KIND=rKind) :: beta_
! Temporary tensor with projection
type(qtensorc) :: Gt, Tmp
! Temporary array of tensors
type(qtensorc), dimension(:), allocatable :: Fts
!if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = zzero
end if
rnk = rank(Psin)
! Build two-site tensor and the projections
call project(Gt, Psin, Psiprojs)
k1 = Hts%rbd
k2 = Hts%cbd
! 1) Contractions of the right overlap
! ------------------------------------
!
! !F^k_{a i j b}= A_{a i b'} R^k_{b' b}
allocate(Fts(k2))
if(rightmost) then
! Initialize
do ii = 1, k2
call copy(Fts(ii), Gt)
end do
else
! Propagate
do ii = 1, k2
call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('projected_mpo_dot_psi_n_qtensor_'//&
! 'qtensorc: contr failed.', &
! 'MPSOps_include.f90:2002', errst=errst)) return
end do
end if
call destroy(Gt)
! 2) Contract MPO and left transfer matrix
! -----------------------------------------
call contractmpol(Gt, 1, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(1), Gt, [2], [1])
end if
if(beta_ == 0.0_rKind) then
call project(Phi, Tmp, Psiprojs)
else
if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
call addproject(Phi, Tmp, Psiprojs)
end if
call destroy(Gt)
call destroy(Tmp)
do ii = 2, k1
call contractmpol(Gt, ii, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
end if
call addproject(Phi, Tmp, Psiprojs)
call destroy(Gt)
call destroy(Tmp)
end do
do ii = 1, k2
call destroy(Fts(ii))
end do
deallocate(Fts)
end subroutine projected_mpo_dot_psi_n_qtensor_qtensorc
"""
return
[docs]def projected_mpo_dot_psi_n_qtensorc_qtensorc():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute the projection of Phi = H * psi, where H=L.W.R
**Details**
Since we need the projectors from the two site tensor, the
two site algorithm is implemented.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine projected_mpo_dot_psi_n_qtensorc_qtensorc(Phi, Lc, Hts, Rc, &
Psin, leftmost, rightmost, Psiprojs, beta, errst)
type(qtensorc), intent(inout) :: Phi
type(qtensorclist), intent(inout) :: Lc, Rc
type(sr_matrix_qtensorc), intent(inout) :: Hts
type(qtensorc), intent(inout) :: Psin
logical, intent(in) :: leftmost, rightmost
type(qtensorc), pointer, intent(inout) :: Psiprojs(:)
complex(KIND=rKind), intent(in), optional :: beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! bond dimensions MPO-matrix
integer :: k1, k2
! rank of the tensor necessary to know contraction index
integer :: rnk
! control action of contr, = or +=
complex(KIND=rKind) :: beta_
! Temporary tensor with projection
type(qtensorc) :: Gt, Tmp
! Temporary array of tensors
type(qtensorc), dimension(:), allocatable :: Fts
!if(present(errst)) errst = 0
if(present(beta)) then
beta_ = beta
else
beta_ = zzero
end if
rnk = rank(Psin)
! Build two-site tensor and the projections
call project(Gt, Psin, Psiprojs)
k1 = Hts%rbd
k2 = Hts%cbd
! 1) Contractions of the right overlap
! ------------------------------------
!
! !F^k_{a i j b}= A_{a i b'} R^k_{b' b}
allocate(Fts(k2))
if(rightmost) then
! Initialize
do ii = 1, k2
call copy(Fts(ii), Gt)
end do
else
! Propagate
do ii = 1, k2
call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
!if(prop_error('projected_mpo_dot_psi_n_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'MPSOps_include.f90:2002', errst=errst)) return
end do
end if
call destroy(Gt)
! 2) Contract MPO and left transfer matrix
! -----------------------------------------
call contractmpol(Gt, 1, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(1), Gt, [2], [1])
end if
if(beta_ == 0.0_rKind) then
call project(Phi, Tmp, Psiprojs)
else
if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
call addproject(Phi, Tmp, Psiprojs)
end if
call destroy(Gt)
call destroy(Tmp)
do ii = 2, k1
call contractmpol(Gt, ii, Hts, Fts)
if(leftmost) then
call copy(Tmp, Gt)
else
call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
end if
call addproject(Phi, Tmp, Psiprojs)
call destroy(Gt)
call destroy(Tmp)
end do
do ii = 1, k2
call destroy(Fts(ii))
end do
deallocate(Fts)
end subroutine projected_mpo_dot_psi_n_qtensorc_qtensorc
"""
return
[docs]def ptm_left_state_tensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the right to the left. This
version is for states.
**Arguments**
Mat : TYPE(tensor), inout
This is the transfer matrix right of Bra and Ket.
Bra : TYPE(tensor), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(tensor), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
rightmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(tensor), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{k,l} = \sum_{i,j,m} Mat_{i,j} Ket_{k,m,i} (Bra_{l,m,j})^{\\ast}`.
This is executed in two steps. This is the leftmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_state_tensor(Mat, Bra, Ket, rightmost, Matin, &
errst)
type(tensor), intent(inout) :: Mat, Bra, Ket
logical, intent(in) :: rightmost
type(tensor), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensor) :: Tens
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
call contr(Mat, Ket, Bra, [2, 3], [2, 3], transr='C', errst=errst)
!if(prop_error('ptm_left_state_tensor: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1: Tens_{k, m, j} = Ket_{k, m, i} Mat_{i, j}
if(present(Matin)) then
call contr(Tens, Ket, Matin, [3], [1], errst=errst)
else
call contr(Tens, Ket, Mat, [3], [1], errst=errst)
end if
!if(prop_error('ptm_left_state_tensor: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{k, l} = Tens_{k, m, j} Bra_{l, m, j}*
call contr(Mat, Tens, Bra, [2, 3], [2, 3], transr='C', errst=errst)
!if(prop_error('ptm_left_state_tensor: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_left_state_tensor
"""
return
[docs]def ptm_left_state_tensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the right to the left. This
version is for states.
**Arguments**
Mat : TYPE(tensorc), inout
This is the transfer matrix right of Bra and Ket.
Bra : TYPE(tensorc), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(tensorc), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
rightmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(tensorc), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{k,l} = \sum_{i,j,m} Mat_{i,j} Ket_{k,m,i} (Bra_{l,m,j})^{\\ast}`.
This is executed in two steps. This is the leftmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_state_tensorc(Mat, Bra, Ket, rightmost, Matin, &
errst)
type(tensorc), intent(inout) :: Mat, Bra, Ket
logical, intent(in) :: rightmost
type(tensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensorc) :: Tens
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
call contr(Mat, Ket, Bra, [2, 3], [2, 3], transr='C', errst=errst)
!if(prop_error('ptm_left_state_tensorc: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1: Tens_{k, m, j} = Ket_{k, m, i} Mat_{i, j}
if(present(Matin)) then
call contr(Tens, Ket, Matin, [3], [1], errst=errst)
else
call contr(Tens, Ket, Mat, [3], [1], errst=errst)
end if
!if(prop_error('ptm_left_state_tensorc: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{k, l} = Tens_{k, m, j} Bra_{l, m, j}*
call contr(Mat, Tens, Bra, [2, 3], [2, 3], transr='C', errst=errst)
!if(prop_error('ptm_left_state_tensorc: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_left_state_tensorc
"""
return
[docs]def ptm_left_state_qtensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the right to the left. This
version is for states.
**Arguments**
Mat : TYPE(qtensor), inout
This is the transfer matrix right of Bra and Ket.
Bra : TYPE(qtensor), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(qtensor), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
rightmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(qtensor), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{k,l} = \sum_{i,j,m} Mat_{i,j} Ket_{k,m,i} (Bra_{l,m,j})^{\\ast}`.
This is executed in two steps. This is the leftmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_state_qtensor(Mat, Bra, Ket, rightmost, Matin, &
errst)
type(qtensor), intent(inout) :: Mat, Bra, Ket
logical, intent(in) :: rightmost
type(qtensor), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensor) :: Tens
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
call contr(Mat, Ket, Bra, [2, 3], [2, 3], transr='C', errst=errst)
!if(prop_error('ptm_left_state_qtensor: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1: Tens_{k, m, j} = Ket_{k, m, i} Mat_{i, j}
if(present(Matin)) then
call contr(Tens, Ket, Matin, [3], [1], errst=errst)
else
call contr(Tens, Ket, Mat, [3], [1], errst=errst)
end if
!if(prop_error('ptm_left_state_qtensor: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{k, l} = Tens_{k, m, j} Bra_{l, m, j}*
call contr(Mat, Tens, Bra, [2, 3], [2, 3], transr='C', errst=errst)
!if(prop_error('ptm_left_state_qtensor: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_left_state_qtensor
"""
return
[docs]def ptm_left_state_qtensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the right to the left. This
version is for states.
**Arguments**
Mat : TYPE(qtensorc), inout
This is the transfer matrix right of Bra and Ket.
Bra : TYPE(qtensorc), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(qtensorc), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
rightmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(qtensorc), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{k,l} = \sum_{i,j,m} Mat_{i,j} Ket_{k,m,i} (Bra_{l,m,j})^{\\ast}`.
This is executed in two steps. This is the leftmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_state_qtensorc(Mat, Bra, Ket, rightmost, Matin, &
errst)
type(qtensorc), intent(inout) :: Mat, Bra, Ket
logical, intent(in) :: rightmost
type(qtensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensorc) :: Tens
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
call contr(Mat, Ket, Bra, [2, 3], [2, 3], transr='C', errst=errst)
!if(prop_error('ptm_left_state_qtensorc: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1: Tens_{k, m, j} = Ket_{k, m, i} Mat_{i, j}
if(present(Matin)) then
call contr(Tens, Ket, Matin, [3], [1], errst=errst)
else
call contr(Tens, Ket, Mat, [3], [1], errst=errst)
end if
!if(prop_error('ptm_left_state_qtensorc: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{k, l} = Tens_{k, m, j} Bra_{l, m, j}*
call contr(Mat, Tens, Bra, [2, 3], [2, 3], transr='C', errst=errst)
!if(prop_error('ptm_left_state_qtensorc: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_left_state_qtensorc
"""
return
[docs]def ptm_right_state_tensor_tensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the left to the right. This
version is for states.
**Arguments**
Mat : TYPE(tensor), inout
This is the transfer matrix left of Bra and Ket.
Bra : TYPE(tensor), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(tensor), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
leftmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(tensor), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\\ast}`.
This is executed in two steps. This is the rightmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_state_tensor_tensor(Mat, Bra, Ket, &
leftmost, Matin, errst)
type(tensor), intent(inout) :: Mat
type(tensor), intent(inout) :: Bra
type(tensor), intent(inout) :: Ket
logical, intent(in) :: leftmost
type(tensor), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensor) :: Tens
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call contr(Mat, Bra, Ket, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_left_state_tensor: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1 : Tens_{i,m,k} = Mat_{i,j} Ket_{j,m,k}
if(present(Matin)) then
call contr(Tens, Matin, Ket, [2], [1], errst=errst)
else
call contr(Tens, Mat, Ket, [2], [1], errst=errst)
end if
!if(prop_error('ptm_right_state_tensor: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{l,k} = Bra_{i,m,l}* Tens_{i,m,k}
call contr(Mat, Bra, Tens, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_right_state_tensor: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_right_state_tensor_tensor
"""
return
[docs]def ptm_right_state_tensor_tensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the left to the right. This
version is for states.
**Arguments**
Mat : TYPE(tensorc), inout
This is the transfer matrix left of Bra and Ket.
Bra : TYPE(tensorc), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(tensorc), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
leftmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(tensorc), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\\ast}`.
This is executed in two steps. This is the rightmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_state_tensor_tensorc(Mat, Bra, Ket, &
leftmost, Matin, errst)
type(tensorc), intent(inout) :: Mat
type(tensor), intent(inout) :: Bra
type(tensorc), intent(inout) :: Ket
logical, intent(in) :: leftmost
type(tensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensorc) :: Tens
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call contr(Mat, Bra, Ket, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_left_state_tensorc: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1 : Tens_{i,m,k} = Mat_{i,j} Ket_{j,m,k}
if(present(Matin)) then
call contr(Tens, Matin, Ket, [2], [1], errst=errst)
else
call contr(Tens, Mat, Ket, [2], [1], errst=errst)
end if
!if(prop_error('ptm_right_state_tensorc: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{l,k} = Bra_{i,m,l}* Tens_{i,m,k}
call contr(Mat, Bra, Tens, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_right_state_tensorc: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_right_state_tensor_tensorc
"""
return
[docs]def ptm_right_state_tensorc_tensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the left to the right. This
version is for states.
**Arguments**
Mat : TYPE(tensorc), inout
This is the transfer matrix left of Bra and Ket.
Bra : TYPE(tensorc), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(tensorc), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
leftmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(tensorc), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\\ast}`.
This is executed in two steps. This is the rightmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_state_tensorc_tensor(Mat, Bra, Ket, &
leftmost, Matin, errst)
type(tensorc), intent(inout) :: Mat
type(tensorc), intent(inout) :: Bra
type(tensor), intent(inout) :: Ket
logical, intent(in) :: leftmost
type(tensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensorc) :: Tens
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call contr(Mat, Bra, Ket, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_left_state_tensorc: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1 : Tens_{i,m,k} = Mat_{i,j} Ket_{j,m,k}
if(present(Matin)) then
call contr(Tens, Matin, Ket, [2], [1], errst=errst)
else
call contr(Tens, Mat, Ket, [2], [1], errst=errst)
end if
!if(prop_error('ptm_right_state_tensorc: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{l,k} = Bra_{i,m,l}* Tens_{i,m,k}
call contr(Mat, Bra, Tens, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_right_state_tensorc: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_right_state_tensorc_tensor
"""
return
[docs]def ptm_right_state_tensorc_tensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the left to the right. This
version is for states.
**Arguments**
Mat : TYPE(tensorc), inout
This is the transfer matrix left of Bra and Ket.
Bra : TYPE(tensorc), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(tensorc), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
leftmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(tensorc), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\\ast}`.
This is executed in two steps. This is the rightmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_state_tensorc_tensorc(Mat, Bra, Ket, &
leftmost, Matin, errst)
type(tensorc), intent(inout) :: Mat
type(tensorc), intent(inout) :: Bra
type(tensorc), intent(inout) :: Ket
logical, intent(in) :: leftmost
type(tensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensorc) :: Tens
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call contr(Mat, Bra, Ket, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_left_state_tensorc: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1 : Tens_{i,m,k} = Mat_{i,j} Ket_{j,m,k}
if(present(Matin)) then
call contr(Tens, Matin, Ket, [2], [1], errst=errst)
else
call contr(Tens, Mat, Ket, [2], [1], errst=errst)
end if
!if(prop_error('ptm_right_state_tensorc: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{l,k} = Bra_{i,m,l}* Tens_{i,m,k}
call contr(Mat, Bra, Tens, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_right_state_tensorc: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_right_state_tensorc_tensorc
"""
return
[docs]def ptm_right_state_qtensor_qtensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the left to the right. This
version is for states.
**Arguments**
Mat : TYPE(qtensor), inout
This is the transfer matrix left of Bra and Ket.
Bra : TYPE(qtensor), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(qtensor), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
leftmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(qtensor), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\\ast}`.
This is executed in two steps. This is the rightmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_state_qtensor_qtensor(Mat, Bra, Ket, &
leftmost, Matin, errst)
type(qtensor), intent(inout) :: Mat
type(qtensor), intent(inout) :: Bra
type(qtensor), intent(inout) :: Ket
logical, intent(in) :: leftmost
type(qtensor), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensor) :: Tens
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call contr(Mat, Bra, Ket, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_left_state_qtensor: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1 : Tens_{i,m,k} = Mat_{i,j} Ket_{j,m,k}
if(present(Matin)) then
call contr(Tens, Matin, Ket, [2], [1], errst=errst)
else
call contr(Tens, Mat, Ket, [2], [1], errst=errst)
end if
!if(prop_error('ptm_right_state_qtensor: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{l,k} = Bra_{i,m,l}* Tens_{i,m,k}
call contr(Mat, Bra, Tens, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_right_state_qtensor: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_right_state_qtensor_qtensor
"""
return
[docs]def ptm_right_state_qtensor_qtensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the left to the right. This
version is for states.
**Arguments**
Mat : TYPE(qtensorc), inout
This is the transfer matrix left of Bra and Ket.
Bra : TYPE(qtensorc), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(qtensorc), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
leftmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(qtensorc), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\\ast}`.
This is executed in two steps. This is the rightmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_state_qtensor_qtensorc(Mat, Bra, Ket, &
leftmost, Matin, errst)
type(qtensorc), intent(inout) :: Mat
type(qtensor), intent(inout) :: Bra
type(qtensorc), intent(inout) :: Ket
logical, intent(in) :: leftmost
type(qtensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensorc) :: Tens
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call contr(Mat, Bra, Ket, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_left_state_qtensorc: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1 : Tens_{i,m,k} = Mat_{i,j} Ket_{j,m,k}
if(present(Matin)) then
call contr(Tens, Matin, Ket, [2], [1], errst=errst)
else
call contr(Tens, Mat, Ket, [2], [1], errst=errst)
end if
!if(prop_error('ptm_right_state_qtensorc: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{l,k} = Bra_{i,m,l}* Tens_{i,m,k}
call contr(Mat, Bra, Tens, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_right_state_qtensorc: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_right_state_qtensor_qtensorc
"""
return
[docs]def ptm_right_state_qtensorc_qtensor():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the left to the right. This
version is for states.
**Arguments**
Mat : TYPE(qtensorc), inout
This is the transfer matrix left of Bra and Ket.
Bra : TYPE(qtensorc), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(qtensorc), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
leftmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(qtensorc), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\\ast}`.
This is executed in two steps. This is the rightmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_state_qtensorc_qtensor(Mat, Bra, Ket, &
leftmost, Matin, errst)
type(qtensorc), intent(inout) :: Mat
type(qtensorc), intent(inout) :: Bra
type(qtensor), intent(inout) :: Ket
logical, intent(in) :: leftmost
type(qtensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensorc) :: Tens
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call contr(Mat, Bra, Ket, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_left_state_qtensorc: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1 : Tens_{i,m,k} = Mat_{i,j} Ket_{j,m,k}
if(present(Matin)) then
call contr(Tens, Matin, Ket, [2], [1], errst=errst)
else
call contr(Tens, Mat, Ket, [2], [1], errst=errst)
end if
!if(prop_error('ptm_right_state_qtensorc: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{l,k} = Bra_{i,m,l}* Tens_{i,m,k}
call contr(Mat, Bra, Tens, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_right_state_qtensorc: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_right_state_qtensorc_qtensor
"""
return
[docs]def ptm_right_state_qtensorc_qtensorc():
"""
fortran-subroutine - June 2017 (dj, updated)
Propagate transfer matrix (PTM) moving from the left to the right. This
version is for states.
**Arguments**
Mat : TYPE(qtensorc), inout
This is the transfer matrix left of Bra and Ket.
Bra : TYPE(qtensorc), inout
Contract conjagated of Bra into the transfer matrix. Intent
inout is for contraction, but should used.
Ket : TYPE(qtensorc), inout
Contract Ket into the transfer matrix. Intent inout is for
contraction, but should used.
leftmost : LOGICAL, in
Indicate if this is the rightmost, and therefore first site,
to be contracted.
Matin : TYPE(qtensorc), OPTIONAL, in
If Matin is present, Matin is the present transfer matrix.
It is not destroyed. If not present, Mat is assumed to be
the present transfer matrix and is overwritten with the new
one.
**Details**
The contraction is over both indices of Mat and can be
written as
:math:`Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\\ast}`.
This is executed in two steps. This is the rightmoving version.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_state_qtensorc_qtensorc(Mat, Bra, Ket, &
leftmost, Matin, errst)
type(qtensorc), intent(inout) :: Mat
type(qtensorc), intent(inout) :: Bra
type(qtensorc), intent(inout) :: Ket
logical, intent(in) :: leftmost
type(qtensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensorc) :: Tens
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call contr(Mat, Bra, Ket, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_left_state_qtensorc: init failed.', &
! errst=errst)) return
return
end if
! Real transfer matrix
! --------------------
! Step 1 : Tens_{i,m,k} = Mat_{i,j} Ket_{j,m,k}
if(present(Matin)) then
call contr(Tens, Matin, Ket, [2], [1], errst=errst)
else
call contr(Tens, Mat, Ket, [2], [1], errst=errst)
end if
!if(prop_error('ptm_right_state_qtensorc: contr I failed.', &
! errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2: Mat_{l,k} = Bra_{i,m,l}* Tens_{i,m,k}
call contr(Mat, Bra, Tens, [1, 2], [1, 2], transl='C', errst=errst)
!if(prop_error('ptm_right_state_qtensorc: contr II failed.', &
! errst=errst)) return
call destroy(Tens)
end subroutine ptm_right_state_qtensorc_qtensorc
"""
return
[docs]def randomize_mps():
"""
fortran-subroutine - June 2017 (dj, updated)
Fill the MPS Psi with random numbers
**Arguments**
Psi : TYPE(mps), inout
Fill the MPS with random numbers. The orthogonality center is not
installed during this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_mps(Psi)
type(mps) :: psi
! Local variables
! ---------------
! for looping
integer :: ii
Psi%oc = -1
Psi%can = 'o'
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) call destroy(Psi%Lambda(ii))
end do
Psi%haslambda = .false.
do ii = 1, Psi%ll
call randomize(Psi%Aa(ii))
end do
end subroutine randomize_mps
"""
return
[docs]def randomize_mpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Fill the MPS Psi with random numbers
**Arguments**
Psi : TYPE(mpsc), inout
Fill the MPS with random numbers. The orthogonality center is not
installed during this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_mpsc(Psi)
type(mpsc) :: psi
! Local variables
! ---------------
! for looping
integer :: ii
Psi%oc = -1
Psi%can = 'o'
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) call destroy(Psi%Lambda(ii))
end do
Psi%haslambda = .false.
do ii = 1, Psi%ll
call randomize(Psi%Aa(ii))
end do
end subroutine randomize_mpsc
"""
return
[docs]def randomize_qmps():
"""
fortran-subroutine - June 2017 (dj, updated)
Fill the MPS Psi with random numbers
**Arguments**
Psi : TYPE(qmps), inout
Fill the MPS with random numbers. The orthogonality center is not
installed during this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_qmps(Psi)
type(qmps) :: psi
! Local variables
! ---------------
! for looping
integer :: ii
Psi%oc = -1
Psi%can = 'o'
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) call destroy(Psi%Lambda(ii))
end do
Psi%haslambda = .false.
do ii = 1, Psi%ll
call randomize(Psi%Aa(ii))
end do
end subroutine randomize_qmps
"""
return
[docs]def randomize_qmpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Fill the MPS Psi with random numbers
**Arguments**
Psi : TYPE(qmpsc), inout
Fill the MPS with random numbers. The orthogonality center is not
installed during this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_qmpsc(Psi)
type(qmpsc) :: psi
! Local variables
! ---------------
! for looping
integer :: ii
Psi%oc = -1
Psi%can = 'o'
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) call destroy(Psi%Lambda(ii))
end do
Psi%haslambda = .false.
do ii = 1, Psi%ll
call randomize(Psi%Aa(ii))
end do
end subroutine randomize_qmpsc
"""
return
[docs]def read_mps():
"""
fortran-subroutine - June 2016 (dj, updated)
Read an MPS given a filename and a unit (assuming you know the type already).
**Arguments**
Psi : TYPE(mps), in
Read MPS in file to this MPS
flnm : CHARACTER(100), in
the MPS is stored in this file.
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B') or human readable ('H')
skip : LOGICAL, OPTIONAL, in
.true. : the first two lines were already read somewhere. Do not read
them here (those lines contain the information about the type of the
MPS in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read MPS; 1 : type of MPS does not correspond type of the MPS
in the file (only checked for skip1st2=false).
closeunit : LOGICAL, OPTIONAL, in
Flag if the unit should be closed on exit. Default to true.
**Details**
The file for MPS has the general form defined as below. Following
these rules, it is possible to provide states to OpenMPS.
* logical if MPS is real or complex valued (real=True, complex=False)
[line 1]
* logical if MPS or qMPS (qMPS=True, non-symmetry MPS=False) [line 2]
* integer with number of size [line 3]
* integer with position of the orthogonality center [line 4]
* "H" : in a loop over the pairs of `haslambda` and `can` are written
in `l` lines. "B" : the array of `can` is read, then `haslambda`.
* In a loop over the sites of the system, the tensors of the MPS are written.
The way how to write the tensors is specified in the corresponding
subroutine.
* Depending on the value of `haslambda`, read the vector (vectorlist) with
the corresponding subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_mps(Psi, flnm, unit, form, skip, closeunit, errst)
type(mps), intent(out) :: Psi
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
logical, intent(in), optional :: skip, closeunit
integer, intent(out), optional :: errst
! Local variables
! ---------------
! set the type of the MPS
logical :: is_real, is_q
! duplette for optional arguments
logical :: skip_
! for looping
integer :: ii
!if(present(errst)) errst = 0
if(present(skip)) then
skip_ = skip
else
skip_ = .false.
end if
if(form == 'H') then
! Read the formatted file
! -----------------------
if(.not. skip_) then
open(UNIT=unit, FILE=trim(flnm), ACTION='read')
read(unit, *) is_real
read(unit, *) is_q
if((is_real .eqv. .true.) .and. &
(is_q .eqv. .false.)) then
! Everything is ok
else
!errst = raise_error('read_mps: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
! Read length and orthogonality center
read(unit, *) Psi%ll
read(unit, *) Psi%oc
allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
Psi%Lambda(Psi%ll + 1))
! Read the canonization toghether with the haslambda
do ii = 1, Psi%ll
read(unit, *) Psi%can(ii), Psi%haslambda(ii)
end do
read(unit, *) Psi%haslambda(Psi%ll + 1)
! Read the tensors of the MPS
do ii = 1, Psi%ll
call read(Psi%Aa(ii), unit, form)
end do
! Read the values of the lambda
do ii = 1, Psi%ll
if(Psi%haslambda(ii)) then
call read(Psi%Lambda(ii), unit, form)
end if
end do
elseif(form == 'B') then
! Read from the binary file
! -------------------------
if(.not. skip_) then
open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
FORM='unformatted')
read(unit) is_real
read(unit) is_q
if((is_real .eqv. .true.) .and. &
(is_q .eqv. .false.)) then
! Everything is ok
else
!errst = raise_error('read_mps: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
! Read length and orthogonality center
read(unit) Psi%ll
read(unit) Psi%oc
allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
Psi%Lambda(Psi%ll + 1))
! Read the canonization and the haslambda as array
read(unit) Psi%can
read(unit) Psi%haslambda
! Read all the tensors
do ii = 1, Psi%ll
call read(Psi%Aa(ii), unit, form)
end do
! Read the lambdas
do ii = 1, Psi%ll
if(Psi%haslambda(ii)) then
call read(Psi%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('read_mps: unallowed formatting.', &
! 99, 'MPSOps_include.f90:2755', errst=errst)
return
end if
if(present(closeunit)) then
if(closeunit) then
close(unit)
end if
else
close(unit)
end if
end subroutine read_mps
"""
return
[docs]def read_mpsc():
"""
fortran-subroutine - June 2016 (dj, updated)
Read an MPS given a filename and a unit (assuming you know the type already).
**Arguments**
Psi : TYPE(mpsc), in
Read MPS in file to this MPS
flnm : CHARACTER(100), in
the MPS is stored in this file.
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B') or human readable ('H')
skip : LOGICAL, OPTIONAL, in
.true. : the first two lines were already read somewhere. Do not read
them here (those lines contain the information about the type of the
MPS in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read MPS; 1 : type of MPS does not correspond type of the MPS
in the file (only checked for skip1st2=false).
closeunit : LOGICAL, OPTIONAL, in
Flag if the unit should be closed on exit. Default to true.
**Details**
The file for MPS has the general form defined as below. Following
these rules, it is possible to provide states to OpenMPS.
* logical if MPS is real or complex valued (real=True, complex=False)
[line 1]
* logical if MPS or qMPS (qMPS=True, non-symmetry MPS=False) [line 2]
* integer with number of size [line 3]
* integer with position of the orthogonality center [line 4]
* "H" : in a loop over the pairs of `haslambda` and `can` are written
in `l` lines. "B" : the array of `can` is read, then `haslambda`.
* In a loop over the sites of the system, the tensors of the MPS are written.
The way how to write the tensors is specified in the corresponding
subroutine.
* Depending on the value of `haslambda`, read the vector (vectorlist) with
the corresponding subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_mpsc(Psi, flnm, unit, form, skip, closeunit, errst)
type(mpsc), intent(out) :: Psi
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
logical, intent(in), optional :: skip, closeunit
integer, intent(out), optional :: errst
! Local variables
! ---------------
! set the type of the MPS
logical :: is_real, is_q
! duplette for optional arguments
logical :: skip_
! for looping
integer :: ii
!if(present(errst)) errst = 0
if(present(skip)) then
skip_ = skip
else
skip_ = .false.
end if
if(form == 'H') then
! Read the formatted file
! -----------------------
if(.not. skip_) then
open(UNIT=unit, FILE=trim(flnm), ACTION='read')
read(unit, *) is_real
read(unit, *) is_q
if((is_real .eqv. .false.) .and. &
(is_q .eqv. .false.)) then
! Everything is ok
else
!errst = raise_error('read_mpsc: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
! Read length and orthogonality center
read(unit, *) Psi%ll
read(unit, *) Psi%oc
allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
Psi%Lambda(Psi%ll + 1))
! Read the canonization toghether with the haslambda
do ii = 1, Psi%ll
read(unit, *) Psi%can(ii), Psi%haslambda(ii)
end do
read(unit, *) Psi%haslambda(Psi%ll + 1)
! Read the tensors of the MPS
do ii = 1, Psi%ll
call read(Psi%Aa(ii), unit, form)
end do
! Read the values of the lambda
do ii = 1, Psi%ll
if(Psi%haslambda(ii)) then
call read(Psi%Lambda(ii), unit, form)
end if
end do
elseif(form == 'B') then
! Read from the binary file
! -------------------------
if(.not. skip_) then
open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
FORM='unformatted')
read(unit) is_real
read(unit) is_q
if((is_real .eqv. .false.) .and. &
(is_q .eqv. .false.)) then
! Everything is ok
else
!errst = raise_error('read_mpsc: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
! Read length and orthogonality center
read(unit) Psi%ll
read(unit) Psi%oc
allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
Psi%Lambda(Psi%ll + 1))
! Read the canonization and the haslambda as array
read(unit) Psi%can
read(unit) Psi%haslambda
! Read all the tensors
do ii = 1, Psi%ll
call read(Psi%Aa(ii), unit, form)
end do
! Read the lambdas
do ii = 1, Psi%ll
if(Psi%haslambda(ii)) then
call read(Psi%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('read_mpsc: unallowed formatting.', &
! 99, 'MPSOps_include.f90:2755', errst=errst)
return
end if
if(present(closeunit)) then
if(closeunit) then
close(unit)
end if
else
close(unit)
end if
end subroutine read_mpsc
"""
return
[docs]def read_qmps():
"""
fortran-subroutine - June 2016 (dj, updated)
Read an MPS given a filename and a unit (assuming you know the type already).
**Arguments**
Psi : TYPE(qmps), in
Read MPS in file to this MPS
flnm : CHARACTER(100), in
the MPS is stored in this file.
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B') or human readable ('H')
skip : LOGICAL, OPTIONAL, in
.true. : the first two lines were already read somewhere. Do not read
them here (those lines contain the information about the type of the
MPS in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read MPS; 1 : type of MPS does not correspond type of the MPS
in the file (only checked for skip1st2=false).
closeunit : LOGICAL, OPTIONAL, in
Flag if the unit should be closed on exit. Default to true.
**Details**
The file for MPS has the general form defined as below. Following
these rules, it is possible to provide states to OpenMPS.
* logical if MPS is real or complex valued (real=True, complex=False)
[line 1]
* logical if MPS or qMPS (qMPS=True, non-symmetry MPS=False) [line 2]
* integer with number of size [line 3]
* integer with position of the orthogonality center [line 4]
* "H" : in a loop over the pairs of `haslambda` and `can` are written
in `l` lines. "B" : the array of `can` is read, then `haslambda`.
* In a loop over the sites of the system, the tensors of the MPS are written.
The way how to write the tensors is specified in the corresponding
subroutine.
* Depending on the value of `haslambda`, read the vector (vectorlist) with
the corresponding subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qmps(Psi, flnm, unit, form, skip, closeunit, errst)
type(qmps), intent(out) :: Psi
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
logical, intent(in), optional :: skip, closeunit
integer, intent(out), optional :: errst
! Local variables
! ---------------
! set the type of the MPS
logical :: is_real, is_q
! duplette for optional arguments
logical :: skip_
! for looping
integer :: ii
!if(present(errst)) errst = 0
if(present(skip)) then
skip_ = skip
else
skip_ = .false.
end if
if(form == 'H') then
! Read the formatted file
! -----------------------
if(.not. skip_) then
open(UNIT=unit, FILE=trim(flnm), ACTION='read')
read(unit, *) is_real
read(unit, *) is_q
if((is_real .eqv. .true.) .and. &
(is_q .eqv. .true.)) then
! Everything is ok
else
!errst = raise_error('read_qmps: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
! Read length and orthogonality center
read(unit, *) Psi%ll
read(unit, *) Psi%oc
allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
Psi%Lambda(Psi%ll + 1))
! Read the canonization toghether with the haslambda
do ii = 1, Psi%ll
read(unit, *) Psi%can(ii), Psi%haslambda(ii)
end do
read(unit, *) Psi%haslambda(Psi%ll + 1)
! Read the tensors of the MPS
do ii = 1, Psi%ll
call read(Psi%Aa(ii), unit, form)
end do
! Read the values of the lambda
do ii = 1, Psi%ll
if(Psi%haslambda(ii)) then
call read(Psi%Lambda(ii), unit, form)
end if
end do
elseif(form == 'B') then
! Read from the binary file
! -------------------------
if(.not. skip_) then
open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
FORM='unformatted')
read(unit) is_real
read(unit) is_q
if((is_real .eqv. .true.) .and. &
(is_q .eqv. .true.)) then
! Everything is ok
else
!errst = raise_error('read_qmps: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
! Read length and orthogonality center
read(unit) Psi%ll
read(unit) Psi%oc
allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
Psi%Lambda(Psi%ll + 1))
! Read the canonization and the haslambda as array
read(unit) Psi%can
read(unit) Psi%haslambda
! Read all the tensors
do ii = 1, Psi%ll
call read(Psi%Aa(ii), unit, form)
end do
! Read the lambdas
do ii = 1, Psi%ll
if(Psi%haslambda(ii)) then
call read(Psi%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('read_qmps: unallowed formatting.', &
! 99, 'MPSOps_include.f90:2755', errst=errst)
return
end if
if(present(closeunit)) then
if(closeunit) then
close(unit)
end if
else
close(unit)
end if
end subroutine read_qmps
"""
return
[docs]def read_qmpsc():
"""
fortran-subroutine - June 2016 (dj, updated)
Read an MPS given a filename and a unit (assuming you know the type already).
**Arguments**
Psi : TYPE(qmpsc), in
Read MPS in file to this MPS
flnm : CHARACTER(100), in
the MPS is stored in this file.
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B') or human readable ('H')
skip : LOGICAL, OPTIONAL, in
.true. : the first two lines were already read somewhere. Do not read
them here (those lines contain the information about the type of the
MPS in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read MPS; 1 : type of MPS does not correspond type of the MPS
in the file (only checked for skip1st2=false).
closeunit : LOGICAL, OPTIONAL, in
Flag if the unit should be closed on exit. Default to true.
**Details**
The file for MPS has the general form defined as below. Following
these rules, it is possible to provide states to OpenMPS.
* logical if MPS is real or complex valued (real=True, complex=False)
[line 1]
* logical if MPS or qMPS (qMPS=True, non-symmetry MPS=False) [line 2]
* integer with number of size [line 3]
* integer with position of the orthogonality center [line 4]
* "H" : in a loop over the pairs of `haslambda` and `can` are written
in `l` lines. "B" : the array of `can` is read, then `haslambda`.
* In a loop over the sites of the system, the tensors of the MPS are written.
The way how to write the tensors is specified in the corresponding
subroutine.
* Depending on the value of `haslambda`, read the vector (vectorlist) with
the corresponding subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qmpsc(Psi, flnm, unit, form, skip, closeunit, errst)
type(qmpsc), intent(out) :: Psi
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
logical, intent(in), optional :: skip, closeunit
integer, intent(out), optional :: errst
! Local variables
! ---------------
! set the type of the MPS
logical :: is_real, is_q
! duplette for optional arguments
logical :: skip_
! for looping
integer :: ii
!if(present(errst)) errst = 0
if(present(skip)) then
skip_ = skip
else
skip_ = .false.
end if
if(form == 'H') then
! Read the formatted file
! -----------------------
if(.not. skip_) then
open(UNIT=unit, FILE=trim(flnm), ACTION='read')
read(unit, *) is_real
read(unit, *) is_q
if((is_real .eqv. .false.) .and. &
(is_q .eqv. .true.)) then
! Everything is ok
else
!errst = raise_error('read_qmpsc: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
! Read length and orthogonality center
read(unit, *) Psi%ll
read(unit, *) Psi%oc
allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
Psi%Lambda(Psi%ll + 1))
! Read the canonization toghether with the haslambda
do ii = 1, Psi%ll
read(unit, *) Psi%can(ii), Psi%haslambda(ii)
end do
read(unit, *) Psi%haslambda(Psi%ll + 1)
! Read the tensors of the MPS
do ii = 1, Psi%ll
call read(Psi%Aa(ii), unit, form)
end do
! Read the values of the lambda
do ii = 1, Psi%ll
if(Psi%haslambda(ii)) then
call read(Psi%Lambda(ii), unit, form)
end if
end do
elseif(form == 'B') then
! Read from the binary file
! -------------------------
if(.not. skip_) then
open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
FORM='unformatted')
read(unit) is_real
read(unit) is_q
if((is_real .eqv. .false.) .and. &
(is_q .eqv. .true.)) then
! Everything is ok
else
!errst = raise_error('read_qmpsc: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
! Read length and orthogonality center
read(unit) Psi%ll
read(unit) Psi%oc
allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
Psi%Lambda(Psi%ll + 1))
! Read the canonization and the haslambda as array
read(unit) Psi%can
read(unit) Psi%haslambda
! Read all the tensors
do ii = 1, Psi%ll
call read(Psi%Aa(ii), unit, form)
end do
! Read the lambdas
do ii = 1, Psi%ll
if(Psi%haslambda(ii)) then
call read(Psi%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('read_qmpsc: unallowed formatting.', &
! 99, 'MPSOps_include.f90:2755', errst=errst)
return
end if
if(present(closeunit)) then
if(closeunit) then
close(unit)
end if
else
close(unit)
end if
end subroutine read_qmpsc
"""
return
[docs]def read_allmps():
"""
fortran-subroutine - June 2017 (dj, updated)
Read MPS from file if you do not know what kind of MPS is saved.
**Arguments**
Psi : TYPE(mps), out
On exit set if MPS representing Psi is real and
has no symmetries.
Psic : TYPE(mpsc), out
On exit set if MPS representing Psi is complex and
has no symmetries.
Psiq : TYPE(qmps), out
On exit set if MPS representing is real and
has symmetries.
Psiqc : TYPE(qmpsc), out
On exit set if MPS representing is complex and
has symmetries.
flag : INTEGER, out
0: reading real MPS, 1: complex MPS, 2: real symmetric MPS,
3: complex symmetric MPS
flnm : CHARACTER(100), in
the MPS is stored in this file.
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B') or human readable ('H')
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_allmps(Psi, Psic, Psiq, Psicq, flag, flnm, unit, form, &
errst)
type(mps), intent(out) :: Psi
type(mpsc), intent(out) :: Psic
type(qmps), intent(out) :: Psiq
type(qmpsc), intent(out) :: Psicq
integer, intent(out) :: flag
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! local variables
! ---------------
! set the type of the MPS
logical :: is_real, is_q
!if(present(errst)) errst = 0
if(form == 'H') then
! Read the formatted file
! -----------------------
open(UNIT=unit, FILE=trim(flnm), ACTION='read')
! Figure out what kind of MPS we need
read(unit, *) is_real
read(unit, *) is_q
elseif(form == 'B') then
! Read from the binary file
open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
FORM='unformatted')
! Figure out what kind of MPS we need
read(unit) is_real
read(unit) is_q
else
!errst = raise_error('read_MPS_TYPE: unallowed formatting.', &
! 99, errst=errst)
return
end if
if(is_real .and. (.not. is_q)) then
! Real (no symmetries)
flag = 0
call read(Psi, flnm, unit, form, skip=.true., errst=errst)
elseif(.not. is_q) then
! Complex (no symmetries)
flag = 1
call read(Psic, flnm, unit, form, skip=.true., errst=errst)
elseif(is_real) then
! Real and symmetry conservation
flag = 2
call read(Psiq, flnm, unit, form, skip=.true., errst=errst)
else
! Complex and symmetry conservation
flag = 3
call read(Psicq, flnm, unit, form, skip=.true., errst=errst)
end if
!if(prop_error('real_allmps: read failed', errst=errst)) return
end subroutine read_allmps
"""
return
[docs]def rho_block_mps():
"""
fortran-subroutine - June 2018 (dj)
Internal subroutine to build the reduced density matrix of a continuous
block of sites.
**Arguments**
Rho : TYPE(tensor), out
On exit the reduced density matrix with the sites specified.
The first half of the indices corresponds to the kets on each
site. The second half corresponds to the bra-indices.
Psi : TYPE(mps), inout
Pure state to build density matrix from. Intent(inout) to shift
orthogonality center.
k1 : INTEGER, in
First site of the subsystem.
k2 : INTEGER, in
Last site of the subsystem.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_block_mps(Rho, Psi, k1, k2, errst)
type(tensor), intent(out) :: Rho
type(mps), intent(inout) :: Psi
integer, intent(in) :: k1, k2
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! keep track of index to be contraced
integer :: idx
! Temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(Psi%oc < k1) then
call canonize(Psi, k1, errst=errst)
elseif(Psi%oc > k2) then
call canonize(Psi, k2, errst=errst)
end if
!if(prop_error('rho_block_mps : canonize failed.', &
! 'MPSOps_include.f90:2970', errst=errst)) return
call contr(Tmpa, Psi%Aa(k1), Psi%Aa(k1 + 1), [3], [1], errst=errst)
!if(prop_error('rho_block_mps : contr failed.', &
! 'MPSOps_include.f90:2974', errst=errst)) return
idx = 4
do ii = (k1 + 2), k2
call contr(Tmpb, Tmpa, Psi%Aa(ii), [idx], [1], errst=errst)
!if(prop_error('rho_block_mps : contr failed.', &
! 'MPSOps_include.f90:2981', errst=errst)) return
call destroy(Tmpa)
call pointto(Tmpa, Tmpb)
idx = idx + 1
end do
call copy(Tmpb, Tmpa, trans='C')
call contr(Rho, Tmpa, Tmpb, [1, idx], [1, idx], errst=errst)
!if(prop_error('rho_block_mps : contr failed.', &
! 'MPSOps_include.f90:2993', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine rho_block_mps
"""
return
[docs]def rho_block_mpsc():
"""
fortran-subroutine - June 2018 (dj)
Internal subroutine to build the reduced density matrix of a continuous
block of sites.
**Arguments**
Rho : TYPE(tensorc), out
On exit the reduced density matrix with the sites specified.
The first half of the indices corresponds to the kets on each
site. The second half corresponds to the bra-indices.
Psi : TYPE(mpsc), inout
Pure state to build density matrix from. Intent(inout) to shift
orthogonality center.
k1 : INTEGER, in
First site of the subsystem.
k2 : INTEGER, in
Last site of the subsystem.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_block_mpsc(Rho, Psi, k1, k2, errst)
type(tensorc), intent(out) :: Rho
type(mpsc), intent(inout) :: Psi
integer, intent(in) :: k1, k2
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! keep track of index to be contraced
integer :: idx
! Temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(Psi%oc < k1) then
call canonize(Psi, k1, errst=errst)
elseif(Psi%oc > k2) then
call canonize(Psi, k2, errst=errst)
end if
!if(prop_error('rho_block_mpsc : canonize failed.', &
! 'MPSOps_include.f90:2970', errst=errst)) return
call contr(Tmpa, Psi%Aa(k1), Psi%Aa(k1 + 1), [3], [1], errst=errst)
!if(prop_error('rho_block_mpsc : contr failed.', &
! 'MPSOps_include.f90:2974', errst=errst)) return
idx = 4
do ii = (k1 + 2), k2
call contr(Tmpb, Tmpa, Psi%Aa(ii), [idx], [1], errst=errst)
!if(prop_error('rho_block_mpsc : contr failed.', &
! 'MPSOps_include.f90:2981', errst=errst)) return
call destroy(Tmpa)
call pointto(Tmpa, Tmpb)
idx = idx + 1
end do
call copy(Tmpb, Tmpa, trans='C')
call contr(Rho, Tmpa, Tmpb, [1, idx], [1, idx], errst=errst)
!if(prop_error('rho_block_mpsc : contr failed.', &
! 'MPSOps_include.f90:2993', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine rho_block_mpsc
"""
return
[docs]def rho_block_qmps():
"""
fortran-subroutine - June 2018 (dj)
Internal subroutine to build the reduced density matrix of a continuous
block of sites.
**Arguments**
Rho : TYPE(qtensor), out
On exit the reduced density matrix with the sites specified.
The first half of the indices corresponds to the kets on each
site. The second half corresponds to the bra-indices.
Psi : TYPE(qmps), inout
Pure state to build density matrix from. Intent(inout) to shift
orthogonality center.
k1 : INTEGER, in
First site of the subsystem.
k2 : INTEGER, in
Last site of the subsystem.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_block_qmps(Rho, Psi, k1, k2, errst)
type(qtensor), intent(out) :: Rho
type(qmps), intent(inout) :: Psi
integer, intent(in) :: k1, k2
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! keep track of index to be contraced
integer :: idx
! Temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(Psi%oc < k1) then
call canonize(Psi, k1, errst=errst)
elseif(Psi%oc > k2) then
call canonize(Psi, k2, errst=errst)
end if
!if(prop_error('rho_block_qmps : canonize failed.', &
! 'MPSOps_include.f90:2970', errst=errst)) return
call contr(Tmpa, Psi%Aa(k1), Psi%Aa(k1 + 1), [3], [1], errst=errst)
!if(prop_error('rho_block_qmps : contr failed.', &
! 'MPSOps_include.f90:2974', errst=errst)) return
idx = 4
do ii = (k1 + 2), k2
call contr(Tmpb, Tmpa, Psi%Aa(ii), [idx], [1], errst=errst)
!if(prop_error('rho_block_qmps : contr failed.', &
! 'MPSOps_include.f90:2981', errst=errst)) return
call destroy(Tmpa)
call pointto(Tmpa, Tmpb)
idx = idx + 1
end do
call copy(Tmpb, Tmpa, trans='C')
call contr(Rho, Tmpa, Tmpb, [1, idx], [1, idx], errst=errst)
!if(prop_error('rho_block_qmps : contr failed.', &
! 'MPSOps_include.f90:2993', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine rho_block_qmps
"""
return
[docs]def rho_block_qmpsc():
"""
fortran-subroutine - June 2018 (dj)
Internal subroutine to build the reduced density matrix of a continuous
block of sites.
**Arguments**
Rho : TYPE(qtensorc), out
On exit the reduced density matrix with the sites specified.
The first half of the indices corresponds to the kets on each
site. The second half corresponds to the bra-indices.
Psi : TYPE(qmpsc), inout
Pure state to build density matrix from. Intent(inout) to shift
orthogonality center.
k1 : INTEGER, in
First site of the subsystem.
k2 : INTEGER, in
Last site of the subsystem.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_block_qmpsc(Rho, Psi, k1, k2, errst)
type(qtensorc), intent(out) :: Rho
type(qmpsc), intent(inout) :: Psi
integer, intent(in) :: k1, k2
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! keep track of index to be contraced
integer :: idx
! Temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(Psi%oc < k1) then
call canonize(Psi, k1, errst=errst)
elseif(Psi%oc > k2) then
call canonize(Psi, k2, errst=errst)
end if
!if(prop_error('rho_block_qmpsc : canonize failed.', &
! 'MPSOps_include.f90:2970', errst=errst)) return
call contr(Tmpa, Psi%Aa(k1), Psi%Aa(k1 + 1), [3], [1], errst=errst)
!if(prop_error('rho_block_qmpsc : contr failed.', &
! 'MPSOps_include.f90:2974', errst=errst)) return
idx = 4
do ii = (k1 + 2), k2
call contr(Tmpb, Tmpa, Psi%Aa(ii), [idx], [1], errst=errst)
!if(prop_error('rho_block_qmpsc : contr failed.', &
! 'MPSOps_include.f90:2981', errst=errst)) return
call destroy(Tmpa)
call pointto(Tmpa, Tmpb)
idx = idx + 1
end do
call copy(Tmpb, Tmpa, trans='C')
call contr(Rho, Tmpa, Tmpb, [1, idx], [1, idx], errst=errst)
!if(prop_error('rho_block_qmpsc : contr failed.', &
! 'MPSOps_include.f90:2993', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine rho_block_qmpsc
"""
return
[docs]def rho_kk_mps():
"""
fortran-subroutine - July 2017 (dj)
Calculate the reduced density matrix represented as tensor.
**Arguments**
Rho : TYPE(tensor), out
The density matrix is stored in this tensor
Psi : TYPE(mps), in
Calculate reduced density matrix for this MPS.
kk : INTEGER, in
Select site where reduced density matrix should be
calculated. It must be the orthogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_kk_mps(Rho, Psi, kk, errst)
type(tensor), intent(out) :: Rho
type(mps), intent(in) :: Psi
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor needed for permutation
type(tensor) :: Tmp, Tmpb
!if(present(errst)) errst = 0
call copy(Tmp, Psi%Aa(kk))
call transposed(Tmp, [1, 3, 2], doperm=.true., errst=errst)
!if(prop_error('rho_kk_mps: transpose failed', &
! errst=errst)) return
call copy(Tmpb, Tmp, trans='C')
call contr(Rho, Tmp, Tmpb, [1, 2], [1, 2])
call destroy(Tmp)
call destroy(Tmpb)
! Set hashes for rho
!call set_hash(Rho, [1])
!call sort(Rho)
end subroutine rho_kk_mps
"""
return
[docs]def rho_kk_mpsc():
"""
fortran-subroutine - July 2017 (dj)
Calculate the reduced density matrix represented as tensor.
**Arguments**
Rho : TYPE(tensorc), out
The density matrix is stored in this tensor
Psi : TYPE(mpsc), in
Calculate reduced density matrix for this MPS.
kk : INTEGER, in
Select site where reduced density matrix should be
calculated. It must be the orthogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_kk_mpsc(Rho, Psi, kk, errst)
type(tensorc), intent(out) :: Rho
type(mpsc), intent(in) :: Psi
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor needed for permutation
type(tensorc) :: Tmp, Tmpb
!if(present(errst)) errst = 0
call copy(Tmp, Psi%Aa(kk))
call transposed(Tmp, [1, 3, 2], doperm=.true., errst=errst)
!if(prop_error('rho_kk_mpsc: transpose failed', &
! errst=errst)) return
call copy(Tmpb, Tmp, trans='C')
call contr(Rho, Tmp, Tmpb, [1, 2], [1, 2])
call destroy(Tmp)
call destroy(Tmpb)
! Set hashes for rho
!call set_hash(Rho, [1])
!call sort(Rho)
end subroutine rho_kk_mpsc
"""
return
[docs]def rho_kk_qmps():
"""
fortran-subroutine - July 2017 (dj)
Calculate the reduced density matrix represented as tensor.
**Arguments**
Rho : TYPE(qtensor), out
The density matrix is stored in this tensor
Psi : TYPE(qmps), in
Calculate reduced density matrix for this MPS.
kk : INTEGER, in
Select site where reduced density matrix should be
calculated. It must be the orthogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_kk_qmps(Rho, Psi, kk, errst)
type(qtensor), intent(out) :: Rho
type(qmps), intent(in) :: Psi
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor needed for permutation
type(qtensor) :: Tmp, Tmpb
!if(present(errst)) errst = 0
call copy(Tmp, Psi%Aa(kk))
call transposed(Tmp, [1, 3, 2], doperm=.true., errst=errst)
!if(prop_error('rho_kk_qmps: transpose failed', &
! errst=errst)) return
call copy(Tmpb, Tmp, trans='C')
call contr(Rho, Tmp, Tmpb, [1, 2], [1, 2])
call destroy(Tmp)
call destroy(Tmpb)
! Set hashes for rho
call set_hash(Rho, [1])
call sort(Rho)
end subroutine rho_kk_qmps
"""
return
[docs]def rho_kk_qmpsc():
"""
fortran-subroutine - July 2017 (dj)
Calculate the reduced density matrix represented as tensor.
**Arguments**
Rho : TYPE(qtensorc), out
The density matrix is stored in this tensor
Psi : TYPE(qmpsc), in
Calculate reduced density matrix for this MPS.
kk : INTEGER, in
Select site where reduced density matrix should be
calculated. It must be the orthogonality center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_kk_qmpsc(Rho, Psi, kk, errst)
type(qtensorc), intent(out) :: Rho
type(qmpsc), intent(in) :: Psi
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor needed for permutation
type(qtensorc) :: Tmp, Tmpb
!if(present(errst)) errst = 0
call copy(Tmp, Psi%Aa(kk))
call transposed(Tmp, [1, 3, 2], doperm=.true., errst=errst)
!if(prop_error('rho_kk_qmpsc: transpose failed', &
! errst=errst)) return
call copy(Tmpb, Tmp, trans='C')
call contr(Rho, Tmp, Tmpb, [1, 2], [1, 2])
call destroy(Tmp)
call destroy(Tmpb)
! Set hashes for rho
call set_hash(Rho, [1])
call sort(Rho)
end subroutine rho_kk_qmpsc
"""
return
[docs]def rho_red_mps():
"""
fortran-subroutine - June 2018 (dj)
Build a general reduced density matrix on multiple sites.
**Arguments**
Rho : TYPE(tensor), out
On exit the reduced density matrix with the sites specified.
The first half of the indices corresponds to the kets on each
site. The second half corresponds to the bra-indices.
Psi : TYPE(mps), inout
Pure state to build density matrix from. Intent(inout) to shift
orthogonality center.
sites : INTEGER(\*), in
List of sites for the reduced density matrix.
cont : LOGICAL, in
Indicator if sites are one continuous block of indices (true)
or separated by indices to be traced out (false).
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
err : REAL, out
Truncation error for tracking it from calling routine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_red_mps(Rho, Psi, sites, cont, trunc, ncut, err, errst)
type(tensor), intent(out) :: Rho
type(mps), intent(inout) :: Psi
integer, dimension(:), intent(in) :: sites
logical, intent(in) :: cont
real(KIND=rKind), intent(in) :: trunc
integer, intent(in) :: ncut
real(KIND=rKind), intent(out) :: err
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping, indexing
integer :: ii, jj
! array for permutations and identifying partial trace indices
integer, dimension(:), allocatable :: ind
logical, dimension(:), allocatable :: ptind
! Copy of MPS for transposed (truncation might change state)
type(mps) :: Phi
!if(present(errst)) errst = 0
err = 0.0_rKind
if(cont) then
! Continuous block of sites - use corresponding method directly
! -------------------------------------------------------------
call rho_block_mps(Rho, Psi, sites(1), &
sites(size(sites, 1)), errst=errst)
!if(prop_error('rho_red_mps : rho_block failed.', &
! 'MPSOps_include.f90:3159', errst=errst)) return
else
! Permute first, then trace out
! -----------------------------
allocate(ind(Psi%ll), ptind(Psi%ll))
ptind = .true.
ptind(sites) = .false.
jj = size(sites, 1)
ind(:jj) = sites
do ii = 1, Psi%ll
if(ptind(ii)) then
jj = jj + 1
ind(jj) = ii
end if
end do
call copy(Phi, Psi)
call transposed(Phi, ind, trunc, ncut, err, errst=errst)
!if(prop_error('rho_red_mps : transposed failed.', &
! 'MPSOps_include.f90:3182', errst=errst)) return
jj = size(sites, 1)
call rho_block_mps(Rho, Phi, 1, jj, errst=errst)
!if(prop_error('rho_red_mps : rho_block failed.', &
! 'MPSOps_include.f90:3187', errst=errst)) return
deallocate(ind, ptind)
call destroy(Phi)
end if
end subroutine rho_red_mps
"""
return
[docs]def rho_red_mpsc():
"""
fortran-subroutine - June 2018 (dj)
Build a general reduced density matrix on multiple sites.
**Arguments**
Rho : TYPE(tensorc), out
On exit the reduced density matrix with the sites specified.
The first half of the indices corresponds to the kets on each
site. The second half corresponds to the bra-indices.
Psi : TYPE(mpsc), inout
Pure state to build density matrix from. Intent(inout) to shift
orthogonality center.
sites : INTEGER(\*), in
List of sites for the reduced density matrix.
cont : LOGICAL, in
Indicator if sites are one continuous block of indices (true)
or separated by indices to be traced out (false).
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
err : REAL, out
Truncation error for tracking it from calling routine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_red_mpsc(Rho, Psi, sites, cont, trunc, ncut, err, errst)
type(tensorc), intent(out) :: Rho
type(mpsc), intent(inout) :: Psi
integer, dimension(:), intent(in) :: sites
logical, intent(in) :: cont
real(KIND=rKind), intent(in) :: trunc
integer, intent(in) :: ncut
real(KIND=rKind), intent(out) :: err
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping, indexing
integer :: ii, jj
! array for permutations and identifying partial trace indices
integer, dimension(:), allocatable :: ind
logical, dimension(:), allocatable :: ptind
! Copy of MPS for transposed (truncation might change state)
type(mpsc) :: Phi
!if(present(errst)) errst = 0
err = 0.0_rKind
if(cont) then
! Continuous block of sites - use corresponding method directly
! -------------------------------------------------------------
call rho_block_mpsc(Rho, Psi, sites(1), &
sites(size(sites, 1)), errst=errst)
!if(prop_error('rho_red_mpsc : rho_block failed.', &
! 'MPSOps_include.f90:3159', errst=errst)) return
else
! Permute first, then trace out
! -----------------------------
allocate(ind(Psi%ll), ptind(Psi%ll))
ptind = .true.
ptind(sites) = .false.
jj = size(sites, 1)
ind(:jj) = sites
do ii = 1, Psi%ll
if(ptind(ii)) then
jj = jj + 1
ind(jj) = ii
end if
end do
call copy(Phi, Psi)
call transposed(Phi, ind, trunc, ncut, err, errst=errst)
!if(prop_error('rho_red_mpsc : transposed failed.', &
! 'MPSOps_include.f90:3182', errst=errst)) return
jj = size(sites, 1)
call rho_block_mpsc(Rho, Phi, 1, jj, errst=errst)
!if(prop_error('rho_red_mpsc : rho_block failed.', &
! 'MPSOps_include.f90:3187', errst=errst)) return
deallocate(ind, ptind)
call destroy(Phi)
end if
end subroutine rho_red_mpsc
"""
return
[docs]def rho_red_qmps():
"""
fortran-subroutine - June 2018 (dj)
Build a general reduced density matrix on multiple sites.
**Arguments**
Rho : TYPE(qtensor), out
On exit the reduced density matrix with the sites specified.
The first half of the indices corresponds to the kets on each
site. The second half corresponds to the bra-indices.
Psi : TYPE(qmps), inout
Pure state to build density matrix from. Intent(inout) to shift
orthogonality center.
sites : INTEGER(\*), in
List of sites for the reduced density matrix.
cont : LOGICAL, in
Indicator if sites are one continuous block of indices (true)
or separated by indices to be traced out (false).
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
err : REAL, out
Truncation error for tracking it from calling routine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_red_qmps(Rho, Psi, sites, cont, trunc, ncut, err, errst)
type(qtensor), intent(out) :: Rho
type(qmps), intent(inout) :: Psi
integer, dimension(:), intent(in) :: sites
logical, intent(in) :: cont
real(KIND=rKind), intent(in) :: trunc
integer, intent(in) :: ncut
real(KIND=rKind), intent(out) :: err
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping, indexing
integer :: ii, jj
! array for permutations and identifying partial trace indices
integer, dimension(:), allocatable :: ind
logical, dimension(:), allocatable :: ptind
! Copy of MPS for transposed (truncation might change state)
type(qmps) :: Phi
!if(present(errst)) errst = 0
err = 0.0_rKind
if(cont) then
! Continuous block of sites - use corresponding method directly
! -------------------------------------------------------------
call rho_block_qmps(Rho, Psi, sites(1), &
sites(size(sites, 1)), errst=errst)
!if(prop_error('rho_red_qmps : rho_block failed.', &
! 'MPSOps_include.f90:3159', errst=errst)) return
else
! Permute first, then trace out
! -----------------------------
allocate(ind(Psi%ll), ptind(Psi%ll))
ptind = .true.
ptind(sites) = .false.
jj = size(sites, 1)
ind(:jj) = sites
do ii = 1, Psi%ll
if(ptind(ii)) then
jj = jj + 1
ind(jj) = ii
end if
end do
call copy(Phi, Psi)
call transposed(Phi, ind, trunc, ncut, err, errst=errst)
!if(prop_error('rho_red_qmps : transposed failed.', &
! 'MPSOps_include.f90:3182', errst=errst)) return
jj = size(sites, 1)
call rho_block_qmps(Rho, Phi, 1, jj, errst=errst)
!if(prop_error('rho_red_qmps : rho_block failed.', &
! 'MPSOps_include.f90:3187', errst=errst)) return
deallocate(ind, ptind)
call destroy(Phi)
end if
end subroutine rho_red_qmps
"""
return
[docs]def rho_red_qmpsc():
"""
fortran-subroutine - June 2018 (dj)
Build a general reduced density matrix on multiple sites.
**Arguments**
Rho : TYPE(qtensorc), out
On exit the reduced density matrix with the sites specified.
The first half of the indices corresponds to the kets on each
site. The second half corresponds to the bra-indices.
Psi : TYPE(qmpsc), inout
Pure state to build density matrix from. Intent(inout) to shift
orthogonality center.
sites : INTEGER(\*), in
List of sites for the reduced density matrix.
cont : LOGICAL, in
Indicator if sites are one continuous block of indices (true)
or separated by indices to be traced out (false).
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
err : REAL, out
Truncation error for tracking it from calling routine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_red_qmpsc(Rho, Psi, sites, cont, trunc, ncut, err, errst)
type(qtensorc), intent(out) :: Rho
type(qmpsc), intent(inout) :: Psi
integer, dimension(:), intent(in) :: sites
logical, intent(in) :: cont
real(KIND=rKind), intent(in) :: trunc
integer, intent(in) :: ncut
real(KIND=rKind), intent(out) :: err
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping, indexing
integer :: ii, jj
! array for permutations and identifying partial trace indices
integer, dimension(:), allocatable :: ind
logical, dimension(:), allocatable :: ptind
! Copy of MPS for transposed (truncation might change state)
type(qmpsc) :: Phi
!if(present(errst)) errst = 0
err = 0.0_rKind
if(cont) then
! Continuous block of sites - use corresponding method directly
! -------------------------------------------------------------
call rho_block_qmpsc(Rho, Psi, sites(1), &
sites(size(sites, 1)), errst=errst)
!if(prop_error('rho_red_qmpsc : rho_block failed.', &
! 'MPSOps_include.f90:3159', errst=errst)) return
else
! Permute first, then trace out
! -----------------------------
allocate(ind(Psi%ll), ptind(Psi%ll))
ptind = .true.
ptind(sites) = .false.
jj = size(sites, 1)
ind(:jj) = sites
do ii = 1, Psi%ll
if(ptind(ii)) then
jj = jj + 1
ind(jj) = ii
end if
end do
call copy(Phi, Psi)
call transposed(Phi, ind, trunc, ncut, err, errst=errst)
!if(prop_error('rho_red_qmpsc : transposed failed.', &
! 'MPSOps_include.f90:3182', errst=errst)) return
jj = size(sites, 1)
call rho_block_qmpsc(Rho, Phi, 1, jj, errst=errst)
!if(prop_error('rho_red_qmpsc : rho_block failed.', &
! 'MPSOps_include.f90:3187', errst=errst)) return
deallocate(ind, ptind)
call destroy(Phi)
end if
end subroutine rho_red_qmpsc
"""
return
[docs]def scale_real_mps():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Psi by some factor.
**Arguments**
scalefactor : real, in
some real number to scale MPS
Psi : TYPE(mps), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_real_mps(scalefactor, Psi)
real(KIND=rKind), intent(in) :: scalefactor
type(mps), intent(inout) :: Psi
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Psi%oc, 1)
call scale(scalefactor, Psi%Aa(oc))
end subroutine scale_real_mps
"""
return
[docs]def scale_real_mpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Psi by some factor.
**Arguments**
scalefactor : real, in
some real number to scale MPS
Psi : TYPE(mpsc), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_real_mpsc(scalefactor, Psi)
real(KIND=rKind), intent(in) :: scalefactor
type(mpsc), intent(inout) :: Psi
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Psi%oc, 1)
call scale(scalefactor, Psi%Aa(oc))
end subroutine scale_real_mpsc
"""
return
[docs]def scale_real_qmps():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Psi by some factor.
**Arguments**
scalefactor : real, in
some real number to scale MPS
Psi : TYPE(qmps), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_real_qmps(scalefactor, Psi)
real(KIND=rKind), intent(in) :: scalefactor
type(qmps), intent(inout) :: Psi
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Psi%oc, 1)
call scale(scalefactor, Psi%Aa(oc))
end subroutine scale_real_qmps
"""
return
[docs]def scale_real_qmpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Psi by some factor.
**Arguments**
scalefactor : real, in
some real number to scale MPS
Psi : TYPE(qmpsc), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_real_qmpsc(scalefactor, Psi)
real(KIND=rKind), intent(in) :: scalefactor
type(qmpsc), intent(inout) :: Psi
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Psi%oc, 1)
call scale(scalefactor, Psi%Aa(oc))
end subroutine scale_real_qmpsc
"""
return
[docs]def scale_complex_mpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Psi by some factor.
**Arguments**
scalefactor : complex, in
some real number to scale MPS
Psi : TYPE(mpsc), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_complex_mpsc(scalefactor, Psi)
complex(KIND=rKind), intent(in) :: scalefactor
type(mpsc), intent(inout) :: Psi
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Psi%oc, 1)
call scale(scalefactor, Psi%Aa(oc))
end subroutine scale_complex_mpsc
"""
return
[docs]def scale_complex_qmpsc():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Psi by some factor.
**Arguments**
scalefactor : complex, in
some real number to scale MPS
Psi : TYPE(qmpsc), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_complex_qmpsc(scalefactor, Psi)
complex(KIND=rKind), intent(in) :: scalefactor
type(qmpsc), intent(inout) :: Psi
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Psi%oc, 1)
call scale(scalefactor, Psi%Aa(oc))
end subroutine scale_complex_qmpsc
"""
return
[docs]def setuplr_mps():
"""
fortran-subroutine - June 2017 (dj)
Initialize the left-right overlaps of two states.
**Arguments**
LR : TYPE(tensorlist), inout
Contains on exit the left-right overlaps between
Psia and Psib.
Psia : TYPE(mps), inout
The first wave function for the overlap.
Psib : TYPE(mps), inout
The second wave function for the overlap.
kk : INTEGER, OPTIONAL, in
Center for the left-right overlap.
Default to the first site kk = 1.
**Details**
The array of left-right overlaps in an array of length
L, where L is the number of sites. There are no identities
padded to the left and right boundary.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine setuplr_mps(LR, Psia, Psib, kk, errst)
type(tensorlist), intent(inout) :: LR
type(mps), intent(inout) :: Psia, Psib
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Initial center for LR overlap
integer :: kin
!if(present(errst)) errst = 0
kin = 1
if(present(kk)) kin = kk
allocate(LR%Li(Psia%ll))
if(kin > 1) then
call ptm_right_state(LR%Li(1), Psia%Aa(1), Psib%Aa(1), &
.true., errst=errst)
!if(prop_error('setuplr_mps : ptm_right_state (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = 2, (kin - 1)
call ptm_right_state(LR%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.false., Matin=LR%Li(ii - 1), errst=errst)
!if(prop_error('setuplr_mps : ptm_right_state (2) '//&
! 'failed.', errst=errst)) return
end do
if(kin < Psia%ll) then
ii = Psia%ll
call ptm_left_state(Lr%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.true., errst=errst)
!if(prop_error('setuplr_mps : ptm_left_state (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = Psia%ll - 1, (kin + 1), (-1)
call ptm_left_state(LR%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.false., Matin=LR%Li(ii + 1), &
errst=errst)
!if(prop_error('setuplr_mps : ptm_left_state (2) '//&
! 'failed.', errst=errst)) return
end do
! Set center to dummy to allocate everything
ii = 1
if(kin == 1) ii = ii + 1
call copy(Lr%Li(kin), Lr%Li(ii))
end subroutine setuplr_mps
"""
return
[docs]def setuplr_mpsc():
"""
fortran-subroutine - June 2017 (dj)
Initialize the left-right overlaps of two states.
**Arguments**
LR : TYPE(tensorlistc), inout
Contains on exit the left-right overlaps between
Psia and Psib.
Psia : TYPE(mpsc), inout
The first wave function for the overlap.
Psib : TYPE(mpsc), inout
The second wave function for the overlap.
kk : INTEGER, OPTIONAL, in
Center for the left-right overlap.
Default to the first site kk = 1.
**Details**
The array of left-right overlaps in an array of length
L, where L is the number of sites. There are no identities
padded to the left and right boundary.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine setuplr_mpsc(LR, Psia, Psib, kk, errst)
type(tensorlistc), intent(inout) :: LR
type(mpsc), intent(inout) :: Psia, Psib
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Initial center for LR overlap
integer :: kin
!if(present(errst)) errst = 0
kin = 1
if(present(kk)) kin = kk
allocate(LR%Li(Psia%ll))
if(kin > 1) then
call ptm_right_state(LR%Li(1), Psia%Aa(1), Psib%Aa(1), &
.true., errst=errst)
!if(prop_error('setuplr_mpsc : ptm_right_state (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = 2, (kin - 1)
call ptm_right_state(LR%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.false., Matin=LR%Li(ii - 1), errst=errst)
!if(prop_error('setuplr_mpsc : ptm_right_state (2) '//&
! 'failed.', errst=errst)) return
end do
if(kin < Psia%ll) then
ii = Psia%ll
call ptm_left_state(Lr%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.true., errst=errst)
!if(prop_error('setuplr_mpsc : ptm_left_state (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = Psia%ll - 1, (kin + 1), (-1)
call ptm_left_state(LR%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.false., Matin=LR%Li(ii + 1), &
errst=errst)
!if(prop_error('setuplr_mpsc : ptm_left_state (2) '//&
! 'failed.', errst=errst)) return
end do
! Set center to dummy to allocate everything
ii = 1
if(kin == 1) ii = ii + 1
call copy(Lr%Li(kin), Lr%Li(ii))
end subroutine setuplr_mpsc
"""
return
[docs]def setuplr_qmps():
"""
fortran-subroutine - June 2017 (dj)
Initialize the left-right overlaps of two states.
**Arguments**
LR : TYPE(qtensorlist), inout
Contains on exit the left-right overlaps between
Psia and Psib.
Psia : TYPE(qmps), inout
The first wave function for the overlap.
Psib : TYPE(qmps), inout
The second wave function for the overlap.
kk : INTEGER, OPTIONAL, in
Center for the left-right overlap.
Default to the first site kk = 1.
**Details**
The array of left-right overlaps in an array of length
L, where L is the number of sites. There are no identities
padded to the left and right boundary.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine setuplr_qmps(LR, Psia, Psib, kk, errst)
type(qtensorlist), intent(inout) :: LR
type(qmps), intent(inout) :: Psia, Psib
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Initial center for LR overlap
integer :: kin
!if(present(errst)) errst = 0
kin = 1
if(present(kk)) kin = kk
allocate(LR%Li(Psia%ll))
if(kin > 1) then
call ptm_right_state(LR%Li(1), Psia%Aa(1), Psib%Aa(1), &
.true., errst=errst)
!if(prop_error('setuplr_qmps : ptm_right_state (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = 2, (kin - 1)
call ptm_right_state(LR%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.false., Matin=LR%Li(ii - 1), errst=errst)
!if(prop_error('setuplr_qmps : ptm_right_state (2) '//&
! 'failed.', errst=errst)) return
end do
if(kin < Psia%ll) then
ii = Psia%ll
call ptm_left_state(Lr%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.true., errst=errst)
!if(prop_error('setuplr_qmps : ptm_left_state (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = Psia%ll - 1, (kin + 1), (-1)
call ptm_left_state(LR%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.false., Matin=LR%Li(ii + 1), &
errst=errst)
!if(prop_error('setuplr_qmps : ptm_left_state (2) '//&
! 'failed.', errst=errst)) return
end do
! Set center to dummy to allocate everything
ii = 1
if(kin == 1) ii = ii + 1
call copy(Lr%Li(kin), Lr%Li(ii))
end subroutine setuplr_qmps
"""
return
[docs]def setuplr_qmpsc():
"""
fortran-subroutine - June 2017 (dj)
Initialize the left-right overlaps of two states.
**Arguments**
LR : TYPE(qtensorclist), inout
Contains on exit the left-right overlaps between
Psia and Psib.
Psia : TYPE(qmpsc), inout
The first wave function for the overlap.
Psib : TYPE(qmpsc), inout
The second wave function for the overlap.
kk : INTEGER, OPTIONAL, in
Center for the left-right overlap.
Default to the first site kk = 1.
**Details**
The array of left-right overlaps in an array of length
L, where L is the number of sites. There are no identities
padded to the left and right boundary.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine setuplr_qmpsc(LR, Psia, Psib, kk, errst)
type(qtensorclist), intent(inout) :: LR
type(qmpsc), intent(inout) :: Psia, Psib
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Initial center for LR overlap
integer :: kin
!if(present(errst)) errst = 0
kin = 1
if(present(kk)) kin = kk
allocate(LR%Li(Psia%ll))
if(kin > 1) then
call ptm_right_state(LR%Li(1), Psia%Aa(1), Psib%Aa(1), &
.true., errst=errst)
!if(prop_error('setuplr_qmpsc : ptm_right_state (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = 2, (kin - 1)
call ptm_right_state(LR%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.false., Matin=LR%Li(ii - 1), errst=errst)
!if(prop_error('setuplr_qmpsc : ptm_right_state (2) '//&
! 'failed.', errst=errst)) return
end do
if(kin < Psia%ll) then
ii = Psia%ll
call ptm_left_state(Lr%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.true., errst=errst)
!if(prop_error('setuplr_qmpsc : ptm_left_state (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = Psia%ll - 1, (kin + 1), (-1)
call ptm_left_state(LR%Li(ii), Psia%Aa(ii), Psib%Aa(ii), &
.false., Matin=LR%Li(ii + 1), &
errst=errst)
!if(prop_error('setuplr_qmpsc : ptm_left_state (2) '//&
! 'failed.', errst=errst)) return
end do
! Set center to dummy to allocate everything
ii = 1
if(kin == 1) ii = ii + 1
call copy(Lr%Li(kin), Lr%Li(ii))
end subroutine setuplr_qmpsc
"""
return
[docs]def swap_mps_tensor():
"""
fortran-subroutine - May 2018 (dj)
Swap two nearest-neighbor sites in an MPS.
**Arguments**
Tensa : TYPE(tensor), inout
The second index of this tensor is on exit contained in Tensb.
Tensb : TYPE(tensor), inout
The second index of this tensor is on exit contained in Tensa.
Lam : TYPE(tensor), inout
On exit, new singular values at splitting Tensa/Tensb.
dir : INTEGER, in
Multiply singular values to Tensa for dir < 0 and to Tensa
for dir > 0 to Tensb.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine swap_mps_tensor(Tensa, Tensb, Lam, dir, trunc, ncut, &
cerr, errst)
type(tensor), intent(inout) :: Tensa, Tensb
type(tensor), intent(inout) :: Lam
integer, intent(in), optional :: dir
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
real(KIND=rKind), intent(inout), optional :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Error from single truncation
real(KIND=rKind) :: err
! Represenation two-site tensor
type(tensor) :: Theta
!if(present(errst)) errst = 0
call contr(Theta, Tensa, Tensb, [3], [1], errst=errst)
!if(prop_error('swap_mps_tensor : contr failed.', &
! 'MPSOps_include.f90:3496', errst=errst)) return
call destroy(Tensa)
call destroy(Tensb)
call split(Tensa, Lam, Tensb, Theta, [1, 3], [2, 4], &
multlr=dir, trunc=trunc, ncut=ncut, err=err, &
method='Y', errst=errst)
!if(prop_error('swap_mps_tensor : split failed.', &
! 'MPSOps_include.f90:3505', errst=errst)) return
call destroy(Theta)
if(present(cerr)) cerr = cerr + err
end subroutine swap_mps_tensor
"""
return
[docs]def swap_mps_tensorc():
"""
fortran-subroutine - May 2018 (dj)
Swap two nearest-neighbor sites in an MPS.
**Arguments**
Tensa : TYPE(tensorc), inout
The second index of this tensor is on exit contained in Tensb.
Tensb : TYPE(tensorc), inout
The second index of this tensor is on exit contained in Tensa.
Lam : TYPE(tensor), inout
On exit, new singular values at splitting Tensa/Tensb.
dir : INTEGER, in
Multiply singular values to Tensa for dir < 0 and to Tensa
for dir > 0 to Tensb.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine swap_mps_tensorc(Tensa, Tensb, Lam, dir, trunc, ncut, &
cerr, errst)
type(tensorc), intent(inout) :: Tensa, Tensb
type(tensor), intent(inout) :: Lam
integer, intent(in), optional :: dir
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
real(KIND=rKind), intent(inout), optional :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Error from single truncation
real(KIND=rKind) :: err
! Represenation two-site tensor
type(tensorc) :: Theta
!if(present(errst)) errst = 0
call contr(Theta, Tensa, Tensb, [3], [1], errst=errst)
!if(prop_error('swap_mps_tensorc : contr failed.', &
! 'MPSOps_include.f90:3496', errst=errst)) return
call destroy(Tensa)
call destroy(Tensb)
call split(Tensa, Lam, Tensb, Theta, [1, 3], [2, 4], &
multlr=dir, trunc=trunc, ncut=ncut, err=err, &
method='Y', errst=errst)
!if(prop_error('swap_mps_tensorc : split failed.', &
! 'MPSOps_include.f90:3505', errst=errst)) return
call destroy(Theta)
if(present(cerr)) cerr = cerr + err
end subroutine swap_mps_tensorc
"""
return
[docs]def swap_mps_qtensor():
"""
fortran-subroutine - May 2018 (dj)
Swap two nearest-neighbor sites in an MPS.
**Arguments**
Tensa : TYPE(qtensor), inout
The second index of this tensor is on exit contained in Tensb.
Tensb : TYPE(qtensor), inout
The second index of this tensor is on exit contained in Tensa.
Lam : TYPE(qtensor), inout
On exit, new singular values at splitting Tensa/Tensb.
dir : INTEGER, in
Multiply singular values to Tensa for dir < 0 and to Tensa
for dir > 0 to Tensb.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine swap_mps_qtensor(Tensa, Tensb, Lam, dir, trunc, ncut, &
cerr, errst)
type(qtensor), intent(inout) :: Tensa, Tensb
type(qtensor), intent(inout) :: Lam
integer, intent(in), optional :: dir
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
real(KIND=rKind), intent(inout), optional :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Error from single truncation
real(KIND=rKind) :: err
! Represenation two-site tensor
type(qtensor) :: Theta
!if(present(errst)) errst = 0
call contr(Theta, Tensa, Tensb, [3], [1], errst=errst)
!if(prop_error('swap_mps_qtensor : contr failed.', &
! 'MPSOps_include.f90:3496', errst=errst)) return
call destroy(Tensa)
call destroy(Tensb)
call split(Tensa, Lam, Tensb, Theta, [1, 3], [2, 4], &
multlr=dir, trunc=trunc, ncut=ncut, err=err, &
method='Y', errst=errst)
!if(prop_error('swap_mps_qtensor : split failed.', &
! 'MPSOps_include.f90:3505', errst=errst)) return
call destroy(Theta)
if(present(cerr)) cerr = cerr + err
end subroutine swap_mps_qtensor
"""
return
[docs]def swap_mps_qtensorc():
"""
fortran-subroutine - May 2018 (dj)
Swap two nearest-neighbor sites in an MPS.
**Arguments**
Tensa : TYPE(qtensorc), inout
The second index of this tensor is on exit contained in Tensb.
Tensb : TYPE(qtensorc), inout
The second index of this tensor is on exit contained in Tensa.
Lam : TYPE(qtensor), inout
On exit, new singular values at splitting Tensa/Tensb.
dir : INTEGER, in
Multiply singular values to Tensa for dir < 0 and to Tensa
for dir > 0 to Tensb.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine swap_mps_qtensorc(Tensa, Tensb, Lam, dir, trunc, ncut, &
cerr, errst)
type(qtensorc), intent(inout) :: Tensa, Tensb
type(qtensor), intent(inout) :: Lam
integer, intent(in), optional :: dir
real(KIND=rKind), intent(in), optional :: trunc
integer, intent(in), optional :: ncut
real(KIND=rKind), intent(inout), optional :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Error from single truncation
real(KIND=rKind) :: err
! Represenation two-site tensor
type(qtensorc) :: Theta
!if(present(errst)) errst = 0
call contr(Theta, Tensa, Tensb, [3], [1], errst=errst)
!if(prop_error('swap_mps_qtensorc : contr failed.', &
! 'MPSOps_include.f90:3496', errst=errst)) return
call destroy(Tensa)
call destroy(Tensb)
call split(Tensa, Lam, Tensb, Theta, [1, 3], [2, 4], &
multlr=dir, trunc=trunc, ncut=ncut, err=err, &
method='Y', errst=errst)
!if(prop_error('swap_mps_qtensorc : split failed.', &
! 'MPSOps_include.f90:3505', errst=errst)) return
call destroy(Theta)
if(present(cerr)) cerr = cerr + err
end subroutine swap_mps_qtensorc
"""
return
[docs]def transposed_mps():
"""
fortran-subroutine - May 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Psi : TYPE(mps), inout
Permute MPS sites in-place. Error can be introduced
due to SVDs.
perm : INTEGER(\*), in
Permutation array has length equal to the number of
sites L in the MPS with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_mps(Psi, perm, trunc, ncut, cerr, errst)
type(mps), intent(inout) :: Psi
integer, dimension(:), intent(in) :: perm
real(KIND=rKind), intent(in) :: trunc
integer, intent(in) :: ncut
real(KIND=rKind), intent(inout), optional :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! copy of permutation
integer, dimension(:), allocatable :: ind
! renorm due to truncation
real(KIND=rKind) :: sc
!if(present(errst)) errst = 0
!if(size(perm) /= Psi%ll) then
! errst = raise_error('transposed_mps : rank '//&
! 'mismatch.', 2, errst=errst)
! return
!end if
! perm is intent(in), have to copy
allocate(ind(Psi%ll))
ind = perm
do ii = 1, Psi%ll
if(ind(ii) == ii) cycle
call canonize(Psi, ind(ii), errst=errst)
!if(prop_error('transposed_mps : canonize failed.', &
! 'MPSOps_include.f90:3596', errst=errst)) return
do jj = ind(ii), (ii + 1), -1
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
call swap_mps(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj), &
dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
errst=errst)
!if(prop_error('transposed_mps : swap failed.', &
! 'MPSOps_include.f90:3605', errst=errst)) return
Psi%can(jj) = 'r'
Psi%can(jj - 1) = 'c'
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
end do
do jj = ii + 1, Psi%ll
if(ind(jj) < ind(ii)) ind(jj) = ind(jj) + 1
end do
end do
deallocate(ind)
! Truncation might violate normalization
sc = norm(Psi)
call scale(1.0_rKind / sqrt(sc), Psi)
end subroutine transposed_mps
"""
return
[docs]def transposed_mpsc():
"""
fortran-subroutine - May 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Psi : TYPE(mpsc), inout
Permute MPS sites in-place. Error can be introduced
due to SVDs.
perm : INTEGER(\*), in
Permutation array has length equal to the number of
sites L in the MPS with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_mpsc(Psi, perm, trunc, ncut, cerr, errst)
type(mpsc), intent(inout) :: Psi
integer, dimension(:), intent(in) :: perm
real(KIND=rKind), intent(in) :: trunc
integer, intent(in) :: ncut
real(KIND=rKind), intent(inout), optional :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! copy of permutation
integer, dimension(:), allocatable :: ind
! renorm due to truncation
real(KIND=rKind) :: sc
!if(present(errst)) errst = 0
!if(size(perm) /= Psi%ll) then
! errst = raise_error('transposed_mpsc : rank '//&
! 'mismatch.', 2, errst=errst)
! return
!end if
! perm is intent(in), have to copy
allocate(ind(Psi%ll))
ind = perm
do ii = 1, Psi%ll
if(ind(ii) == ii) cycle
call canonize(Psi, ind(ii), errst=errst)
!if(prop_error('transposed_mpsc : canonize failed.', &
! 'MPSOps_include.f90:3596', errst=errst)) return
do jj = ind(ii), (ii + 1), -1
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
call swap_mps(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj), &
dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
errst=errst)
!if(prop_error('transposed_mpsc : swap failed.', &
! 'MPSOps_include.f90:3605', errst=errst)) return
Psi%can(jj) = 'r'
Psi%can(jj - 1) = 'c'
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
end do
do jj = ii + 1, Psi%ll
if(ind(jj) < ind(ii)) ind(jj) = ind(jj) + 1
end do
end do
deallocate(ind)
! Truncation might violate normalization
sc = norm(Psi)
call scale(1.0_rKind / sqrt(sc), Psi)
end subroutine transposed_mpsc
"""
return
[docs]def transposed_qmps():
"""
fortran-subroutine - May 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Psi : TYPE(qmps), inout
Permute MPS sites in-place. Error can be introduced
due to SVDs.
perm : INTEGER(\*), in
Permutation array has length equal to the number of
sites L in the MPS with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_qmps(Psi, perm, trunc, ncut, cerr, errst)
type(qmps), intent(inout) :: Psi
integer, dimension(:), intent(in) :: perm
real(KIND=rKind), intent(in) :: trunc
integer, intent(in) :: ncut
real(KIND=rKind), intent(inout), optional :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! copy of permutation
integer, dimension(:), allocatable :: ind
! renorm due to truncation
real(KIND=rKind) :: sc
!if(present(errst)) errst = 0
!if(size(perm) /= Psi%ll) then
! errst = raise_error('transposed_qmps : rank '//&
! 'mismatch.', 2, errst=errst)
! return
!end if
! perm is intent(in), have to copy
allocate(ind(Psi%ll))
ind = perm
do ii = 1, Psi%ll
if(ind(ii) == ii) cycle
call canonize(Psi, ind(ii), errst=errst)
!if(prop_error('transposed_qmps : canonize failed.', &
! 'MPSOps_include.f90:3596', errst=errst)) return
do jj = ind(ii), (ii + 1), -1
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
call swap_mps(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj), &
dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
errst=errst)
!if(prop_error('transposed_qmps : swap failed.', &
! 'MPSOps_include.f90:3605', errst=errst)) return
Psi%can(jj) = 'r'
Psi%can(jj - 1) = 'c'
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
end do
do jj = ii + 1, Psi%ll
if(ind(jj) < ind(ii)) ind(jj) = ind(jj) + 1
end do
end do
deallocate(ind)
! Truncation might violate normalization
sc = norm(Psi)
call scale(1.0_rKind / sqrt(sc), Psi)
end subroutine transposed_qmps
"""
return
[docs]def transposed_qmpsc():
"""
fortran-subroutine - May 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Psi : TYPE(qmpsc), inout
Permute MPS sites in-place. Error can be introduced
due to SVDs.
perm : INTEGER(\*), in
Permutation array has length equal to the number of
sites L in the MPS with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_qmpsc(Psi, perm, trunc, ncut, cerr, errst)
type(qmpsc), intent(inout) :: Psi
integer, dimension(:), intent(in) :: perm
real(KIND=rKind), intent(in) :: trunc
integer, intent(in) :: ncut
real(KIND=rKind), intent(inout), optional :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! copy of permutation
integer, dimension(:), allocatable :: ind
! renorm due to truncation
real(KIND=rKind) :: sc
!if(present(errst)) errst = 0
!if(size(perm) /= Psi%ll) then
! errst = raise_error('transposed_qmpsc : rank '//&
! 'mismatch.', 2, errst=errst)
! return
!end if
! perm is intent(in), have to copy
allocate(ind(Psi%ll))
ind = perm
do ii = 1, Psi%ll
if(ind(ii) == ii) cycle
call canonize(Psi, ind(ii), errst=errst)
!if(prop_error('transposed_qmpsc : canonize failed.', &
! 'MPSOps_include.f90:3596', errst=errst)) return
do jj = ind(ii), (ii + 1), -1
if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))
call swap_mps(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj), &
dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
errst=errst)
!if(prop_error('transposed_qmpsc : swap failed.', &
! 'MPSOps_include.f90:3605', errst=errst)) return
Psi%can(jj) = 'r'
Psi%can(jj - 1) = 'c'
Psi%oc = jj - 1
Psi%haslambda(jj) = .true.
end do
do jj = ii + 1, Psi%ll
if(ind(jj) < ind(ii)) ind(jj) = ind(jj) + 1
end do
end do
deallocate(ind)
! Truncation might violate normalization
sc = norm(Psi)
call scale(1.0_rKind / sqrt(sc), Psi)
end subroutine transposed_qmpsc
"""
return
[docs]def updatelr_mps():
"""
fortran-subroutine - June 2017 (dj)
Shift the left-right overlap by one site.
**Arguments**
LR : TYPE(tensorlist), inout
Contains on exit the left-right overlaps between
Psia and Psib.
Psia : TYPE(mps), inout
The first wave function for the overlap.
Psib : TYPE(mps), inout
The second wave function for the overlap.
kk : INTEGER, in
New center for the left-right overlap.
sense : INTEGER, in
Move center of the left-right overlap to the right for
sense > 0 and to the left for sense < 0.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine updatelr_mps(LR, PsiA, PsiB, kk, sense, errst)
type(tensorlist), intent(inout) :: LR
type(mps), intent(inout) :: Psia, Psib
integer, intent(in) :: kk, sense
integer, intent(out), optional :: errst
! Local variables
! ---------------
call destroy(LR%Li(kk))
if(kk == 1) then
call ptm_right_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
.true., errst=errst)
!if(prop_error('updatelr_mps : ptm_right_state '//&
! '(1) failed.', errst=errst)) return
elseif(kk == Psia%ll) then
call ptm_left_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
.true., errst=errst)
!if(prop_error('updatelr_mps : ptm_left_state '//&
! '(1) failed.', errst=errst)) return
elseif(sense > 0) then
call ptm_right_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
(kk == 1), Matin=LR%Li(kk - 1), errst=errst)
!if(prop_error('updatelr_mps : ptm_right_state '//&
! '(2) failed.', errst=errst)) return
else
call ptm_left_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
(kk == Psia%ll), Matin=LR%Li(kk + 1), errst=errst)
!if(prop_error('updatelr_mps : ptm_left_state '//&
! '(2) failed.', errst=errst)) return
end if
end subroutine updatelr_mps
"""
return
[docs]def updatelr_mpsc():
"""
fortran-subroutine - June 2017 (dj)
Shift the left-right overlap by one site.
**Arguments**
LR : TYPE(tensorlistc), inout
Contains on exit the left-right overlaps between
Psia and Psib.
Psia : TYPE(mpsc), inout
The first wave function for the overlap.
Psib : TYPE(mpsc), inout
The second wave function for the overlap.
kk : INTEGER, in
New center for the left-right overlap.
sense : INTEGER, in
Move center of the left-right overlap to the right for
sense > 0 and to the left for sense < 0.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine updatelr_mpsc(LR, PsiA, PsiB, kk, sense, errst)
type(tensorlistc), intent(inout) :: LR
type(mpsc), intent(inout) :: Psia, Psib
integer, intent(in) :: kk, sense
integer, intent(out), optional :: errst
! Local variables
! ---------------
call destroy(LR%Li(kk))
if(kk == 1) then
call ptm_right_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
.true., errst=errst)
!if(prop_error('updatelr_mpsc : ptm_right_state '//&
! '(1) failed.', errst=errst)) return
elseif(kk == Psia%ll) then
call ptm_left_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
.true., errst=errst)
!if(prop_error('updatelr_mpsc : ptm_left_state '//&
! '(1) failed.', errst=errst)) return
elseif(sense > 0) then
call ptm_right_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
(kk == 1), Matin=LR%Li(kk - 1), errst=errst)
!if(prop_error('updatelr_mpsc : ptm_right_state '//&
! '(2) failed.', errst=errst)) return
else
call ptm_left_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
(kk == Psia%ll), Matin=LR%Li(kk + 1), errst=errst)
!if(prop_error('updatelr_mpsc : ptm_left_state '//&
! '(2) failed.', errst=errst)) return
end if
end subroutine updatelr_mpsc
"""
return
[docs]def updatelr_qmps():
"""
fortran-subroutine - June 2017 (dj)
Shift the left-right overlap by one site.
**Arguments**
LR : TYPE(qtensorlist), inout
Contains on exit the left-right overlaps between
Psia and Psib.
Psia : TYPE(qmps), inout
The first wave function for the overlap.
Psib : TYPE(qmps), inout
The second wave function for the overlap.
kk : INTEGER, in
New center for the left-right overlap.
sense : INTEGER, in
Move center of the left-right overlap to the right for
sense > 0 and to the left for sense < 0.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine updatelr_qmps(LR, PsiA, PsiB, kk, sense, errst)
type(qtensorlist), intent(inout) :: LR
type(qmps), intent(inout) :: Psia, Psib
integer, intent(in) :: kk, sense
integer, intent(out), optional :: errst
! Local variables
! ---------------
call destroy(LR%Li(kk))
if(kk == 1) then
call ptm_right_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
.true., errst=errst)
!if(prop_error('updatelr_qmps : ptm_right_state '//&
! '(1) failed.', errst=errst)) return
elseif(kk == Psia%ll) then
call ptm_left_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
.true., errst=errst)
!if(prop_error('updatelr_qmps : ptm_left_state '//&
! '(1) failed.', errst=errst)) return
elseif(sense > 0) then
call ptm_right_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
(kk == 1), Matin=LR%Li(kk - 1), errst=errst)
!if(prop_error('updatelr_qmps : ptm_right_state '//&
! '(2) failed.', errst=errst)) return
else
call ptm_left_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
(kk == Psia%ll), Matin=LR%Li(kk + 1), errst=errst)
!if(prop_error('updatelr_qmps : ptm_left_state '//&
! '(2) failed.', errst=errst)) return
end if
end subroutine updatelr_qmps
"""
return
[docs]def updatelr_qmpsc():
"""
fortran-subroutine - June 2017 (dj)
Shift the left-right overlap by one site.
**Arguments**
LR : TYPE(qtensorclist), inout
Contains on exit the left-right overlaps between
Psia and Psib.
Psia : TYPE(qmpsc), inout
The first wave function for the overlap.
Psib : TYPE(qmpsc), inout
The second wave function for the overlap.
kk : INTEGER, in
New center for the left-right overlap.
sense : INTEGER, in
Move center of the left-right overlap to the right for
sense > 0 and to the left for sense < 0.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine updatelr_qmpsc(LR, PsiA, PsiB, kk, sense, errst)
type(qtensorclist), intent(inout) :: LR
type(qmpsc), intent(inout) :: Psia, Psib
integer, intent(in) :: kk, sense
integer, intent(out), optional :: errst
! Local variables
! ---------------
call destroy(LR%Li(kk))
if(kk == 1) then
call ptm_right_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
.true., errst=errst)
!if(prop_error('updatelr_qmpsc : ptm_right_state '//&
! '(1) failed.', errst=errst)) return
elseif(kk == Psia%ll) then
call ptm_left_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
.true., errst=errst)
!if(prop_error('updatelr_qmpsc : ptm_left_state '//&
! '(1) failed.', errst=errst)) return
elseif(sense > 0) then
call ptm_right_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
(kk == 1), Matin=LR%Li(kk - 1), errst=errst)
!if(prop_error('updatelr_qmpsc : ptm_right_state '//&
! '(2) failed.', errst=errst)) return
else
call ptm_left_state(LR%Li(kk), Psia%Aa(kk), Psib%Aa(kk), &
(kk == Psia%ll), Matin=LR%Li(kk + 1), errst=errst)
!if(prop_error('updatelr_qmpsc : ptm_left_state '//&
! '(2) failed.', errst=errst)) return
end if
end subroutine updatelr_qmpsc
"""
return
[docs]def write_mps():
"""
fortran-subroutine - August 2015 (dj)
Write an MPS to file
**Arguments**
Psi : TYPE(mps), in
save this MPS
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B'), human readable ('H'), or user-friendly ("6").
**Details**
For details see the description of the order which the information
is written, please see `read_mps`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_mps(Psi, unit, form, errst)
type(mps), intent(in) :: Psi
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! type of the MPS
logical :: is_real, is_q
! for looping
integer :: ii
is_real = .true.
is_q = .false.
if(form == "6") then
write(unit, *) 'MPS size, oc', Psi%ll, Psi%oc
do ii = 1, Psi%ll
write(unit, *) ' site i data:', ii
write(unit, *) ' canonization', Psi%can(ii)
write(unit, *) ' Lambda:', Psi%haslambda(ii)
if(Psi%haslambda(ii)) then
call print(Psi%Lambda(ii))
end if
call print(Psi%Aa(ii))
end do
elseif(form == 'H') then
! Open the formatted file
! -----------------------
!open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write')
! Write the data type, the MPS type, the number of sites and
! the orthogonality center
write(unit, *) is_real
write(unit, *) is_q
write(unit, *) Psi%ll
write(unit, *) Psi%oc
! Write the canonization and the haslambda together
do ii = 1, Psi%ll
write(unit, *) Psi%can(ii), Psi%haslambda(ii)
end do
write(unit, *) Psi%haslambda(Psi%ll + 1)
! Write the tensors of the MPS
do ii = 1, Psi%ll
call write(Psi%Aa(ii), unit, form)
end do
! Finally write the lambdas
do ii = 1, Psi%ll + 1
if(Psi%haslambda(ii)) then
call write(Psi%lambda(ii), unit, form)
end if
end do
elseif(form == 'B') then
! Binary file
! -----------
!open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write', &
! FORM='unformatted')
! Write the data type, the MPS type, the number of sites and
! the orthogonality center
write(unit) is_real
write(unit) is_q
write(unit) Psi%ll
write(unit) Psi%oc
! Canonization and haslambda go as array
write(unit) Psi%can
write(unit) Psi%haslambda
! Write the tensors of the MPS
do ii = 1, Psi%ll
call write(Psi%Aa(ii), unit, form)
end do
! Finally write the values for the lambdas
do ii = 1, Psi%ll + 1
if(Psi%haslambda(ii)) then
call write(Psi%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('write_mps: unallowed formatting.', &
! 99, errst=errst)
return
end if
!close(unit)
end subroutine write_mps
"""
return
[docs]def write_mpsc():
"""
fortran-subroutine - August 2015 (dj)
Write an MPS to file
**Arguments**
Psi : TYPE(mpsc), in
save this MPS
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B'), human readable ('H'), or user-friendly ("6").
**Details**
For details see the description of the order which the information
is written, please see `read_mpsc`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_mpsc(Psi, unit, form, errst)
type(mpsc), intent(in) :: Psi
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! type of the MPS
logical :: is_real, is_q
! for looping
integer :: ii
is_real = .false.
is_q = .false.
if(form == "6") then
write(unit, *) 'MPS size, oc', Psi%ll, Psi%oc
do ii = 1, Psi%ll
write(unit, *) ' site i data:', ii
write(unit, *) ' canonization', Psi%can(ii)
write(unit, *) ' Lambda:', Psi%haslambda(ii)
if(Psi%haslambda(ii)) then
call print(Psi%Lambda(ii))
end if
call print(Psi%Aa(ii))
end do
elseif(form == 'H') then
! Open the formatted file
! -----------------------
!open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write')
! Write the data type, the MPS type, the number of sites and
! the orthogonality center
write(unit, *) is_real
write(unit, *) is_q
write(unit, *) Psi%ll
write(unit, *) Psi%oc
! Write the canonization and the haslambda together
do ii = 1, Psi%ll
write(unit, *) Psi%can(ii), Psi%haslambda(ii)
end do
write(unit, *) Psi%haslambda(Psi%ll + 1)
! Write the tensors of the MPS
do ii = 1, Psi%ll
call write(Psi%Aa(ii), unit, form)
end do
! Finally write the lambdas
do ii = 1, Psi%ll + 1
if(Psi%haslambda(ii)) then
call write(Psi%lambda(ii), unit, form)
end if
end do
elseif(form == 'B') then
! Binary file
! -----------
!open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write', &
! FORM='unformatted')
! Write the data type, the MPS type, the number of sites and
! the orthogonality center
write(unit) is_real
write(unit) is_q
write(unit) Psi%ll
write(unit) Psi%oc
! Canonization and haslambda go as array
write(unit) Psi%can
write(unit) Psi%haslambda
! Write the tensors of the MPS
do ii = 1, Psi%ll
call write(Psi%Aa(ii), unit, form)
end do
! Finally write the values for the lambdas
do ii = 1, Psi%ll + 1
if(Psi%haslambda(ii)) then
call write(Psi%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('write_mpsc: unallowed formatting.', &
! 99, errst=errst)
return
end if
!close(unit)
end subroutine write_mpsc
"""
return
[docs]def write_qmps():
"""
fortran-subroutine - August 2015 (dj)
Write an MPS to file
**Arguments**
Psi : TYPE(qmps), in
save this MPS
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B'), human readable ('H'), or user-friendly ("6").
**Details**
For details see the description of the order which the information
is written, please see `read_qmps`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qmps(Psi, unit, form, errst)
type(qmps), intent(in) :: Psi
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! type of the MPS
logical :: is_real, is_q
! for looping
integer :: ii
is_real = .true.
is_q = .true.
if(form == "6") then
write(unit, *) 'MPS size, oc', Psi%ll, Psi%oc
do ii = 1, Psi%ll
write(unit, *) ' site i data:', ii
write(unit, *) ' canonization', Psi%can(ii)
write(unit, *) ' Lambda:', Psi%haslambda(ii)
if(Psi%haslambda(ii)) then
call print(Psi%Lambda(ii))
end if
call print(Psi%Aa(ii))
end do
elseif(form == 'H') then
! Open the formatted file
! -----------------------
!open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write')
! Write the data type, the MPS type, the number of sites and
! the orthogonality center
write(unit, *) is_real
write(unit, *) is_q
write(unit, *) Psi%ll
write(unit, *) Psi%oc
! Write the canonization and the haslambda together
do ii = 1, Psi%ll
write(unit, *) Psi%can(ii), Psi%haslambda(ii)
end do
write(unit, *) Psi%haslambda(Psi%ll + 1)
! Write the tensors of the MPS
do ii = 1, Psi%ll
call write(Psi%Aa(ii), unit, form)
end do
! Finally write the lambdas
do ii = 1, Psi%ll + 1
if(Psi%haslambda(ii)) then
call write(Psi%lambda(ii), unit, form)
end if
end do
elseif(form == 'B') then
! Binary file
! -----------
!open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write', &
! FORM='unformatted')
! Write the data type, the MPS type, the number of sites and
! the orthogonality center
write(unit) is_real
write(unit) is_q
write(unit) Psi%ll
write(unit) Psi%oc
! Canonization and haslambda go as array
write(unit) Psi%can
write(unit) Psi%haslambda
! Write the tensors of the MPS
do ii = 1, Psi%ll
call write(Psi%Aa(ii), unit, form)
end do
! Finally write the values for the lambdas
do ii = 1, Psi%ll + 1
if(Psi%haslambda(ii)) then
call write(Psi%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('write_qmps: unallowed formatting.', &
! 99, errst=errst)
return
end if
!close(unit)
end subroutine write_qmps
"""
return
[docs]def write_qmpsc():
"""
fortran-subroutine - August 2015 (dj)
Write an MPS to file
**Arguments**
Psi : TYPE(qmpsc), in
save this MPS
unit : INTEGER, in
open file on this unit
form : CHARACTER, in
Binary ('B'), human readable ('H'), or user-friendly ("6").
**Details**
For details see the description of the order which the information
is written, please see `read_qmpsc`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qmpsc(Psi, unit, form, errst)
type(qmpsc), intent(in) :: Psi
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! type of the MPS
logical :: is_real, is_q
! for looping
integer :: ii
is_real = .false.
is_q = .true.
if(form == "6") then
write(unit, *) 'MPS size, oc', Psi%ll, Psi%oc
do ii = 1, Psi%ll
write(unit, *) ' site i data:', ii
write(unit, *) ' canonization', Psi%can(ii)
write(unit, *) ' Lambda:', Psi%haslambda(ii)
if(Psi%haslambda(ii)) then
call print(Psi%Lambda(ii))
end if
call print(Psi%Aa(ii))
end do
elseif(form == 'H') then
! Open the formatted file
! -----------------------
!open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write')
! Write the data type, the MPS type, the number of sites and
! the orthogonality center
write(unit, *) is_real
write(unit, *) is_q
write(unit, *) Psi%ll
write(unit, *) Psi%oc
! Write the canonization and the haslambda together
do ii = 1, Psi%ll
write(unit, *) Psi%can(ii), Psi%haslambda(ii)
end do
write(unit, *) Psi%haslambda(Psi%ll + 1)
! Write the tensors of the MPS
do ii = 1, Psi%ll
call write(Psi%Aa(ii), unit, form)
end do
! Finally write the lambdas
do ii = 1, Psi%ll + 1
if(Psi%haslambda(ii)) then
call write(Psi%lambda(ii), unit, form)
end if
end do
elseif(form == 'B') then
! Binary file
! -----------
!open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write', &
! FORM='unformatted')
! Write the data type, the MPS type, the number of sites and
! the orthogonality center
write(unit) is_real
write(unit) is_q
write(unit) Psi%ll
write(unit) Psi%oc
! Canonization and haslambda go as array
write(unit) Psi%can
write(unit) Psi%haslambda
! Write the tensors of the MPS
do ii = 1, Psi%ll
call write(Psi%Aa(ii), unit, form)
end do
! Finally write the values for the lambdas
do ii = 1, Psi%ll + 1
if(Psi%haslambda(ii)) then
call write(Psi%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('write_qmpsc: unallowed formatting.', &
! 99, errst=errst)
return
end if
!close(unit)
end subroutine write_qmpsc
"""
return