"""
Fortran module LPTNOps: September 2017 (dj, updated)
Containing basic operations for local purified tensor networks (LPTN)
**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 |
+=================================+=============+=============+=============+
| build_kraus_first_order | X | | |
+---------------------------------+-------------+-------------+-------------+
| canonize | X | | |
+---------------------------------+-------------+-------------+-------------+
| canonize_svd | X | | |
+---------------------------------+-------------+-------------+-------------+
| check | X | | |
+---------------------------------+-------------+-------------+-------------+
| copy | X | | |
+---------------------------------+-------------+-------------+-------------+
| corr_init_lptn | X | | |
+---------------------------------+-------------+-------------+-------------+
| corr_init_l_lptn | X | | |
+---------------------------------+-------------+-------------+-------------+
| corr_meas_lptn | X | | |
+---------------------------------+-------------+-------------+-------------+
| corr_meas_l_lptn | X | | |
+---------------------------------+-------------+-------------+-------------+
| create | X | | |
+---------------------------------+-------------+-------------+-------------+
| destroy | X | | |
+---------------------------------+-------------+-------------+-------------+
| fidelity | X | | |
+---------------------------------+-------------+-------------+-------------+
| gaugesite_qr | X | | |
+---------------------------------+-------------+-------------+-------------+
| gaugesite_rq | X | | |
+---------------------------------+-------------+-------------+-------------+
| gaugesite_rsvd | X | | |
+---------------------------------+-------------+-------------+-------------+
| gaugesite_lsvd | X | | |
+---------------------------------+-------------+-------------+-------------+
| maxchi | X | | |
+---------------------------------+-------------+-------------+-------------+
| maxkappa | X | | |
+---------------------------------+-------------+-------------+-------------+
| meas_mpo (dummy) | X | | |
+---------------------------------+-------------+-------------+-------------+
| norm | X | | |
+---------------------------------+-------------+-------------+-------------+
| randomize | X | | |
+---------------------------------+-------------+-------------+-------------+
| rho_kk | X | | |
+---------------------------------+-------------+-------------+-------------+
| rhoij_init_lptn | X | | |
+---------------------------------+-------------+-------------+-------------+
| rhoij_meas_lptn | X | | |
+---------------------------------+-------------+-------------+-------------+
| scale | X | | |
+---------------------------------+-------------+-------------+-------------+
| write | X | | |
+---------------------------------+-------------+-------------+-------------+
| purity | X | | |
+---------------------------------+-------------+-------------+-------------+
| read | X | | |
+---------------------------------+-------------+-------------+-------------+
| print | X | | |
+---------------------------------+-------------+-------------+-------------+
| orthonormalize | X | | |
+---------------------------------+-------------+-------------+-------------+
"""
[docs]def apply_kraus_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Contract a set of Kraus operators with the tensor for a site and
compress.
**Arguments**
Tens : TYPE(tensorc), inout
On entry, tensor representing the site in the LPTN, on exit
tensor of the site after application of the Kraus operators.
Kraus : TYPE(tensorc), inout
Kraus operators represented as rank-3 tensor.
max_kappa : INTEGER, in
The hard-cut off for the kappa bond dimension.
local_tol : REAL, in
Local tolerance for cutting singular values.
renorm : CHARACTER, in
Control on renormalization of the singular values.
cerr : REAL, inout
Cumulative error. The error from the splitting inside
this subroutine is added.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine apply_kraus_tensorc(Tens, Kraus, max_kappa, local_tol, &
renorm, cerr, errst)
type(tensorc), intent(inout) :: Tens
type(tensorc), intent(inout) :: Kraus
integer, intent(in) :: max_kappa
real(KIND=rKind), intent(in) :: local_tol
character, intent(in) :: renorm
real(KIND=rKind), intent(inout) :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! error from a single split
real(KIND=rKind) :: err
! temporary tensors
type(tensorc) :: Tmp, Vtens
! singular values
type(tensor) :: Lam
! IF SYMMETRY --> set quantum number of third leg
call contr(Tmp, Tens, Kraus, [2], [2], errst=errst)!permout=[1, 4, 3, 2, 5], &
!errst=errst)
!if(prop_error('apply_kraus_tensorc : contr failed.', &
! 'LPTNOps_include.f90:78', errst=errst)) return
call transposed(Tmp, [1, 4, 3, 2, 5], doperm=.true.)
call destroy(Tens)
call split(Tens, Lam, Vtens, Tmp, [1, 2, 3], [4, 5], multlr=-1, &
trunc=local_tol, ncut=max_kappa, &
err=err, renorm=renorm, method='Y', errst=errst)
!if(prop_error('apply_kraus_tensorc : split failed.', &
! errst=errst)) return
cerr = cerr + err
call destroy(Lam)
call destroy(Tmp)
call destroy(Vtens)
call transposed(Tens, perm=[1, 2, 4, 3], doperm=.true.)
! IF SYMMETRY --> unset quantum number on third leg
end subroutine apply_kraus_tensorc
"""
return
[docs]def apply_kraus_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Contract a set of Kraus operators with the tensor for a site and
compress.
**Arguments**
Tens : TYPE(qtensorc), inout
On entry, tensor representing the site in the LPTN, on exit
tensor of the site after application of the Kraus operators.
Kraus : TYPE(qtensorc), inout
Kraus operators represented as rank-3 tensor.
max_kappa : INTEGER, in
The hard-cut off for the kappa bond dimension.
local_tol : REAL, in
Local tolerance for cutting singular values.
renorm : CHARACTER, in
Control on renormalization of the singular values.
cerr : REAL, inout
Cumulative error. The error from the splitting inside
this subroutine is added.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine apply_kraus_qtensorc(Tens, Kraus, max_kappa, local_tol, &
renorm, cerr, errst)
type(qtensorc), intent(inout) :: Tens
type(qtensorc), intent(inout) :: Kraus
integer, intent(in) :: max_kappa
real(KIND=rKind), intent(in) :: local_tol
character, intent(in) :: renorm
real(KIND=rKind), intent(inout) :: cerr
integer, intent(out), optional :: errst
! Local variables
! ---------------
! error from a single split
real(KIND=rKind) :: err
! temporary tensors
type(qtensorc) :: Tmp, Vtens
! singular values
type(qtensor) :: Lam
! IF SYMMETRY --> set quantum number of third leg
call contr(Tmp, Tens, Kraus, [2], [2], errst=errst)!permout=[1, 4, 3, 2, 5], &
!errst=errst)
!if(prop_error('apply_kraus_qtensorc : contr failed.', &
! 'LPTNOps_include.f90:78', errst=errst)) return
call transposed(Tmp, [1, 4, 3, 2, 5], doperm=.true.)
call destroy(Tens)
call split(Tens, Lam, Vtens, Tmp, [1, 2, 3], [4, 5], multlr=-1, &
trunc=local_tol, ncut=max_kappa, &
err=err, renorm=renorm, method='Y', errst=errst)
!if(prop_error('apply_kraus_qtensorc : split failed.', &
! errst=errst)) return
cerr = cerr + err
call destroy(Lam)
call destroy(Tmp)
call destroy(Vtens)
call transposed(Tens, perm=[1, 2, 4, 3], doperm=.true.)
! IF SYMMETRY --> unset quantum number on third leg
end subroutine apply_kraus_qtensorc
"""
return
[docs]def canonize_lptn():
"""
fortran-subroutine - June 2017 (dj, updated)
Canonize the LPTN with gauged matrices.
**Arguments**
Rho : TYPE(lptn), inout
Bring this LPTN into a canonical form using QR decompositions.
k0 : INTEGER, in
This is the new orthogonality center for the LPTN.
kl : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the LPTN from the left side of the LPTN. 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 LPTN from the right side of the LPTN. If
not given, the minimum of the system size and the present
orthogonality center is choosen.
**Details**
Put the LPTN 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_lptn(Rho, k0, kl, kr, errst)
type(lptn), intent(inout) :: Rho
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 > Rho%ll)) then
! errst = raise_error('canonize_lptn : k0 not valid ', &
! 99, errst=errst)
! return
!end if
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Rho%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Rho%ll, Rho%oc)
end if
!if(kleft < 1) then
! errst = raise_error('canonize_lptn : kl < 1', &
! 99, errst=errst)
! return
!end if
!if(kright > Rho%ll) then
! errst = raise_error('canonize_lptn : kr > ll', &
! 99, errst=errst)
! return
!end if
do ii = kleft, (k0 - 1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_qr(Rho%Aa(ii), Rho%Aa(ii + 1), errst=errst)
!if(prop_error('canonize_lptn: qr failed', &
! errst=errst)) return
Rho%can(ii) = 'l'
Rho%can(ii + 1) = 'c'
call set_q_kappa(Rho%Aa(ii))
end do
do ii = kright, (k0 + 1), (-1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_rq(Rho%Aa(ii - 1), Rho%Aa(ii), errst=errst)
!if(prop_error('canonize_lptn: rq failed', &
! errst=errst)) return
Rho%can(ii - 1) = 'c'
Rho%can(ii) = 'r'
call set_q_kappa(Rho%Aa(ii))
end do
Rho%oc = k0
end subroutine canonize_lptn
"""
return
[docs]def canonize_svd_lptn():
"""
fortran-subroutine - June 2017 (dj, updated)
Put the LPTN into a canonical form using SVD.
**Arguments**
Rho : TYPE(lptn), inout
LPTN 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 LPTN). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Details**
Put the LPTN 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_lptn(Rho, k0, kl, kr, trunc, ncut, errst)
type(lptn), intent(inout) :: Rho
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, Rho%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Rho%ll, Rho%oc)
end if
do ii = kleft, (k0 - 1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_rsvd(Rho%Aa(ii), Rho%Lambda(ii), Rho%Aa(ii + 1), &
Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_lptn: gaugesite_rsvd failed', &
! errst=errst)) return
Rho%can(ii) = 'l'
Rho%can(ii + 1) = 'c'
call set_q_kappa(Rho%Aa(ii))
end do
do ii = kright, (k0 + 1), (-1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_lsvd(Rho%Aa(ii - 1), Rho%Lambda(ii), Rho%Aa(ii), &
Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_lptn: gaugesite_lsvd failed', &
! errst=errst)) return
Rho%can(ii - 1) = 'c'
Rho%can(ii) = 'r'
call set_q_kappa(Rho%Aa(ii))
end do
Rho%oc = k0
end subroutine canonize_svd_lptn
"""
return
[docs]def canonize_lptnc():
"""
fortran-subroutine - June 2017 (dj, updated)
Canonize the LPTN with gauged matrices.
**Arguments**
Rho : TYPE(lptnc), inout
Bring this LPTN into a canonical form using QR decompositions.
k0 : INTEGER, in
This is the new orthogonality center for the LPTN.
kl : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the LPTN from the left side of the LPTN. 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 LPTN from the right side of the LPTN. If
not given, the minimum of the system size and the present
orthogonality center is choosen.
**Details**
Put the LPTN 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_lptnc(Rho, k0, kl, kr, errst)
type(lptnc), intent(inout) :: Rho
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 > Rho%ll)) then
! errst = raise_error('canonize_lptnc : k0 not valid ', &
! 99, errst=errst)
! return
!end if
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Rho%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Rho%ll, Rho%oc)
end if
!if(kleft < 1) then
! errst = raise_error('canonize_lptnc : kl < 1', &
! 99, errst=errst)
! return
!end if
!if(kright > Rho%ll) then
! errst = raise_error('canonize_lptnc : kr > ll', &
! 99, errst=errst)
! return
!end if
do ii = kleft, (k0 - 1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_qr(Rho%Aa(ii), Rho%Aa(ii + 1), errst=errst)
!if(prop_error('canonize_lptnc: qr failed', &
! errst=errst)) return
Rho%can(ii) = 'l'
Rho%can(ii + 1) = 'c'
call set_q_kappa(Rho%Aa(ii))
end do
do ii = kright, (k0 + 1), (-1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_rq(Rho%Aa(ii - 1), Rho%Aa(ii), errst=errst)
!if(prop_error('canonize_lptnc: rq failed', &
! errst=errst)) return
Rho%can(ii - 1) = 'c'
Rho%can(ii) = 'r'
call set_q_kappa(Rho%Aa(ii))
end do
Rho%oc = k0
end subroutine canonize_lptnc
"""
return
[docs]def canonize_svd_lptnc():
"""
fortran-subroutine - June 2017 (dj, updated)
Put the LPTN into a canonical form using SVD.
**Arguments**
Rho : TYPE(lptnc), inout
LPTN 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 LPTN). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Details**
Put the LPTN 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_lptnc(Rho, k0, kl, kr, trunc, ncut, errst)
type(lptnc), intent(inout) :: Rho
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, Rho%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Rho%ll, Rho%oc)
end if
do ii = kleft, (k0 - 1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_rsvd(Rho%Aa(ii), Rho%Lambda(ii), Rho%Aa(ii + 1), &
Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_lptnc: gaugesite_rsvd failed', &
! errst=errst)) return
Rho%can(ii) = 'l'
Rho%can(ii + 1) = 'c'
call set_q_kappa(Rho%Aa(ii))
end do
do ii = kright, (k0 + 1), (-1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_lsvd(Rho%Aa(ii - 1), Rho%Lambda(ii), Rho%Aa(ii), &
Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_lptnc: gaugesite_lsvd failed', &
! errst=errst)) return
Rho%can(ii - 1) = 'c'
Rho%can(ii) = 'r'
call set_q_kappa(Rho%Aa(ii))
end do
Rho%oc = k0
end subroutine canonize_svd_lptnc
"""
return
[docs]def canonize_qlptn():
"""
fortran-subroutine - June 2017 (dj, updated)
Canonize the LPTN with gauged matrices.
**Arguments**
Rho : TYPE(qlptn), inout
Bring this LPTN into a canonical form using QR decompositions.
k0 : INTEGER, in
This is the new orthogonality center for the LPTN.
kl : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the LPTN from the left side of the LPTN. 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 LPTN from the right side of the LPTN. If
not given, the minimum of the system size and the present
orthogonality center is choosen.
**Details**
Put the LPTN 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_qlptn(Rho, k0, kl, kr, errst)
type(qlptn), intent(inout) :: Rho
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 > Rho%ll)) then
! errst = raise_error('canonize_qlptn : k0 not valid ', &
! 99, errst=errst)
! return
!end if
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Rho%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Rho%ll, Rho%oc)
end if
!if(kleft < 1) then
! errst = raise_error('canonize_qlptn : kl < 1', &
! 99, errst=errst)
! return
!end if
!if(kright > Rho%ll) then
! errst = raise_error('canonize_qlptn : kr > ll', &
! 99, errst=errst)
! return
!end if
do ii = kleft, (k0 - 1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_qr(Rho%Aa(ii), Rho%Aa(ii + 1), errst=errst)
!if(prop_error('canonize_qlptn: qr failed', &
! errst=errst)) return
Rho%can(ii) = 'l'
Rho%can(ii + 1) = 'c'
call set_q_kappa(Rho%Aa(ii))
end do
do ii = kright, (k0 + 1), (-1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_rq(Rho%Aa(ii - 1), Rho%Aa(ii), errst=errst)
!if(prop_error('canonize_qlptn: rq failed', &
! errst=errst)) return
Rho%can(ii - 1) = 'c'
Rho%can(ii) = 'r'
call set_q_kappa(Rho%Aa(ii))
end do
Rho%oc = k0
end subroutine canonize_qlptn
"""
return
[docs]def canonize_svd_qlptn():
"""
fortran-subroutine - June 2017 (dj, updated)
Put the LPTN into a canonical form using SVD.
**Arguments**
Rho : TYPE(qlptn), inout
LPTN 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 LPTN). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Details**
Put the LPTN 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_qlptn(Rho, k0, kl, kr, trunc, ncut, errst)
type(qlptn), intent(inout) :: Rho
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, Rho%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Rho%ll, Rho%oc)
end if
do ii = kleft, (k0 - 1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_rsvd(Rho%Aa(ii), Rho%Lambda(ii), Rho%Aa(ii + 1), &
Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_qlptn: gaugesite_rsvd failed', &
! errst=errst)) return
Rho%can(ii) = 'l'
Rho%can(ii + 1) = 'c'
call set_q_kappa(Rho%Aa(ii))
end do
do ii = kright, (k0 + 1), (-1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_lsvd(Rho%Aa(ii - 1), Rho%Lambda(ii), Rho%Aa(ii), &
Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_qlptn: gaugesite_lsvd failed', &
! errst=errst)) return
Rho%can(ii - 1) = 'c'
Rho%can(ii) = 'r'
call set_q_kappa(Rho%Aa(ii))
end do
Rho%oc = k0
end subroutine canonize_svd_qlptn
"""
return
[docs]def canonize_qlptnc():
"""
fortran-subroutine - June 2017 (dj, updated)
Canonize the LPTN with gauged matrices.
**Arguments**
Rho : TYPE(qlptnc), inout
Bring this LPTN into a canonical form using QR decompositions.
k0 : INTEGER, in
This is the new orthogonality center for the LPTN.
kl : INTEGER, OPTIONAL, in
This optional argument can provide the information where to
start with gauging the LPTN from the left side of the LPTN. 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 LPTN from the right side of the LPTN. If
not given, the minimum of the system size and the present
orthogonality center is choosen.
**Details**
Put the LPTN 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_qlptnc(Rho, k0, kl, kr, errst)
type(qlptnc), intent(inout) :: Rho
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 > Rho%ll)) then
! errst = raise_error('canonize_qlptnc : k0 not valid ', &
! 99, errst=errst)
! return
!end if
! Find begin of canonization from the left
if(present(kl)) then
kleft = kl
else
kleft = max(1, Rho%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Rho%ll, Rho%oc)
end if
!if(kleft < 1) then
! errst = raise_error('canonize_qlptnc : kl < 1', &
! 99, errst=errst)
! return
!end if
!if(kright > Rho%ll) then
! errst = raise_error('canonize_qlptnc : kr > ll', &
! 99, errst=errst)
! return
!end if
do ii = kleft, (k0 - 1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_qr(Rho%Aa(ii), Rho%Aa(ii + 1), errst=errst)
!if(prop_error('canonize_qlptnc: qr failed', &
! errst=errst)) return
Rho%can(ii) = 'l'
Rho%can(ii + 1) = 'c'
call set_q_kappa(Rho%Aa(ii))
end do
do ii = kright, (k0 + 1), (-1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_rq(Rho%Aa(ii - 1), Rho%Aa(ii), errst=errst)
!if(prop_error('canonize_qlptnc: rq failed', &
! errst=errst)) return
Rho%can(ii - 1) = 'c'
Rho%can(ii) = 'r'
call set_q_kappa(Rho%Aa(ii))
end do
Rho%oc = k0
end subroutine canonize_qlptnc
"""
return
[docs]def canonize_svd_qlptnc():
"""
fortran-subroutine - June 2017 (dj, updated)
Put the LPTN into a canonical form using SVD.
**Arguments**
Rho : TYPE(qlptnc), inout
LPTN 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 LPTN). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
**Details**
Put the LPTN 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_qlptnc(Rho, k0, kl, kr, trunc, ncut, errst)
type(qlptnc), intent(inout) :: Rho
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, Rho%oc)
end if
! Find begin of canonization from the right
if(present(kr)) then
kright = kr
else
kright = min(Rho%ll, Rho%oc)
end if
do ii = kleft, (k0 - 1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_rsvd(Rho%Aa(ii), Rho%Lambda(ii), Rho%Aa(ii + 1), &
Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_qlptnc: gaugesite_rsvd failed', &
! errst=errst)) return
Rho%can(ii) = 'l'
Rho%can(ii + 1) = 'c'
call set_q_kappa(Rho%Aa(ii))
end do
do ii = kright, (k0 + 1), (-1)
call set_0_kappa(Rho%Aa(ii))
call gaugesite_lsvd(Rho%Aa(ii - 1), Rho%Lambda(ii), Rho%Aa(ii), &
Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
errst=errst)
!if(prop_error('canonize_svd_qlptnc: gaugesite_lsvd failed', &
! errst=errst)) return
Rho%can(ii - 1) = 'c'
Rho%can(ii) = 'r'
call set_q_kappa(Rho%Aa(ii))
end do
Rho%oc = k0
end subroutine canonize_svd_qlptnc
"""
return
[docs]def check_lptn():
"""
fortran-subroutine - August 2017 (dj)
Run basic checks on LPTN, such as left-right unitary and normed.
**Arguments**
Rho : TYPE(lptn), in
Run checks on this LPTN.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_lptn(Rho, errst)
type(lptn), intent(in) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Check norm of orthgonality center
real(KIND=rKind) :: normoc
! temporary tensor to keep Rho 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(Rho%Aa(Rho%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_lptn : norm failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(abs(normoc - 1.0_rKind) > 1e-14_rKind) stop 'check_lptn: norm.'
do ii = (Rho%oc + 1), Rho%ll
call copy(Tmp, Rho%Aa(ii))
call contr(Tens, Tmp, Tmp, [2, 3, 4], [2, 3, 4], &
transr='C', errst=errst)
!if(prop_error('check_lptn : contr (1) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_lptn : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_lptn: unitary failed (1).'
call destroy(Tmp)
call destroy(Tens)
end do
do ii = 1, (Rho%oc - 1)
call copy(Tmp, Rho%Aa(ii))
call contr(Tens, Tmp, Tmp, [1, 2, 3], [1, 2, 3], &
transr='C', errst=errst)
!if(prop_error('check_lptn : contr (2) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_lptn : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_lptn: unitary failed (2).'
call destroy(Tmp)
call destroy(Tens)
end do
end subroutine check_lptn
"""
return
[docs]def check_lptnc():
"""
fortran-subroutine - August 2017 (dj)
Run basic checks on LPTN, such as left-right unitary and normed.
**Arguments**
Rho : TYPE(lptnc), in
Run checks on this LPTN.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_lptnc(Rho, errst)
type(lptnc), intent(in) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Check norm of orthgonality center
real(KIND=rKind) :: normoc
! temporary tensor to keep Rho 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(Rho%Aa(Rho%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_lptnc : norm failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(abs(normoc - 1.0_rKind) > 1e-14_rKind) stop 'check_lptnc: norm.'
do ii = (Rho%oc + 1), Rho%ll
call copy(Tmp, Rho%Aa(ii))
call contr(Tens, Tmp, Tmp, [2, 3, 4], [2, 3, 4], &
transr='C', errst=errst)
!if(prop_error('check_lptnc : contr (1) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_lptnc : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_lptnc: unitary failed (1).'
call destroy(Tmp)
call destroy(Tens)
end do
do ii = 1, (Rho%oc - 1)
call copy(Tmp, Rho%Aa(ii))
call contr(Tens, Tmp, Tmp, [1, 2, 3], [1, 2, 3], &
transr='C', errst=errst)
!if(prop_error('check_lptnc : contr (2) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_lptnc : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_lptnc: unitary failed (2).'
call destroy(Tmp)
call destroy(Tens)
end do
end subroutine check_lptnc
"""
return
[docs]def check_qlptn():
"""
fortran-subroutine - August 2017 (dj)
Run basic checks on LPTN, such as left-right unitary and normed.
**Arguments**
Rho : TYPE(qlptn), in
Run checks on this LPTN.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_qlptn(Rho, errst)
type(qlptn), intent(in) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Check norm of orthgonality center
real(KIND=rKind) :: normoc
! temporary tensor to keep Rho 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(Rho%Aa(Rho%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_qlptn : norm failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(abs(normoc - 1.0_rKind) > 1e-14_rKind) stop 'check_qlptn: norm.'
do ii = (Rho%oc + 1), Rho%ll
call copy(Tmp, Rho%Aa(ii))
call contr(Tens, Tmp, Tmp, [2, 3, 4], [2, 3, 4], &
transr='C', errst=errst)
!if(prop_error('check_qlptn : contr (1) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_qlptn : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_qlptn: unitary failed (1).'
call destroy(Tmp)
call destroy(Tens)
end do
do ii = 1, (Rho%oc - 1)
call copy(Tmp, Rho%Aa(ii))
call contr(Tens, Tmp, Tmp, [1, 2, 3], [1, 2, 3], &
transr='C', errst=errst)
!if(prop_error('check_qlptn : contr (2) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_qlptn : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_qlptn: unitary failed (2).'
call destroy(Tmp)
call destroy(Tens)
end do
end subroutine check_qlptn
"""
return
[docs]def check_qlptnc():
"""
fortran-subroutine - August 2017 (dj)
Run basic checks on LPTN, such as left-right unitary and normed.
**Arguments**
Rho : TYPE(qlptnc), in
Run checks on this LPTN.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_qlptnc(Rho, errst)
type(qlptnc), intent(in) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Check norm of orthgonality center
real(KIND=rKind) :: normoc
! temporary tensor to keep Rho 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(Rho%Aa(Rho%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_qlptnc : norm failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(abs(normoc - 1.0_rKind) > 1e-14_rKind) stop 'check_qlptnc: norm.'
do ii = (Rho%oc + 1), Rho%ll
call copy(Tmp, Rho%Aa(ii))
call contr(Tens, Tmp, Tmp, [2, 3, 4], [2, 3, 4], &
transr='C', errst=errst)
!if(prop_error('check_qlptnc : contr (1) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_qlptnc : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_qlptnc: unitary failed (1).'
call destroy(Tmp)
call destroy(Tens)
end do
do ii = 1, (Rho%oc - 1)
call copy(Tmp, Rho%Aa(ii))
call contr(Tens, Tmp, Tmp, [1, 2, 3], [1, 2, 3], &
transr='C', errst=errst)
!if(prop_error('check_qlptnc : contr (2) failed.', &
! errst=errst)) return
!if(.not. is_eye(Tens)) then
! write(info, '(1I5)') ii
! errst = raise_error('check_qlptnc : unitary failed '//&
! trim(adjustl(info)), 99, errst=errst)
! return
!end if
if(.not. is_eye(Tens)) stop 'check_qlptnc: unitary failed (2).'
call destroy(Tmp)
call destroy(Tens)
end do
end subroutine check_qlptnc
"""
return
[docs]def copy_lptn_lptn():
"""
fortran-subroutine - September 2017 (dj, updated)
Make a copy of a LPTN
**Arguments**
Rho_new : TYPE(LPTN_TYPE), out
Store a copy of Rho_old here.
Rho_in : TYPE(LPTN_TYPE), in
Copy this LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_lptn_lptn(Rho_new, Rho_in, errst)
type(lptn), intent(out) :: Rho_new
type(lptn), intent(in) :: Rho_in
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
Rho_new%ll = Rho_in%ll
Rho_new%oc = Rho_in%oc
allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))
! Copy the arrays outside the loop
Rho_new%can = Rho_in%can
Rho_new%haslambda = Rho_in%haslambda
do ii = 1, Rho_new%ll
call copy(Rho_new%AA(ii), Rho_in%AA(ii))
if(Rho_new%haslambda(ii)) then
call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
end if
end do
if((Rho_new%haslambda(Rho_new%ll + 1))) then
call copy(Rho_new%Lambda(Rho_new%ll + 1), &
Rho_in%Lambda(Rho_new%ll + 1))
end if
end subroutine copy_lptn_lptn
"""
return
[docs]def copy_lptnc_lptnc():
"""
fortran-subroutine - September 2017 (dj, updated)
Make a copy of a LPTN
**Arguments**
Rho_new : TYPE(LPTN_TYPE), out
Store a copy of Rho_old here.
Rho_in : TYPE(LPTN_TYPE), in
Copy this LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_lptnc_lptnc(Rho_new, Rho_in, errst)
type(lptnc), intent(out) :: Rho_new
type(lptnc), intent(in) :: Rho_in
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
Rho_new%ll = Rho_in%ll
Rho_new%oc = Rho_in%oc
allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))
! Copy the arrays outside the loop
Rho_new%can = Rho_in%can
Rho_new%haslambda = Rho_in%haslambda
do ii = 1, Rho_new%ll
call copy(Rho_new%AA(ii), Rho_in%AA(ii))
if(Rho_new%haslambda(ii)) then
call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
end if
end do
if((Rho_new%haslambda(Rho_new%ll + 1))) then
call copy(Rho_new%Lambda(Rho_new%ll + 1), &
Rho_in%Lambda(Rho_new%ll + 1))
end if
end subroutine copy_lptnc_lptnc
"""
return
[docs]def copy_qlptn_qlptn():
"""
fortran-subroutine - September 2017 (dj, updated)
Make a copy of a LPTN
**Arguments**
Rho_new : TYPE(LPTN_TYPE), out
Store a copy of Rho_old here.
Rho_in : TYPE(LPTN_TYPE), in
Copy this LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qlptn_qlptn(Rho_new, Rho_in, errst)
type(qlptn), intent(out) :: Rho_new
type(qlptn), intent(in) :: Rho_in
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
Rho_new%ll = Rho_in%ll
Rho_new%oc = Rho_in%oc
allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))
! Copy the arrays outside the loop
Rho_new%can = Rho_in%can
Rho_new%haslambda = Rho_in%haslambda
do ii = 1, Rho_new%ll
call copy(Rho_new%AA(ii), Rho_in%AA(ii))
if(Rho_new%haslambda(ii)) then
call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
end if
end do
if((Rho_new%haslambda(Rho_new%ll + 1))) then
call copy(Rho_new%Lambda(Rho_new%ll + 1), &
Rho_in%Lambda(Rho_new%ll + 1))
end if
end subroutine copy_qlptn_qlptn
"""
return
[docs]def copy_qlptnc_qlptnc():
"""
fortran-subroutine - September 2017 (dj, updated)
Make a copy of a LPTN
**Arguments**
Rho_new : TYPE(LPTN_TYPE), out
Store a copy of Rho_old here.
Rho_in : TYPE(LPTN_TYPE), in
Copy this LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qlptnc_qlptnc(Rho_new, Rho_in, errst)
type(qlptnc), intent(out) :: Rho_new
type(qlptnc), intent(in) :: Rho_in
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
Rho_new%ll = Rho_in%ll
Rho_new%oc = Rho_in%oc
allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))
! Copy the arrays outside the loop
Rho_new%can = Rho_in%can
Rho_new%haslambda = Rho_in%haslambda
do ii = 1, Rho_new%ll
call copy(Rho_new%AA(ii), Rho_in%AA(ii))
if(Rho_new%haslambda(ii)) then
call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
end if
end do
if((Rho_new%haslambda(Rho_new%ll + 1))) then
call copy(Rho_new%Lambda(Rho_new%ll + 1), &
Rho_in%Lambda(Rho_new%ll + 1))
end if
end subroutine copy_qlptnc_qlptnc
"""
return
[docs]def copy_lptnc_lptn():
"""
fortran-subroutine - September 2017 (dj, updated)
Make a copy of a LPTN
**Arguments**
Rho_new : TYPE(LPTN_TYPE), out
Store a copy of Rho_old here.
Rho_in : TYPE(LPTN_TYPE), in
Copy this LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_lptnc_lptn(Rho_new, Rho_in, errst)
type(lptnc), intent(out) :: Rho_new
type(lptn), intent(in) :: Rho_in
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
Rho_new%ll = Rho_in%ll
Rho_new%oc = Rho_in%oc
allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))
! Copy the arrays outside the loop
Rho_new%can = Rho_in%can
Rho_new%haslambda = Rho_in%haslambda
do ii = 1, Rho_new%ll
call copy(Rho_new%AA(ii), Rho_in%AA(ii))
if(Rho_new%haslambda(ii)) then
call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
end if
end do
if((Rho_new%haslambda(Rho_new%ll + 1))) then
call copy(Rho_new%Lambda(Rho_new%ll + 1), &
Rho_in%Lambda(Rho_new%ll + 1))
end if
end subroutine copy_lptnc_lptn
"""
return
[docs]def copy_qlptnc_qlptn():
"""
fortran-subroutine - September 2017 (dj, updated)
Make a copy of a LPTN
**Arguments**
Rho_new : TYPE(LPTN_TYPE), out
Store a copy of Rho_old here.
Rho_in : TYPE(LPTN_TYPE), in
Copy this LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qlptnc_qlptn(Rho_new, Rho_in, errst)
type(qlptnc), intent(out) :: Rho_new
type(qlptn), intent(in) :: Rho_in
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
Rho_new%ll = Rho_in%ll
Rho_new%oc = Rho_in%oc
allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))
! Copy the arrays outside the loop
Rho_new%can = Rho_in%can
Rho_new%haslambda = Rho_in%haslambda
do ii = 1, Rho_new%ll
call copy(Rho_new%AA(ii), Rho_in%AA(ii))
if(Rho_new%haslambda(ii)) then
call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
end if
end do
if((Rho_new%haslambda(Rho_new%ll + 1))) then
call copy(Rho_new%Lambda(Rho_new%ll + 1), &
Rho_in%Lambda(Rho_new%ll + 1))
end if
end subroutine copy_qlptnc_qlptn
"""
return
[docs]def copy_lptn_mps():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS wave function Psi to a LPTN density matrix Rho.
**Arguments**
Rho : TYPE(lptn), inout
Copy MPS into this LPTN.
Psi : TYPE(mps), in
MPS to be converted to an LPTN
scalar : REAL, OPTIONAL, in
Scale Rho by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_lptn_mps(Rho, Psi, scalar, errst)
type(lptn), intent(inout) :: Rho
type(mps), intent(in) :: Psi
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
Rho%ll = Psi%ll
Rho%oc = Psi%oc
allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))
Rho%can = Psi%can
Rho%haslambda = Psi%haslambda
do ii = 1, Psi%ll
call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
!if(prop_error('copy_lptn_mps : copy '//&
! '(1) failed.', errst=errst)) return
call add_dummylink(Rho%Aa(ii), 3, errst=errst)
!if(prop_error('copy_lptn_mps : add_dummylink '//&
! 'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
end do
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) then
call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
!if(prop_error('copy_lptn_mps : copy '//&
! '(2) failed.', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Rho)
end if
end subroutine copy_lptn_mps
"""
return
[docs]def copy_lptnc_mps():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS wave function Psi to a LPTN density matrix Rho.
**Arguments**
Rho : TYPE(lptnc), inout
Copy MPS into this LPTN.
Psi : TYPE(mps), in
MPS to be converted to an LPTN
scalar : REAL, OPTIONAL, in
Scale Rho by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_lptnc_mps(Rho, Psi, scalar, errst)
type(lptnc), intent(inout) :: Rho
type(mps), intent(in) :: Psi
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
Rho%ll = Psi%ll
Rho%oc = Psi%oc
allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))
Rho%can = Psi%can
Rho%haslambda = Psi%haslambda
do ii = 1, Psi%ll
call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
!if(prop_error('copy_lptnc_mps : copy '//&
! '(1) failed.', errst=errst)) return
call add_dummylink(Rho%Aa(ii), 3, errst=errst)
!if(prop_error('copy_lptnc_mps : add_dummylink '//&
! 'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
end do
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) then
call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
!if(prop_error('copy_lptnc_mps : copy '//&
! '(2) failed.', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Rho)
end if
end subroutine copy_lptnc_mps
"""
return
[docs]def copy_lptnc_mpsc():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS wave function Psi to a LPTN density matrix Rho.
**Arguments**
Rho : TYPE(lptnc), inout
Copy MPS into this LPTN.
Psi : TYPE(mpsc), in
MPS to be converted to an LPTN
scalar : REAL, OPTIONAL, in
Scale Rho by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_lptnc_mpsc(Rho, Psi, scalar, errst)
type(lptnc), intent(inout) :: Rho
type(mpsc), intent(in) :: Psi
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
Rho%ll = Psi%ll
Rho%oc = Psi%oc
allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))
Rho%can = Psi%can
Rho%haslambda = Psi%haslambda
do ii = 1, Psi%ll
call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
!if(prop_error('copy_lptnc_mpsc : copy '//&
! '(1) failed.', errst=errst)) return
call add_dummylink(Rho%Aa(ii), 3, errst=errst)
!if(prop_error('copy_lptnc_mpsc : add_dummylink '//&
! 'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
end do
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) then
call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
!if(prop_error('copy_lptnc_mpsc : copy '//&
! '(2) failed.', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Rho)
end if
end subroutine copy_lptnc_mpsc
"""
return
[docs]def copy_qlptn_qmps():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS wave function Psi to a LPTN density matrix Rho.
**Arguments**
Rho : TYPE(qlptn), inout
Copy MPS into this LPTN.
Psi : TYPE(qmps), in
MPS to be converted to an LPTN
scalar : REAL, OPTIONAL, in
Scale Rho by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qlptn_qmps(Rho, Psi, scalar, errst)
type(qlptn), intent(inout) :: Rho
type(qmps), intent(in) :: Psi
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
Rho%ll = Psi%ll
Rho%oc = Psi%oc
allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))
Rho%can = Psi%can
Rho%haslambda = Psi%haslambda
do ii = 1, Psi%ll
call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
!if(prop_error('copy_qlptn_qmps : copy '//&
! '(1) failed.', errst=errst)) return
call add_dummylink(Rho%Aa(ii), 3, errst=errst)
!if(prop_error('copy_qlptn_qmps : add_dummylink '//&
! 'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
end do
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) then
call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
!if(prop_error('copy_qlptn_qmps : copy '//&
! '(2) failed.', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Rho)
end if
end subroutine copy_qlptn_qmps
"""
return
[docs]def copy_qlptnc_qmps():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS wave function Psi to a LPTN density matrix Rho.
**Arguments**
Rho : TYPE(qlptnc), inout
Copy MPS into this LPTN.
Psi : TYPE(qmps), in
MPS to be converted to an LPTN
scalar : REAL, OPTIONAL, in
Scale Rho by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qlptnc_qmps(Rho, Psi, scalar, errst)
type(qlptnc), intent(inout) :: Rho
type(qmps), intent(in) :: Psi
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
Rho%ll = Psi%ll
Rho%oc = Psi%oc
allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))
Rho%can = Psi%can
Rho%haslambda = Psi%haslambda
do ii = 1, Psi%ll
call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
!if(prop_error('copy_qlptnc_qmps : copy '//&
! '(1) failed.', errst=errst)) return
call add_dummylink(Rho%Aa(ii), 3, errst=errst)
!if(prop_error('copy_qlptnc_qmps : add_dummylink '//&
! 'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
end do
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) then
call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
!if(prop_error('copy_qlptnc_qmps : copy '//&
! '(2) failed.', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Rho)
end if
end subroutine copy_qlptnc_qmps
"""
return
[docs]def copy_qlptnc_qmpsc():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS wave function Psi to a LPTN density matrix Rho.
**Arguments**
Rho : TYPE(qlptnc), inout
Copy MPS into this LPTN.
Psi : TYPE(qmpsc), in
MPS to be converted to an LPTN
scalar : REAL, OPTIONAL, in
Scale Rho by a factor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qlptnc_qmpsc(Rho, Psi, scalar, errst)
type(qlptnc), intent(inout) :: Rho
type(qmpsc), intent(in) :: Psi
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
Rho%ll = Psi%ll
Rho%oc = Psi%oc
allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))
Rho%can = Psi%can
Rho%haslambda = Psi%haslambda
do ii = 1, Psi%ll
call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
!if(prop_error('copy_qlptnc_qmpsc : copy '//&
! '(1) failed.', errst=errst)) return
call add_dummylink(Rho%Aa(ii), 3, errst=errst)
!if(prop_error('copy_qlptnc_qmpsc : add_dummylink '//&
! 'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
end do
do ii = 1, (Psi%ll + 1)
if(Psi%haslambda(ii)) then
call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
!if(prop_error('copy_qlptnc_qmpsc : copy '//&
! '(2) failed.', errst=errst)) return
end if
end do
if(present(scalar)) then
! Could be more efficient inside loop
call scale(scalar, Rho)
end if
end subroutine copy_qlptnc_qmpsc
"""
return
[docs]def corr_init_lptn_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Tenskk : TYPE(tensor), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensor), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_lptn_tensor_tensor(Tenskk, Theta, Op, errst)
type(tensor), intent(inout) :: Tenskk
type(tensor), intent(out) :: Theta
type(tensor), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
end subroutine corr_init_lptn_tensor_tensor
"""
return
[docs]def corr_init_lptn_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Tenskk : TYPE(tensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_lptn_tensorc_tensor(Tenskk, Theta, Op, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorc), intent(out) :: Theta
type(tensor), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
end subroutine corr_init_lptn_tensorc_tensor
"""
return
[docs]def corr_init_lptn_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Tenskk : TYPE(tensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_lptn_tensorc_tensorc(Tenskk, Theta, Op, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorc), intent(out) :: Theta
type(tensorc), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
end subroutine corr_init_lptn_tensorc_tensorc
"""
return
[docs]def corr_init_lptn_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Tenskk : TYPE(qtensor), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensor), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_lptn_qtensor_qtensor(Tenskk, Theta, Op, errst)
type(qtensor), intent(inout) :: Tenskk
type(qtensor), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
end subroutine corr_init_lptn_qtensor_qtensor
"""
return
[docs]def corr_init_lptn_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_lptn_qtensorc_qtensor(Tenskk, Theta, Op, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorc), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
end subroutine corr_init_lptn_qtensorc_qtensor
"""
return
[docs]def corr_init_lptn_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_lptn_qtensorc_qtensorc(Tenskk, Theta, Op, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorc), intent(out) :: Theta
type(qtensorc), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
end subroutine corr_init_lptn_qtensorc_qtensorc
"""
return
[docs]def corr_init_l_lptn_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Calculate the correlation with a left-moving contraction. This is the
initialization.
**Arguments**
Tenskk : TYPE(tensor), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensor), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_lptn_tensor_tensor(Tenskk, Theta, Op, errst)
type(tensor), intent(inout) :: Tenskk
type(tensor), intent(out) :: Theta
type(tensor), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensor) :: Tmpa, Tmpb
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
end subroutine corr_init_l_lptn_tensor_tensor
"""
return
[docs]def corr_init_l_lptn_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Calculate the correlation with a left-moving contraction. This is the
initialization.
**Arguments**
Tenskk : TYPE(tensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_lptn_tensorc_tensor(Tenskk, Theta, Op, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorc), intent(out) :: Theta
type(tensor), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
end subroutine corr_init_l_lptn_tensorc_tensor
"""
return
[docs]def corr_init_l_lptn_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Calculate the correlation with a left-moving contraction. This is the
initialization.
**Arguments**
Tenskk : TYPE(tensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_lptn_tensorc_tensorc(Tenskk, Theta, Op, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorc), intent(out) :: Theta
type(tensorc), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
end subroutine corr_init_l_lptn_tensorc_tensorc
"""
return
[docs]def corr_init_l_lptn_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Calculate the correlation with a left-moving contraction. This is the
initialization.
**Arguments**
Tenskk : TYPE(qtensor), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensor), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_lptn_qtensor_qtensor(Tenskk, Theta, Op, errst)
type(qtensor), intent(inout) :: Tenskk
type(qtensor), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
end subroutine corr_init_l_lptn_qtensor_qtensor
"""
return
[docs]def corr_init_l_lptn_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Calculate the correlation with a left-moving contraction. This is the
initialization.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_lptn_qtensorc_qtensor(Tenskk, Theta, Op, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorc), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
end subroutine corr_init_l_lptn_qtensorc_qtensor
"""
return
[docs]def corr_init_l_lptn_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Calculate the correlation with a left-moving contraction. This is the
initialization.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_lptn_qtensorc_qtensorc(Tenskk, Theta, Op, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorc), intent(out) :: Theta
type(qtensorc), intent(inout) :: Op
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
! First index |ket>, second <bra|
call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
end subroutine corr_init_l_lptn_qtensorc_qtensorc
"""
return
[docs]def corr_meas_lptn_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Right-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensor), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensor), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_lptn_tensor_tensor(vals, Tenskk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
real(KIND=rKIND), intent(out) :: vals
type(tensor), intent(inout) :: Tenskk
integer, intent(in) :: kk, ll
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Tenskk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_lptn_tensor_tensor
"""
return
[docs]def corr_meas_lptn_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Right-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_lptn_tensorc_tensor(vals, Tenskk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=rKIND), intent(out) :: vals
type(tensorc), intent(inout) :: Tenskk
integer, intent(in) :: kk, ll
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Tenskk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_lptn_tensorc_tensor
"""
return
[docs]def corr_meas_lptn_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Right-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensorc), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_lptn_tensorc_tensorc(vals, Tenskk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=rKIND), intent(out) :: vals
type(tensorc), intent(inout) :: Tenskk
integer, intent(in) :: kk, ll
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Tenskk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_lptn_tensorc_tensorc
"""
return
[docs]def corr_meas_lptn_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Right-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensor), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensor), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_lptn_qtensor_qtensor(vals, Tenskk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
real(KIND=rKIND), intent(out) :: vals
type(qtensor), intent(inout) :: Tenskk
integer, intent(in) :: kk, ll
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Tenskk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_lptn_qtensor_qtensor
"""
return
[docs]def corr_meas_lptn_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Right-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_lptn_qtensorc_qtensor(vals, Tenskk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=rKIND), intent(out) :: vals
type(qtensorc), intent(inout) :: Tenskk
integer, intent(in) :: kk, ll
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Tenskk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_lptn_qtensorc_qtensor
"""
return
[docs]def corr_meas_lptn_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Right-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensorc), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_lptn_qtensorc_qtensorc(vals, Tenskk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=rKIND), intent(out) :: vals
type(qtensorc), intent(inout) :: Tenskk
integer, intent(in) :: kk, ll
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Tenskk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_lptn_qtensorc_qtensorc
"""
return
[docs]def corr_meas_l_lptn_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensor), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensor), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_lptn_tensor_tensor(vals, Tenskk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
real(KIND=RKind), intent(out) :: vals
type(tensor), intent(inout) :: Tenskk
integer, intent(in) :: kk
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpa)
call destroy(Tmpb)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_lptn_tensor_tensor
"""
return
[docs]def corr_meas_l_lptn_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_lptn_tensorc_tensor(vals, Tenskk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=RKind), intent(out) :: vals
type(tensorc), intent(inout) :: Tenskk
integer, intent(in) :: kk
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpa)
call destroy(Tmpb)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_lptn_tensorc_tensor
"""
return
[docs]def corr_meas_l_lptn_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensorc), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_lptn_tensorc_tensorc(vals, Tenskk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=RKind), intent(out) :: vals
type(tensorc), intent(inout) :: Tenskk
integer, intent(in) :: kk
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpa)
call destroy(Tmpb)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_lptn_tensorc_tensorc
"""
return
[docs]def corr_meas_l_lptn_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensor), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensor), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_lptn_qtensor_qtensor(vals, Tenskk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
real(KIND=RKind), intent(out) :: vals
type(qtensor), intent(inout) :: Tenskk
integer, intent(in) :: kk
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpa)
call destroy(Tmpb)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_lptn_qtensor_qtensor
"""
return
[docs]def corr_meas_l_lptn_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_lptn_qtensorc_qtensor(vals, Tenskk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=RKind), intent(out) :: vals
type(qtensorc), intent(inout) :: Tenskk
integer, intent(in) :: kk
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpa)
call destroy(Tmpb)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_lptn_qtensorc_qtensor
"""
return
[docs]def corr_meas_l_lptn_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensorc), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_lptn_qtensorc_qtensorc(vals, Tenskk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=RKind), intent(out) :: vals
type(qtensorc), intent(inout) :: Tenskk
integer, intent(in) :: kk
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Tenskk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
call destroy(Tmpa)
call destroy(Tmpb)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Tenskk, Theta, [4], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_lptn_qtensorc_qtensorc
"""
return
[docs]def create_lptn():
"""
fortran-subroutine - December 2014 (dj)
Initialize LPTN
**Arguments**
Rho : TYPE(lptn), out
LPTN to be initialized
ll : INTEGER, in
number of sites in the system
fill : CHARACTER, in
'N' : allocate, but do not initialize
'Z' : fill with zeros
'O' : fill with ones
'I' : start with the identity / maximally mixed state
(chi and kappa not necessary)
'R' : random numbers
dd : INTEGER(*), in
dimension of the local Hilbert space
SIZE(dd) = 1 : all sites have the same size
SIZE(dd) = ll: site dependent local Hilbert space
chi : INTEGER(*), OPTIONAL, in
dimension of the bond dimension to nearest neighbor
SIZE(chi) = 1 : all sites have the same bond dimension
boundary effects are considered
SIZE(chi) = ll - 1: site dependent bond dimension, boundary effects
have to be considered in the array.
kappa : INTEGER(*), OPTIONAL, in
dimension of the kraus link to complex conjugated tensor
SIZE(kappa) = 1 : all sites have the same bond dimension
SIZE(kappa) = ll: site dependent Kraus dimension
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_lptn(Rho, ll, fill, dd, chi, kappa)
type(lptn), intent(out) :: Rho
integer, intent(in) :: ll
character, intent(in) :: fill
integer, dimension(:), intent(in) :: dd
integer, dimension(:), intent(in), optional ::chi, kappa
! for looping
integer :: ii, jj, kk
! arrays with the dimensions used
integer, dimension(ll) :: dd_, kappa_
integer, dimension(ll+1) :: chi_
Rho%ll = ll
allocate(Rho%AA(ll), Rho%haslambda(ll + 1), Rho%Lambda(ll + 1), &
Rho%can(ll))
! To-do: set haslambda, Lambda, oc, can in most cases
! To-do: set boundary effects for chi
! Fill the arrays with the dimensions
! ===================================
if(size(dd) == 1) then
dd_ = dd(1)
else
dd_ = dd
end if
if(present(chi)) then
if(size(chi) == 1) then
chi_ = chi(1)
else
chi_(1) = 1
chi_(2:ll) = chi
chi_(ll + 1) = 1
end if
else
chi_ = 1
end if
if(present(kappa)) then
if(size(kappa) == 1) then
kappa_ = kappa(1)
else
kappa_ = kappa
end if
else
kappa_ = 1
end if
! Fill the tensors
! ================
if(fill == 'N') then
! Only allocate, but do not initialize
! ------------------------------------
do ii = 1, ll
call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
chi_(ii + 1)])
end do
Rho%oc = -1
Rho%can = 'n'
Rho%haslambda = .false.
elseif(fill == 'Z') then
! Fill the LPTN with zeros
! ------------------------
do ii = 1, ll
call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
chi_(ii + 1)], init='0')
end do
Rho%oc = -1
Rho%can = 'n'
Rho%haslambda = .false.
elseif(fill == 'I') then
! Identity / maximally mixed state
! --------------------------------
! all other sites
do ii = 1, ll
call create(Rho%AA(ii), [1, dd_(ii), dd_(ii), 1])
kk = 1
do jj = 1, dd_(ii)
Rho%AA(ii)%elem(kk) = sqrt(1.0_rKind / dd_(ii))
kk = kk + dd_(ii) + 1
end do
end do
! Set canonization
Rho%oc = 1
Rho%can = 'r'
Rho%can(1) = 'c'
Rho%haslambda = .false.
! Set Schmidt values
do ii = 2, ll
allocate(Rho%Lambda(ii)%elem(1))
Rho%Lambda(ii)%elem(1) = 1.0_rKind
Rho%haslambda(ii) = .true.
end do
elseif(fill == 'O') then
! Fill the LPTN with ones
! ------------------------
stop 'Init_LPTNc: ones not implemented.'
elseif(fill == 'R') then
! Fill with Random numbers
! ------------------------
do ii = 1, ll
call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
chi_(ii + 1)], init='R')
end do
! Set canonization
Rho%oc = 1
Rho%can = 'r'
Rho%can(1) = 'c'
Rho%haslambda = .false.
! And canonize it
call canonize(Rho, 1)
else
stop 'Init_LPTNc: bad argument for fill'
end if
end subroutine create_lptn
"""
return
[docs]def create_lptnc():
"""
fortran-subroutine - December 2014 (dj)
Initialize LPTN
**Arguments**
Rho : TYPE(lptnc), out
LPTN to be initialized
ll : INTEGER, in
number of sites in the system
fill : CHARACTER, in
'N' : allocate, but do not initialize
'Z' : fill with zeros
'O' : fill with ones
'I' : start with the identity / maximally mixed state
(chi and kappa not necessary)
'R' : random numbers
dd : INTEGER(*), in
dimension of the local Hilbert space
SIZE(dd) = 1 : all sites have the same size
SIZE(dd) = ll: site dependent local Hilbert space
chi : INTEGER(*), OPTIONAL, in
dimension of the bond dimension to nearest neighbor
SIZE(chi) = 1 : all sites have the same bond dimension
boundary effects are considered
SIZE(chi) = ll - 1: site dependent bond dimension, boundary effects
have to be considered in the array.
kappa : INTEGER(*), OPTIONAL, in
dimension of the kraus link to complex conjugated tensor
SIZE(kappa) = 1 : all sites have the same bond dimension
SIZE(kappa) = ll: site dependent Kraus dimension
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_lptnc(Rho, ll, fill, dd, chi, kappa)
type(lptnc), intent(out) :: Rho
integer, intent(in) :: ll
character, intent(in) :: fill
integer, dimension(:), intent(in) :: dd
integer, dimension(:), intent(in), optional ::chi, kappa
! for looping
integer :: ii, jj, kk
! arrays with the dimensions used
integer, dimension(ll) :: dd_, kappa_
integer, dimension(ll+1) :: chi_
Rho%ll = ll
allocate(Rho%AA(ll), Rho%haslambda(ll + 1), Rho%Lambda(ll + 1), &
Rho%can(ll))
! To-do: set haslambda, Lambda, oc, can in most cases
! To-do: set boundary effects for chi
! Fill the arrays with the dimensions
! ===================================
if(size(dd) == 1) then
dd_ = dd(1)
else
dd_ = dd
end if
if(present(chi)) then
if(size(chi) == 1) then
chi_ = chi(1)
else
chi_(1) = 1
chi_(2:ll) = chi
chi_(ll + 1) = 1
end if
else
chi_ = 1
end if
if(present(kappa)) then
if(size(kappa) == 1) then
kappa_ = kappa(1)
else
kappa_ = kappa
end if
else
kappa_ = 1
end if
! Fill the tensors
! ================
if(fill == 'N') then
! Only allocate, but do not initialize
! ------------------------------------
do ii = 1, ll
call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
chi_(ii + 1)])
end do
Rho%oc = -1
Rho%can = 'n'
Rho%haslambda = .false.
elseif(fill == 'Z') then
! Fill the LPTN with zeros
! ------------------------
do ii = 1, ll
call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
chi_(ii + 1)], init='0')
end do
Rho%oc = -1
Rho%can = 'n'
Rho%haslambda = .false.
elseif(fill == 'I') then
! Identity / maximally mixed state
! --------------------------------
! all other sites
do ii = 1, ll
call create(Rho%AA(ii), [1, dd_(ii), dd_(ii), 1])
kk = 1
do jj = 1, dd_(ii)
Rho%AA(ii)%elem(kk) = sqrt(1.0_rKind / dd_(ii))
kk = kk + dd_(ii) + 1
end do
end do
! Set canonization
Rho%oc = 1
Rho%can = 'r'
Rho%can(1) = 'c'
Rho%haslambda = .false.
! Set Schmidt values
do ii = 2, ll
allocate(Rho%Lambda(ii)%elem(1))
Rho%Lambda(ii)%elem(1) = 1.0_rKind
Rho%haslambda(ii) = .true.
end do
elseif(fill == 'O') then
! Fill the LPTN with ones
! ------------------------
stop 'Init_LPTNc: ones not implemented.'
elseif(fill == 'R') then
! Fill with Random numbers
! ------------------------
do ii = 1, ll
call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
chi_(ii + 1)], init='R')
end do
! Set canonization
Rho%oc = 1
Rho%can = 'r'
Rho%can(1) = 'c'
Rho%haslambda = .false.
! And canonize it
call canonize(Rho, 1)
else
stop 'Init_LPTNc: bad argument for fill'
end if
end subroutine create_lptnc
"""
return
[docs]def destroy_lptn():
"""
fortran-subroutine - September 2017 (dj, updated)
Deallocate a LPTN
**Arguments**
Rho : TYPE(lptn), inout
deallocate the LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_lptn(Rho)
type(lptn), intent(inout) :: Rho
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Rho%ll
call destroy(Rho%AA(ii))
if(Rho%haslambda(ii)) then
call destroy(Rho%Lambda(ii))
end if
end do
if(Rho%haslambda(Rho%ll + 1)) then
call destroy(Rho%Lambda(Rho%ll + 1))
end if
deallocate(Rho%haslambda, Rho%Lambda, Rho%can, Rho%AA)
Rho%ll = -1
end subroutine destroy_lptn
"""
return
[docs]def destroy_lptnc():
"""
fortran-subroutine - September 2017 (dj, updated)
Deallocate a LPTN
**Arguments**
Rho : TYPE(lptnc), inout
deallocate the LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_lptnc(Rho)
type(lptnc), intent(inout) :: Rho
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Rho%ll
call destroy(Rho%AA(ii))
if(Rho%haslambda(ii)) then
call destroy(Rho%Lambda(ii))
end if
end do
if(Rho%haslambda(Rho%ll + 1)) then
call destroy(Rho%Lambda(Rho%ll + 1))
end if
deallocate(Rho%haslambda, Rho%Lambda, Rho%can, Rho%AA)
Rho%ll = -1
end subroutine destroy_lptnc
"""
return
[docs]def destroy_qlptn():
"""
fortran-subroutine - September 2017 (dj, updated)
Deallocate a LPTN
**Arguments**
Rho : TYPE(qlptn), inout
deallocate the LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qlptn(Rho)
type(qlptn), intent(inout) :: Rho
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Rho%ll
call destroy(Rho%AA(ii))
if(Rho%haslambda(ii)) then
call destroy(Rho%Lambda(ii))
end if
end do
if(Rho%haslambda(Rho%ll + 1)) then
call destroy(Rho%Lambda(Rho%ll + 1))
end if
deallocate(Rho%haslambda, Rho%Lambda, Rho%can, Rho%AA)
Rho%ll = -1
end subroutine destroy_qlptn
"""
return
[docs]def destroy_qlptnc():
"""
fortran-subroutine - September 2017 (dj, updated)
Deallocate a LPTN
**Arguments**
Rho : TYPE(qlptnc), inout
deallocate the LPTN
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qlptnc(Rho)
type(qlptnc), intent(inout) :: Rho
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Rho%ll
call destroy(Rho%AA(ii))
if(Rho%haslambda(ii)) then
call destroy(Rho%Lambda(ii))
end if
end do
if(Rho%haslambda(Rho%ll + 1)) then
call destroy(Rho%Lambda(Rho%ll + 1))
end if
deallocate(Rho%haslambda, Rho%Lambda, Rho%can, Rho%AA)
Rho%ll = -1
end subroutine destroy_qlptnc
"""
return
[docs]def distance_lptn_mps():
"""
fortran-function - September 2017 (dj)
Measure the distance between an LPTN and an MPS.
**Arguments**
Rho : TYPE(lptn), in
Density matrix for distance measure.
Psi : TYPE(mps), in
Pure state in the distance measure.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Only option right now is
'F' (fidelity, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_lptn_mps(Rho, Psi, dist_type, &
errst) result(dist)
type(lptn), intent(in) :: Rho
type(mps), intent(in) :: Psi
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 = 'F'
if(present(dist_type)) dtype = dist_type
if(dtype == 'F') then
dist = fidelity(Rho, Psi, errst=errst)
!if(prop_error('distance_lptn_mps : fidelity '//&
! 'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
else
errst = raise_error('distance_lptn_mps : unkown '//&
'dist_type', 99, errst=errst)
end if
end function distance_lptn_mps
"""
return
[docs]def distance_lptn_mpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between an LPTN and an MPS.
**Arguments**
Rho : TYPE(lptn), in
Density matrix for distance measure.
Psi : TYPE(mpsc), in
Pure state in the distance measure.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Only option right now is
'F' (fidelity, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_lptn_mpsc(Rho, Psi, dist_type, &
errst) result(dist)
type(lptn), intent(in) :: Rho
type(mpsc), intent(in) :: Psi
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 = 'F'
if(present(dist_type)) dtype = dist_type
if(dtype == 'F') then
dist = fidelity(Rho, Psi, errst=errst)
!if(prop_error('distance_lptn_mpsc : fidelity '//&
! 'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
else
errst = raise_error('distance_lptn_mpsc : unkown '//&
'dist_type', 99, errst=errst)
end if
end function distance_lptn_mpsc
"""
return
[docs]def distance_lptnc_mps():
"""
fortran-function - September 2017 (dj)
Measure the distance between an LPTN and an MPS.
**Arguments**
Rho : TYPE(lptnc), in
Density matrix for distance measure.
Psi : TYPE(mps), in
Pure state in the distance measure.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Only option right now is
'F' (fidelity, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_lptnc_mps(Rho, Psi, dist_type, &
errst) result(dist)
type(lptnc), intent(in) :: Rho
type(mps), intent(in) :: Psi
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 = 'F'
if(present(dist_type)) dtype = dist_type
if(dtype == 'F') then
dist = fidelity(Rho, Psi, errst=errst)
!if(prop_error('distance_lptnc_mps : fidelity '//&
! 'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
else
errst = raise_error('distance_lptnc_mps : unkown '//&
'dist_type', 99, errst=errst)
end if
end function distance_lptnc_mps
"""
return
[docs]def distance_lptnc_mpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between an LPTN and an MPS.
**Arguments**
Rho : TYPE(lptnc), in
Density matrix for distance measure.
Psi : TYPE(mpsc), in
Pure state in the distance measure.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Only option right now is
'F' (fidelity, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_lptnc_mpsc(Rho, Psi, dist_type, &
errst) result(dist)
type(lptnc), intent(in) :: Rho
type(mpsc), intent(in) :: Psi
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 = 'F'
if(present(dist_type)) dtype = dist_type
if(dtype == 'F') then
dist = fidelity(Rho, Psi, errst=errst)
!if(prop_error('distance_lptnc_mpsc : fidelity '//&
! 'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
else
errst = raise_error('distance_lptnc_mpsc : unkown '//&
'dist_type', 99, errst=errst)
end if
end function distance_lptnc_mpsc
"""
return
[docs]def distance_qlptn_qmps():
"""
fortran-function - September 2017 (dj)
Measure the distance between an LPTN and an MPS.
**Arguments**
Rho : TYPE(qlptn), in
Density matrix for distance measure.
Psi : TYPE(qmps), in
Pure state in the distance measure.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Only option right now is
'F' (fidelity, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_qlptn_qmps(Rho, Psi, dist_type, &
errst) result(dist)
type(qlptn), intent(in) :: Rho
type(qmps), intent(in) :: Psi
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 = 'F'
if(present(dist_type)) dtype = dist_type
if(dtype == 'F') then
dist = fidelity(Rho, Psi, errst=errst)
!if(prop_error('distance_qlptn_qmps : fidelity '//&
! 'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
else
errst = raise_error('distance_qlptn_qmps : unkown '//&
'dist_type', 99, errst=errst)
end if
end function distance_qlptn_qmps
"""
return
[docs]def distance_qlptn_qmpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between an LPTN and an MPS.
**Arguments**
Rho : TYPE(qlptn), in
Density matrix for distance measure.
Psi : TYPE(qmpsc), in
Pure state in the distance measure.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Only option right now is
'F' (fidelity, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_qlptn_qmpsc(Rho, Psi, dist_type, &
errst) result(dist)
type(qlptn), intent(in) :: Rho
type(qmpsc), intent(in) :: Psi
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 = 'F'
if(present(dist_type)) dtype = dist_type
if(dtype == 'F') then
dist = fidelity(Rho, Psi, errst=errst)
!if(prop_error('distance_qlptn_qmpsc : fidelity '//&
! 'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
else
errst = raise_error('distance_qlptn_qmpsc : unkown '//&
'dist_type', 99, errst=errst)
end if
end function distance_qlptn_qmpsc
"""
return
[docs]def distance_qlptnc_qmps():
"""
fortran-function - September 2017 (dj)
Measure the distance between an LPTN and an MPS.
**Arguments**
Rho : TYPE(qlptnc), in
Density matrix for distance measure.
Psi : TYPE(qmps), in
Pure state in the distance measure.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Only option right now is
'F' (fidelity, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_qlptnc_qmps(Rho, Psi, dist_type, &
errst) result(dist)
type(qlptnc), intent(in) :: Rho
type(qmps), intent(in) :: Psi
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 = 'F'
if(present(dist_type)) dtype = dist_type
if(dtype == 'F') then
dist = fidelity(Rho, Psi, errst=errst)
!if(prop_error('distance_qlptnc_qmps : fidelity '//&
! 'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
else
errst = raise_error('distance_qlptnc_qmps : unkown '//&
'dist_type', 99, errst=errst)
end if
end function distance_qlptnc_qmps
"""
return
[docs]def distance_qlptnc_qmpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between an LPTN and an MPS.
**Arguments**
Rho : TYPE(qlptnc), in
Density matrix for distance measure.
Psi : TYPE(qmpsc), in
Pure state in the distance measure.
dist_type : CHARACTER, OPTIONAL, in
Specify the distance to be calculated. Only option right now is
'F' (fidelity, default).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function distance_qlptnc_qmpsc(Rho, Psi, dist_type, &
errst) result(dist)
type(qlptnc), intent(in) :: Rho
type(qmpsc), intent(in) :: Psi
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 = 'F'
if(present(dist_type)) dtype = dist_type
if(dtype == 'F') then
dist = fidelity(Rho, Psi, errst=errst)
!if(prop_error('distance_qlptnc_qmpsc : fidelity '//&
! 'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
else
errst = raise_error('distance_qlptnc_qmpsc : unkown '//&
'dist_type', 99, errst=errst)
end if
end function distance_qlptnc_qmpsc
"""
return
[docs]def fidelity_lptn_mps():
"""
fortran-function - September 2017 (dj)
Calculate the fidelity between a density matrix represented as
LPTN and a state represented as MPS.
**Arguments**
Rho : TYPE(lptn), inout
Density matrix for distance measure.
Psi : TYPE(mps), in
Pure state in the distance measure.
**Details**
With :math:`\\sigma = | \psi \\rangle \\langle \psi |` the
fidelity is
:math:`F = Tr \\sqrt{ \\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`. It
simplifies to :math:`F = \\sqrt{\\langle \psi | \\rho | \psi \\rangle}`
The two layers of the MPS and the LPTN are contracted. After fusing the
chi-links we remain with an MPS-like construct. The local dimension is
represented with the kappa-links. This norm of this MPS construct
yields the actual distance.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_lptn_mps(Rho, Psi, errst) result(fid)
type(lptn), intent(in) :: Rho
type(mps), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
! for looping
integer :: ii
! MPS representing contraction
type(mps) :: RP, RPc
! Copy of tensors
type(tensor) :: Tensp
type(tensor) :: Tensr
!if(present(errst)) errst = 0
RP%ll = Rho%ll
RP%oc = -1
allocate(RP%Aa(RP%ll), RP%can(RP%ll), &
RP%haslambda(RP%ll + 1), RP%lambda(RP%ll + 1))
RP%can = 'o'
RP%haslambda = .false.
do ii = 1, RP%ll
call copy(Tensr, Rho%Aa(ii))
call copy(Tensp, Psi%Aa(ii))
call contr(RP%Aa(ii), Tensr, Tensp, [2], [2], transl='C', &
errst=errst)!permout=[1, 3, 4, 2, 5], errst=errst)
!if(prop_error('fidelity_lptn_mps : contr '//&
! 'failed.', 'LPTNOps_include.f90:1352', errst=errst)) return
call transposed(RP%Aa(ii), [1, 4, 2, 3, 5], doperm=.true.)
call fuse(RP%Aa(ii), [1, 2])
call fuse(RP%Aa(ii), [3, 4])
call destroy(Tensr)
call destroy(Tensp)
end do
call copy(RPc, RP)
fid = real(dot(RP, RPc, errst=errst), KIND=rKind)
!if(prop_error('fidelity_lptn_mps : dot failed.', &
! 'LPTNOps_include.f90:1367', errst=errst)) return
call destroy(RP)
call destroy(RPc)
end function fidelity_lptn_mps
"""
return
[docs]def fidelity_lptn_mpsc():
"""
fortran-function - September 2017 (dj)
Calculate the fidelity between a density matrix represented as
LPTN and a state represented as MPS.
**Arguments**
Rho : TYPE(lptn), inout
Density matrix for distance measure.
Psi : TYPE(mpsc), in
Pure state in the distance measure.
**Details**
With :math:`\\sigma = | \psi \\rangle \\langle \psi |` the
fidelity is
:math:`F = Tr \\sqrt{ \\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`. It
simplifies to :math:`F = \\sqrt{\\langle \psi | \\rho | \psi \\rangle}`
The two layers of the MPS and the LPTN are contracted. After fusing the
chi-links we remain with an MPS-like construct. The local dimension is
represented with the kappa-links. This norm of this MPS construct
yields the actual distance.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_lptn_mpsc(Rho, Psi, errst) result(fid)
type(lptn), intent(in) :: Rho
type(mpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
! for looping
integer :: ii
! MPS representing contraction
type(mpsc) :: RP, RPc
! Copy of tensors
type(tensorc) :: Tensp
type(tensorc) :: Tensr
!if(present(errst)) errst = 0
RP%ll = Rho%ll
RP%oc = -1
allocate(RP%Aa(RP%ll), RP%can(RP%ll), &
RP%haslambda(RP%ll + 1), RP%lambda(RP%ll + 1))
RP%can = 'o'
RP%haslambda = .false.
do ii = 1, RP%ll
call copy(Tensr, Rho%Aa(ii))
call copy(Tensp, Psi%Aa(ii))
call contr(RP%Aa(ii), Tensr, Tensp, [2], [2], transl='C', &
errst=errst)!permout=[1, 3, 4, 2, 5], errst=errst)
!if(prop_error('fidelity_lptn_mpsc : contr '//&
! 'failed.', 'LPTNOps_include.f90:1352', errst=errst)) return
call transposed(RP%Aa(ii), [1, 4, 2, 3, 5], doperm=.true.)
call fuse(RP%Aa(ii), [1, 2])
call fuse(RP%Aa(ii), [3, 4])
call destroy(Tensr)
call destroy(Tensp)
end do
call copy(RPc, RP)
fid = real(dot(RP, RPc, errst=errst), KIND=rKind)
!if(prop_error('fidelity_lptn_mpsc : dot failed.', &
! 'LPTNOps_include.f90:1367', errst=errst)) return
call destroy(RP)
call destroy(RPc)
end function fidelity_lptn_mpsc
"""
return
[docs]def fidelity_lptnc_mps():
"""
fortran-function - September 2017 (dj)
Calculate the fidelity between a density matrix represented as
LPTN and a state represented as MPS.
**Arguments**
Rho : TYPE(lptnc), inout
Density matrix for distance measure.
Psi : TYPE(mps), in
Pure state in the distance measure.
**Details**
With :math:`\\sigma = | \psi \\rangle \\langle \psi |` the
fidelity is
:math:`F = Tr \\sqrt{ \\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`. It
simplifies to :math:`F = \\sqrt{\\langle \psi | \\rho | \psi \\rangle}`
The two layers of the MPS and the LPTN are contracted. After fusing the
chi-links we remain with an MPS-like construct. The local dimension is
represented with the kappa-links. This norm of this MPS construct
yields the actual distance.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_lptnc_mps(Rho, Psi, errst) result(fid)
type(lptnc), intent(in) :: Rho
type(mps), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
! for looping
integer :: ii
! MPS representing contraction
type(mpsc) :: RP, RPc
! Copy of tensors
type(tensorc) :: Tensp
type(tensorc) :: Tensr
!if(present(errst)) errst = 0
RP%ll = Rho%ll
RP%oc = -1
allocate(RP%Aa(RP%ll), RP%can(RP%ll), &
RP%haslambda(RP%ll + 1), RP%lambda(RP%ll + 1))
RP%can = 'o'
RP%haslambda = .false.
do ii = 1, RP%ll
call copy(Tensr, Rho%Aa(ii))
call copy(Tensp, Psi%Aa(ii))
call contr(RP%Aa(ii), Tensr, Tensp, [2], [2], transl='C', &
errst=errst)!permout=[1, 3, 4, 2, 5], errst=errst)
!if(prop_error('fidelity_lptnc_mps : contr '//&
! 'failed.', 'LPTNOps_include.f90:1352', errst=errst)) return
call transposed(RP%Aa(ii), [1, 4, 2, 3, 5], doperm=.true.)
call fuse(RP%Aa(ii), [1, 2])
call fuse(RP%Aa(ii), [3, 4])
call destroy(Tensr)
call destroy(Tensp)
end do
call copy(RPc, RP)
fid = real(dot(RP, RPc, errst=errst), KIND=rKind)
!if(prop_error('fidelity_lptnc_mps : dot failed.', &
! 'LPTNOps_include.f90:1367', errst=errst)) return
call destroy(RP)
call destroy(RPc)
end function fidelity_lptnc_mps
"""
return
[docs]def fidelity_lptnc_mpsc():
"""
fortran-function - September 2017 (dj)
Calculate the fidelity between a density matrix represented as
LPTN and a state represented as MPS.
**Arguments**
Rho : TYPE(lptnc), inout
Density matrix for distance measure.
Psi : TYPE(mpsc), in
Pure state in the distance measure.
**Details**
With :math:`\\sigma = | \psi \\rangle \\langle \psi |` the
fidelity is
:math:`F = Tr \\sqrt{ \\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`. It
simplifies to :math:`F = \\sqrt{\\langle \psi | \\rho | \psi \\rangle}`
The two layers of the MPS and the LPTN are contracted. After fusing the
chi-links we remain with an MPS-like construct. The local dimension is
represented with the kappa-links. This norm of this MPS construct
yields the actual distance.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_lptnc_mpsc(Rho, Psi, errst) result(fid)
type(lptnc), intent(in) :: Rho
type(mpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
! for looping
integer :: ii
! MPS representing contraction
type(mpsc) :: RP, RPc
! Copy of tensors
type(tensorc) :: Tensp
type(tensorc) :: Tensr
!if(present(errst)) errst = 0
RP%ll = Rho%ll
RP%oc = -1
allocate(RP%Aa(RP%ll), RP%can(RP%ll), &
RP%haslambda(RP%ll + 1), RP%lambda(RP%ll + 1))
RP%can = 'o'
RP%haslambda = .false.
do ii = 1, RP%ll
call copy(Tensr, Rho%Aa(ii))
call copy(Tensp, Psi%Aa(ii))
call contr(RP%Aa(ii), Tensr, Tensp, [2], [2], transl='C', &
errst=errst)!permout=[1, 3, 4, 2, 5], errst=errst)
!if(prop_error('fidelity_lptnc_mpsc : contr '//&
! 'failed.', 'LPTNOps_include.f90:1352', errst=errst)) return
call transposed(RP%Aa(ii), [1, 4, 2, 3, 5], doperm=.true.)
call fuse(RP%Aa(ii), [1, 2])
call fuse(RP%Aa(ii), [3, 4])
call destroy(Tensr)
call destroy(Tensp)
end do
call copy(RPc, RP)
fid = real(dot(RP, RPc, errst=errst), KIND=rKind)
!if(prop_error('fidelity_lptnc_mpsc : dot failed.', &
! 'LPTNOps_include.f90:1367', errst=errst)) return
call destroy(RP)
call destroy(RPc)
end function fidelity_lptnc_mpsc
"""
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], [4], 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, 4], errst=errst)
!if(prop_error('gaugesite_rq_tensor: rq failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tl, [1], [4], 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], [4], 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, 4], errst=errst)
!if(prop_error('gaugesite_rq_tensorc: rq failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tl, [1], [4], 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], [4], 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, 4], errst=errst)
!if(prop_error('gaugesite_rq_qtensor: rq failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tl, [1], [4], 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], [4], 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, 4], errst=errst)
!if(prop_error('gaugesite_rq_qtensorc: rq failed', &
! errst=errst)) return
call contr_uplo(Tmp, Tl, [1], [4], 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], [4], 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 copy(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 copy(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, 4], 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 copy(Tr, Tr2)
call destroy(Tr2)
call contr(Tl2, Tl, Tmp, [4], [1], errst=errst)
!if(prop_error('gaugesite_lsvd_tensor: contr failed', &
! errst=errst)) return
call destroy(Tl)
call copy(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], [4], 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 copy(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 copy(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, 4], 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 copy(Tr, Tr2)
call destroy(Tr2)
call contr(Tl2, Tl, Tmp, [4], [1], errst=errst)
!if(prop_error('gaugesite_lsvd_tensorc: contr failed', &
! errst=errst)) return
call destroy(Tl)
call copy(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], [4], 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 copy(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 copy(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, 4], 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 copy(Tr, Tr2)
call destroy(Tr2)
call contr(Tl2, Tl, Tmp, [4], [1], errst=errst)
!if(prop_error('gaugesite_lsvd_qtensor: contr failed', &
! errst=errst)) return
call destroy(Tl)
call copy(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], [4], 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 copy(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 copy(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, 4], 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 copy(Tr, Tr2)
call destroy(Tr2)
call contr(Tl2, Tl, Tmp, [4], [1], errst=errst)
!if(prop_error('gaugesite_lsvd_qtensorc: contr failed', &
! errst=errst)) return
call destroy(Tl)
call copy(Tl, Tl2)
call destroy(Tl2)
call destroy(Tmp)
end subroutine gaugesite_lsvd_qtensorc
"""
return
[docs]def maxchi_lptn():
"""
fortran-function - September 2017 (dj, updated)
Get the maximal bond dimension to nearest neighbors of the LPTN.
**Arguments**
Rho : TYPE(lptn), in
Get the maximal bond dimension present in the LPTN for the
link between nearest neighbors.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxchi_lptn(Rho) result(chi)
type(lptn), intent(in) :: Rho
integer :: chi
! Local variables
! ---------------
! for looping
integer :: ii
chi = 0
do ii = 1, Rho%ll
chi = max(chi, maxlineardim(Rho%Aa(ii), idx=[1, 4]))
end do
end function maxchi_lptn
"""
return
[docs]def maxchi_lptnc():
"""
fortran-function - September 2017 (dj, updated)
Get the maximal bond dimension to nearest neighbors of the LPTN.
**Arguments**
Rho : TYPE(lptnc), in
Get the maximal bond dimension present in the LPTN for the
link between nearest neighbors.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxchi_lptnc(Rho) result(chi)
type(lptnc), intent(in) :: Rho
integer :: chi
! Local variables
! ---------------
! for looping
integer :: ii
chi = 0
do ii = 1, Rho%ll
chi = max(chi, maxlineardim(Rho%Aa(ii), idx=[1, 4]))
end do
end function maxchi_lptnc
"""
return
[docs]def maxchi_qlptn():
"""
fortran-function - September 2017 (dj, updated)
Get the maximal bond dimension to nearest neighbors of the LPTN.
**Arguments**
Rho : TYPE(qlptn), in
Get the maximal bond dimension present in the LPTN for the
link between nearest neighbors.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxchi_qlptn(Rho) result(chi)
type(qlptn), intent(in) :: Rho
integer :: chi
! Local variables
! ---------------
! for looping
integer :: ii
chi = 0
do ii = 1, Rho%ll
chi = max(chi, maxlineardim(Rho%Aa(ii), idx=[1, 4]))
end do
end function maxchi_qlptn
"""
return
[docs]def maxchi_qlptnc():
"""
fortran-function - September 2017 (dj, updated)
Get the maximal bond dimension to nearest neighbors of the LPTN.
**Arguments**
Rho : TYPE(qlptnc), in
Get the maximal bond dimension present in the LPTN for the
link between nearest neighbors.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxchi_qlptnc(Rho) result(chi)
type(qlptnc), intent(in) :: Rho
integer :: chi
! Local variables
! ---------------
! for looping
integer :: ii
chi = 0
do ii = 1, Rho%ll
chi = max(chi, maxlineardim(Rho%Aa(ii), idx=[1, 4]))
end do
end function maxchi_qlptnc
"""
return
[docs]def maxkappa_lptn():
"""
fortran-function - September 2017 (dj, updated)
Get the maximal bond dimension to conjugate tensors of the LPTN.
**Arguments**
Rho : TYPE(lptn), in
Get the maximal bond dimension present in the LPTN for the
link between the complex conjugate tensors.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxkappa_lptn(Rho) result(kappa)
type(lptn), intent(in) :: Rho
integer :: kappa
! Local variables
! ---------------
! for looping
integer :: ii
kappa = 0
do ii = 1, Rho%ll
kappa = max(kappa, maxlineardim(Rho%Aa(ii), idx=[3]))
end do
end function maxkappa_lptn
"""
return
[docs]def maxkappa_lptnc():
"""
fortran-function - September 2017 (dj, updated)
Get the maximal bond dimension to conjugate tensors of the LPTN.
**Arguments**
Rho : TYPE(lptnc), in
Get the maximal bond dimension present in the LPTN for the
link between the complex conjugate tensors.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxkappa_lptnc(Rho) result(kappa)
type(lptnc), intent(in) :: Rho
integer :: kappa
! Local variables
! ---------------
! for looping
integer :: ii
kappa = 0
do ii = 1, Rho%ll
kappa = max(kappa, maxlineardim(Rho%Aa(ii), idx=[3]))
end do
end function maxkappa_lptnc
"""
return
[docs]def maxkappa_qlptn():
"""
fortran-function - September 2017 (dj, updated)
Get the maximal bond dimension to conjugate tensors of the LPTN.
**Arguments**
Rho : TYPE(qlptn), in
Get the maximal bond dimension present in the LPTN for the
link between the complex conjugate tensors.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxkappa_qlptn(Rho) result(kappa)
type(qlptn), intent(in) :: Rho
integer :: kappa
! Local variables
! ---------------
! for looping
integer :: ii
kappa = 0
do ii = 1, Rho%ll
kappa = max(kappa, maxlineardim(Rho%Aa(ii), idx=[3]))
end do
end function maxkappa_qlptn
"""
return
[docs]def maxkappa_qlptnc():
"""
fortran-function - September 2017 (dj, updated)
Get the maximal bond dimension to conjugate tensors of the LPTN.
**Arguments**
Rho : TYPE(qlptnc), in
Get the maximal bond dimension present in the LPTN for the
link between the complex conjugate tensors.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxkappa_qlptnc(Rho) result(kappa)
type(qlptnc), intent(in) :: Rho
integer :: kappa
! Local variables
! ---------------
! for looping
integer :: ii
kappa = 0
do ii = 1, Rho%ll
kappa = max(kappa, maxlineardim(Rho%Aa(ii), idx=[3]))
end do
end function maxkappa_qlptnc
"""
return
[docs]def meas_mpo_lptn_mpo():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a LPTN.
**Arguments**
val : REAL_OR_COMPLEX, out
Result of the measurement of the MPO applied to Psi.
H : TYPE(mpo), inout
Representation of the MPO to be measured.
Rho : TYPE(lptn), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_lptn_mpo(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(mpo) :: Ham
type(lptn) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlist) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
errst=errst)
!if(prop_error('meas_mpo_lptn_mpo : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
! errst=errst)) return
! Looping to the left
do ii = (Rho%ll - 1), 1, (-1)
call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
errst=errst)
!if(prop_error('meas_mpo_lptn_mpo : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
! errst=errst)) return
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_lptn_mpo
"""
return
[docs]def meas_mpo_lptnc_mpo():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a LPTN.
**Arguments**
val : REAL_OR_COMPLEX, out
Result of the measurement of the MPO applied to Psi.
H : TYPE(mpo), inout
Representation of the MPO to be measured.
Rho : TYPE(lptnc), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_lptnc_mpo(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(mpo) :: Ham
type(lptnc) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlistc) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
errst=errst)
!if(prop_error('meas_mpo_lptnc_mpo : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
! errst=errst)) return
! Looping to the left
do ii = (Rho%ll - 1), 1, (-1)
call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
errst=errst)
!if(prop_error('meas_mpo_lptnc_mpo : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
! errst=errst)) return
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_lptnc_mpo
"""
return
[docs]def meas_mpo_lptnc_mpoc():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a LPTN.
**Arguments**
val : REAL_OR_COMPLEX, out
Result of the measurement of the MPO applied to Psi.
H : TYPE(mpoc), inout
Representation of the MPO to be measured.
Rho : TYPE(lptnc), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_lptnc_mpoc(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(mpoc) :: Ham
type(lptnc) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlistc) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
errst=errst)
!if(prop_error('meas_mpo_lptnc_mpoc : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
! errst=errst)) return
! Looping to the left
do ii = (Rho%ll - 1), 1, (-1)
call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
errst=errst)
!if(prop_error('meas_mpo_lptnc_mpoc : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
! errst=errst)) return
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_lptnc_mpoc
"""
return
[docs]def meas_mpo_qlptn_qmpo():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a LPTN.
**Arguments**
val : REAL_OR_COMPLEX, out
Result of the measurement of the MPO applied to Psi.
H : TYPE(qmpo), inout
Representation of the MPO to be measured.
Rho : TYPE(qlptn), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qlptn_qmpo(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(qmpo) :: Ham
type(qlptn) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorlist) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
errst=errst)
!if(prop_error('meas_mpo_qlptn_qmpo : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
! errst=errst)) return
! Looping to the left
do ii = (Rho%ll - 1), 1, (-1)
call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
errst=errst)
!if(prop_error('meas_mpo_qlptn_qmpo : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
! errst=errst)) return
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qlptn_qmpo
"""
return
[docs]def meas_mpo_qlptnc_qmpo():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a LPTN.
**Arguments**
val : REAL_OR_COMPLEX, out
Result of the measurement of the MPO applied to Psi.
H : TYPE(qmpo), inout
Representation of the MPO to be measured.
Rho : TYPE(qlptnc), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qlptnc_qmpo(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(qmpo) :: Ham
type(qlptnc) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorclist) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
errst=errst)
!if(prop_error('meas_mpo_qlptnc_qmpo : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
! errst=errst)) return
! Looping to the left
do ii = (Rho%ll - 1), 1, (-1)
call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
errst=errst)
!if(prop_error('meas_mpo_qlptnc_qmpo : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
! errst=errst)) return
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qlptnc_qmpo
"""
return
[docs]def meas_mpo_qlptnc_qmpoc():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a LPTN.
**Arguments**
val : REAL_OR_COMPLEX, out
Result of the measurement of the MPO applied to Psi.
H : TYPE(qmpoc), inout
Representation of the MPO to be measured.
Rho : TYPE(qlptnc), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qlptnc_qmpoc(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(qmpoc) :: Ham
type(qlptnc) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorclist) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
errst=errst)
!if(prop_error('meas_mpo_qlptnc_qmpoc : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
! errst=errst)) return
! Looping to the left
do ii = (Rho%ll - 1), 1, (-1)
call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
errst=errst)
!if(prop_error('meas_mpo_qlptnc_qmpoc : '//&
! 'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
! errst=errst)) return
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qlptnc_qmpoc
"""
return
[docs]def ptm_left_mpo_lptn_tensor_tensor():
"""
fortran-subroutine - November 2017 (dj)
Build transfer matrix for site between a state and a Hamiltonian (or MPO).
**Arguments**
Mat : TYPE(tensorlist), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Braket : TYPE(tensor), in
Represent the state of the LPTN on this site.
Hmat : TYPE(tensor), inout
Represents the Hamiltonian on this site.
rightmost : LOGICAL, in
Flag if this is the first site. If true, there is no transfer
matrix on the right.
Matin : TYPE(tensorlist), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if rightmost
is true.
**Details**
In contrast to the MPS method, the LPTN method only works for the same
state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_lptn_tensor_tensor(Mat, Braket, Hmat, &
rightmost, Matin, errst)
type(tensorlist), intent(inout) :: Mat
type(tensor), intent(inout) :: Braket
type(sr_matrix_tensor), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(tensorlist), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, kk
! shortcut to row/column bond dimension of MPO-matrix
integer :: bd
! temporary tensors for contraction
type(tensor), dimension(:), allocatable :: Tens
type(tensor) :: Tmp
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_tensor'//&
! ': contr failed.', 'LPTNOps_include.f90:1996', &
! errst=errst)) return
call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_tensor'//&
! ': transpose failed.', 'LPTNOps_include.f90:2001', &
! errst=errst)) return
do kk = 1, bd
call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
[1, 2], [1, 2], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2009', errst=errst)) return
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with Ket and then Bra
! -----------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2029', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2035', errst=errst)) return
call destroy(Tmp)
end do
else
do ii = 1, bd
call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2045', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2051', errst=errst)) return
call destroy(Tmp)
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
do ii = 1, bd
call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_tensor'//&
! ': transpose failed.', 'LPTNOps_include.f90:2064', &
! errst=errst)) return
end do
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensor_tensor'//&
! ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_lptn_tensor_tensor
"""
return
[docs]def ptm_left_mpo_lptn_tensorc_tensor():
"""
fortran-subroutine - November 2017 (dj)
Build transfer matrix for site between a state and a Hamiltonian (or MPO).
**Arguments**
Mat : TYPE(tensorlistc), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Braket : TYPE(tensorc), in
Represent the state of the LPTN on this site.
Hmat : TYPE(tensorc), inout
Represents the Hamiltonian on this site.
rightmost : LOGICAL, in
Flag if this is the first site. If true, there is no transfer
matrix on the right.
Matin : TYPE(tensorlistc), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if rightmost
is true.
**Details**
In contrast to the MPS method, the LPTN method only works for the same
state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_lptn_tensorc_tensor(Mat, Braket, Hmat, &
rightmost, Matin, errst)
type(tensorlistc), intent(inout) :: Mat
type(tensorc), intent(inout) :: Braket
type(sr_matrix_tensor), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(tensorlistc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, kk
! shortcut to row/column bond dimension of MPO-matrix
integer :: bd
! temporary tensors for contraction
type(tensorc), dimension(:), allocatable :: Tens
type(tensorc) :: Tmp
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_tensor'//&
! ': contr failed.', 'LPTNOps_include.f90:1996', &
! errst=errst)) return
call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_tensor'//&
! ': transpose failed.', 'LPTNOps_include.f90:2001', &
! errst=errst)) return
do kk = 1, bd
call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
[1, 2], [1, 2], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2009', errst=errst)) return
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with Ket and then Bra
! -----------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2029', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2035', errst=errst)) return
call destroy(Tmp)
end do
else
do ii = 1, bd
call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2045', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensor: contr failed.', &
! 'LPTNOps_include.f90:2051', errst=errst)) return
call destroy(Tmp)
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
do ii = 1, bd
call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_tensor'//&
! ': transpose failed.', 'LPTNOps_include.f90:2064', &
! errst=errst)) return
end do
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_tensor'//&
! ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_lptn_tensorc_tensor
"""
return
[docs]def ptm_left_mpo_lptn_tensorc_tensorc():
"""
fortran-subroutine - November 2017 (dj)
Build transfer matrix for site between a state and a Hamiltonian (or MPO).
**Arguments**
Mat : TYPE(tensorlistc), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Braket : TYPE(tensorc), in
Represent the state of the LPTN on this site.
Hmat : TYPE(tensorc), inout
Represents the Hamiltonian on this site.
rightmost : LOGICAL, in
Flag if this is the first site. If true, there is no transfer
matrix on the right.
Matin : TYPE(tensorlistc), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if rightmost
is true.
**Details**
In contrast to the MPS method, the LPTN method only works for the same
state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_lptn_tensorc_tensorc(Mat, Braket, Hmat, &
rightmost, Matin, errst)
type(tensorlistc), intent(inout) :: Mat
type(tensorc), intent(inout) :: Braket
type(sr_matrix_tensorc), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(tensorlistc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, kk
! shortcut to row/column bond dimension of MPO-matrix
integer :: bd
! temporary tensors for contraction
type(tensorc), dimension(:), allocatable :: Tens
type(tensorc) :: Tmp
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_tensorc'//&
! ': contr failed.', 'LPTNOps_include.f90:1996', &
! errst=errst)) return
call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_tensorc'//&
! ': transpose failed.', 'LPTNOps_include.f90:2001', &
! errst=errst)) return
do kk = 1, bd
call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
[1, 2], [1, 2], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensorc: contr failed.', &
! 'LPTNOps_include.f90:2009', errst=errst)) return
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with Ket and then Bra
! -----------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensorc: contr failed.', &
! 'LPTNOps_include.f90:2029', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensorc: contr failed.', &
! 'LPTNOps_include.f90:2035', errst=errst)) return
call destroy(Tmp)
end do
else
do ii = 1, bd
call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensorc: contr failed.', &
! 'LPTNOps_include.f90:2045', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
! 'tensorc: contr failed.', &
! 'LPTNOps_include.f90:2051', errst=errst)) return
call destroy(Tmp)
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
do ii = 1, bd
call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_tensorc'//&
! ': transpose failed.', 'LPTNOps_include.f90:2064', &
! errst=errst)) return
end do
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpo_lptn_tensorc_tensorc'//&
! ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_lptn_tensorc_tensorc
"""
return
[docs]def ptm_left_mpo_lptn_qtensor_qtensor():
"""
fortran-subroutine - November 2017 (dj)
Build transfer matrix for site between a state and a Hamiltonian (or MPO).
**Arguments**
Mat : TYPE(qtensorlist), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Braket : TYPE(qtensor), in
Represent the state of the LPTN on this site.
Hmat : TYPE(qtensor), inout
Represents the Hamiltonian on this site.
rightmost : LOGICAL, in
Flag if this is the first site. If true, there is no transfer
matrix on the right.
Matin : TYPE(qtensorlist), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if rightmost
is true.
**Details**
In contrast to the MPS method, the LPTN method only works for the same
state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_lptn_qtensor_qtensor(Mat, Braket, Hmat, &
rightmost, Matin, errst)
type(qtensorlist), intent(inout) :: Mat
type(qtensor), intent(inout) :: Braket
type(sr_matrix_qtensor), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(qtensorlist), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, kk
! shortcut to row/column bond dimension of MPO-matrix
integer :: bd
! temporary tensors for contraction
type(qtensor), dimension(:), allocatable :: Tens
type(qtensor) :: Tmp
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_qtensor'//&
! ': contr failed.', 'LPTNOps_include.f90:1996', &
! errst=errst)) return
call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_qtensor'//&
! ': transpose failed.', 'LPTNOps_include.f90:2001', &
! errst=errst)) return
do kk = 1, bd
call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
[1, 2], [1, 2], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2009', errst=errst)) return
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with Ket and then Bra
! -----------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2029', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2035', errst=errst)) return
call destroy(Tmp)
end do
else
do ii = 1, bd
call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2045', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2051', errst=errst)) return
call destroy(Tmp)
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
do ii = 1, bd
call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_qtensor'//&
! ': transpose failed.', 'LPTNOps_include.f90:2064', &
! errst=errst)) return
end do
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensor_qtensor'//&
! ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_lptn_qtensor_qtensor
"""
return
[docs]def ptm_left_mpo_lptn_qtensorc_qtensor():
"""
fortran-subroutine - November 2017 (dj)
Build transfer matrix for site between a state and a Hamiltonian (or MPO).
**Arguments**
Mat : TYPE(qtensorclist), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Braket : TYPE(qtensorc), in
Represent the state of the LPTN on this site.
Hmat : TYPE(qtensorc), inout
Represents the Hamiltonian on this site.
rightmost : LOGICAL, in
Flag if this is the first site. If true, there is no transfer
matrix on the right.
Matin : TYPE(qtensorclist), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if rightmost
is true.
**Details**
In contrast to the MPS method, the LPTN method only works for the same
state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_lptn_qtensorc_qtensor(Mat, Braket, Hmat, &
rightmost, Matin, errst)
type(qtensorclist), intent(inout) :: Mat
type(qtensorc), intent(inout) :: Braket
type(sr_matrix_qtensor), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(qtensorclist), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, kk
! shortcut to row/column bond dimension of MPO-matrix
integer :: bd
! temporary tensors for contraction
type(qtensorc), dimension(:), allocatable :: Tens
type(qtensorc) :: Tmp
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensor'//&
! ': contr failed.', 'LPTNOps_include.f90:1996', &
! errst=errst)) return
call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensor'//&
! ': transpose failed.', 'LPTNOps_include.f90:2001', &
! errst=errst)) return
do kk = 1, bd
call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
[1, 2], [1, 2], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2009', errst=errst)) return
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with Ket and then Bra
! -----------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2029', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2035', errst=errst)) return
call destroy(Tmp)
end do
else
do ii = 1, bd
call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2045', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'LPTNOps_include.f90:2051', errst=errst)) return
call destroy(Tmp)
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
do ii = 1, bd
call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensor'//&
! ': transpose failed.', 'LPTNOps_include.f90:2064', &
! errst=errst)) return
end do
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensor'//&
! ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_lptn_qtensorc_qtensor
"""
return
[docs]def ptm_left_mpo_lptn_qtensorc_qtensorc():
"""
fortran-subroutine - November 2017 (dj)
Build transfer matrix for site between a state and a Hamiltonian (or MPO).
**Arguments**
Mat : TYPE(qtensorclist), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Braket : TYPE(qtensorc), in
Represent the state of the LPTN on this site.
Hmat : TYPE(qtensorc), inout
Represents the Hamiltonian on this site.
rightmost : LOGICAL, in
Flag if this is the first site. If true, there is no transfer
matrix on the right.
Matin : TYPE(qtensorclist), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if rightmost
is true.
**Details**
In contrast to the MPS method, the LPTN method only works for the same
state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_lptn_qtensorc_qtensorc(Mat, Braket, Hmat, &
rightmost, Matin, errst)
type(qtensorclist), intent(inout) :: Mat
type(qtensorc), intent(inout) :: Braket
type(sr_matrix_qtensorc), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(qtensorclist), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, kk
! shortcut to row/column bond dimension of MPO-matrix
integer :: bd
! temporary tensors for contraction
type(qtensorc), dimension(:), allocatable :: Tens
type(qtensorc) :: Tmp
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensorc'//&
! ': contr failed.', 'LPTNOps_include.f90:1996', &
! errst=errst)) return
call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensorc'//&
! ': transpose failed.', 'LPTNOps_include.f90:2001', &
! errst=errst)) return
do kk = 1, bd
call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
[1, 2], [1, 2], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'LPTNOps_include.f90:2009', errst=errst)) return
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with Ket and then Bra
! -----------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'LPTNOps_include.f90:2029', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'LPTNOps_include.f90:2035', errst=errst)) return
call destroy(Tmp)
end do
else
do ii = 1, bd
call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'LPTNOps_include.f90:2045', errst=errst)) return
call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'LPTNOps_include.f90:2051', errst=errst)) return
call destroy(Tmp)
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
do ii = 1, bd
call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensorc'//&
! ': transpose failed.', 'LPTNOps_include.f90:2064', &
! errst=errst)) return
end do
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensorc'//&
! ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_lptn_qtensorc_qtensorc
"""
return
[docs]def norm_lptn():
"""
fortran-function - September 2017 (dj)
Calculate the norm of the density matrix defined as the trace.
**Arguments**
Rho : TYPE(lptn), in
Rho is density matrix represented as LPTN with an orthogonality
center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_lptn(Rho, errst) result(res)
type(lptn), intent(in) :: Rho
integer, intent(out), optional :: errst
real(KIND=rKind) :: res
! Local variables
! ---------------
! copy due to permutation etc
type(tensor) :: Rt
call rho_kk(Rt, Rho, Rho%oc, errst=errst)
!if(prop_error('norm_lptn : rho_kk failed.', &
! errst=errst)) return
res = real(trace(Rt), KIND=rKind)
call destroy(Rt)
end function norm_lptn
"""
return
[docs]def norm_lptnc():
"""
fortran-function - September 2017 (dj)
Calculate the norm of the density matrix defined as the trace.
**Arguments**
Rho : TYPE(lptnc), in
Rho is density matrix represented as LPTN with an orthogonality
center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_lptnc(Rho, errst) result(res)
type(lptnc), intent(in) :: Rho
integer, intent(out), optional :: errst
real(KIND=rKind) :: res
! Local variables
! ---------------
! copy due to permutation etc
type(tensorc) :: Rt
call rho_kk(Rt, Rho, Rho%oc, errst=errst)
!if(prop_error('norm_lptnc : rho_kk failed.', &
! errst=errst)) return
res = real(trace(Rt), KIND=rKind)
call destroy(Rt)
end function norm_lptnc
"""
return
[docs]def norm_qlptn():
"""
fortran-function - September 2017 (dj)
Calculate the norm of the density matrix defined as the trace.
**Arguments**
Rho : TYPE(qlptn), in
Rho is density matrix represented as LPTN with an orthogonality
center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_qlptn(Rho, errst) result(res)
type(qlptn), intent(in) :: Rho
integer, intent(out), optional :: errst
real(KIND=rKind) :: res
! Local variables
! ---------------
! copy due to permutation etc
type(qtensor) :: Rt
call rho_kk(Rt, Rho, Rho%oc, errst=errst)
!if(prop_error('norm_qlptn : rho_kk failed.', &
! errst=errst)) return
res = real(trace(Rt), KIND=rKind)
call destroy(Rt)
end function norm_qlptn
"""
return
[docs]def norm_qlptnc():
"""
fortran-function - September 2017 (dj)
Calculate the norm of the density matrix defined as the trace.
**Arguments**
Rho : TYPE(qlptnc), in
Rho is density matrix represented as LPTN with an orthogonality
center.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_qlptnc(Rho, errst) result(res)
type(qlptnc), intent(in) :: Rho
integer, intent(out), optional :: errst
real(KIND=rKind) :: res
! Local variables
! ---------------
! copy due to permutation etc
type(qtensorc) :: Rt
call rho_kk(Rt, Rho, Rho%oc, errst=errst)
!if(prop_error('norm_qlptnc : rho_kk failed.', &
! errst=errst)) return
res = real(trace(Rt), KIND=rKind)
call destroy(Rt)
end function norm_qlptnc
"""
return
[docs]def randomize_lptn():
"""
fortran-subroutine - September 2014 (dj)
Fill the tensors of a LPTN with random number.
**Arguments**
Rho : TYPE(lptn), inout
Fill the tensor of each site with random number. This operations
destroys gauges/isometry.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_lptn(Rho)
type(lptn), intent(inout) :: Rho
! Local variables
! ---------------
! for looping
integer :: ii
! Canonical form will be destroyed
Rho%oc = -1
Rho%can = 'o'
! Fill with random number
do ii = 1, Rho%ll
call randomize(Rho%AA(ii))
end do
end subroutine randomize_lptn
"""
return
[docs]def randomize_lptnc():
"""
fortran-subroutine - September 2014 (dj)
Fill the tensors of a LPTN with random number.
**Arguments**
Rho : TYPE(lptnc), inout
Fill the tensor of each site with random number. This operations
destroys gauges/isometry.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_lptnc(Rho)
type(lptnc), intent(inout) :: Rho
! Local variables
! ---------------
! for looping
integer :: ii
! Canonical form will be destroyed
Rho%oc = -1
Rho%can = 'o'
! Fill with random number
do ii = 1, Rho%ll
call randomize(Rho%AA(ii))
end do
end subroutine randomize_lptnc
"""
return
[docs]def randomize_qlptn():
"""
fortran-subroutine - September 2014 (dj)
Fill the tensors of a LPTN with random number.
**Arguments**
Rho : TYPE(qlptn), inout
Fill the tensor of each site with random number. This operations
destroys gauges/isometry.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_qlptn(Rho)
type(qlptn), intent(inout) :: Rho
! Local variables
! ---------------
! for looping
integer :: ii
! Canonical form will be destroyed
Rho%oc = -1
Rho%can = 'o'
! Fill with random number
do ii = 1, Rho%ll
call randomize(Rho%AA(ii))
end do
end subroutine randomize_qlptn
"""
return
[docs]def randomize_qlptnc():
"""
fortran-subroutine - September 2014 (dj)
Fill the tensors of a LPTN with random number.
**Arguments**
Rho : TYPE(qlptnc), inout
Fill the tensor of each site with random number. This operations
destroys gauges/isometry.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_qlptnc(Rho)
type(qlptnc), intent(inout) :: Rho
! Local variables
! ---------------
! for looping
integer :: ii
! Canonical form will be destroyed
Rho%oc = -1
Rho%can = 'o'
! Fill with random number
do ii = 1, Rho%ll
call randomize(Rho%AA(ii))
end do
end subroutine randomize_qlptnc
"""
return
[docs]def read_lptn():
"""
fortran-subroutine - June 2016 (dj, updated)
Read an LPTN given a filename and a unit (assuming you know the type already).
**Arguments**
Rho : TYPE(lptn), in
Read LPTN in file to this LPTN
flnm : CHARACTER(100), in
the LPTN 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
LPTN in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read LPTN; 1 : type of LPTN does not correspond type of the LPTN
in the file (only checked for skip1st2=false).
**Details**
The file for LPTN has the general form defined as below. Following
these rules, it is possible to provide states to OpenLPTN.
* logical if LPTN is real or complex valued (real=True, complex=False)
[line 1]
* logical if LPTN or qLPTN (qLPTN=True, non-symmetry LPTN=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 LPTN 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_lptn(Rho, flnm, unit, form, skip, errst)
type(lptn), intent(out) :: Rho
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! set the type of the LPTN
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_lptn: 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, *) Rho%ll
read(unit, *) Rho%oc
allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
Rho%Lambda(Rho%ll + 1))
! Read the canonization toghether with the haslambda
do ii = 1, Rho%ll
read(unit, *) Rho%can(ii), Rho%haslambda(ii)
end do
read(unit, *) Rho%haslambda(Rho%ll + 1)
! Read the tensors of the LPTN
do ii = 1, Rho%ll
call read(Rho%Aa(ii), unit, form)
end do
! Read the values of the lambda
do ii = 1, Rho%ll
if(Rho%haslambda(ii)) then
call read(Rho%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_lptn: 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) Rho%ll
read(unit) Rho%oc
allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
Rho%Lambda(Rho%ll + 1))
! Read the canonization and the haslambda as array
read(unit) Rho%can
read(unit) Rho%haslambda
! Read all the tensors
do ii = 1, Rho%ll
call read(Rho%Aa(ii), unit, form)
end do
! Read the lambdas
do ii = 1, Rho%ll
if(Rho%haslambda(ii)) then
call read(Rho%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('read_lptn: unallowed formatting.', &
! 99, errst=errst)
return
end if
close(unit)
end subroutine read_lptn
"""
return
[docs]def read_lptnc():
"""
fortran-subroutine - June 2016 (dj, updated)
Read an LPTN given a filename and a unit (assuming you know the type already).
**Arguments**
Rho : TYPE(lptnc), in
Read LPTN in file to this LPTN
flnm : CHARACTER(100), in
the LPTN 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
LPTN in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read LPTN; 1 : type of LPTN does not correspond type of the LPTN
in the file (only checked for skip1st2=false).
**Details**
The file for LPTN has the general form defined as below. Following
these rules, it is possible to provide states to OpenLPTN.
* logical if LPTN is real or complex valued (real=True, complex=False)
[line 1]
* logical if LPTN or qLPTN (qLPTN=True, non-symmetry LPTN=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 LPTN 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_lptnc(Rho, flnm, unit, form, skip, errst)
type(lptnc), intent(out) :: Rho
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! set the type of the LPTN
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_lptnc: 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, *) Rho%ll
read(unit, *) Rho%oc
allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
Rho%Lambda(Rho%ll + 1))
! Read the canonization toghether with the haslambda
do ii = 1, Rho%ll
read(unit, *) Rho%can(ii), Rho%haslambda(ii)
end do
read(unit, *) Rho%haslambda(Rho%ll + 1)
! Read the tensors of the LPTN
do ii = 1, Rho%ll
call read(Rho%Aa(ii), unit, form)
end do
! Read the values of the lambda
do ii = 1, Rho%ll
if(Rho%haslambda(ii)) then
call read(Rho%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_lptnc: 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) Rho%ll
read(unit) Rho%oc
allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
Rho%Lambda(Rho%ll + 1))
! Read the canonization and the haslambda as array
read(unit) Rho%can
read(unit) Rho%haslambda
! Read all the tensors
do ii = 1, Rho%ll
call read(Rho%Aa(ii), unit, form)
end do
! Read the lambdas
do ii = 1, Rho%ll
if(Rho%haslambda(ii)) then
call read(Rho%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('read_lptnc: unallowed formatting.', &
! 99, errst=errst)
return
end if
close(unit)
end subroutine read_lptnc
"""
return
[docs]def read_qlptn():
"""
fortran-subroutine - June 2016 (dj, updated)
Read an LPTN given a filename and a unit (assuming you know the type already).
**Arguments**
Rho : TYPE(qlptn), in
Read LPTN in file to this LPTN
flnm : CHARACTER(100), in
the LPTN 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
LPTN in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read LPTN; 1 : type of LPTN does not correspond type of the LPTN
in the file (only checked for skip1st2=false).
**Details**
The file for LPTN has the general form defined as below. Following
these rules, it is possible to provide states to OpenLPTN.
* logical if LPTN is real or complex valued (real=True, complex=False)
[line 1]
* logical if LPTN or qLPTN (qLPTN=True, non-symmetry LPTN=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 LPTN 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_qlptn(Rho, flnm, unit, form, skip, errst)
type(qlptn), intent(out) :: Rho
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! set the type of the LPTN
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_qlptn: 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, *) Rho%ll
read(unit, *) Rho%oc
allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
Rho%Lambda(Rho%ll + 1))
! Read the canonization toghether with the haslambda
do ii = 1, Rho%ll
read(unit, *) Rho%can(ii), Rho%haslambda(ii)
end do
read(unit, *) Rho%haslambda(Rho%ll + 1)
! Read the tensors of the LPTN
do ii = 1, Rho%ll
call read(Rho%Aa(ii), unit, form)
end do
! Read the values of the lambda
do ii = 1, Rho%ll
if(Rho%haslambda(ii)) then
call read(Rho%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_qlptn: 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) Rho%ll
read(unit) Rho%oc
allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
Rho%Lambda(Rho%ll + 1))
! Read the canonization and the haslambda as array
read(unit) Rho%can
read(unit) Rho%haslambda
! Read all the tensors
do ii = 1, Rho%ll
call read(Rho%Aa(ii), unit, form)
end do
! Read the lambdas
do ii = 1, Rho%ll
if(Rho%haslambda(ii)) then
call read(Rho%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('read_qlptn: unallowed formatting.', &
! 99, errst=errst)
return
end if
close(unit)
end subroutine read_qlptn
"""
return
[docs]def read_qlptnc():
"""
fortran-subroutine - June 2016 (dj, updated)
Read an LPTN given a filename and a unit (assuming you know the type already).
**Arguments**
Rho : TYPE(qlptnc), in
Read LPTN in file to this LPTN
flnm : CHARACTER(100), in
the LPTN 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
LPTN in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read LPTN; 1 : type of LPTN does not correspond type of the LPTN
in the file (only checked for skip1st2=false).
**Details**
The file for LPTN has the general form defined as below. Following
these rules, it is possible to provide states to OpenLPTN.
* logical if LPTN is real or complex valued (real=True, complex=False)
[line 1]
* logical if LPTN or qLPTN (qLPTN=True, non-symmetry LPTN=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 LPTN 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_qlptnc(Rho, flnm, unit, form, skip, errst)
type(qlptnc), intent(out) :: Rho
character(len=*), intent(in) :: flnm
integer, intent(in) :: unit
character, intent(in) :: form
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! set the type of the LPTN
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_qlptnc: 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, *) Rho%ll
read(unit, *) Rho%oc
allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
Rho%Lambda(Rho%ll + 1))
! Read the canonization toghether with the haslambda
do ii = 1, Rho%ll
read(unit, *) Rho%can(ii), Rho%haslambda(ii)
end do
read(unit, *) Rho%haslambda(Rho%ll + 1)
! Read the tensors of the LPTN
do ii = 1, Rho%ll
call read(Rho%Aa(ii), unit, form)
end do
! Read the values of the lambda
do ii = 1, Rho%ll
if(Rho%haslambda(ii)) then
call read(Rho%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_qlptnc: 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) Rho%ll
read(unit) Rho%oc
allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
Rho%Lambda(Rho%ll + 1))
! Read the canonization and the haslambda as array
read(unit) Rho%can
read(unit) Rho%haslambda
! Read all the tensors
do ii = 1, Rho%ll
call read(Rho%Aa(ii), unit, form)
end do
! Read the lambdas
do ii = 1, Rho%ll
if(Rho%haslambda(ii)) then
call read(Rho%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('read_qlptnc: unallowed formatting.', &
! 99, errst=errst)
return
end if
close(unit)
end subroutine read_qlptnc
"""
return
[docs]def rho_kk_lptn():
"""
fortran-subroutine - September 2017 (dj)
Calculate the reduced density matrix represented as tensor.
**Arguments**
Rhokk : TYPE(tensor), out
The density matrix is stored in this tensor
Rho : TYPE(lptn), in
Calculate reduced density matrix for this LPTN.
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_lptn(Rhokk, Rho, kk, errst)
type(tensor), intent(out) :: Rhokk
type(lptn), intent(in) :: Rho
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! copy due to permutation etc
type(tensor) :: Tens, Tensc
!if(present(errst)) errst = 0
call copy(Tens, Rho%Aa(kk))
call copy(Tensc, Rho%Aa(kk))
call contr(Rhokk, Tens, Tensc, [1, 3, 4], [1, 3, 4], transl='C')
call destroy(Tens)
call destroy(Tensc)
! Set hashes for rho
!call set_hash(Rhokk, [1])
!call sort(Rhokk)
end subroutine rho_kk_lptn
"""
return
[docs]def rho_kk_lptnc():
"""
fortran-subroutine - September 2017 (dj)
Calculate the reduced density matrix represented as tensor.
**Arguments**
Rhokk : TYPE(tensorc), out
The density matrix is stored in this tensor
Rho : TYPE(lptnc), in
Calculate reduced density matrix for this LPTN.
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_lptnc(Rhokk, Rho, kk, errst)
type(tensorc), intent(out) :: Rhokk
type(lptnc), intent(in) :: Rho
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! copy due to permutation etc
type(tensorc) :: Tens, Tensc
!if(present(errst)) errst = 0
call copy(Tens, Rho%Aa(kk))
call copy(Tensc, Rho%Aa(kk))
call contr(Rhokk, Tens, Tensc, [1, 3, 4], [1, 3, 4], transl='C')
call destroy(Tens)
call destroy(Tensc)
! Set hashes for rho
!call set_hash(Rhokk, [1])
!call sort(Rhokk)
end subroutine rho_kk_lptnc
"""
return
[docs]def rho_kk_qlptn():
"""
fortran-subroutine - September 2017 (dj)
Calculate the reduced density matrix represented as tensor.
**Arguments**
Rhokk : TYPE(qtensor), out
The density matrix is stored in this tensor
Rho : TYPE(qlptn), in
Calculate reduced density matrix for this LPTN.
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_qlptn(Rhokk, Rho, kk, errst)
type(qtensor), intent(out) :: Rhokk
type(qlptn), intent(in) :: Rho
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! copy due to permutation etc
type(qtensor) :: Tens, Tensc
!if(present(errst)) errst = 0
call copy(Tens, Rho%Aa(kk))
call copy(Tensc, Rho%Aa(kk))
call contr(Rhokk, Tens, Tensc, [1, 3, 4], [1, 3, 4], transl='C')
call destroy(Tens)
call destroy(Tensc)
! Set hashes for rho
call set_hash(Rhokk, [1])
call sort(Rhokk)
end subroutine rho_kk_qlptn
"""
return
[docs]def rho_kk_qlptnc():
"""
fortran-subroutine - September 2017 (dj)
Calculate the reduced density matrix represented as tensor.
**Arguments**
Rhokk : TYPE(qtensorc), out
The density matrix is stored in this tensor
Rho : TYPE(qlptnc), in
Calculate reduced density matrix for this LPTN.
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_qlptnc(Rhokk, Rho, kk, errst)
type(qtensorc), intent(out) :: Rhokk
type(qlptnc), intent(in) :: Rho
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! copy due to permutation etc
type(qtensorc) :: Tens, Tensc
!if(present(errst)) errst = 0
call copy(Tens, Rho%Aa(kk))
call copy(Tensc, Rho%Aa(kk))
call contr(Rhokk, Tens, Tensc, [1, 3, 4], [1, 3, 4], transl='C')
call destroy(Tens)
call destroy(Tensc)
! Set hashes for rho
call set_hash(Rhokk, [1])
call sort(Rhokk)
end subroutine rho_kk_qlptnc
"""
return
[docs]def rhoij_init_lptn_tensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize the measurement for the two-site density matrix, i.e., building the
left overlap leaving the local Hilbert space uncontractred.
**Arguments**
Tenskk : TYPE(tensor), inout
Tensor representing the site kk, should be the orthgonality center.
Theta : TYPE(tensor), out
On exit, contraction of the tensor on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_lptn_tensor(Tenskk, Theta)
type(tensor), intent(inout) :: Tenskk
type(tensor), intent(out) :: Theta
! Local variables
! ---------------
! copy due to permutation
type(tensor) :: Tmp
call copy(Tmp, Tenskk)
call contr(Theta, Tmp, [1, 3], [1, 3], transr='C', permout=[1, 3, 2, 4])
call destroy(Tmp)
end subroutine rhoij_init_lptn_tensor
"""
return
[docs]def rhoij_init_lptn_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize the measurement for the two-site density matrix, i.e., building the
left overlap leaving the local Hilbert space uncontractred.
**Arguments**
Tenskk : TYPE(tensorc), inout
Tensor representing the site kk, should be the orthgonality center.
Theta : TYPE(tensorc), out
On exit, contraction of the tensor on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_lptn_tensorc(Tenskk, Theta)
type(tensorc), intent(inout) :: Tenskk
type(tensorc), intent(out) :: Theta
! Local variables
! ---------------
! copy due to permutation
type(tensorc) :: Tmp
call copy(Tmp, Tenskk)
call contr(Theta, Tmp, [1, 3], [1, 3], transr='C', permout=[1, 3, 2, 4])
call destroy(Tmp)
end subroutine rhoij_init_lptn_tensorc
"""
return
[docs]def rhoij_init_lptn_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize the measurement for the two-site density matrix, i.e., building the
left overlap leaving the local Hilbert space uncontractred.
**Arguments**
Tenskk : TYPE(qtensor), inout
Tensor representing the site kk, should be the orthgonality center.
Theta : TYPE(qtensor), out
On exit, contraction of the tensor on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_lptn_qtensor(Tenskk, Theta)
type(qtensor), intent(inout) :: Tenskk
type(qtensor), intent(out) :: Theta
! Local variables
! ---------------
! copy due to permutation
type(qtensor) :: Tmp
call copy(Tmp, Tenskk)
call contr(Theta, Tmp, [1, 3], [1, 3], transr='C', permout=[1, 3, 2, 4])
call destroy(Tmp)
end subroutine rhoij_init_lptn_qtensor
"""
return
[docs]def rhoij_init_lptn_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize the measurement for the two-site density matrix, i.e., building the
left overlap leaving the local Hilbert space uncontractred.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Tensor representing the site kk, should be the orthgonality center.
Theta : TYPE(qtensorc), out
On exit, contraction of the tensor on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_lptn_qtensorc(Tenskk, Theta)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorc), intent(out) :: Theta
! Local variables
! ---------------
! copy due to permutation
type(qtensorc) :: Tmp
call copy(Tmp, Tenskk)
call contr(Theta, Tmp, [1, 3], [1, 3], transr='C', permout=[1, 3, 2, 4])
call destroy(Tmp)
end subroutine rhoij_init_lptn_qtensorc
"""
return
[docs]def rhoij_meas_lptn_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measure two-site reduced density matrix for sites i and j and propagate
for the next measurement.
**Arguments**
Rhosij : TYPE(tensor)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(tensor), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(tensor), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(tensor), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_lptn_tensor_tensor(Rhosij, Tensjj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(tensor), dimension(:, :), intent(inout) :: Rhosij
type(tensor), intent(inout) :: Tensjj
integer, intent(in) :: ii, jj, ll
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
permout=[1, 3, 2, 4])
call destroy(Tmpa)
end if
! 2) Propagate for the next sites
! -------------------------------
if((jj < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
call copy(Tmpa, Tensjj)
call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_lptn_tensor_tensor
"""
return
[docs]def rhoij_meas_lptn_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measure two-site reduced density matrix for sites i and j and propagate
for the next measurement.
**Arguments**
Rhosij : TYPE(tensorc)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(tensorc), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(tensorc), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(tensor), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_lptn_tensorc_tensor(Rhosij, Tensjj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(tensorc), dimension(:, :), intent(inout) :: Rhosij
type(tensorc), intent(inout) :: Tensjj
integer, intent(in) :: ii, jj, ll
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
permout=[1, 3, 2, 4])
call destroy(Tmpa)
end if
! 2) Propagate for the next sites
! -------------------------------
if((jj < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
call copy(Tmpa, Tensjj)
call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_lptn_tensorc_tensor
"""
return
[docs]def rhoij_meas_lptn_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Measure two-site reduced density matrix for sites i and j and propagate
for the next measurement.
**Arguments**
Rhosij : TYPE(tensorc)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(tensorc), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(tensorc), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(tensorc), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_lptn_tensorc_tensorc(Rhosij, Tensjj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(tensorc), dimension(:, :), intent(inout) :: Rhosij
type(tensorc), intent(inout) :: Tensjj
integer, intent(in) :: ii, jj, ll
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
permout=[1, 3, 2, 4])
call destroy(Tmpa)
end if
! 2) Propagate for the next sites
! -------------------------------
if((jj < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
call copy(Tmpa, Tensjj)
call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_lptn_tensorc_tensorc
"""
return
[docs]def rhoij_meas_lptn_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measure two-site reduced density matrix for sites i and j and propagate
for the next measurement.
**Arguments**
Rhosij : TYPE(qtensor)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(qtensor), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(qtensor), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(qtensor), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_lptn_qtensor_qtensor(Rhosij, Tensjj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(qtensor), dimension(:, :), intent(inout) :: Rhosij
type(qtensor), intent(inout) :: Tensjj
integer, intent(in) :: ii, jj, ll
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
permout=[1, 3, 2, 4])
call destroy(Tmpa)
end if
! 2) Propagate for the next sites
! -------------------------------
if((jj < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
call copy(Tmpa, Tensjj)
call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_lptn_qtensor_qtensor
"""
return
[docs]def rhoij_meas_lptn_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measure two-site reduced density matrix for sites i and j and propagate
for the next measurement.
**Arguments**
Rhosij : TYPE(qtensorc)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(qtensorc), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(qtensorc), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(qtensor), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_lptn_qtensorc_qtensor(Rhosij, Tensjj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(qtensorc), dimension(:, :), intent(inout) :: Rhosij
type(qtensorc), intent(inout) :: Tensjj
integer, intent(in) :: ii, jj, ll
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
permout=[1, 3, 2, 4])
call destroy(Tmpa)
end if
! 2) Propagate for the next sites
! -------------------------------
if((jj < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
call copy(Tmpa, Tensjj)
call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_lptn_qtensorc_qtensor
"""
return
[docs]def rhoij_meas_lptn_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Measure two-site reduced density matrix for sites i and j and propagate
for the next measurement.
**Arguments**
Rhosij : TYPE(qtensorc)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(qtensorc), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(qtensorc), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(qtensorc), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_lptn_qtensorc_qtensorc(Rhosij, Tensjj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(qtensorc), dimension(:, :), intent(inout) :: Rhosij
type(qtensorc), intent(inout) :: Tensjj
integer, intent(in) :: ii, jj, ll
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
permout=[1, 3, 2, 4])
call destroy(Tmpa)
end if
! 2) Propagate for the next sites
! -------------------------------
if((jj < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
call copy(Tmpa, Tensjj)
call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [3], [1])
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_lptn_qtensorc_qtensorc
"""
return
[docs]def rho_red_lptn():
"""
fortran-subroutine - June 2018 (dj)
Build a general reduced density matrix on multiple sites.
**Arguments**
Red : 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.
Rho : TYPE(lptn), in
LPTN to build reduced density matrix from.
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_lptn(Red, Rho, sites, cont, trunc, ncut, err, errst)
type(tensor), intent(out) :: Red
type(lptn), intent(inout) :: Rho
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, kk, jsub
! next site kept
integer :: next
! number of sites kept
integer :: nn
! for permutation of indices
integer, dimension(:), allocatable :: perm
! temporary tensors
type(tensor) :: Tmp, Tmpb, Tmpc
!if(present(errst)) errst = 0
! Set error - always zero as no permutation needed
err = 0.0_rKind
nn = size(sites, 1)
! 1) Initialize / first site
! ==========================
kk = 1
next = sites(kk)
if(next == 1) then
call copy(Tmpb, Rho%Aa(1))
call copy(Tmpc, Rho%Aa(1), trans='C')
call contr(Tmp, Tmpb, Tmpc, [1, 3], [1, 3], errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2724', errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpc)
kk = kk + 1
if(kk > nn) then
next = -1
else
next = sites(kk)
end if
jj = 3
else
call copy(Tmpc, Rho%Aa(1), trans='C')
call contr(Tmp, Rho%Aa(1), Tmpc, [1, 2, 3], [1, 2, 3], errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2742', errst=errst)) return
call destroy(Tmpc)
jj = 1
end if
! 2) Loop over sites in the bulk of the system
! ============================================
do ii = 2, (Rho%ll - 1)
if(next == ii) then
! Keep this site
! --------------
! Contract tensor from last step
call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2760', errst=errst)) return
call destroy(Tmp)
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmp, Tmpb, Tmpc, [jj, jj + 2], [1, 3], &
errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2768', errst=errst)) return
! Have to permute local indices and links to next neighbor
allocate(perm(jj + 3))
perm = [(jsub, jsub = 1, jj + 3)]
perm(jj + 2) = jj + 1
perm(jj + 1) = jj + 2
call transposed(Tmp, perm, doperm=.true., errst=errst)
!if(prop_error('rho_red_lptn : transposed failed.', &
! 'LPTNOps_include.f90:2778', errst=errst)) return
deallocate(perm)
else
! Trace this site out
! -------------------
! Contract tensor from last step
call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2788', errst=errst)) return
call destroy(Tmp)
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmp, Tmpb, Tmpc, [jj, jj + 1, jj + 2], [1, 2, 3], &
errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2796', errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpc)
end if
end do
! 3) Finalize / last site
! =======================
ii = Rho%ll
if(ii == next) then
! Keep this site
! --------------
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmpb, Rho%Aa(ii), Tmpc, [3, 4], [3, 4], errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2815', errst=errst)) return
call destroy(Tmpc)
call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 3], errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2821', errst=errst)) return
call destroy(Tmp)
call destroy(Tmpb)
else
! Trace this site out
! -------------------
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmpb, Rho%Aa(ii), Tmpc, [2, 3, 4], [2, 3, 4], errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2832', errst=errst)) return
call destroy(Tmpc)
call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 2], errst=errst)
!if(prop_error('rho_red_lptn : contr failed.', &
! 'LPTNOps_include.f90:2838', errst=errst)) return
end if
! Grouping ket and bra indices together
allocate(perm(2 * nn))
perm(:nn) = [(2 * ii - 1, ii = 1, nn)]
perm(nn + 1:) = [(2 * ii, ii = 1, nn)]
call transposed(Red, perm, doperm=.true., errst=errst)
!if(prop_error('rho_red_MPDO_TYPE : transposed failed.', &
! 'LPTNOps_include.f90:2850', errst=errst)) return
deallocate(perm)
! Access intentionally unused variables needed for compliance with
! MPS interface
!if(cont) kk = 1
!if(trunc < 0.0_rKind) kk = 2
!if(ncut < 0) kk = 3
end subroutine rho_red_lptn
"""
return
[docs]def rho_red_lptnc():
"""
fortran-subroutine - June 2018 (dj)
Build a general reduced density matrix on multiple sites.
**Arguments**
Red : 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.
Rho : TYPE(lptnc), in
LPTN to build reduced density matrix from.
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_lptnc(Red, Rho, sites, cont, trunc, ncut, err, errst)
type(tensorc), intent(out) :: Red
type(lptnc), intent(inout) :: Rho
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, kk, jsub
! next site kept
integer :: next
! number of sites kept
integer :: nn
! for permutation of indices
integer, dimension(:), allocatable :: perm
! temporary tensors
type(tensorc) :: Tmp, Tmpb, Tmpc
!if(present(errst)) errst = 0
! Set error - always zero as no permutation needed
err = 0.0_rKind
nn = size(sites, 1)
! 1) Initialize / first site
! ==========================
kk = 1
next = sites(kk)
if(next == 1) then
call copy(Tmpb, Rho%Aa(1))
call copy(Tmpc, Rho%Aa(1), trans='C')
call contr(Tmp, Tmpb, Tmpc, [1, 3], [1, 3], errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2724', errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpc)
kk = kk + 1
if(kk > nn) then
next = -1
else
next = sites(kk)
end if
jj = 3
else
call copy(Tmpc, Rho%Aa(1), trans='C')
call contr(Tmp, Rho%Aa(1), Tmpc, [1, 2, 3], [1, 2, 3], errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2742', errst=errst)) return
call destroy(Tmpc)
jj = 1
end if
! 2) Loop over sites in the bulk of the system
! ============================================
do ii = 2, (Rho%ll - 1)
if(next == ii) then
! Keep this site
! --------------
! Contract tensor from last step
call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2760', errst=errst)) return
call destroy(Tmp)
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmp, Tmpb, Tmpc, [jj, jj + 2], [1, 3], &
errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2768', errst=errst)) return
! Have to permute local indices and links to next neighbor
allocate(perm(jj + 3))
perm = [(jsub, jsub = 1, jj + 3)]
perm(jj + 2) = jj + 1
perm(jj + 1) = jj + 2
call transposed(Tmp, perm, doperm=.true., errst=errst)
!if(prop_error('rho_red_lptnc : transposed failed.', &
! 'LPTNOps_include.f90:2778', errst=errst)) return
deallocate(perm)
else
! Trace this site out
! -------------------
! Contract tensor from last step
call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2788', errst=errst)) return
call destroy(Tmp)
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmp, Tmpb, Tmpc, [jj, jj + 1, jj + 2], [1, 2, 3], &
errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2796', errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpc)
end if
end do
! 3) Finalize / last site
! =======================
ii = Rho%ll
if(ii == next) then
! Keep this site
! --------------
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmpb, Rho%Aa(ii), Tmpc, [3, 4], [3, 4], errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2815', errst=errst)) return
call destroy(Tmpc)
call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 3], errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2821', errst=errst)) return
call destroy(Tmp)
call destroy(Tmpb)
else
! Trace this site out
! -------------------
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmpb, Rho%Aa(ii), Tmpc, [2, 3, 4], [2, 3, 4], errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2832', errst=errst)) return
call destroy(Tmpc)
call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 2], errst=errst)
!if(prop_error('rho_red_lptnc : contr failed.', &
! 'LPTNOps_include.f90:2838', errst=errst)) return
end if
! Grouping ket and bra indices together
allocate(perm(2 * nn))
perm(:nn) = [(2 * ii - 1, ii = 1, nn)]
perm(nn + 1:) = [(2 * ii, ii = 1, nn)]
call transposed(Red, perm, doperm=.true., errst=errst)
!if(prop_error('rho_red_MPDO_TYPE : transposed failed.', &
! 'LPTNOps_include.f90:2850', errst=errst)) return
deallocate(perm)
! Access intentionally unused variables needed for compliance with
! MPS interface
!if(cont) kk = 1
!if(trunc < 0.0_rKind) kk = 2
!if(ncut < 0) kk = 3
end subroutine rho_red_lptnc
"""
return
[docs]def rho_red_qlptn():
"""
fortran-subroutine - June 2018 (dj)
Build a general reduced density matrix on multiple sites.
**Arguments**
Red : 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.
Rho : TYPE(qlptn), in
LPTN to build reduced density matrix from.
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_qlptn(Red, Rho, sites, cont, trunc, ncut, err, errst)
type(qtensor), intent(out) :: Red
type(qlptn), intent(inout) :: Rho
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, kk, jsub
! next site kept
integer :: next
! number of sites kept
integer :: nn
! for permutation of indices
integer, dimension(:), allocatable :: perm
! temporary tensors
type(qtensor) :: Tmp, Tmpb, Tmpc
!if(present(errst)) errst = 0
! Set error - always zero as no permutation needed
err = 0.0_rKind
nn = size(sites, 1)
! 1) Initialize / first site
! ==========================
kk = 1
next = sites(kk)
if(next == 1) then
call copy(Tmpb, Rho%Aa(1))
call copy(Tmpc, Rho%Aa(1), trans='C')
call contr(Tmp, Tmpb, Tmpc, [1, 3], [1, 3], errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2724', errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpc)
kk = kk + 1
if(kk > nn) then
next = -1
else
next = sites(kk)
end if
jj = 3
else
call copy(Tmpc, Rho%Aa(1), trans='C')
call contr(Tmp, Rho%Aa(1), Tmpc, [1, 2, 3], [1, 2, 3], errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2742', errst=errst)) return
call destroy(Tmpc)
jj = 1
end if
! 2) Loop over sites in the bulk of the system
! ============================================
do ii = 2, (Rho%ll - 1)
if(next == ii) then
! Keep this site
! --------------
! Contract tensor from last step
call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2760', errst=errst)) return
call destroy(Tmp)
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmp, Tmpb, Tmpc, [jj, jj + 2], [1, 3], &
errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2768', errst=errst)) return
! Have to permute local indices and links to next neighbor
allocate(perm(jj + 3))
perm = [(jsub, jsub = 1, jj + 3)]
perm(jj + 2) = jj + 1
perm(jj + 1) = jj + 2
call transposed(Tmp, perm, doperm=.true., errst=errst)
!if(prop_error('rho_red_qlptn : transposed failed.', &
! 'LPTNOps_include.f90:2778', errst=errst)) return
deallocate(perm)
else
! Trace this site out
! -------------------
! Contract tensor from last step
call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2788', errst=errst)) return
call destroy(Tmp)
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmp, Tmpb, Tmpc, [jj, jj + 1, jj + 2], [1, 2, 3], &
errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2796', errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpc)
end if
end do
! 3) Finalize / last site
! =======================
ii = Rho%ll
if(ii == next) then
! Keep this site
! --------------
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmpb, Rho%Aa(ii), Tmpc, [3, 4], [3, 4], errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2815', errst=errst)) return
call destroy(Tmpc)
call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 3], errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2821', errst=errst)) return
call destroy(Tmp)
call destroy(Tmpb)
else
! Trace this site out
! -------------------
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmpb, Rho%Aa(ii), Tmpc, [2, 3, 4], [2, 3, 4], errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2832', errst=errst)) return
call destroy(Tmpc)
call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 2], errst=errst)
!if(prop_error('rho_red_qlptn : contr failed.', &
! 'LPTNOps_include.f90:2838', errst=errst)) return
end if
! Grouping ket and bra indices together
allocate(perm(2 * nn))
perm(:nn) = [(2 * ii - 1, ii = 1, nn)]
perm(nn + 1:) = [(2 * ii, ii = 1, nn)]
call transposed(Red, perm, doperm=.true., errst=errst)
!if(prop_error('rho_red_MPDO_TYPE : transposed failed.', &
! 'LPTNOps_include.f90:2850', errst=errst)) return
deallocate(perm)
! Access intentionally unused variables needed for compliance with
! MPS interface
!if(cont) kk = 1
!if(trunc < 0.0_rKind) kk = 2
!if(ncut < 0) kk = 3
end subroutine rho_red_qlptn
"""
return
[docs]def rho_red_qlptnc():
"""
fortran-subroutine - June 2018 (dj)
Build a general reduced density matrix on multiple sites.
**Arguments**
Red : 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.
Rho : TYPE(qlptnc), in
LPTN to build reduced density matrix from.
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_qlptnc(Red, Rho, sites, cont, trunc, ncut, err, errst)
type(qtensorc), intent(out) :: Red
type(qlptnc), intent(inout) :: Rho
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, kk, jsub
! next site kept
integer :: next
! number of sites kept
integer :: nn
! for permutation of indices
integer, dimension(:), allocatable :: perm
! temporary tensors
type(qtensorc) :: Tmp, Tmpb, Tmpc
!if(present(errst)) errst = 0
! Set error - always zero as no permutation needed
err = 0.0_rKind
nn = size(sites, 1)
! 1) Initialize / first site
! ==========================
kk = 1
next = sites(kk)
if(next == 1) then
call copy(Tmpb, Rho%Aa(1))
call copy(Tmpc, Rho%Aa(1), trans='C')
call contr(Tmp, Tmpb, Tmpc, [1, 3], [1, 3], errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2724', errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpc)
kk = kk + 1
if(kk > nn) then
next = -1
else
next = sites(kk)
end if
jj = 3
else
call copy(Tmpc, Rho%Aa(1), trans='C')
call contr(Tmp, Rho%Aa(1), Tmpc, [1, 2, 3], [1, 2, 3], errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2742', errst=errst)) return
call destroy(Tmpc)
jj = 1
end if
! 2) Loop over sites in the bulk of the system
! ============================================
do ii = 2, (Rho%ll - 1)
if(next == ii) then
! Keep this site
! --------------
! Contract tensor from last step
call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2760', errst=errst)) return
call destroy(Tmp)
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmp, Tmpb, Tmpc, [jj, jj + 2], [1, 3], &
errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2768', errst=errst)) return
! Have to permute local indices and links to next neighbor
allocate(perm(jj + 3))
perm = [(jsub, jsub = 1, jj + 3)]
perm(jj + 2) = jj + 1
perm(jj + 1) = jj + 2
call transposed(Tmp, perm, doperm=.true., errst=errst)
!if(prop_error('rho_red_qlptnc : transposed failed.', &
! 'LPTNOps_include.f90:2778', errst=errst)) return
deallocate(perm)
else
! Trace this site out
! -------------------
! Contract tensor from last step
call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2788', errst=errst)) return
call destroy(Tmp)
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmp, Tmpb, Tmpc, [jj, jj + 1, jj + 2], [1, 2, 3], &
errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2796', errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpc)
end if
end do
! 3) Finalize / last site
! =======================
ii = Rho%ll
if(ii == next) then
! Keep this site
! --------------
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmpb, Rho%Aa(ii), Tmpc, [3, 4], [3, 4], errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2815', errst=errst)) return
call destroy(Tmpc)
call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 3], errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2821', errst=errst)) return
call destroy(Tmp)
call destroy(Tmpb)
else
! Trace this site out
! -------------------
call copy(Tmpc, Rho%Aa(ii), trans='C')
call contr(Tmpb, Rho%Aa(ii), Tmpc, [2, 3, 4], [2, 3, 4], errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2832', errst=errst)) return
call destroy(Tmpc)
call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 2], errst=errst)
!if(prop_error('rho_red_qlptnc : contr failed.', &
! 'LPTNOps_include.f90:2838', errst=errst)) return
end if
! Grouping ket and bra indices together
allocate(perm(2 * nn))
perm(:nn) = [(2 * ii - 1, ii = 1, nn)]
perm(nn + 1:) = [(2 * ii, ii = 1, nn)]
call transposed(Red, perm, doperm=.true., errst=errst)
!if(prop_error('rho_red_MPDO_TYPE : transposed failed.', &
! 'LPTNOps_include.f90:2850', errst=errst)) return
deallocate(perm)
! Access intentionally unused variables needed for compliance with
! MPS interface
!if(cont) kk = 1
!if(trunc < 0.0_rKind) kk = 2
!if(ncut < 0) kk = 3
end subroutine rho_red_qlptnc
"""
return
[docs]def scale_real_lptn():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Rho by some factor. The square is taken since X from rho = xxdagger
is normalized.
**Arguments**
scalefactor : real, in
some real number to scale LPTN
Rho : TYPE(lptn), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Details**
The tensor is multiplied with sqrt(sc), after the contraction
with the complex conjugate this step results in sc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_real_lptn(scalefactor, Rho)
real(KIND=rKind), intent(in) :: scalefactor
type(lptn), intent(inout) :: Rho
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Rho%oc, 1)
call scale(sqrt(scalefactor), Rho%Aa(oc))
end subroutine scale_real_lptn
"""
return
[docs]def scale_real_lptnc():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Rho by some factor. The square is taken since X from rho = xxdagger
is normalized.
**Arguments**
scalefactor : real, in
some real number to scale LPTN
Rho : TYPE(lptnc), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Details**
The tensor is multiplied with sqrt(sc), after the contraction
with the complex conjugate this step results in sc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_real_lptnc(scalefactor, Rho)
real(KIND=rKind), intent(in) :: scalefactor
type(lptnc), intent(inout) :: Rho
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Rho%oc, 1)
call scale(sqrt(scalefactor), Rho%Aa(oc))
end subroutine scale_real_lptnc
"""
return
[docs]def scale_real_qlptn():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Rho by some factor. The square is taken since X from rho = xxdagger
is normalized.
**Arguments**
scalefactor : real, in
some real number to scale LPTN
Rho : TYPE(qlptn), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Details**
The tensor is multiplied with sqrt(sc), after the contraction
with the complex conjugate this step results in sc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_real_qlptn(scalefactor, Rho)
real(KIND=rKind), intent(in) :: scalefactor
type(qlptn), intent(inout) :: Rho
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Rho%oc, 1)
call scale(sqrt(scalefactor), Rho%Aa(oc))
end subroutine scale_real_qlptn
"""
return
[docs]def scale_real_qlptnc():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Rho by some factor. The square is taken since X from rho = xxdagger
is normalized.
**Arguments**
scalefactor : real, in
some real number to scale LPTN
Rho : TYPE(qlptnc), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Details**
The tensor is multiplied with sqrt(sc), after the contraction
with the complex conjugate this step results in sc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_real_qlptnc(scalefactor, Rho)
real(KIND=rKind), intent(in) :: scalefactor
type(qlptnc), intent(inout) :: Rho
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Rho%oc, 1)
call scale(sqrt(scalefactor), Rho%Aa(oc))
end subroutine scale_real_qlptnc
"""
return
[docs]def scale_complex_lptnc():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Rho by some factor. The square is taken since X from rho = xxdagger
is normalized.
**Arguments**
scalefactor : complex, in
some real number to scale LPTN
Rho : TYPE(lptnc), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Details**
The tensor is multiplied with sqrt(sc), after the contraction
with the complex conjugate this step results in sc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_complex_lptnc(scalefactor, Rho)
complex(KIND=rKind), intent(in) :: scalefactor
type(lptnc), intent(inout) :: Rho
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Rho%oc, 1)
call scale(sqrt(scalefactor), Rho%Aa(oc))
end subroutine scale_complex_lptnc
"""
return
[docs]def scale_complex_qlptnc():
"""
fortran-subroutine - June 2017 (dj, updated)
Rescale Rho by some factor. The square is taken since X from rho = xxdagger
is normalized.
**Arguments**
scalefactor : complex, in
some real number to scale LPTN
Rho : TYPE(qlptnc), inout
Mutliply the orthogonality center (or 1 if no orthogonality center)
with a scalar factor).
**Details**
The tensor is multiplied with sqrt(sc), after the contraction
with the complex conjugate this step results in sc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_complex_qlptnc(scalefactor, Rho)
complex(KIND=rKind), intent(in) :: scalefactor
type(qlptnc), intent(inout) :: Rho
! Local variables
! ---------------
! scale at orthogonality center if present
integer :: oc
oc = max(Rho%oc, 1)
call scale(sqrt(scalefactor), Rho%Aa(oc))
end subroutine scale_complex_qlptnc
"""
return
[docs]def set_q_kappa_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Set the quantum number on the kappa link.
**Arguments**
Qt : TYPE(qtensor), inout
Tensor to be modified. The quantum numbers of the third leg
connecting to the complex conjugate tensor of the LPTN will
be set.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_q_kappa_qtensor(Qt, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer kk
! indices for quantum numbers
integer :: i1, i2, j1, j2
! total number of converved quantities
integer :: snqs
!if(present(errst)) errst = 0
snqs = sum(Qt%nqs)
i1 = snqs + 1
i2 = 2 * snqs
j1 = i2 + 1
j2 = i2 + snqs
do kk = 1, Qt%nb
Qt%Data(kk)%qq(j1:j2) = Qt%Data(kk)%qq(i1:i2)
end do
end subroutine set_q_kappa_qtensor
"""
return
[docs]def set_q_kappa_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Set the quantum number on the kappa link.
**Arguments**
Qt : TYPE(qtensorc), inout
Tensor to be modified. The quantum numbers of the third leg
connecting to the complex conjugate tensor of the LPTN will
be set.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_q_kappa_qtensorc(Qt, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer kk
! indices for quantum numbers
integer :: i1, i2, j1, j2
! total number of converved quantities
integer :: snqs
!if(present(errst)) errst = 0
snqs = sum(Qt%nqs)
i1 = snqs + 1
i2 = 2 * snqs
j1 = i2 + 1
j2 = i2 + snqs
do kk = 1, Qt%nb
Qt%Data(kk)%qq(j1:j2) = Qt%Data(kk)%qq(i1:i2)
end do
end subroutine set_q_kappa_qtensorc
"""
return
[docs]def set_q_kappa_tensor():
"""
fortran-subroutine - October 2017 (dj)
Set the quantum number on the kappa link.
**Arguments**
Tens : TYPE(tensor), inout
Dummy subroutine to provide interface.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_q_kappa_tensor(Tens, errst)
type(tensor), intent(inout) :: Tens
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
! Touch intentionally unused variables to avoid warning
!if(.false.) print *, Tens%rank
end subroutine set_q_kappa_tensor
"""
return
[docs]def set_q_kappa_tensorc():
"""
fortran-subroutine - October 2017 (dj)
Set the quantum number on the kappa link.
**Arguments**
Tens : TYPE(tensorc), inout
Dummy subroutine to provide interface.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_q_kappa_tensorc(Tens, errst)
type(tensorc), intent(inout) :: Tens
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
! Touch intentionally unused variables to avoid warning
!if(.false.) print *, Tens%rank
end subroutine set_q_kappa_tensorc
"""
return
[docs]def set_0_kappa_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Set the quantum number on the kappa link to zero.
**Arguments**
Qt : TYPE(qtensor), inout
Tensor to be modified. The quantum numbers of the third leg
connecting to the complex conjugate tensor of the LPTN will
be set to zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_0_kappa_qtensor(Qt, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer kk
! indices for quantum numbers
integer :: j1, j2
! total number of converved quantities
integer :: snqs
!if(present(errst)) errst = 0
snqs = sum(Qt%nqs)
j1 = 2 * snqs + 1
j2 = 3 * snqs
do kk = 1, Qt%nb
Qt%Data(kk)%qq(j1:j2) = 0
end do
end subroutine set_0_kappa_qtensor
"""
return
[docs]def set_0_kappa_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Set the quantum number on the kappa link to zero.
**Arguments**
Qt : TYPE(qtensorc), inout
Tensor to be modified. The quantum numbers of the third leg
connecting to the complex conjugate tensor of the LPTN will
be set to zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_0_kappa_qtensorc(Qt, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer kk
! indices for quantum numbers
integer :: j1, j2
! total number of converved quantities
integer :: snqs
!if(present(errst)) errst = 0
snqs = sum(Qt%nqs)
j1 = 2 * snqs + 1
j2 = 3 * snqs
do kk = 1, Qt%nb
Qt%Data(kk)%qq(j1:j2) = 0
end do
end subroutine set_0_kappa_qtensorc
"""
return
[docs]def set_0_kappa_tensor():
"""
fortran-subroutine - October 2017 (dj)
Set the quantum number on the kappa link to zero.
**Arguments**
Tens : TYPE(tensor), inout
Dummy subroutine to provide interface.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_0_kappa_tensor(Tens, errst)
type(tensor), intent(inout) :: Tens
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
! Touch intentionally unused variables to avoid warning
!if(.false.) print *, Tens%rank
end subroutine set_0_kappa_tensor
"""
return
[docs]def set_0_kappa_tensorc():
"""
fortran-subroutine - October 2017 (dj)
Set the quantum number on the kappa link to zero.
**Arguments**
Tens : TYPE(tensorc), inout
Dummy subroutine to provide interface.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_0_kappa_tensorc(Tens, errst)
type(tensorc), intent(inout) :: Tens
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
! Touch intentionally unused variables to avoid warning
!if(.false.) print *, Tens%rank
end subroutine set_0_kappa_tensorc
"""
return
[docs]def swap_lptn_tensor():
"""
fortran-subroutine - May 2018 (dj)
Swap two nearest-neighbor sites in an LPTN.
**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 LPTN). 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_lptn_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, [4], [1], errst=errst)
!if(prop_error('swap_lptn_tensor : contr failed.', &
! 'LPTNOps_include.f90:3162', errst=errst)) return
call destroy(Tensa)
call destroy(Tensb)
call split(Tensa, Lam, Tensb, Theta, [1, 4, 5], [2, 3, 6], &
multlr=dir, trunc=trunc, ncut=ncut, err=err, &
method='Y', errst=errst)
!if(prop_error('swap_lptn_tensor : split failed.', &
! 'LPTNOps_include.f90:3171', errst=errst)) return
call destroy(Theta)
if(present(cerr)) cerr = cerr + err
end subroutine swap_lptn_tensor
"""
return
[docs]def swap_lptn_tensorc():
"""
fortran-subroutine - May 2018 (dj)
Swap two nearest-neighbor sites in an LPTN.
**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 LPTN). 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_lptn_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, [4], [1], errst=errst)
!if(prop_error('swap_lptn_tensorc : contr failed.', &
! 'LPTNOps_include.f90:3162', errst=errst)) return
call destroy(Tensa)
call destroy(Tensb)
call split(Tensa, Lam, Tensb, Theta, [1, 4, 5], [2, 3, 6], &
multlr=dir, trunc=trunc, ncut=ncut, err=err, &
method='Y', errst=errst)
!if(prop_error('swap_lptn_tensorc : split failed.', &
! 'LPTNOps_include.f90:3171', errst=errst)) return
call destroy(Theta)
if(present(cerr)) cerr = cerr + err
end subroutine swap_lptn_tensorc
"""
return
[docs]def swap_lptn_qtensor():
"""
fortran-subroutine - May 2018 (dj)
Swap two nearest-neighbor sites in an LPTN.
**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 LPTN). 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_lptn_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, [4], [1], errst=errst)
!if(prop_error('swap_lptn_qtensor : contr failed.', &
! 'LPTNOps_include.f90:3162', errst=errst)) return
call destroy(Tensa)
call destroy(Tensb)
call split(Tensa, Lam, Tensb, Theta, [1, 4, 5], [2, 3, 6], &
multlr=dir, trunc=trunc, ncut=ncut, err=err, &
method='Y', errst=errst)
!if(prop_error('swap_lptn_qtensor : split failed.', &
! 'LPTNOps_include.f90:3171', errst=errst)) return
call destroy(Theta)
if(present(cerr)) cerr = cerr + err
end subroutine swap_lptn_qtensor
"""
return
[docs]def swap_lptn_qtensorc():
"""
fortran-subroutine - May 2018 (dj)
Swap two nearest-neighbor sites in an LPTN.
**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 LPTN). 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_lptn_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, [4], [1], errst=errst)
!if(prop_error('swap_lptn_qtensorc : contr failed.', &
! 'LPTNOps_include.f90:3162', errst=errst)) return
call destroy(Tensa)
call destroy(Tensb)
call split(Tensa, Lam, Tensb, Theta, [1, 4, 5], [2, 3, 6], &
multlr=dir, trunc=trunc, ncut=ncut, err=err, &
method='Y', errst=errst)
!if(prop_error('swap_lptn_qtensorc : split failed.', &
! 'LPTNOps_include.f90:3171', errst=errst)) return
call destroy(Theta)
if(present(cerr)) cerr = cerr + err
end subroutine swap_lptn_qtensorc
"""
return
[docs]def transposed_lptn():
"""
fortran-subroutine - June 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Psi : TYPE(lptn), inout
Permute LPTN 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 LPTN with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for LPTN). 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_lptn(Psi, perm, trunc, ncut, cerr, errst)
type(lptn), 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_lptn : rank '//&
! 'mismatch.', 2, errst=errst)
! return
!end if
allocate(ind(Psi%ll))
do ii = 1, Psi%ll
if(ind(ii) == ii) cycle
call canonize(Psi, ind(ii))
do jj = ind(ii), (ii + 1), -1
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
call swap_lptn(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj + 1), &
dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
errst=errst)
Psi%can(jj) = 'r'
Psi%can(jj - 1) = 'c'
Psi%oc = jj - 1
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_lptn
"""
return
[docs]def transposed_lptnc():
"""
fortran-subroutine - June 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Psi : TYPE(lptnc), inout
Permute LPTN 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 LPTN with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for LPTN). 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_lptnc(Psi, perm, trunc, ncut, cerr, errst)
type(lptnc), 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_lptnc : rank '//&
! 'mismatch.', 2, errst=errst)
! return
!end if
allocate(ind(Psi%ll))
do ii = 1, Psi%ll
if(ind(ii) == ii) cycle
call canonize(Psi, ind(ii))
do jj = ind(ii), (ii + 1), -1
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
call swap_lptn(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj + 1), &
dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
errst=errst)
Psi%can(jj) = 'r'
Psi%can(jj - 1) = 'c'
Psi%oc = jj - 1
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_lptnc
"""
return
[docs]def transposed_qlptn():
"""
fortran-subroutine - June 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Psi : TYPE(qlptn), inout
Permute LPTN 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 LPTN with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for LPTN). 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_qlptn(Psi, perm, trunc, ncut, cerr, errst)
type(qlptn), 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_qlptn : rank '//&
! 'mismatch.', 2, errst=errst)
! return
!end if
allocate(ind(Psi%ll))
do ii = 1, Psi%ll
if(ind(ii) == ii) cycle
call canonize(Psi, ind(ii))
do jj = ind(ii), (ii + 1), -1
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
call swap_lptn(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj + 1), &
dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
errst=errst)
Psi%can(jj) = 'r'
Psi%can(jj - 1) = 'c'
Psi%oc = jj - 1
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_qlptn
"""
return
[docs]def transposed_qlptnc():
"""
fortran-subroutine - June 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Psi : TYPE(qlptnc), inout
Permute LPTN 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 LPTN with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for LPTN). 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_qlptnc(Psi, perm, trunc, ncut, cerr, errst)
type(qlptnc), 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_qlptnc : rank '//&
! 'mismatch.', 2, errst=errst)
! return
!end if
allocate(ind(Psi%ll))
do ii = 1, Psi%ll
if(ind(ii) == ii) cycle
call canonize(Psi, ind(ii))
do jj = ind(ii), (ii + 1), -1
if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))
call swap_lptn(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj + 1), &
dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
errst=errst)
Psi%can(jj) = 'r'
Psi%can(jj - 1) = 'c'
Psi%oc = jj - 1
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_qlptnc
"""
return
[docs]def write_lptn():
"""
fortran-subroutine - August 2015 (dj)
Write an LPTN to file
**Arguments**
Rho : TYPE(lptn), in
save this LPTN
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_lptn`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_lptn(Rho, unit, form, errst)
type(lptn), intent(in) :: Rho
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! type of the LPTN
logical :: is_real, is_q
! for looping
integer :: ii
is_real = .true.
is_q = .false.
if(form == "6") then
write(unit, *) 'LPTN size, oc', Rho%ll, Rho%oc
do ii = 1, Rho%ll
write(unit, *) ' site i data:', ii
write(unit, *) ' canonization', Rho%can(ii)
write(unit, *) ' Lambda:', Rho%haslambda(ii)
if(Rho%haslambda(ii)) then
call print(Rho%Lambda(ii))
end if
call print(Rho%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 LPTN type, the number of sites and
! the orthogonality center
write(unit, *) is_real
write(unit, *) is_q
write(unit, *) Rho%ll
write(unit, *) Rho%oc
! Write the canonization and the haslambda together
do ii = 1, Rho%ll
write(unit, *) Rho%can(ii), Rho%haslambda(ii)
end do
write(unit, *) Rho%haslambda(Rho%ll + 1)
! Write the tensors of the LPTN
do ii = 1, Rho%ll
call write(Rho%Aa(ii), unit, form)
end do
! Finally write the lambdas
do ii = 1, Rho%ll + 1
if(Rho%haslambda(ii)) then
call write(Rho%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 LPTN type, the number of sites and
! the orthogonality center
write(unit) is_real
write(unit) is_q
write(unit) Rho%ll
write(unit) Rho%oc
! Canonization and haslambda go as array
write(unit) Rho%can
write(unit) Rho%haslambda
! Write the tensors of the LPTN
do ii = 1, Rho%ll
call write(Rho%Aa(ii), unit, form)
end do
! Finally write the values for the lambdas
do ii = 1, Rho%ll + 1
if(Rho%haslambda(ii)) then
call write(Rho%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('write_lptn: unallowed formatting.', &
! 99, errst=errst)
return
end if
!close(unit)
end subroutine write_lptn
"""
return
[docs]def write_lptnc():
"""
fortran-subroutine - August 2015 (dj)
Write an LPTN to file
**Arguments**
Rho : TYPE(lptnc), in
save this LPTN
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_lptnc`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_lptnc(Rho, unit, form, errst)
type(lptnc), intent(in) :: Rho
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! type of the LPTN
logical :: is_real, is_q
! for looping
integer :: ii
is_real = .false.
is_q = .false.
if(form == "6") then
write(unit, *) 'LPTN size, oc', Rho%ll, Rho%oc
do ii = 1, Rho%ll
write(unit, *) ' site i data:', ii
write(unit, *) ' canonization', Rho%can(ii)
write(unit, *) ' Lambda:', Rho%haslambda(ii)
if(Rho%haslambda(ii)) then
call print(Rho%Lambda(ii))
end if
call print(Rho%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 LPTN type, the number of sites and
! the orthogonality center
write(unit, *) is_real
write(unit, *) is_q
write(unit, *) Rho%ll
write(unit, *) Rho%oc
! Write the canonization and the haslambda together
do ii = 1, Rho%ll
write(unit, *) Rho%can(ii), Rho%haslambda(ii)
end do
write(unit, *) Rho%haslambda(Rho%ll + 1)
! Write the tensors of the LPTN
do ii = 1, Rho%ll
call write(Rho%Aa(ii), unit, form)
end do
! Finally write the lambdas
do ii = 1, Rho%ll + 1
if(Rho%haslambda(ii)) then
call write(Rho%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 LPTN type, the number of sites and
! the orthogonality center
write(unit) is_real
write(unit) is_q
write(unit) Rho%ll
write(unit) Rho%oc
! Canonization and haslambda go as array
write(unit) Rho%can
write(unit) Rho%haslambda
! Write the tensors of the LPTN
do ii = 1, Rho%ll
call write(Rho%Aa(ii), unit, form)
end do
! Finally write the values for the lambdas
do ii = 1, Rho%ll + 1
if(Rho%haslambda(ii)) then
call write(Rho%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('write_lptnc: unallowed formatting.', &
! 99, errst=errst)
return
end if
!close(unit)
end subroutine write_lptnc
"""
return
[docs]def write_qlptn():
"""
fortran-subroutine - August 2015 (dj)
Write an LPTN to file
**Arguments**
Rho : TYPE(qlptn), in
save this LPTN
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_qlptn`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qlptn(Rho, unit, form, errst)
type(qlptn), intent(in) :: Rho
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! type of the LPTN
logical :: is_real, is_q
! for looping
integer :: ii
is_real = .true.
is_q = .true.
if(form == "6") then
write(unit, *) 'LPTN size, oc', Rho%ll, Rho%oc
do ii = 1, Rho%ll
write(unit, *) ' site i data:', ii
write(unit, *) ' canonization', Rho%can(ii)
write(unit, *) ' Lambda:', Rho%haslambda(ii)
if(Rho%haslambda(ii)) then
call print(Rho%Lambda(ii))
end if
call print(Rho%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 LPTN type, the number of sites and
! the orthogonality center
write(unit, *) is_real
write(unit, *) is_q
write(unit, *) Rho%ll
write(unit, *) Rho%oc
! Write the canonization and the haslambda together
do ii = 1, Rho%ll
write(unit, *) Rho%can(ii), Rho%haslambda(ii)
end do
write(unit, *) Rho%haslambda(Rho%ll + 1)
! Write the tensors of the LPTN
do ii = 1, Rho%ll
call write(Rho%Aa(ii), unit, form)
end do
! Finally write the lambdas
do ii = 1, Rho%ll + 1
if(Rho%haslambda(ii)) then
call write(Rho%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 LPTN type, the number of sites and
! the orthogonality center
write(unit) is_real
write(unit) is_q
write(unit) Rho%ll
write(unit) Rho%oc
! Canonization and haslambda go as array
write(unit) Rho%can
write(unit) Rho%haslambda
! Write the tensors of the LPTN
do ii = 1, Rho%ll
call write(Rho%Aa(ii), unit, form)
end do
! Finally write the values for the lambdas
do ii = 1, Rho%ll + 1
if(Rho%haslambda(ii)) then
call write(Rho%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('write_qlptn: unallowed formatting.', &
! 99, errst=errst)
return
end if
!close(unit)
end subroutine write_qlptn
"""
return
[docs]def write_qlptnc():
"""
fortran-subroutine - August 2015 (dj)
Write an LPTN to file
**Arguments**
Rho : TYPE(qlptnc), in
save this LPTN
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_qlptnc`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qlptnc(Rho, unit, form, errst)
type(qlptnc), intent(in) :: Rho
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! type of the LPTN
logical :: is_real, is_q
! for looping
integer :: ii
is_real = .false.
is_q = .true.
if(form == "6") then
write(unit, *) 'LPTN size, oc', Rho%ll, Rho%oc
do ii = 1, Rho%ll
write(unit, *) ' site i data:', ii
write(unit, *) ' canonization', Rho%can(ii)
write(unit, *) ' Lambda:', Rho%haslambda(ii)
if(Rho%haslambda(ii)) then
call print(Rho%Lambda(ii))
end if
call print(Rho%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 LPTN type, the number of sites and
! the orthogonality center
write(unit, *) is_real
write(unit, *) is_q
write(unit, *) Rho%ll
write(unit, *) Rho%oc
! Write the canonization and the haslambda together
do ii = 1, Rho%ll
write(unit, *) Rho%can(ii), Rho%haslambda(ii)
end do
write(unit, *) Rho%haslambda(Rho%ll + 1)
! Write the tensors of the LPTN
do ii = 1, Rho%ll
call write(Rho%Aa(ii), unit, form)
end do
! Finally write the lambdas
do ii = 1, Rho%ll + 1
if(Rho%haslambda(ii)) then
call write(Rho%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 LPTN type, the number of sites and
! the orthogonality center
write(unit) is_real
write(unit) is_q
write(unit) Rho%ll
write(unit) Rho%oc
! Canonization and haslambda go as array
write(unit) Rho%can
write(unit) Rho%haslambda
! Write the tensors of the LPTN
do ii = 1, Rho%ll
call write(Rho%Aa(ii), unit, form)
end do
! Finally write the values for the lambdas
do ii = 1, Rho%ll + 1
if(Rho%haslambda(ii)) then
call write(Rho%lambda(ii), unit, form)
end if
end do
else
!errst = raise_error('write_qlptnc: unallowed formatting.', &
! 99, errst=errst)
return
end if
!close(unit)
end subroutine write_qlptnc
"""
return