"""
Fortran module MPDOOps: September 2017 (dj)
Containing basic operations for matrix product density
operators (MPDO)
**Authors**
* D. Jaschke
* M. L. Wall
**Details**
The error status can be decoded the following way
The following subroutines / functions are defined for the
applicable data type
+---------------------------------+-------------+-------------+-------------+
| Procedure | include.f90 | mpi.f90 | omp.f90 |
+=================================+=============+=============+=============+
| copy | X | | |
+---------------------------------+-------------+-------------+-------------+
| corr_init_mpdo | X | | |
+---------------------------------+-------------+-------------+-------------+
| corr_init_l_mpdo | X | | |
+---------------------------------+-------------+-------------+-------------+
| corr_meas_mpdo | X | | |
+---------------------------------+-------------+-------------+-------------+
| corr_meas_l_mpdo | X | | |
+---------------------------------+-------------+-------------+-------------+
| destroy | X | | |
+---------------------------------+-------------+-------------+-------------+
| norm | X | | |
+---------------------------------+-------------+-------------+-------------+
| ptm_left_mpdo | X | | |
+---------------------------------+-------------+-------------+-------------+
| ptm_right_mpdo | X | | |
+---------------------------------+-------------+-------------+-------------+
| purity | X | | |
+---------------------------------+-------------+-------------+-------------+
| rho_kk | X | | |
+---------------------------------+-------------+-------------+-------------+
| rhoij_init_mpdo | X | | |
+---------------------------------+-------------+-------------+-------------+
| rhoij_meas_mpdo | X | | |
+---------------------------------+-------------+-------------+-------------+
| setuplr | X | | |
+---------------------------------+-------------+-------------+-------------+
| updatelr | X | | |
+---------------------------------+-------------+-------------+-------------+
"""
[docs]def check_rho_kk_mpdo():
"""
fortran-subroutine - October 2017 (dj)
Run verbose checks on reduced density matrix.
**Arguments**
Rho_orig : TYPE(mpdo), in
Check the building of reduced density matrices for this MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_rho_kk_mpdo(Rho_orig)
type(mpdo), intent(in) :: Rho_orig
! Local variables
! ---------------
! for looping
integer :: ii
! Copy of the density matrix
type(mpdo) :: Rho
! Left-right overlap for MPDO
type(tensorlist) :: myLR
! Reduced density matrix
type(tensor) :: Rhokk
call copy(Rho, Rho_orig)
call setuplr_mpdo(myLR, Rho)
do ii = 1, Rho%Superket%ll
print *, ''
print *, ''
print *, 'Site', ii
if(ii /= 1) call updatelr(myLR, Rho, ii, 1)
if(ii > 1) then
print *, ''
print *, 'Left overlap'
call print(myLR%Li(ii - 1))
end if
if(ii < Rho%Superket%ll) then
print *, ''
print *, 'Right overlap'
call print(myLR%Li(ii + 1))
end if
call rho_kk(Rhokk, Rho, myLR, ii)
print *, ''
print *, 'Reduced density matrix'
call print(Rhokk)
call destroy(Rhokk)
end do
call destroy(myLR)
call destroy(Rho)
end subroutine check_rho_kk_mpdo
"""
return
[docs]def check_rho_kk_mpdoc():
"""
fortran-subroutine - October 2017 (dj)
Run verbose checks on reduced density matrix.
**Arguments**
Rho_orig : TYPE(mpdoc), in
Check the building of reduced density matrices for this MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_rho_kk_mpdoc(Rho_orig)
type(mpdoc), intent(in) :: Rho_orig
! Local variables
! ---------------
! for looping
integer :: ii
! Copy of the density matrix
type(mpdoc) :: Rho
! Left-right overlap for MPDO
type(tensorlistc) :: myLR
! Reduced density matrix
type(tensorc) :: Rhokk
call copy(Rho, Rho_orig)
call setuplr_mpdoc(myLR, Rho)
do ii = 1, Rho%Superket%ll
print *, ''
print *, ''
print *, 'Site', ii
if(ii /= 1) call updatelr(myLR, Rho, ii, 1)
if(ii > 1) then
print *, ''
print *, 'Left overlap'
call print(myLR%Li(ii - 1))
end if
if(ii < Rho%Superket%ll) then
print *, ''
print *, 'Right overlap'
call print(myLR%Li(ii + 1))
end if
call rho_kk(Rhokk, Rho, myLR, ii)
print *, ''
print *, 'Reduced density matrix'
call print(Rhokk)
call destroy(Rhokk)
end do
call destroy(myLR)
call destroy(Rho)
end subroutine check_rho_kk_mpdoc
"""
return
[docs]def check_rho_kk_qmpdo():
"""
fortran-subroutine - October 2017 (dj)
Run verbose checks on reduced density matrix.
**Arguments**
Rho_orig : TYPE(qmpdo), in
Check the building of reduced density matrices for this MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_rho_kk_qmpdo(Rho_orig)
type(qmpdo), intent(in) :: Rho_orig
! Local variables
! ---------------
! for looping
integer :: ii
! Copy of the density matrix
type(qmpdo) :: Rho
! Left-right overlap for MPDO
type(qtensorlist) :: myLR
! Reduced density matrix
type(qtensor) :: Rhokk
call copy(Rho, Rho_orig)
call setuplr_qmpdo(myLR, Rho)
do ii = 1, Rho%Superket%ll
print *, ''
print *, ''
print *, 'Site', ii
if(ii /= 1) call updatelr(myLR, Rho, ii, 1)
if(ii > 1) then
print *, ''
print *, 'Left overlap'
call print(myLR%Li(ii - 1))
end if
if(ii < Rho%Superket%ll) then
print *, ''
print *, 'Right overlap'
call print(myLR%Li(ii + 1))
end if
call rho_kk(Rhokk, Rho, myLR, ii)
print *, ''
print *, 'Reduced density matrix'
call print(Rhokk)
call destroy(Rhokk)
end do
call destroy(myLR)
call destroy(Rho)
end subroutine check_rho_kk_qmpdo
"""
return
[docs]def check_rho_kk_qmpdoc():
"""
fortran-subroutine - October 2017 (dj)
Run verbose checks on reduced density matrix.
**Arguments**
Rho_orig : TYPE(qmpdoc), in
Check the building of reduced density matrices for this MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_rho_kk_qmpdoc(Rho_orig)
type(qmpdoc), intent(in) :: Rho_orig
! Local variables
! ---------------
! for looping
integer :: ii
! Copy of the density matrix
type(qmpdoc) :: Rho
! Left-right overlap for MPDO
type(qtensorclist) :: myLR
! Reduced density matrix
type(qtensorc) :: Rhokk
call copy(Rho, Rho_orig)
call setuplr_qmpdoc(myLR, Rho)
do ii = 1, Rho%Superket%ll
print *, ''
print *, ''
print *, 'Site', ii
if(ii /= 1) call updatelr(myLR, Rho, ii, 1)
if(ii > 1) then
print *, ''
print *, 'Left overlap'
call print(myLR%Li(ii - 1))
end if
if(ii < Rho%Superket%ll) then
print *, ''
print *, 'Right overlap'
call print(myLR%Li(ii + 1))
end if
call rho_kk(Rhokk, Rho, myLR, ii)
print *, ''
print *, 'Reduced density matrix'
call print(Rhokk)
call destroy(Rhokk)
end do
call destroy(myLR)
call destroy(Rho)
end subroutine check_rho_kk_qmpdoc
"""
return
[docs]def rho_red_mpdo():
"""
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(mpdo), in
MPDO 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). Not
accessed, kept for compliance with MPS interface.
trunc : REAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Not accessed, kept for compliance
with MPS interface.
ncut : INTEGER, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values. Not accessed, kept for compliance
with MPS interface.
err : REAL, out
Truncation error for tracking it from calling routine. No
truncation introduced in MPDOs and thus zero by default.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_red_mpdo(Red, Rho, sites, cont, trunc, ncut, err, errst)
type(tensor), intent(out) :: Red
type(mpdo), 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, kk
! next site kept
integer :: next
! number of sites kept
integer :: nn
! for permutation of indices
integer, dimension(:), allocatable :: perm
! temporary tensors
type(tensor) :: Tmp, Tmp2
!if(present(errst)) errst = 0
! Set err - always zero as no permutation needed
err = 0.0_rKind
nn = size(sites, 1)
call copy(Tmp2, Rho%Superket%Aa(1))
call split(Tmp2, 1, Rho%Sl_left, errst=errst)
!if(prop_error('rho_red_mpdo : split failed.', &
! 'MPDOOps_include.f90:179', errst=errst)) return
call pcontr(Tmp, Tmp2, [1], [2], errst=errst)
!if(prop_error('rho_red_mpdo : pcontr failed.', &
! 'MPDOOps_include.f90:183', errst=errst)) return
call destroy(Tmp2)
kk = 1
next = sites(kk)
do ii = 1, (Rho%Superket%ll - 1)
if(next == ii) then
! Keep this site
! --------------
kk = kk + 1
if(kk > nn) then
next = -1
else
next = sites(kk)
end if
call contr(Tmp2, Tmp, Rho%Superket%Aa(ii + 1), [kk], [1], &
errst=errst)
!if(prop_error('rho_red_mpdo : contr failed.', &
! 'MPDOOps_include.f90:206', errst=errst)) return
call destroy(Tmp)
call pointto(Tmp, Tmp2)
else
! Trace this site out
! -------------------
call split(Tmp, kk, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_mpdo : split failed.', &
! 'MPDOOps_include.f90:217', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_mpdo : pcontr failed.', &
! 'MPDOOps_include.f90:221', errst=errst)) return
call destroy(Tmp)
! Contract with next site
call contr(Tmp, Tmp2, Rho%Superket%Aa(ii + 1), [kk], [1], &
errst=errst)
!if(prop_error('rho_red_mpdo : contr failed.', &
! 'MPDOOps_include.f90:229', errst=errst)) return
call destroy(Tmp2)
end if
end do
! Last site
! ---------
if(next == -1) then
! Trace this site out
! -------------------
call split(Tmp, kk, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_mpdo : split failed.', &
! 'MPDOOps_include.f90:244', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_mpdo : pcontr failed.', &
! 'MPDOOps_include.f90:248', errst=errst)) return
call destroy(Tmp)
call split(Tmp2, kk, Rho%Sl_right, errst=errst)
!if(prop_error('rho_red_mpdo : split failed.', &
! 'MPDOOps_include.f90:254', errst=errst)) return
call pcontr(Red, Tmp2, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_mpdo : pcontr failed.', &
! 'MPDOOps_include.f90:258', errst=errst)) return
call destroy(Tmp2)
else
! Contract only possible indices to the right
! -------------------------------------------
kk = kk + 1
call split(Tmp, kk, Rho%Sl_right, errst=errst)
!if(prop_error('rho_red_mpdo : split failed.', &
! 'MPDOOps_include.f90:269', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_mpdo : pcontr failed.', &
! 'MPDOOps_include.f90:273', errst=errst)) return
call destroy(Tmp)
call pointto(Red, Tmp2)
end if
! Split local Hilbert spaces and permute
! --------------------------------------
!
! Grouping ket and bra indices together
allocate(perm(2 * nn))
do ii = nn, 1, -1
call split(Red, ii, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_mpdo : split failed.', &
! 'MPDOOps_include.f90:289', errst=errst)) return
end do
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 : transposed failed.', &
! 'MPDOOps_include.f90:297', 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_mpdo
"""
return
[docs]def rho_red_mpdoc():
"""
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(mpdoc), in
MPDO 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). Not
accessed, kept for compliance with MPS interface.
trunc : REAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Not accessed, kept for compliance
with MPS interface.
ncut : INTEGER, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values. Not accessed, kept for compliance
with MPS interface.
err : REAL, out
Truncation error for tracking it from calling routine. No
truncation introduced in MPDOs and thus zero by default.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_red_mpdoc(Red, Rho, sites, cont, trunc, ncut, err, errst)
type(tensorc), intent(out) :: Red
type(mpdoc), 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, kk
! next site kept
integer :: next
! number of sites kept
integer :: nn
! for permutation of indices
integer, dimension(:), allocatable :: perm
! temporary tensors
type(tensorc) :: Tmp, Tmp2
!if(present(errst)) errst = 0
! Set err - always zero as no permutation needed
err = 0.0_rKind
nn = size(sites, 1)
call copy(Tmp2, Rho%Superket%Aa(1))
call split(Tmp2, 1, Rho%Sl_left, errst=errst)
!if(prop_error('rho_red_mpdoc : split failed.', &
! 'MPDOOps_include.f90:179', errst=errst)) return
call pcontr(Tmp, Tmp2, [1], [2], errst=errst)
!if(prop_error('rho_red_mpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:183', errst=errst)) return
call destroy(Tmp2)
kk = 1
next = sites(kk)
do ii = 1, (Rho%Superket%ll - 1)
if(next == ii) then
! Keep this site
! --------------
kk = kk + 1
if(kk > nn) then
next = -1
else
next = sites(kk)
end if
call contr(Tmp2, Tmp, Rho%Superket%Aa(ii + 1), [kk], [1], &
errst=errst)
!if(prop_error('rho_red_mpdoc : contr failed.', &
! 'MPDOOps_include.f90:206', errst=errst)) return
call destroy(Tmp)
call pointto(Tmp, Tmp2)
else
! Trace this site out
! -------------------
call split(Tmp, kk, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_mpdoc : split failed.', &
! 'MPDOOps_include.f90:217', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_mpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:221', errst=errst)) return
call destroy(Tmp)
! Contract with next site
call contr(Tmp, Tmp2, Rho%Superket%Aa(ii + 1), [kk], [1], &
errst=errst)
!if(prop_error('rho_red_mpdoc : contr failed.', &
! 'MPDOOps_include.f90:229', errst=errst)) return
call destroy(Tmp2)
end if
end do
! Last site
! ---------
if(next == -1) then
! Trace this site out
! -------------------
call split(Tmp, kk, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_mpdoc : split failed.', &
! 'MPDOOps_include.f90:244', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_mpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:248', errst=errst)) return
call destroy(Tmp)
call split(Tmp2, kk, Rho%Sl_right, errst=errst)
!if(prop_error('rho_red_mpdoc : split failed.', &
! 'MPDOOps_include.f90:254', errst=errst)) return
call pcontr(Red, Tmp2, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_mpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:258', errst=errst)) return
call destroy(Tmp2)
else
! Contract only possible indices to the right
! -------------------------------------------
kk = kk + 1
call split(Tmp, kk, Rho%Sl_right, errst=errst)
!if(prop_error('rho_red_mpdoc : split failed.', &
! 'MPDOOps_include.f90:269', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_mpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:273', errst=errst)) return
call destroy(Tmp)
call pointto(Red, Tmp2)
end if
! Split local Hilbert spaces and permute
! --------------------------------------
!
! Grouping ket and bra indices together
allocate(perm(2 * nn))
do ii = nn, 1, -1
call split(Red, ii, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_mpdoc : split failed.', &
! 'MPDOOps_include.f90:289', errst=errst)) return
end do
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_mpdoc : transposed failed.', &
! 'MPDOOps_include.f90:297', 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_mpdoc
"""
return
[docs]def rho_red_qmpdo():
"""
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(qmpdo), in
MPDO 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). Not
accessed, kept for compliance with MPS interface.
trunc : REAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Not accessed, kept for compliance
with MPS interface.
ncut : INTEGER, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values. Not accessed, kept for compliance
with MPS interface.
err : REAL, out
Truncation error for tracking it from calling routine. No
truncation introduced in MPDOs and thus zero by default.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_red_qmpdo(Red, Rho, sites, cont, trunc, ncut, err, errst)
type(qtensor), intent(out) :: Red
type(qmpdo), 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, kk
! next site kept
integer :: next
! number of sites kept
integer :: nn
! for permutation of indices
integer, dimension(:), allocatable :: perm
! temporary tensors
type(qtensor) :: Tmp, Tmp2
!if(present(errst)) errst = 0
! Set err - always zero as no permutation needed
err = 0.0_rKind
nn = size(sites, 1)
call copy(Tmp2, Rho%Superket%Aa(1))
call split(Tmp2, 1, Rho%Sl_left, errst=errst)
!if(prop_error('rho_red_qmpdo : split failed.', &
! 'MPDOOps_include.f90:179', errst=errst)) return
call pcontr(Tmp, Tmp2, [1], [2], errst=errst)
!if(prop_error('rho_red_qmpdo : pcontr failed.', &
! 'MPDOOps_include.f90:183', errst=errst)) return
call destroy(Tmp2)
kk = 1
next = sites(kk)
do ii = 1, (Rho%Superket%ll - 1)
if(next == ii) then
! Keep this site
! --------------
kk = kk + 1
if(kk > nn) then
next = -1
else
next = sites(kk)
end if
call contr(Tmp2, Tmp, Rho%Superket%Aa(ii + 1), [kk], [1], &
errst=errst)
!if(prop_error('rho_red_qmpdo : contr failed.', &
! 'MPDOOps_include.f90:206', errst=errst)) return
call destroy(Tmp)
call pointto(Tmp, Tmp2)
else
! Trace this site out
! -------------------
call split(Tmp, kk, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_qmpdo : split failed.', &
! 'MPDOOps_include.f90:217', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_qmpdo : pcontr failed.', &
! 'MPDOOps_include.f90:221', errst=errst)) return
call destroy(Tmp)
! Contract with next site
call contr(Tmp, Tmp2, Rho%Superket%Aa(ii + 1), [kk], [1], &
errst=errst)
!if(prop_error('rho_red_qmpdo : contr failed.', &
! 'MPDOOps_include.f90:229', errst=errst)) return
call destroy(Tmp2)
end if
end do
! Last site
! ---------
if(next == -1) then
! Trace this site out
! -------------------
call split(Tmp, kk, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_qmpdo : split failed.', &
! 'MPDOOps_include.f90:244', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_qmpdo : pcontr failed.', &
! 'MPDOOps_include.f90:248', errst=errst)) return
call destroy(Tmp)
call split(Tmp2, kk, Rho%Sl_right, errst=errst)
!if(prop_error('rho_red_qmpdo : split failed.', &
! 'MPDOOps_include.f90:254', errst=errst)) return
call pcontr(Red, Tmp2, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_qmpdo : pcontr failed.', &
! 'MPDOOps_include.f90:258', errst=errst)) return
call destroy(Tmp2)
else
! Contract only possible indices to the right
! -------------------------------------------
kk = kk + 1
call split(Tmp, kk, Rho%Sl_right, errst=errst)
!if(prop_error('rho_red_qmpdo : split failed.', &
! 'MPDOOps_include.f90:269', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_qmpdo : pcontr failed.', &
! 'MPDOOps_include.f90:273', errst=errst)) return
call destroy(Tmp)
call pointto(Red, Tmp2)
end if
! Split local Hilbert spaces and permute
! --------------------------------------
!
! Grouping ket and bra indices together
allocate(perm(2 * nn))
do ii = nn, 1, -1
call split(Red, ii, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_qmpdo : split failed.', &
! 'MPDOOps_include.f90:289', errst=errst)) return
end do
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_qmpdo : transposed failed.', &
! 'MPDOOps_include.f90:297', 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_qmpdo
"""
return
[docs]def rho_red_qmpdoc():
"""
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(qmpdoc), in
MPDO 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). Not
accessed, kept for compliance with MPS interface.
trunc : REAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Not accessed, kept for compliance
with MPS interface.
ncut : INTEGER, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values. Not accessed, kept for compliance
with MPS interface.
err : REAL, out
Truncation error for tracking it from calling routine. No
truncation introduced in MPDOs and thus zero by default.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_red_qmpdoc(Red, Rho, sites, cont, trunc, ncut, err, errst)
type(qtensorc), intent(out) :: Red
type(qmpdoc), 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, kk
! next site kept
integer :: next
! number of sites kept
integer :: nn
! for permutation of indices
integer, dimension(:), allocatable :: perm
! temporary tensors
type(qtensorc) :: Tmp, Tmp2
!if(present(errst)) errst = 0
! Set err - always zero as no permutation needed
err = 0.0_rKind
nn = size(sites, 1)
call copy(Tmp2, Rho%Superket%Aa(1))
call split(Tmp2, 1, Rho%Sl_left, errst=errst)
!if(prop_error('rho_red_qmpdoc : split failed.', &
! 'MPDOOps_include.f90:179', errst=errst)) return
call pcontr(Tmp, Tmp2, [1], [2], errst=errst)
!if(prop_error('rho_red_qmpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:183', errst=errst)) return
call destroy(Tmp2)
kk = 1
next = sites(kk)
do ii = 1, (Rho%Superket%ll - 1)
if(next == ii) then
! Keep this site
! --------------
kk = kk + 1
if(kk > nn) then
next = -1
else
next = sites(kk)
end if
call contr(Tmp2, Tmp, Rho%Superket%Aa(ii + 1), [kk], [1], &
errst=errst)
!if(prop_error('rho_red_qmpdoc : contr failed.', &
! 'MPDOOps_include.f90:206', errst=errst)) return
call destroy(Tmp)
call pointto(Tmp, Tmp2)
else
! Trace this site out
! -------------------
call split(Tmp, kk, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_qmpdoc : split failed.', &
! 'MPDOOps_include.f90:217', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_qmpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:221', errst=errst)) return
call destroy(Tmp)
! Contract with next site
call contr(Tmp, Tmp2, Rho%Superket%Aa(ii + 1), [kk], [1], &
errst=errst)
!if(prop_error('rho_red_qmpdoc : contr failed.', &
! 'MPDOOps_include.f90:229', errst=errst)) return
call destroy(Tmp2)
end if
end do
! Last site
! ---------
if(next == -1) then
! Trace this site out
! -------------------
call split(Tmp, kk, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_qmpdoc : split failed.', &
! 'MPDOOps_include.f90:244', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_qmpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:248', errst=errst)) return
call destroy(Tmp)
call split(Tmp2, kk, Rho%Sl_right, errst=errst)
!if(prop_error('rho_red_qmpdoc : split failed.', &
! 'MPDOOps_include.f90:254', errst=errst)) return
call pcontr(Red, Tmp2, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_qmpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:258', errst=errst)) return
call destroy(Tmp2)
else
! Contract only possible indices to the right
! -------------------------------------------
kk = kk + 1
call split(Tmp, kk, Rho%Sl_right, errst=errst)
!if(prop_error('rho_red_qmpdoc : split failed.', &
! 'MPDOOps_include.f90:269', errst=errst)) return
call pcontr(Tmp2, Tmp, [kk], [kk + 1], errst=errst)
!if(prop_error('rho_red_qmpdoc : pcontr failed.', &
! 'MPDOOps_include.f90:273', errst=errst)) return
call destroy(Tmp)
call pointto(Red, Tmp2)
end if
! Split local Hilbert spaces and permute
! --------------------------------------
!
! Grouping ket and bra indices together
allocate(perm(2 * nn))
do ii = nn, 1, -1
call split(Red, ii, Rho%Sl_local, errst=errst)
!if(prop_error('rho_red_qmpdoc : split failed.', &
! 'MPDOOps_include.f90:289', errst=errst)) return
end do
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_qmpdoc : transposed failed.', &
! 'MPDOOps_include.f90:297', 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_qmpdoc
"""
return
[docs]def copy_mpdo_mpdo():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPDO.
**Arguments**
Rhoout : TYPE(mpdo), inout
On exit, copy of Rhoin.
Rhoin : TYPE(mpdo), in
Make a copy of this MPDO.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rhoout with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mpdo_mpdo(Rhoout, Rhoin, scalar, errst)
type(mpdo), intent(inout) :: Rhoout
type(mpdo), intent(in) :: Rhoin
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call copy(Rhoout%Superket, Rhoin%Superket, scalar=scalar, errst=errst)
!if(prop_error('copy_mpdo_mpdo : copy failed.', &
! 'MPDOOps_include.f90:355', errst=errst)) return
call copy(Rhoout%Sl_left, Rhoin%Sl_left, errst=errst)
!if(prop_error('copy_mpdo_mpdo : copy failed.', &
! 'MPDOOps_include.f90:359', errst=errst)) return
call copy(Rhoout%Sl_local, Rhoin%Sl_local, errst=errst)
!if(prop_error('copy_mpdo_mpdo : copy failed.', &
! 'MPDOOps_include.f90:363', errst=errst)) return
call copy(Rhoout%Sl_right, Rhoin%Sl_right, errst=errst)
!if(prop_error('copy_mpdo_mpdo : copy failed.', &
! 'MPDOOps_include.f90:367', errst=errst)) return
end subroutine copy_mpdo_mpdo
"""
return
[docs]def copy_mpdoc_mpdo():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPDO.
**Arguments**
Rhoout : TYPE(mpdoc), inout
On exit, copy of Rhoin.
Rhoin : TYPE(mpdo), in
Make a copy of this MPDO.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rhoout with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mpdoc_mpdo(Rhoout, Rhoin, scalar, errst)
type(mpdoc), intent(inout) :: Rhoout
type(mpdo), intent(in) :: Rhoin
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call copy(Rhoout%Superket, Rhoin%Superket, scalar=scalar, errst=errst)
!if(prop_error('copy_mpdoc_mpdo : copy failed.', &
! 'MPDOOps_include.f90:355', errst=errst)) return
call copy(Rhoout%Sl_left, Rhoin%Sl_left, errst=errst)
!if(prop_error('copy_mpdoc_mpdo : copy failed.', &
! 'MPDOOps_include.f90:359', errst=errst)) return
call copy(Rhoout%Sl_local, Rhoin%Sl_local, errst=errst)
!if(prop_error('copy_mpdoc_mpdo : copy failed.', &
! 'MPDOOps_include.f90:363', errst=errst)) return
call copy(Rhoout%Sl_right, Rhoin%Sl_right, errst=errst)
!if(prop_error('copy_mpdoc_mpdo : copy failed.', &
! 'MPDOOps_include.f90:367', errst=errst)) return
end subroutine copy_mpdoc_mpdo
"""
return
[docs]def copy_mpdoc_mpdoc():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPDO.
**Arguments**
Rhoout : TYPE(mpdoc), inout
On exit, copy of Rhoin.
Rhoin : TYPE(mpdoc), in
Make a copy of this MPDO.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rhoout with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mpdoc_mpdoc(Rhoout, Rhoin, scalar, errst)
type(mpdoc), intent(inout) :: Rhoout
type(mpdoc), intent(in) :: Rhoin
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call copy(Rhoout%Superket, Rhoin%Superket, scalar=scalar, errst=errst)
!if(prop_error('copy_mpdoc_mpdoc : copy failed.', &
! 'MPDOOps_include.f90:355', errst=errst)) return
call copy(Rhoout%Sl_left, Rhoin%Sl_left, errst=errst)
!if(prop_error('copy_mpdoc_mpdoc : copy failed.', &
! 'MPDOOps_include.f90:359', errst=errst)) return
call copy(Rhoout%Sl_local, Rhoin%Sl_local, errst=errst)
!if(prop_error('copy_mpdoc_mpdoc : copy failed.', &
! 'MPDOOps_include.f90:363', errst=errst)) return
call copy(Rhoout%Sl_right, Rhoin%Sl_right, errst=errst)
!if(prop_error('copy_mpdoc_mpdoc : copy failed.', &
! 'MPDOOps_include.f90:367', errst=errst)) return
end subroutine copy_mpdoc_mpdoc
"""
return
[docs]def copy_qmpdo_qmpdo():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPDO.
**Arguments**
Rhoout : TYPE(qmpdo), inout
On exit, copy of Rhoin.
Rhoin : TYPE(qmpdo), in
Make a copy of this MPDO.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rhoout with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmpdo_qmpdo(Rhoout, Rhoin, scalar, errst)
type(qmpdo), intent(inout) :: Rhoout
type(qmpdo), intent(in) :: Rhoin
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call copy(Rhoout%Superket, Rhoin%Superket, scalar=scalar, errst=errst)
!if(prop_error('copy_qmpdo_qmpdo : copy failed.', &
! 'MPDOOps_include.f90:355', errst=errst)) return
call copy(Rhoout%Sl_left, Rhoin%Sl_left, errst=errst)
!if(prop_error('copy_qmpdo_qmpdo : copy failed.', &
! 'MPDOOps_include.f90:359', errst=errst)) return
call copy(Rhoout%Sl_local, Rhoin%Sl_local, errst=errst)
!if(prop_error('copy_qmpdo_qmpdo : copy failed.', &
! 'MPDOOps_include.f90:363', errst=errst)) return
call copy(Rhoout%Sl_right, Rhoin%Sl_right, errst=errst)
!if(prop_error('copy_qmpdo_qmpdo : copy failed.', &
! 'MPDOOps_include.f90:367', errst=errst)) return
end subroutine copy_qmpdo_qmpdo
"""
return
[docs]def copy_qmpdoc_qmpdo():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPDO.
**Arguments**
Rhoout : TYPE(qmpdoc), inout
On exit, copy of Rhoin.
Rhoin : TYPE(qmpdo), in
Make a copy of this MPDO.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rhoout with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmpdoc_qmpdo(Rhoout, Rhoin, scalar, errst)
type(qmpdoc), intent(inout) :: Rhoout
type(qmpdo), intent(in) :: Rhoin
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call copy(Rhoout%Superket, Rhoin%Superket, scalar=scalar, errst=errst)
!if(prop_error('copy_qmpdoc_qmpdo : copy failed.', &
! 'MPDOOps_include.f90:355', errst=errst)) return
call copy(Rhoout%Sl_left, Rhoin%Sl_left, errst=errst)
!if(prop_error('copy_qmpdoc_qmpdo : copy failed.', &
! 'MPDOOps_include.f90:359', errst=errst)) return
call copy(Rhoout%Sl_local, Rhoin%Sl_local, errst=errst)
!if(prop_error('copy_qmpdoc_qmpdo : copy failed.', &
! 'MPDOOps_include.f90:363', errst=errst)) return
call copy(Rhoout%Sl_right, Rhoin%Sl_right, errst=errst)
!if(prop_error('copy_qmpdoc_qmpdo : copy failed.', &
! 'MPDOOps_include.f90:367', errst=errst)) return
end subroutine copy_qmpdoc_qmpdo
"""
return
[docs]def copy_qmpdoc_qmpdoc():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPDO.
**Arguments**
Rhoout : TYPE(qmpdoc), inout
On exit, copy of Rhoin.
Rhoin : TYPE(qmpdoc), in
Make a copy of this MPDO.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rhoout with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmpdoc_qmpdoc(Rhoout, Rhoin, scalar, errst)
type(qmpdoc), intent(inout) :: Rhoout
type(qmpdoc), intent(in) :: Rhoin
complex(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call copy(Rhoout%Superket, Rhoin%Superket, scalar=scalar, errst=errst)
!if(prop_error('copy_qmpdoc_qmpdoc : copy failed.', &
! 'MPDOOps_include.f90:355', errst=errst)) return
call copy(Rhoout%Sl_left, Rhoin%Sl_left, errst=errst)
!if(prop_error('copy_qmpdoc_qmpdoc : copy failed.', &
! 'MPDOOps_include.f90:359', errst=errst)) return
call copy(Rhoout%Sl_local, Rhoin%Sl_local, errst=errst)
!if(prop_error('copy_qmpdoc_qmpdoc : copy failed.', &
! 'MPDOOps_include.f90:363', errst=errst)) return
call copy(Rhoout%Sl_right, Rhoin%Sl_right, errst=errst)
!if(prop_error('copy_qmpdoc_qmpdoc : copy failed.', &
! 'MPDOOps_include.f90:367', errst=errst)) return
end subroutine copy_qmpdoc_qmpdoc
"""
return
[docs]def copy_mpdo_mps():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS into an MPDO.
**Arguments**
Rho : TYPE(mpdo), inout
On exit, copy of Psi written as density matrix / MPDO.
Psi : TYPE(mps), in
Make a copy of this MPS and write it as MPDO.
Slsite : TYPE(splitlink), in
Object defining spliting the local Hilbert space of an MPDO. Has to be
passed, since it is based on the complete Hilbert space, which is not
necessarily present in the state Psi passed to be converted.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rho with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mpdo_mps(Rho, Psi, Slsite, scalar, errst)
type(mpdo), intent(inout) :: Rho
type(mps), intent(in) :: Psi
type(splitlink), intent(in) :: Slsite
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! indices for fusing
integer, dimension(2, 3) :: fidx
! temporary tensors
type(tensor) :: Tmpa, Tmpb
Rho%Superket%ll = Psi%ll
Rho%Superket%oc = -1
allocate(Rho%Superket%AA(Psi%ll), Rho%Superket%haslambda(Psi%ll + 1), &
Rho%Superket%Lambda(Psi%ll + 1), Rho%Superket%can(Psi%ll))
Rho%Superket%can = 'o'
Rho%Superket%haslambda = .false.
fidx = reshape([1, 4, 2, 5, 3, 6], [2, 3])
do ii = 1, Psi%ll
! Copy tensor twice
call copy(Tmpa, Psi%Aa(ii))
call copy(Tmpb, Psi%Aa(ii))
! Insert dummylink to be contracted in the next step
call add_dummylink(Tmpa, 1, errst=errst)
!if(prop_error('copy_mpdo_mps : add_dummylink '//&
! '(1) failed.', 'MPDOOps_include.f90:450', &
! errst=errst)) return
call add_dummylink(Tmpb, 1, errst=errst)
!if(prop_error('copy_mpdo_mps : add_dummylink '//&
! '(2) failed.', 'MPDOOps_include.f90:455', &
! errst=errst)) return
! Contract over dummy link
call contr(Rho%Superket%Aa(ii), Tmpa, Tmpb, [1], [1], transr='C', &
errst=errst)
!if(prop_error('copy_mpdo_mps : contr failed.', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
if(ii == 1) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_left, Rho%Superket%Aa(1), [1, 4], errst=errst)
!if(prop_error('copy_mpdo_mps : create '//&
! 'failed.', 'MPDOOps_include.f90:471', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), [3, 6], &
errst=errst)
!if(prop_error('copy_mpdo_mps : create '//&
! 'failed.', 'MPDOOps_include.f90:478', &
! errst=errst)) return
end if
call fuse(Rho%Superket%Aa(ii), fidx, '0', errst=errst)
!if(prop_error('copy_mpdo_mps : fuse failed.', &
! errst=errst)) return
if(ii == 1) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_left, Rho%Superket%Aa(1), 1, errst=errst)
!if(prop_error('copy_mpdo_mps : create '//&
! 'failed.', 'MPDOOps_include.f90:490', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), 3, &
errst=errst)
!if(prop_error('copy_mpdo_mps : create '//&
! 'failed.', 'MPDOOps_include.f90:497', &
! errst=errst)) return
end if
end do
call copy(Rho%Sl_local, Slsite)
if(present(scalar)) then
call scale(scalar, Rho%Superket)
end if
end subroutine copy_mpdo_mps
"""
return
[docs]def copy_mpdoc_mps():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS into an MPDO.
**Arguments**
Rho : TYPE(mpdoc), inout
On exit, copy of Psi written as density matrix / MPDO.
Psi : TYPE(mps), in
Make a copy of this MPS and write it as MPDO.
Slsite : TYPE(splitlink), in
Object defining spliting the local Hilbert space of an MPDO. Has to be
passed, since it is based on the complete Hilbert space, which is not
necessarily present in the state Psi passed to be converted.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rho with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mpdoc_mps(Rho, Psi, Slsite, scalar, errst)
type(mpdoc), intent(inout) :: Rho
type(mps), intent(in) :: Psi
type(splitlink), intent(in) :: Slsite
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! indices for fusing
integer, dimension(2, 3) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
Rho%Superket%ll = Psi%ll
Rho%Superket%oc = -1
allocate(Rho%Superket%AA(Psi%ll), Rho%Superket%haslambda(Psi%ll + 1), &
Rho%Superket%Lambda(Psi%ll + 1), Rho%Superket%can(Psi%ll))
Rho%Superket%can = 'o'
Rho%Superket%haslambda = .false.
fidx = reshape([1, 4, 2, 5, 3, 6], [2, 3])
do ii = 1, Psi%ll
! Copy tensor twice
call copy(Tmpa, Psi%Aa(ii))
call copy(Tmpb, Psi%Aa(ii))
! Insert dummylink to be contracted in the next step
call add_dummylink(Tmpa, 1, errst=errst)
!if(prop_error('copy_mpdoc_mps : add_dummylink '//&
! '(1) failed.', 'MPDOOps_include.f90:450', &
! errst=errst)) return
call add_dummylink(Tmpb, 1, errst=errst)
!if(prop_error('copy_mpdoc_mps : add_dummylink '//&
! '(2) failed.', 'MPDOOps_include.f90:455', &
! errst=errst)) return
! Contract over dummy link
call contr(Rho%Superket%Aa(ii), Tmpa, Tmpb, [1], [1], transr='C', &
errst=errst)
!if(prop_error('copy_mpdoc_mps : contr failed.', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
if(ii == 1) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_left, Rho%Superket%Aa(1), [1, 4], errst=errst)
!if(prop_error('copy_mpdoc_mps : create '//&
! 'failed.', 'MPDOOps_include.f90:471', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), [3, 6], &
errst=errst)
!if(prop_error('copy_mpdoc_mps : create '//&
! 'failed.', 'MPDOOps_include.f90:478', &
! errst=errst)) return
end if
call fuse(Rho%Superket%Aa(ii), fidx, '0', errst=errst)
!if(prop_error('copy_mpdoc_mps : fuse failed.', &
! errst=errst)) return
if(ii == 1) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_left, Rho%Superket%Aa(1), 1, errst=errst)
!if(prop_error('copy_mpdoc_mps : create '//&
! 'failed.', 'MPDOOps_include.f90:490', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), 3, &
errst=errst)
!if(prop_error('copy_mpdoc_mps : create '//&
! 'failed.', 'MPDOOps_include.f90:497', &
! errst=errst)) return
end if
end do
call copy(Rho%Sl_local, Slsite)
if(present(scalar)) then
call scale(scalar, Rho%Superket)
end if
end subroutine copy_mpdoc_mps
"""
return
[docs]def copy_mpdoc_mpsc():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS into an MPDO.
**Arguments**
Rho : TYPE(mpdoc), inout
On exit, copy of Psi written as density matrix / MPDO.
Psi : TYPE(mpsc), in
Make a copy of this MPS and write it as MPDO.
Slsite : TYPE(splitlink), in
Object defining spliting the local Hilbert space of an MPDO. Has to be
passed, since it is based on the complete Hilbert space, which is not
necessarily present in the state Psi passed to be converted.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rho with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_mpdoc_mpsc(Rho, Psi, Slsite, scalar, errst)
type(mpdoc), intent(inout) :: Rho
type(mpsc), intent(in) :: Psi
type(splitlink), intent(in) :: Slsite
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! indices for fusing
integer, dimension(2, 3) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
Rho%Superket%ll = Psi%ll
Rho%Superket%oc = -1
allocate(Rho%Superket%AA(Psi%ll), Rho%Superket%haslambda(Psi%ll + 1), &
Rho%Superket%Lambda(Psi%ll + 1), Rho%Superket%can(Psi%ll))
Rho%Superket%can = 'o'
Rho%Superket%haslambda = .false.
fidx = reshape([1, 4, 2, 5, 3, 6], [2, 3])
do ii = 1, Psi%ll
! Copy tensor twice
call copy(Tmpa, Psi%Aa(ii))
call copy(Tmpb, Psi%Aa(ii))
! Insert dummylink to be contracted in the next step
call add_dummylink(Tmpa, 1, errst=errst)
!if(prop_error('copy_mpdoc_mpsc : add_dummylink '//&
! '(1) failed.', 'MPDOOps_include.f90:450', &
! errst=errst)) return
call add_dummylink(Tmpb, 1, errst=errst)
!if(prop_error('copy_mpdoc_mpsc : add_dummylink '//&
! '(2) failed.', 'MPDOOps_include.f90:455', &
! errst=errst)) return
! Contract over dummy link
call contr(Rho%Superket%Aa(ii), Tmpa, Tmpb, [1], [1], transr='C', &
errst=errst)
!if(prop_error('copy_mpdoc_mpsc : contr failed.', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
if(ii == 1) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_left, Rho%Superket%Aa(1), [1, 4], errst=errst)
!if(prop_error('copy_mpdoc_mpsc : create '//&
! 'failed.', 'MPDOOps_include.f90:471', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), [3, 6], &
errst=errst)
!if(prop_error('copy_mpdoc_mpsc : create '//&
! 'failed.', 'MPDOOps_include.f90:478', &
! errst=errst)) return
end if
call fuse(Rho%Superket%Aa(ii), fidx, '0', errst=errst)
!if(prop_error('copy_mpdoc_mpsc : fuse failed.', &
! errst=errst)) return
if(ii == 1) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_left, Rho%Superket%Aa(1), 1, errst=errst)
!if(prop_error('copy_mpdoc_mpsc : create '//&
! 'failed.', 'MPDOOps_include.f90:490', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), 3, &
errst=errst)
!if(prop_error('copy_mpdoc_mpsc : create '//&
! 'failed.', 'MPDOOps_include.f90:497', &
! errst=errst)) return
end if
end do
call copy(Rho%Sl_local, Slsite)
if(present(scalar)) then
call scale(scalar, Rho%Superket)
end if
end subroutine copy_mpdoc_mpsc
"""
return
[docs]def copy_qmpdo_qmps():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS into an MPDO.
**Arguments**
Rho : TYPE(qmpdo), inout
On exit, copy of Psi written as density matrix / MPDO.
Psi : TYPE(qmps), in
Make a copy of this MPS and write it as MPDO.
Slsite : TYPE(splitlink), in
Object defining spliting the local Hilbert space of an MPDO. Has to be
passed, since it is based on the complete Hilbert space, which is not
necessarily present in the state Psi passed to be converted.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rho with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmpdo_qmps(Rho, Psi, Slsite, scalar, errst)
type(qmpdo), intent(inout) :: Rho
type(qmps), intent(in) :: Psi
type(splitlink), intent(in) :: Slsite
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! indices for fusing
integer, dimension(2, 3) :: fidx
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
Rho%Superket%ll = Psi%ll
Rho%Superket%oc = -1
allocate(Rho%Superket%AA(Psi%ll), Rho%Superket%haslambda(Psi%ll + 1), &
Rho%Superket%Lambda(Psi%ll + 1), Rho%Superket%can(Psi%ll))
Rho%Superket%can = 'o'
Rho%Superket%haslambda = .false.
fidx = reshape([1, 4, 2, 5, 3, 6], [2, 3])
do ii = 1, Psi%ll
! Copy tensor twice
call copy(Tmpa, Psi%Aa(ii))
call copy(Tmpb, Psi%Aa(ii))
! Insert dummylink to be contracted in the next step
call add_dummylink(Tmpa, 1, errst=errst)
!if(prop_error('copy_qmpdo_qmps : add_dummylink '//&
! '(1) failed.', 'MPDOOps_include.f90:450', &
! errst=errst)) return
call add_dummylink(Tmpb, 1, errst=errst)
!if(prop_error('copy_qmpdo_qmps : add_dummylink '//&
! '(2) failed.', 'MPDOOps_include.f90:455', &
! errst=errst)) return
! Contract over dummy link
call contr(Rho%Superket%Aa(ii), Tmpa, Tmpb, [1], [1], transr='C', &
errst=errst)
!if(prop_error('copy_qmpdo_qmps : contr failed.', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
if(ii == 1) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_left, Rho%Superket%Aa(1), [1, 4], errst=errst)
!if(prop_error('copy_qmpdo_qmps : create '//&
! 'failed.', 'MPDOOps_include.f90:471', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), [3, 6], &
errst=errst)
!if(prop_error('copy_qmpdo_qmps : create '//&
! 'failed.', 'MPDOOps_include.f90:478', &
! errst=errst)) return
end if
call fuse(Rho%Superket%Aa(ii), fidx, '0', errst=errst)
!if(prop_error('copy_qmpdo_qmps : fuse failed.', &
! errst=errst)) return
if(ii == 1) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_left, Rho%Superket%Aa(1), 1, errst=errst)
!if(prop_error('copy_qmpdo_qmps : create '//&
! 'failed.', 'MPDOOps_include.f90:490', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), 3, &
errst=errst)
!if(prop_error('copy_qmpdo_qmps : create '//&
! 'failed.', 'MPDOOps_include.f90:497', &
! errst=errst)) return
end if
end do
call copy(Rho%Sl_local, Slsite)
if(present(scalar)) then
call scale(scalar, Rho%Superket)
end if
end subroutine copy_qmpdo_qmps
"""
return
[docs]def copy_qmpdoc_qmps():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS into an MPDO.
**Arguments**
Rho : TYPE(qmpdoc), inout
On exit, copy of Psi written as density matrix / MPDO.
Psi : TYPE(qmps), in
Make a copy of this MPS and write it as MPDO.
Slsite : TYPE(splitlink), in
Object defining spliting the local Hilbert space of an MPDO. Has to be
passed, since it is based on the complete Hilbert space, which is not
necessarily present in the state Psi passed to be converted.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rho with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmpdoc_qmps(Rho, Psi, Slsite, scalar, errst)
type(qmpdoc), intent(inout) :: Rho
type(qmps), intent(in) :: Psi
type(splitlink), intent(in) :: Slsite
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! indices for fusing
integer, dimension(2, 3) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
Rho%Superket%ll = Psi%ll
Rho%Superket%oc = -1
allocate(Rho%Superket%AA(Psi%ll), Rho%Superket%haslambda(Psi%ll + 1), &
Rho%Superket%Lambda(Psi%ll + 1), Rho%Superket%can(Psi%ll))
Rho%Superket%can = 'o'
Rho%Superket%haslambda = .false.
fidx = reshape([1, 4, 2, 5, 3, 6], [2, 3])
do ii = 1, Psi%ll
! Copy tensor twice
call copy(Tmpa, Psi%Aa(ii))
call copy(Tmpb, Psi%Aa(ii))
! Insert dummylink to be contracted in the next step
call add_dummylink(Tmpa, 1, errst=errst)
!if(prop_error('copy_qmpdoc_qmps : add_dummylink '//&
! '(1) failed.', 'MPDOOps_include.f90:450', &
! errst=errst)) return
call add_dummylink(Tmpb, 1, errst=errst)
!if(prop_error('copy_qmpdoc_qmps : add_dummylink '//&
! '(2) failed.', 'MPDOOps_include.f90:455', &
! errst=errst)) return
! Contract over dummy link
call contr(Rho%Superket%Aa(ii), Tmpa, Tmpb, [1], [1], transr='C', &
errst=errst)
!if(prop_error('copy_qmpdoc_qmps : contr failed.', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
if(ii == 1) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_left, Rho%Superket%Aa(1), [1, 4], errst=errst)
!if(prop_error('copy_qmpdoc_qmps : create '//&
! 'failed.', 'MPDOOps_include.f90:471', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), [3, 6], &
errst=errst)
!if(prop_error('copy_qmpdoc_qmps : create '//&
! 'failed.', 'MPDOOps_include.f90:478', &
! errst=errst)) return
end if
call fuse(Rho%Superket%Aa(ii), fidx, '0', errst=errst)
!if(prop_error('copy_qmpdoc_qmps : fuse failed.', &
! errst=errst)) return
if(ii == 1) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_left, Rho%Superket%Aa(1), 1, errst=errst)
!if(prop_error('copy_qmpdoc_qmps : create '//&
! 'failed.', 'MPDOOps_include.f90:490', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), 3, &
errst=errst)
!if(prop_error('copy_qmpdoc_qmps : create '//&
! 'failed.', 'MPDOOps_include.f90:497', &
! errst=errst)) return
end if
end do
call copy(Rho%Sl_local, Slsite)
if(present(scalar)) then
call scale(scalar, Rho%Superket)
end if
end subroutine copy_qmpdoc_qmps
"""
return
[docs]def copy_qmpdoc_qmpsc():
"""
fortran-subroutine - September 2017 (dj)
Copy an MPS into an MPDO.
**Arguments**
Rho : TYPE(qmpdoc), inout
On exit, copy of Psi written as density matrix / MPDO.
Psi : TYPE(qmpsc), in
Make a copy of this MPS and write it as MPDO.
Slsite : TYPE(splitlink), in
Object defining spliting the local Hilbert space of an MPDO. Has to be
passed, since it is based on the complete Hilbert space, which is not
necessarily present in the state Psi passed to be converted.
scalar : REAL, OPTIONAL, in
Scale the new MPDO Rho with a scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qmpdoc_qmpsc(Rho, Psi, Slsite, scalar, errst)
type(qmpdoc), intent(inout) :: Rho
type(qmpsc), intent(in) :: Psi
type(splitlink), intent(in) :: Slsite
real(KIND=rKind), intent(in), optional :: scalar
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! indices for fusing
integer, dimension(2, 3) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
Rho%Superket%ll = Psi%ll
Rho%Superket%oc = -1
allocate(Rho%Superket%AA(Psi%ll), Rho%Superket%haslambda(Psi%ll + 1), &
Rho%Superket%Lambda(Psi%ll + 1), Rho%Superket%can(Psi%ll))
Rho%Superket%can = 'o'
Rho%Superket%haslambda = .false.
fidx = reshape([1, 4, 2, 5, 3, 6], [2, 3])
do ii = 1, Psi%ll
! Copy tensor twice
call copy(Tmpa, Psi%Aa(ii))
call copy(Tmpb, Psi%Aa(ii))
! Insert dummylink to be contracted in the next step
call add_dummylink(Tmpa, 1, errst=errst)
!if(prop_error('copy_qmpdoc_qmpsc : add_dummylink '//&
! '(1) failed.', 'MPDOOps_include.f90:450', &
! errst=errst)) return
call add_dummylink(Tmpb, 1, errst=errst)
!if(prop_error('copy_qmpdoc_qmpsc : add_dummylink '//&
! '(2) failed.', 'MPDOOps_include.f90:455', &
! errst=errst)) return
! Contract over dummy link
call contr(Rho%Superket%Aa(ii), Tmpa, Tmpb, [1], [1], transr='C', &
errst=errst)
!if(prop_error('copy_qmpdoc_qmpsc : contr failed.', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
if(ii == 1) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_left, Rho%Superket%Aa(1), [1, 4], errst=errst)
!if(prop_error('copy_qmpdoc_qmpsc : create '//&
! 'failed.', 'MPDOOps_include.f90:471', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call init(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), [3, 6], &
errst=errst)
!if(prop_error('copy_qmpdoc_qmpsc : create '//&
! 'failed.', 'MPDOOps_include.f90:478', &
! errst=errst)) return
end if
call fuse(Rho%Superket%Aa(ii), fidx, '0', errst=errst)
!if(prop_error('copy_qmpdoc_qmpsc : fuse failed.', &
! errst=errst)) return
if(ii == 1) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_left, Rho%Superket%Aa(1), 1, errst=errst)
!if(prop_error('copy_qmpdoc_qmpsc : create '//&
! 'failed.', 'MPDOOps_include.f90:490', &
! errst=errst)) return
elseif(ii == Psi%ll) then
! Set the information how to incoming and outgoing links
call finalize(Rho%Sl_right, Rho%Superket%Aa(Psi%ll), 3, &
errst=errst)
!if(prop_error('copy_qmpdoc_qmpsc : create '//&
! 'failed.', 'MPDOOps_include.f90:497', &
! errst=errst)) return
end if
end do
call copy(Rho%Sl_local, Slsite)
if(present(scalar)) then
call scale(scalar, Rho%Superket)
end if
end subroutine copy_qmpdoc_qmpsc
"""
return
[docs]def corr_init_mpdo_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
right-moving version.
**Arguments**
Tenskk : TYPE(tensor), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlist), inout
Left-right overlap of the MPDO.
Theta : TYPE(tensor), out
On exit, the left overlap for the correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
Sl_left : TYPE(splitlink), in
Information how to split the link to the left of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mpdo_tensor_tensor(Tenskk, LR, Theta, Op, &
kk, Sl_left, errst)
type(tensor), intent(inout) :: Tenskk
type(tensorlist), intent(inout) :: LR
type(tensor), intent(out) :: Theta
type(tensor), intent(inout) :: Op
integer, intent(in) :: kk
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! Split link to left and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_init_mpdo_tensor_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:593', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_init_mpdo_tensor_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:598', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_mpdo_tensor_tensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:609', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_init_mpdo_tensor_tensor: '//&
! 'contr failed.', 'MPDOOps_include.f90:614', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_mpdo_tensor_tensor
"""
return
[docs]def corr_init_mpdo_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
right-moving version.
**Arguments**
Tenskk : TYPE(tensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
Theta : TYPE(tensorc), out
On exit, the left overlap for the correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
Sl_left : TYPE(splitlink), in
Information how to split the link to the left of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mpdo_tensorc_tensor(Tenskk, LR, Theta, Op, &
kk, Sl_left, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
type(tensorc), intent(out) :: Theta
type(tensor), intent(inout) :: Op
integer, intent(in) :: kk
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! Split link to left and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_init_mpdo_tensorc_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:593', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_init_mpdo_tensorc_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:598', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_mpdo_tensorc_tensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:609', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_init_mpdo_tensorc_tensor: '//&
! 'contr failed.', 'MPDOOps_include.f90:614', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_mpdo_tensorc_tensor
"""
return
[docs]def corr_init_mpdo_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
right-moving version.
**Arguments**
Tenskk : TYPE(tensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
Theta : TYPE(tensorc), out
On exit, the left overlap for the correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
Sl_left : TYPE(splitlink), in
Information how to split the link to the left of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mpdo_tensorc_tensorc(Tenskk, LR, Theta, Op, &
kk, Sl_left, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
type(tensorc), intent(out) :: Theta
type(tensorc), intent(inout) :: Op
integer, intent(in) :: kk
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! Split link to left and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_init_mpdo_tensorc_tensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:593', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_init_mpdo_tensorc_tensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:598', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_mpdo_tensorc_tensorc: '//&
! 'fuse failed.', 'MPDOOps_include.f90:609', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_init_mpdo_tensorc_tensorc: '//&
! 'contr failed.', 'MPDOOps_include.f90:614', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_mpdo_tensorc_tensorc
"""
return
[docs]def corr_init_mpdo_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
right-moving version.
**Arguments**
Tenskk : TYPE(qtensor), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorlist), inout
Left-right overlap of the MPDO.
Theta : TYPE(qtensor), out
On exit, the left overlap for the correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
Sl_left : TYPE(splitlink), in
Information how to split the link to the left of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mpdo_qtensor_qtensor(Tenskk, LR, Theta, Op, &
kk, Sl_left, errst)
type(qtensor), intent(inout) :: Tenskk
type(qtensorlist), intent(inout) :: LR
type(qtensor), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
integer, intent(in) :: kk
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! Split link to left and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_init_mpdo_qtensor_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:593', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_init_mpdo_qtensor_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:598', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_mpdo_qtensor_qtensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:609', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_init_mpdo_qtensor_qtensor: '//&
! 'contr failed.', 'MPDOOps_include.f90:614', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_mpdo_qtensor_qtensor
"""
return
[docs]def corr_init_mpdo_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
right-moving version.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
Theta : TYPE(qtensorc), out
On exit, the left overlap for the correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
Sl_left : TYPE(splitlink), in
Information how to split the link to the left of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mpdo_qtensorc_qtensor(Tenskk, LR, Theta, Op, &
kk, Sl_left, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
type(qtensorc), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
integer, intent(in) :: kk
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! Split link to left and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_init_mpdo_qtensorc_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:593', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_init_mpdo_qtensorc_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:598', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_mpdo_qtensorc_qtensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:609', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_init_mpdo_qtensorc_qtensor: '//&
! 'contr failed.', 'MPDOOps_include.f90:614', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_mpdo_qtensorc_qtensor
"""
return
[docs]def corr_init_mpdo_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
right-moving version.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
Theta : TYPE(qtensorc), out
On exit, the left overlap for the correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
Sl_left : TYPE(splitlink), in
Information how to split the link to the left of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mpdo_qtensorc_qtensorc(Tenskk, LR, Theta, Op, &
kk, Sl_left, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
type(qtensorc), intent(out) :: Theta
type(qtensorc), intent(inout) :: Op
integer, intent(in) :: kk
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! Split link to left and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_init_mpdo_qtensorc_qtensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:593', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_init_mpdo_qtensorc_qtensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:598', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_mpdo_qtensorc_qtensorc: '//&
! 'fuse failed.', 'MPDOOps_include.f90:609', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_init_mpdo_qtensorc_qtensorc: '//&
! 'contr failed.', 'MPDOOps_include.f90:614', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_mpdo_qtensorc_qtensorc
"""
return
[docs]def corr_init_l_mpdo_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
left-moving version.
**Arguments**
Tenskk : TYPE(tensor), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlist), inout
Left-right overlap of the MPDO.
Theta : TYPE(tensor), out
On exit, the right overlap for the correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
ll : INTEGER, in
System size to address correct entry in LR.
Sl_right : TYPE(splitlink), in
Information how to split the link right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mpdo_tensor_tensor(Tenskk, LR, Theta, Op, &
kk, ll, Sl_right, errst)
type(tensor), intent(inout) :: Tenskk
type(tensorlist), intent(inout) :: LR
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: Op
integer, intent(in) :: kk, ll
type(splitlink), intent(in) :: Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk < ll) then
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_init_l_mpdo_tensor_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:709', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_init_l_mpdo_tensor_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:714', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_l_mpdo_tensor_tensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:725', &
! errst=errst)) return
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_init_l_mpdo_tensor_tensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:730', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_l_mpdo_tensor_tensor
"""
return
[docs]def corr_init_l_mpdo_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
left-moving version.
**Arguments**
Tenskk : TYPE(tensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
Theta : TYPE(tensorc), out
On exit, the right overlap for the correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
ll : INTEGER, in
System size to address correct entry in LR.
Sl_right : TYPE(splitlink), in
Information how to split the link right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mpdo_tensorc_tensor(Tenskk, LR, Theta, Op, &
kk, ll, Sl_right, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: Op
integer, intent(in) :: kk, ll
type(splitlink), intent(in) :: Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk < ll) then
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_init_l_mpdo_tensorc_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:709', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_init_l_mpdo_tensorc_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:714', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_l_mpdo_tensorc_tensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:725', &
! errst=errst)) return
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_init_l_mpdo_tensorc_tensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:730', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_l_mpdo_tensorc_tensor
"""
return
[docs]def corr_init_l_mpdo_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
left-moving version.
**Arguments**
Tenskk : TYPE(tensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
Theta : TYPE(tensorc), out
On exit, the right overlap for the correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
ll : INTEGER, in
System size to address correct entry in LR.
Sl_right : TYPE(splitlink), in
Information how to split the link right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mpdo_tensorc_tensorc(Tenskk, LR, Theta, Op, &
kk, ll, Sl_right, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: Op
integer, intent(in) :: kk, ll
type(splitlink), intent(in) :: Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk < ll) then
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_init_l_mpdo_tensorc_tensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:709', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_init_l_mpdo_tensorc_tensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:714', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_l_mpdo_tensorc_tensorc: '//&
! 'fuse failed.', 'MPDOOps_include.f90:725', &
! errst=errst)) return
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_init_l_mpdo_tensorc_tensorc: '//&
! 'fuse failed.', 'MPDOOps_include.f90:730', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_l_mpdo_tensorc_tensorc
"""
return
[docs]def corr_init_l_mpdo_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
left-moving version.
**Arguments**
Tenskk : TYPE(qtensor), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorlist), inout
Left-right overlap of the MPDO.
Theta : TYPE(qtensor), out
On exit, the right overlap for the correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
ll : INTEGER, in
System size to address correct entry in LR.
Sl_right : TYPE(splitlink), in
Information how to split the link right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mpdo_qtensor_qtensor(Tenskk, LR, Theta, Op, &
kk, ll, Sl_right, errst)
type(qtensor), intent(inout) :: Tenskk
type(qtensorlist), intent(inout) :: LR
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op
integer, intent(in) :: kk, ll
type(splitlink), intent(in) :: Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk < ll) then
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensor_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:709', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensor_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:714', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensor_qtensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:725', &
! errst=errst)) return
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensor_qtensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:730', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_l_mpdo_qtensor_qtensor
"""
return
[docs]def corr_init_l_mpdo_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
left-moving version.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
Theta : TYPE(qtensorc), out
On exit, the right overlap for the correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
ll : INTEGER, in
System size to address correct entry in LR.
Sl_right : TYPE(splitlink), in
Information how to split the link right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mpdo_qtensorc_qtensor(Tenskk, LR, Theta, Op, &
kk, ll, Sl_right, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op
integer, intent(in) :: kk, ll
type(splitlink), intent(in) :: Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk < ll) then
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensorc_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:709', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensorc_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:714', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensorc_qtensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:725', &
! errst=errst)) return
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensorc_qtensor: '//&
! 'fuse failed.', 'MPDOOps_include.f90:730', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_l_mpdo_qtensorc_qtensor
"""
return
[docs]def corr_init_l_mpdo_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize a correlation measurement involving site kk. This is the
left-moving version.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
Theta : TYPE(qtensorc), out
On exit, the right overlap for the correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement on site kk.
kk : INTEGER, in
Initialize the correlation measurement on site kk. Necessary to
address LR.
ll : INTEGER, in
System size to address correct entry in LR.
Sl_right : TYPE(splitlink), in
Information how to split the link right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mpdo_qtensorc_qtensorc(Tenskk, LR, Theta, Op, &
kk, ll, Sl_right, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: Op
integer, intent(in) :: kk, ll
type(splitlink), intent(in) :: Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing operator
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk < ll) then
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensorc_qtensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:709', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensorc_qtensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:714', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensorc_qtensorc: '//&
! 'fuse failed.', 'MPDOOps_include.f90:725', &
! errst=errst)) return
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_init_l_mpdo_qtensorc_qtensorc: '//&
! 'fuse failed.', 'MPDOOps_include.f90:730', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
end subroutine corr_init_l_mpdo_qtensorc_qtensorc
"""
return
[docs]def corr_meas_mpdo_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
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlist), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(tensor), inout
Left overlap for the correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mpdo_tensor_tensor(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_right, errst)
real(KIND=rKIND), intent(out) :: vals
type(tensor), intent(inout) :: Tenskk
type(tensorlist), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensor) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate the correlation j, k, with j < k
! ---------------------------------------------
if(kk < ll) then
! Contract overlap from the right
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
! Last site - split 3rd link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:857', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'contr failed.', 'MPDOOps_include.f90:862', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:873', &
! errst=errst)) return
! Contract operator
call contr(Tmpc, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:879', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
! Contract overlap from left
call contr(Tmpa, Theta, Tmpc, [1], [1])
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:888', &
! errst=errst)) return
! No open links - result is a scalar
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 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 copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:909', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:914', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:924', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 1, Sl_local, errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:931', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_mpdo_tensor_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:936', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_mpdo_tensor_tensor
"""
return
[docs]def corr_meas_mpdo_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
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
Left overlap for the correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mpdo_tensorc_tensor(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_right, errst)
complex(KIND=rKIND), intent(out) :: vals
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate the correlation j, k, with j < k
! ---------------------------------------------
if(kk < ll) then
! Contract overlap from the right
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
! Last site - split 3rd link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:857', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'contr failed.', 'MPDOOps_include.f90:862', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:873', &
! errst=errst)) return
! Contract operator
call contr(Tmpc, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:879', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
! Contract overlap from left
call contr(Tmpa, Theta, Tmpc, [1], [1])
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:888', &
! errst=errst)) return
! No open links - result is a scalar
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 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 copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:909', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:914', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:924', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 1, Sl_local, errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:931', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:936', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_mpdo_tensorc_tensor
"""
return
[docs]def corr_meas_mpdo_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
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
Left overlap for the correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensorc), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mpdo_tensorc_tensorc(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_right, errst)
complex(KIND=rKIND), intent(out) :: vals
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate the correlation j, k, with j < k
! ---------------------------------------------
if(kk < ll) then
! Contract overlap from the right
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
! Last site - split 3rd link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:857', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'contr failed.', 'MPDOOps_include.f90:862', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:873', &
! errst=errst)) return
! Contract operator
call contr(Tmpc, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:879', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
! Contract overlap from left
call contr(Tmpa, Theta, Tmpc, [1], [1])
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:888', &
! errst=errst)) return
! No open links - result is a scalar
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 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 copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:909', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:914', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:924', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 1, Sl_local, errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:931', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_mpdo_tensorc_tensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:936', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_mpdo_tensorc_tensorc
"""
return
[docs]def corr_meas_mpdo_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
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorlist), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(qtensor), inout
Left overlap for the correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mpdo_qtensor_qtensor(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_right, errst)
real(KIND=rKIND), intent(out) :: vals
type(qtensor), intent(inout) :: Tenskk
type(qtensorlist), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensor) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate the correlation j, k, with j < k
! ---------------------------------------------
if(kk < ll) then
! Contract overlap from the right
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
! Last site - split 3rd link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:857', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'contr failed.', 'MPDOOps_include.f90:862', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:873', &
! errst=errst)) return
! Contract operator
call contr(Tmpc, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:879', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
! Contract overlap from left
call contr(Tmpa, Theta, Tmpc, [1], [1])
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:888', &
! errst=errst)) return
! No open links - result is a scalar
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 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 copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:909', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:914', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:924', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 1, Sl_local, errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:931', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensor_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:936', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_mpdo_qtensor_qtensor
"""
return
[docs]def corr_meas_mpdo_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
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
Left overlap for the correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mpdo_qtensorc_qtensor(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_right, errst)
complex(KIND=rKIND), intent(out) :: vals
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate the correlation j, k, with j < k
! ---------------------------------------------
if(kk < ll) then
! Contract overlap from the right
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
! Last site - split 3rd link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:857', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'contr failed.', 'MPDOOps_include.f90:862', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:873', &
! errst=errst)) return
! Contract operator
call contr(Tmpc, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:879', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
! Contract overlap from left
call contr(Tmpa, Theta, Tmpc, [1], [1])
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:888', &
! errst=errst)) return
! No open links - result is a scalar
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 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 copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:909', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:914', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:924', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 1, Sl_local, errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:931', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:936', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_mpdo_qtensorc_qtensor
"""
return
[docs]def corr_meas_mpdo_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
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
Left overlap for the correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensorc), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mpdo_qtensorc_qtensorc(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_right, errst)
complex(KIND=rKIND), intent(out) :: vals
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate the correlation j, k, with j < k
! ---------------------------------------------
if(kk < ll) then
! Contract overlap from the right
call contr(Tmpa, Tenskk, LR%Li(kk + 1), [3], [1])
else
! Last site - split 3rd link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:857', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'contr failed.', 'MPDOOps_include.f90:862', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpb, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:873', &
! errst=errst)) return
! Contract operator
call contr(Tmpc, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:879', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
! Contract overlap from left
call contr(Tmpa, Theta, Tmpc, [1], [1])
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:888', &
! errst=errst)) return
! No open links - result is a scalar
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 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 copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:909', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:914', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Tenskk, [1], [1], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:924', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 1, Sl_local, errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:931', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_mpdo_qtensorc_qtensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:936', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_mpdo_qtensorc_qtensorc
"""
return
[docs]def corr_meas_l_mpdo_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensor), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlist), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(tensor), inout
Right overlap for the correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mpdo_tensor_tensor(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_left, errst)
real(KIND=rKIND), intent(out) :: vals
type(tensor), intent(inout) :: Tenskk
type(tensorlist), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensor) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! First site - split left link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:1066', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1071', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpa, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:1082', &
! errst=errst)) return
call contr(Tmpc, Tmpa, Tmpb, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:1087', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call contr(Tmpa, Tmpc, Theta, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:1095', &
! errst=errst)) return
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [3], [1])
call destroy(Theta)
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'fuse (2) failed.', 'MPDOOps_include.f90:1115', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:1120', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Tenskk, Theta, [3], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:1130', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 2, Sl_local, errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:1137', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensor_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1142', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_l_mpdo_tensor_tensor
"""
return
[docs]def corr_meas_l_mpdo_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
Right overlap for the correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mpdo_tensorc_tensor(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_left, errst)
complex(KIND=rKIND), intent(out) :: vals
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! First site - split left link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:1066', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1071', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpa, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:1082', &
! errst=errst)) return
call contr(Tmpc, Tmpa, Tmpb, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:1087', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call contr(Tmpa, Tmpc, Theta, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:1095', &
! errst=errst)) return
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [3], [1])
call destroy(Theta)
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'fuse (2) failed.', 'MPDOOps_include.f90:1115', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:1120', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Tenskk, Theta, [3], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:1130', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 2, Sl_local, errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'split failed.', 'MPDOOps_include.f90:1137', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1142', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_l_mpdo_tensorc_tensor
"""
return
[docs]def corr_meas_l_mpdo_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(tensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
Right overlap for the correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensorc), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mpdo_tensorc_tensorc(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_left, errst)
complex(KIND=rKIND), intent(out) :: vals
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(tensorc) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! First site - split left link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:1066', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1071', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpa, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:1082', &
! errst=errst)) return
call contr(Tmpc, Tmpa, Tmpb, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:1087', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call contr(Tmpa, Tmpc, Theta, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:1095', &
! errst=errst)) return
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [3], [1])
call destroy(Theta)
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'fuse (2) failed.', 'MPDOOps_include.f90:1115', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:1120', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Tenskk, Theta, [3], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:1130', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 2, Sl_local, errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:1137', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('corr_meas_l_mpdo_tensorc_tensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1142', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_l_mpdo_tensorc_tensorc
"""
return
[docs]def corr_meas_l_mpdo_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensor), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorlist), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(qtensor), inout
Right overlap for the correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mpdo_qtensor_qtensor(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_left, errst)
real(KIND=rKIND), intent(out) :: vals
type(qtensor), intent(inout) :: Tenskk
type(qtensorlist), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensor) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! First site - split left link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:1066', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1071', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpa, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:1082', &
! errst=errst)) return
call contr(Tmpc, Tmpa, Tmpb, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:1087', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call contr(Tmpa, Tmpc, Theta, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:1095', &
! errst=errst)) return
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [3], [1])
call destroy(Theta)
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'fuse (2) failed.', 'MPDOOps_include.f90:1115', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:1120', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Tenskk, Theta, [3], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:1130', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 2, Sl_local, errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:1137', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensor_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1142', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_l_mpdo_qtensor_qtensor
"""
return
[docs]def corr_meas_l_mpdo_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
Right overlap for the correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mpdo_qtensorc_qtensor(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_left, errst)
complex(KIND=rKIND), intent(out) :: vals
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! First site - split left link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:1066', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1071', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpa, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:1082', &
! errst=errst)) return
call contr(Tmpc, Tmpa, Tmpb, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:1087', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call contr(Tmpa, Tmpc, Theta, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:1095', &
! errst=errst)) return
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [3], [1])
call destroy(Theta)
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'fuse (2) failed.', 'MPDOOps_include.f90:1115', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:1120', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Tenskk, Theta, [3], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:1130', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 2, Sl_local, errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'split failed.', 'MPDOOps_include.f90:1137', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensor: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1142', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_l_mpdo_qtensorc_qtensor
"""
return
[docs]def corr_meas_l_mpdo_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Measure correlation and propagate. Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Tenskk : TYPE(qtensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
kk : INTEGER, in
Site for the measurement.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
Right overlap for the correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensorc), inout
Phase operator for propagation for the following
correlation measurement.
hasphase : LOGICAL, in
Flag if the phase operator is contracted (.true.).
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mpdo_qtensorc_qtensorc(vals, Tenskk, LR, kk, &
ll, Theta, Op, PhaseOp, hasphase, Sl_local, Sl_left, errst)
complex(KIND=rKIND), intent(out) :: vals
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
integer, intent(in) :: kk, ll
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb, Tmpc
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with k < j
! ----------------------------------------
if(kk > 1) then
! Contract overlap from the left
call contr(Tmpa, LR%Li(kk - 1), Tenskk, [1], [1])
else
! First site - split left link and contract with itself
call copy(Tmpb, Tenskk)
call split(Tmpb, 1, Sl_left, errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:1066', &
! errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1071', &
! errst=errst)) return
call destroy(Tmpb)
end if
fidx(:, 1) = [1, 2]
call copy(Tmpa, Op)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'fuse (1) failed.', 'MPDOOps_include.f90:1082', &
! errst=errst)) return
call contr(Tmpc, Tmpa, Tmpb, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'contr (1) failed.', 'MPDOOps_include.f90:1087', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call contr(Tmpa, Tmpc, Theta, [1], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'contr (2) failed.', 'MPDOOps_include.f90:1095', &
! errst=errst)) return
vals = get_scalar(Tmpa)
call destroy(Tmpa)
call destroy(Tmpc)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Tenskk, Theta, [3], [1])
call destroy(Theta)
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0', errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'fuse (2) failed.', 'MPDOOps_include.f90:1115', &
! errst=errst)) return
call contr(Theta, Tmpb, Tmpa, [1], [2], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'contr (3) failed.', 'MPDOOps_include.f90:1120', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Tenskk, Theta, [3], [1], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'contr (4) failed.', 'MPDOOps_include.f90:1130', &
! errst=errst)) return
call destroy(Theta)
call split(Tmpa, 2, Sl_local, errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'split failed.', 'MPDOOps_include.f90:1137', &
! errst=errst)) return
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('corr_meas_l_mpdo_qtensorc_qtensorc: '//&
! 'pcontr failed.', 'MPDOOps_include.f90:1142', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy - this was the last site
call destroy(Theta)
end if
end subroutine corr_meas_l_mpdo_qtensorc_qtensorc
"""
return
[docs]def destroy_mpdo():
"""
fortran-subroutine - September 2017 (dj)
Deallocate all variables for an MPDO.
**Arguments**
Rho : TYPE(mpdo), inout
MPDO to be deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_mpdo(Rho, errst)
type(mpdo), intent(inout) :: Rho
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call destroy(Rho%Superket)
call destroy(Rho%Sl_local)
call destroy(Rho%Sl_left)
call destroy(Rho%Sl_right)
end subroutine destroy_mpdo
"""
return
[docs]def destroy_mpdoc():
"""
fortran-subroutine - September 2017 (dj)
Deallocate all variables for an MPDO.
**Arguments**
Rho : TYPE(mpdoc), inout
MPDO to be deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_mpdoc(Rho, errst)
type(mpdoc), intent(inout) :: Rho
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call destroy(Rho%Superket)
call destroy(Rho%Sl_local)
call destroy(Rho%Sl_left)
call destroy(Rho%Sl_right)
end subroutine destroy_mpdoc
"""
return
[docs]def destroy_qmpdo():
"""
fortran-subroutine - September 2017 (dj)
Deallocate all variables for an MPDO.
**Arguments**
Rho : TYPE(qmpdo), inout
MPDO to be deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qmpdo(Rho, errst)
type(qmpdo), intent(inout) :: Rho
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call destroy(Rho%Superket)
call destroy(Rho%Sl_local)
call destroy(Rho%Sl_left)
call destroy(Rho%Sl_right)
end subroutine destroy_qmpdo
"""
return
[docs]def destroy_qmpdoc():
"""
fortran-subroutine - September 2017 (dj)
Deallocate all variables for an MPDO.
**Arguments**
Rho : TYPE(qmpdoc), inout
MPDO to be deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qmpdoc(Rho, errst)
type(qmpdoc), intent(inout) :: Rho
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
call destroy(Rho%Superket)
call destroy(Rho%Sl_local)
call destroy(Rho%Sl_left)
call destroy(Rho%Sl_right)
end subroutine destroy_qmpdoc
"""
return
[docs]def distance_mpdo_mps():
"""
fortran-function - September 2017 (dj)
Measure the distance between an MPDO and an MPS.
**Arguments**
Rho : TYPE(mpdo), inout
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_mpdo_mps(Rho, Psi, dist_type, &
errst) result(dist)
type(mpdo), 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
select case(dtype)
case('F')
dist = fidelity(Rho, Psi, errst=errst)
case default
errst = raise_error('distance_mpdo_mps : unkown '//&
'dist_type', 99, errst=errst)
end select
end function distance_mpdo_mps
"""
return
[docs]def distance_mpdo_mpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between an MPDO and an MPS.
**Arguments**
Rho : TYPE(mpdo), inout
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_mpdo_mpsc(Rho, Psi, dist_type, &
errst) result(dist)
type(mpdo), 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
select case(dtype)
case('F')
dist = fidelity(Rho, Psi, errst=errst)
case default
errst = raise_error('distance_mpdo_mpsc : unkown '//&
'dist_type', 99, errst=errst)
end select
end function distance_mpdo_mpsc
"""
return
[docs]def distance_mpdoc_mps():
"""
fortran-function - September 2017 (dj)
Measure the distance between an MPDO and an MPS.
**Arguments**
Rho : TYPE(mpdoc), inout
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_mpdoc_mps(Rho, Psi, dist_type, &
errst) result(dist)
type(mpdoc), 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
select case(dtype)
case('F')
dist = fidelity(Rho, Psi, errst=errst)
case default
errst = raise_error('distance_mpdoc_mps : unkown '//&
'dist_type', 99, errst=errst)
end select
end function distance_mpdoc_mps
"""
return
[docs]def distance_mpdoc_mpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between an MPDO and an MPS.
**Arguments**
Rho : TYPE(mpdoc), inout
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_mpdoc_mpsc(Rho, Psi, dist_type, &
errst) result(dist)
type(mpdoc), 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
select case(dtype)
case('F')
dist = fidelity(Rho, Psi, errst=errst)
case default
errst = raise_error('distance_mpdoc_mpsc : unkown '//&
'dist_type', 99, errst=errst)
end select
end function distance_mpdoc_mpsc
"""
return
[docs]def distance_qmpdo_qmps():
"""
fortran-function - September 2017 (dj)
Measure the distance between an MPDO and an MPS.
**Arguments**
Rho : TYPE(qmpdo), inout
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_qmpdo_qmps(Rho, Psi, dist_type, &
errst) result(dist)
type(qmpdo), 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
select case(dtype)
case('F')
dist = fidelity(Rho, Psi, errst=errst)
case default
errst = raise_error('distance_qmpdo_qmps : unkown '//&
'dist_type', 99, errst=errst)
end select
end function distance_qmpdo_qmps
"""
return
[docs]def distance_qmpdo_qmpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between an MPDO and an MPS.
**Arguments**
Rho : TYPE(qmpdo), inout
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_qmpdo_qmpsc(Rho, Psi, dist_type, &
errst) result(dist)
type(qmpdo), 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
select case(dtype)
case('F')
dist = fidelity(Rho, Psi, errst=errst)
case default
errst = raise_error('distance_qmpdo_qmpsc : unkown '//&
'dist_type', 99, errst=errst)
end select
end function distance_qmpdo_qmpsc
"""
return
[docs]def distance_qmpdoc_qmps():
"""
fortran-function - September 2017 (dj)
Measure the distance between an MPDO and an MPS.
**Arguments**
Rho : TYPE(qmpdoc), inout
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_qmpdoc_qmps(Rho, Psi, dist_type, &
errst) result(dist)
type(qmpdoc), 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
select case(dtype)
case('F')
dist = fidelity(Rho, Psi, errst=errst)
case default
errst = raise_error('distance_qmpdoc_qmps : unkown '//&
'dist_type', 99, errst=errst)
end select
end function distance_qmpdoc_qmps
"""
return
[docs]def distance_qmpdoc_qmpsc():
"""
fortran-function - September 2017 (dj)
Measure the distance between an MPDO and an MPS.
**Arguments**
Rho : TYPE(qmpdoc), inout
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_qmpdoc_qmpsc(Rho, Psi, dist_type, &
errst) result(dist)
type(qmpdoc), 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
select case(dtype)
case('F')
dist = fidelity(Rho, Psi, errst=errst)
case default
errst = raise_error('distance_qmpdoc_qmpsc : unkown '//&
'dist_type', 99, errst=errst)
end select
end function distance_qmpdoc_qmpsc
"""
return
[docs]def fidelity_mpdo_mps():
"""
fortran-function - November 2017 (dj)
Calculate the fidelity between a density matrix (MPDO) :math:`\\rho`
and a pure state :math:`\\sigma` defined as
:math:`Tr \\sqrt{\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`.
**Arguments**
Rho : TYPE(mpdo), in
Density Matrix represented as MPDO for the distance measurement.
Psi : TYPE(mps), in
Pure state in the fidelity measurement represented as MPS.
**Details**
The MPS in converted into an MPDO and we calculate the overlap
between the two superkets. This approach only works for a density matrix
and a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_mpdo_mps(Rho, Psi, errst) result(fid)
type(mpdo), intent(in) :: Rho
type(mps), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
real(KIND=rKind) :: overlap
! MPDO representation for the MPS
type(mpdo) :: Sigma
! Copy of rho for intent(in)
type(mpdo) :: Copy_rho
!if(present(errst)) errst = 0
call copy(Sigma, Psi, Rho%Sl_local, errst=errst)
!if(prop_error('fidelity_mpdo_mps : copy failed.', &
! 'MPDOOps_include.f90:1308', errst=errst)) return
call copy(Copy_rho, Rho, errst=errst)
!if(prop_error('fidelity_mpdo_mps : copy failed.', &
! 'MPDOOps_include.f90:1312', errst=errst)) return
overlap = dot(Sigma%Superket, Copy_rho%Superket, errst=errst)
!if(prop_error('fidelity_mpdo_mps : dot failed.', &
! 'MPDOOps_include.f90:1316', errst=errst)) return
call destroy(Sigma)
call destroy(Copy_rho)
! aimag only works on complex numbers
!!if(aimag(overlap) > 1e-10_rKind) then
!! errst = raise_error('fidelity_mpdo_mps : '//&
!! 'imag part in fidelity.', 99, &
!! 'MPDOOps_include.f90:1325', errst=errst)
!! return
!!end if
fid = real(overlap, KIND=rKind)
end function fidelity_mpdo_mps
"""
return
[docs]def fidelity_mpdo_mpsc():
"""
fortran-function - November 2017 (dj)
Calculate the fidelity between a density matrix (MPDO) :math:`\\rho`
and a pure state :math:`\\sigma` defined as
:math:`Tr \\sqrt{\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`.
**Arguments**
Rho : TYPE(mpdo), in
Density Matrix represented as MPDO for the distance measurement.
Psi : TYPE(mpsc), in
Pure state in the fidelity measurement represented as MPS.
**Details**
The MPS in converted into an MPDO and we calculate the overlap
between the two superkets. This approach only works for a density matrix
and a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_mpdo_mpsc(Rho, Psi, errst) result(fid)
type(mpdo), intent(in) :: Rho
type(mpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
complex(KIND=rKind) :: overlap
! MPDO representation for the MPS
type(mpdoc) :: Sigma
! Copy of rho for intent(in)
type(mpdo) :: Copy_rho
!if(present(errst)) errst = 0
call copy(Sigma, Psi, Rho%Sl_local, errst=errst)
!if(prop_error('fidelity_mpdo_mpsc : copy failed.', &
! 'MPDOOps_include.f90:1308', errst=errst)) return
call copy(Copy_rho, Rho, errst=errst)
!if(prop_error('fidelity_mpdo_mpsc : copy failed.', &
! 'MPDOOps_include.f90:1312', errst=errst)) return
overlap = dot(Sigma%Superket, Copy_rho%Superket, errst=errst)
!if(prop_error('fidelity_mpdo_mpsc : dot failed.', &
! 'MPDOOps_include.f90:1316', errst=errst)) return
call destroy(Sigma)
call destroy(Copy_rho)
! aimag only works on complex numbers
!!if(aimag(overlap) > 1e-10_rKind) then
!! errst = raise_error('fidelity_mpdo_mpsc : '//&
!! 'imag part in fidelity.', 99, &
!! 'MPDOOps_include.f90:1325', errst=errst)
!! return
!!end if
fid = real(overlap, KIND=rKind)
end function fidelity_mpdo_mpsc
"""
return
[docs]def fidelity_mpdoc_mps():
"""
fortran-function - November 2017 (dj)
Calculate the fidelity between a density matrix (MPDO) :math:`\\rho`
and a pure state :math:`\\sigma` defined as
:math:`Tr \\sqrt{\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`.
**Arguments**
Rho : TYPE(mpdoc), in
Density Matrix represented as MPDO for the distance measurement.
Psi : TYPE(mps), in
Pure state in the fidelity measurement represented as MPS.
**Details**
The MPS in converted into an MPDO and we calculate the overlap
between the two superkets. This approach only works for a density matrix
and a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_mpdoc_mps(Rho, Psi, errst) result(fid)
type(mpdoc), intent(in) :: Rho
type(mps), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
complex(KIND=rKind) :: overlap
! MPDO representation for the MPS
type(mpdo) :: Sigma
! Copy of rho for intent(in)
type(mpdoc) :: Copy_rho
!if(present(errst)) errst = 0
call copy(Sigma, Psi, Rho%Sl_local, errst=errst)
!if(prop_error('fidelity_mpdoc_mps : copy failed.', &
! 'MPDOOps_include.f90:1308', errst=errst)) return
call copy(Copy_rho, Rho, errst=errst)
!if(prop_error('fidelity_mpdoc_mps : copy failed.', &
! 'MPDOOps_include.f90:1312', errst=errst)) return
overlap = dot(Sigma%Superket, Copy_rho%Superket, errst=errst)
!if(prop_error('fidelity_mpdoc_mps : dot failed.', &
! 'MPDOOps_include.f90:1316', errst=errst)) return
call destroy(Sigma)
call destroy(Copy_rho)
! aimag only works on complex numbers
!!if(aimag(overlap) > 1e-10_rKind) then
!! errst = raise_error('fidelity_mpdoc_mps : '//&
!! 'imag part in fidelity.', 99, &
!! 'MPDOOps_include.f90:1325', errst=errst)
!! return
!!end if
fid = real(overlap, KIND=rKind)
end function fidelity_mpdoc_mps
"""
return
[docs]def fidelity_mpdoc_mpsc():
"""
fortran-function - November 2017 (dj)
Calculate the fidelity between a density matrix (MPDO) :math:`\\rho`
and a pure state :math:`\\sigma` defined as
:math:`Tr \\sqrt{\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`.
**Arguments**
Rho : TYPE(mpdoc), in
Density Matrix represented as MPDO for the distance measurement.
Psi : TYPE(mpsc), in
Pure state in the fidelity measurement represented as MPS.
**Details**
The MPS in converted into an MPDO and we calculate the overlap
between the two superkets. This approach only works for a density matrix
and a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_mpdoc_mpsc(Rho, Psi, errst) result(fid)
type(mpdoc), intent(in) :: Rho
type(mpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
complex(KIND=rKind) :: overlap
! MPDO representation for the MPS
type(mpdoc) :: Sigma
! Copy of rho for intent(in)
type(mpdoc) :: Copy_rho
!if(present(errst)) errst = 0
call copy(Sigma, Psi, Rho%Sl_local, errst=errst)
!if(prop_error('fidelity_mpdoc_mpsc : copy failed.', &
! 'MPDOOps_include.f90:1308', errst=errst)) return
call copy(Copy_rho, Rho, errst=errst)
!if(prop_error('fidelity_mpdoc_mpsc : copy failed.', &
! 'MPDOOps_include.f90:1312', errst=errst)) return
overlap = dot(Sigma%Superket, Copy_rho%Superket, errst=errst)
!if(prop_error('fidelity_mpdoc_mpsc : dot failed.', &
! 'MPDOOps_include.f90:1316', errst=errst)) return
call destroy(Sigma)
call destroy(Copy_rho)
! aimag only works on complex numbers
!!if(aimag(overlap) > 1e-10_rKind) then
!! errst = raise_error('fidelity_mpdoc_mpsc : '//&
!! 'imag part in fidelity.', 99, &
!! 'MPDOOps_include.f90:1325', errst=errst)
!! return
!!end if
fid = real(overlap, KIND=rKind)
end function fidelity_mpdoc_mpsc
"""
return
[docs]def fidelity_qmpdo_qmps():
"""
fortran-function - November 2017 (dj)
Calculate the fidelity between a density matrix (MPDO) :math:`\\rho`
and a pure state :math:`\\sigma` defined as
:math:`Tr \\sqrt{\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`.
**Arguments**
Rho : TYPE(qmpdo), in
Density Matrix represented as MPDO for the distance measurement.
Psi : TYPE(qmps), in
Pure state in the fidelity measurement represented as MPS.
**Details**
The MPS in converted into an MPDO and we calculate the overlap
between the two superkets. This approach only works for a density matrix
and a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_qmpdo_qmps(Rho, Psi, errst) result(fid)
type(qmpdo), intent(in) :: Rho
type(qmps), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
real(KIND=rKind) :: overlap
! MPDO representation for the MPS
type(qmpdo) :: Sigma
! Copy of rho for intent(in)
type(qmpdo) :: Copy_rho
!if(present(errst)) errst = 0
call copy(Sigma, Psi, Rho%Sl_local, errst=errst)
!if(prop_error('fidelity_qmpdo_qmps : copy failed.', &
! 'MPDOOps_include.f90:1308', errst=errst)) return
call copy(Copy_rho, Rho, errst=errst)
!if(prop_error('fidelity_qmpdo_qmps : copy failed.', &
! 'MPDOOps_include.f90:1312', errst=errst)) return
overlap = dot(Sigma%Superket, Copy_rho%Superket, errst=errst)
!if(prop_error('fidelity_qmpdo_qmps : dot failed.', &
! 'MPDOOps_include.f90:1316', errst=errst)) return
call destroy(Sigma)
call destroy(Copy_rho)
! aimag only works on complex numbers
!!if(aimag(overlap) > 1e-10_rKind) then
!! errst = raise_error('fidelity_qmpdo_qmps : '//&
!! 'imag part in fidelity.', 99, &
!! 'MPDOOps_include.f90:1325', errst=errst)
!! return
!!end if
fid = real(overlap, KIND=rKind)
end function fidelity_qmpdo_qmps
"""
return
[docs]def fidelity_qmpdo_qmpsc():
"""
fortran-function - November 2017 (dj)
Calculate the fidelity between a density matrix (MPDO) :math:`\\rho`
and a pure state :math:`\\sigma` defined as
:math:`Tr \\sqrt{\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`.
**Arguments**
Rho : TYPE(qmpdo), in
Density Matrix represented as MPDO for the distance measurement.
Psi : TYPE(qmpsc), in
Pure state in the fidelity measurement represented as MPS.
**Details**
The MPS in converted into an MPDO and we calculate the overlap
between the two superkets. This approach only works for a density matrix
and a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_qmpdo_qmpsc(Rho, Psi, errst) result(fid)
type(qmpdo), intent(in) :: Rho
type(qmpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
complex(KIND=rKind) :: overlap
! MPDO representation for the MPS
type(qmpdoc) :: Sigma
! Copy of rho for intent(in)
type(qmpdo) :: Copy_rho
!if(present(errst)) errst = 0
call copy(Sigma, Psi, Rho%Sl_local, errst=errst)
!if(prop_error('fidelity_qmpdo_qmpsc : copy failed.', &
! 'MPDOOps_include.f90:1308', errst=errst)) return
call copy(Copy_rho, Rho, errst=errst)
!if(prop_error('fidelity_qmpdo_qmpsc : copy failed.', &
! 'MPDOOps_include.f90:1312', errst=errst)) return
overlap = dot(Sigma%Superket, Copy_rho%Superket, errst=errst)
!if(prop_error('fidelity_qmpdo_qmpsc : dot failed.', &
! 'MPDOOps_include.f90:1316', errst=errst)) return
call destroy(Sigma)
call destroy(Copy_rho)
! aimag only works on complex numbers
!!if(aimag(overlap) > 1e-10_rKind) then
!! errst = raise_error('fidelity_qmpdo_qmpsc : '//&
!! 'imag part in fidelity.', 99, &
!! 'MPDOOps_include.f90:1325', errst=errst)
!! return
!!end if
fid = real(overlap, KIND=rKind)
end function fidelity_qmpdo_qmpsc
"""
return
[docs]def fidelity_qmpdoc_qmps():
"""
fortran-function - November 2017 (dj)
Calculate the fidelity between a density matrix (MPDO) :math:`\\rho`
and a pure state :math:`\\sigma` defined as
:math:`Tr \\sqrt{\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`.
**Arguments**
Rho : TYPE(qmpdoc), in
Density Matrix represented as MPDO for the distance measurement.
Psi : TYPE(qmps), in
Pure state in the fidelity measurement represented as MPS.
**Details**
The MPS in converted into an MPDO and we calculate the overlap
between the two superkets. This approach only works for a density matrix
and a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_qmpdoc_qmps(Rho, Psi, errst) result(fid)
type(qmpdoc), intent(in) :: Rho
type(qmps), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
complex(KIND=rKind) :: overlap
! MPDO representation for the MPS
type(qmpdo) :: Sigma
! Copy of rho for intent(in)
type(qmpdoc) :: Copy_rho
!if(present(errst)) errst = 0
call copy(Sigma, Psi, Rho%Sl_local, errst=errst)
!if(prop_error('fidelity_qmpdoc_qmps : copy failed.', &
! 'MPDOOps_include.f90:1308', errst=errst)) return
call copy(Copy_rho, Rho, errst=errst)
!if(prop_error('fidelity_qmpdoc_qmps : copy failed.', &
! 'MPDOOps_include.f90:1312', errst=errst)) return
overlap = dot(Sigma%Superket, Copy_rho%Superket, errst=errst)
!if(prop_error('fidelity_qmpdoc_qmps : dot failed.', &
! 'MPDOOps_include.f90:1316', errst=errst)) return
call destroy(Sigma)
call destroy(Copy_rho)
! aimag only works on complex numbers
!!if(aimag(overlap) > 1e-10_rKind) then
!! errst = raise_error('fidelity_qmpdoc_qmps : '//&
!! 'imag part in fidelity.', 99, &
!! 'MPDOOps_include.f90:1325', errst=errst)
!! return
!!end if
fid = real(overlap, KIND=rKind)
end function fidelity_qmpdoc_qmps
"""
return
[docs]def fidelity_qmpdoc_qmpsc():
"""
fortran-function - November 2017 (dj)
Calculate the fidelity between a density matrix (MPDO) :math:`\\rho`
and a pure state :math:`\\sigma` defined as
:math:`Tr \\sqrt{\sqrt{\\sigma} \\rho \\sqrt{\\sigma}}`.
**Arguments**
Rho : TYPE(qmpdoc), in
Density Matrix represented as MPDO for the distance measurement.
Psi : TYPE(qmpsc), in
Pure state in the fidelity measurement represented as MPS.
**Details**
The MPS in converted into an MPDO and we calculate the overlap
between the two superkets. This approach only works for a density matrix
and a pure state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function fidelity_qmpdoc_qmpsc(Rho, Psi, errst) result(fid)
type(qmpdoc), intent(in) :: Rho
type(qmpsc), intent(in) :: Psi
integer, intent(out), optional :: errst
real(KIND=rKind) :: fid
! Local variables
! ---------------
complex(KIND=rKind) :: overlap
! MPDO representation for the MPS
type(qmpdoc) :: Sigma
! Copy of rho for intent(in)
type(qmpdoc) :: Copy_rho
!if(present(errst)) errst = 0
call copy(Sigma, Psi, Rho%Sl_local, errst=errst)
!if(prop_error('fidelity_qmpdoc_qmpsc : copy failed.', &
! 'MPDOOps_include.f90:1308', errst=errst)) return
call copy(Copy_rho, Rho, errst=errst)
!if(prop_error('fidelity_qmpdoc_qmpsc : copy failed.', &
! 'MPDOOps_include.f90:1312', errst=errst)) return
overlap = dot(Sigma%Superket, Copy_rho%Superket, errst=errst)
!if(prop_error('fidelity_qmpdoc_qmpsc : dot failed.', &
! 'MPDOOps_include.f90:1316', errst=errst)) return
call destroy(Sigma)
call destroy(Copy_rho)
! aimag only works on complex numbers
!!if(aimag(overlap) > 1e-10_rKind) then
!! errst = raise_error('fidelity_qmpdoc_qmpsc : '//&
!! 'imag part in fidelity.', 99, &
!! 'MPDOOps_include.f90:1325', errst=errst)
!! return
!!end if
fid = real(overlap, KIND=rKind)
end function fidelity_qmpdoc_qmpsc
"""
return
[docs]def meas_mpo_mpdo_mpo():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a MPDO.
**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(mpdo), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_mpdo_mpo(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(mpo) :: Ham
type(mpdo) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! system size
integer :: ll
! Contracting the overlap
type(tensorlist) :: Lmat
!if(present(errst)) errst = 0
ll = Rho%Superket%ll
! Last site
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ll), Ham%Ws(ll), .true., &
Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_mpdo_mpo : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1484', &
! errst=errst)) return
! Looping to the left
do ii = (ll - 1), 1, (-1)
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ii), Ham%Ws(ii), &
.false., Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_mpdo_mpo : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1492', &
! errst=errst)) return
end do
call split(Lmat%Li(1), [Rho%Sl_left], errst=errst)
!if(prop_error('meas_mpo_mpdo_mpo : '//&
! 'split failed.', 'MPDOOps_include.f90:1498', &
! errst=errst)) return
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_mpdo_mpo
"""
return
[docs]def meas_mpo_mpdoc_mpo():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a MPDO.
**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(mpdoc), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_mpdoc_mpo(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(mpo) :: Ham
type(mpdoc) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! system size
integer :: ll
! Contracting the overlap
type(tensorlistc) :: Lmat
!if(present(errst)) errst = 0
ll = Rho%Superket%ll
! Last site
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ll), Ham%Ws(ll), .true., &
Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_mpdoc_mpo : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1484', &
! errst=errst)) return
! Looping to the left
do ii = (ll - 1), 1, (-1)
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ii), Ham%Ws(ii), &
.false., Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_mpdoc_mpo : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1492', &
! errst=errst)) return
end do
call split(Lmat%Li(1), [Rho%Sl_left], errst=errst)
!if(prop_error('meas_mpo_mpdoc_mpo : '//&
! 'split failed.', 'MPDOOps_include.f90:1498', &
! errst=errst)) return
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_mpdoc_mpo
"""
return
[docs]def meas_mpo_mpdoc_mpoc():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a MPDO.
**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(mpdoc), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_mpdoc_mpoc(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(mpoc) :: Ham
type(mpdoc) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! system size
integer :: ll
! Contracting the overlap
type(tensorlistc) :: Lmat
!if(present(errst)) errst = 0
ll = Rho%Superket%ll
! Last site
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ll), Ham%Ws(ll), .true., &
Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_mpdoc_mpoc : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1484', &
! errst=errst)) return
! Looping to the left
do ii = (ll - 1), 1, (-1)
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ii), Ham%Ws(ii), &
.false., Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_mpdoc_mpoc : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1492', &
! errst=errst)) return
end do
call split(Lmat%Li(1), [Rho%Sl_left], errst=errst)
!if(prop_error('meas_mpo_mpdoc_mpoc : '//&
! 'split failed.', 'MPDOOps_include.f90:1498', &
! errst=errst)) return
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_mpdoc_mpoc
"""
return
[docs]def meas_mpo_qmpdo_qmpo():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a MPDO.
**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(qmpdo), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qmpdo_qmpo(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(qmpo) :: Ham
type(qmpdo) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! system size
integer :: ll
! Contracting the overlap
type(qtensorlist) :: Lmat
!if(present(errst)) errst = 0
ll = Rho%Superket%ll
! Last site
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ll), Ham%Ws(ll), .true., &
Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_qmpdo_qmpo : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1484', &
! errst=errst)) return
! Looping to the left
do ii = (ll - 1), 1, (-1)
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ii), Ham%Ws(ii), &
.false., Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_qmpdo_qmpo : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1492', &
! errst=errst)) return
end do
call split(Lmat%Li(1), [Rho%Sl_left], errst=errst)
!if(prop_error('meas_mpo_qmpdo_qmpo : '//&
! 'split failed.', 'MPDOOps_include.f90:1498', &
! errst=errst)) return
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qmpdo_qmpo
"""
return
[docs]def meas_mpo_qmpdoc_qmpo():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a MPDO.
**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(qmpdoc), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qmpdoc_qmpo(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(qmpo) :: Ham
type(qmpdoc) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! system size
integer :: ll
! Contracting the overlap
type(qtensorclist) :: Lmat
!if(present(errst)) errst = 0
ll = Rho%Superket%ll
! Last site
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ll), Ham%Ws(ll), .true., &
Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_qmpdoc_qmpo : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1484', &
! errst=errst)) return
! Looping to the left
do ii = (ll - 1), 1, (-1)
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ii), Ham%Ws(ii), &
.false., Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_qmpdoc_qmpo : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1492', &
! errst=errst)) return
end do
call split(Lmat%Li(1), [Rho%Sl_left], errst=errst)
!if(prop_error('meas_mpo_qmpdoc_qmpo : '//&
! 'split failed.', 'MPDOOps_include.f90:1498', &
! errst=errst)) return
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qmpdoc_qmpo
"""
return
[docs]def meas_mpo_qmpdoc_qmpoc():
"""
fortran-subroutine - November 2017 (dj)
Compute the expectation value of an MPO on a MPDO.
**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(qmpdoc), inout
Measure this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qmpdoc_qmpoc(val, Ham, Rho, errst)
real(KIND=rKind) :: val
type(qmpoc) :: Ham
type(qmpdoc) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! system size
integer :: ll
! Contracting the overlap
type(qtensorclist) :: Lmat
!if(present(errst)) errst = 0
ll = Rho%Superket%ll
! Last site
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ll), Ham%Ws(ll), .true., &
Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_qmpdoc_qmpoc : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1484', &
! errst=errst)) return
! Looping to the left
do ii = (ll - 1), 1, (-1)
call ptm_left_mpo_mpdo(Lmat, Rho%Superket%Aa(ii), Ham%Ws(ii), &
.false., Rho%Sl_right, errst=errst)
!if(prop_error('meas_mpo_qmpdoc_qmpoc : '//&
! 'ptm_left_mpo_mpdo failed.', 'MPDOOps_include.f90:1492', &
! errst=errst)) return
end do
call split(Lmat%Li(1), [Rho%Sl_left], errst=errst)
!if(prop_error('meas_mpo_qmpdoc_qmpoc : '//&
! 'split failed.', 'MPDOOps_include.f90:1498', &
! errst=errst)) return
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qmpdoc_qmpoc
"""
return
[docs]def norm_mpdo():
"""
fortran-function - September 2017 (dj)
Calculate the norm of an MPDO, i.e., the trace.
**Arguments**
Rho : TYPE(mpdo), inout
Calculate the trace of this density matrix.
LR : TYPE(tensorlist), OPTIONAL, inout
If LR and kk given, the overlap can be used to speed-up the
calculation of the norm.
kk : INTEGER, OPTIONAL, in
The center of the LR overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_mpdo(Rho, LR, kk, errst) result(rhonorm)
type(mpdo), intent(inout) :: Rho
type(tensorlist), intent(inout), optional :: LR
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
real(KIND=rKind) :: rhonorm
! Local variables
! ---------------
! for looping
integer :: ii
! tensors for contractions
type(tensor) :: Tmp
! Tensor for overlap
type(tensorlist) :: Lover
if(present(LR) .and. present(kk)) then
! Use given overlap
! -----------------
call rho_kk(Tmp, Rho, LR, kk, errst=errst)
!if(prop_error('norm_mpdo : rho_kk (1) failed.', &
! errst=errst)) return
rhonorm = real(trace(Tmp), KIND=rKind)
call destroy(Tmp)
return
end if
! Have to calculate overlap
! -------------------------
allocate(Lover%Li(2))
do ii = Rho%Superket%ll, 2, (-1)
call ptm_left_mpdo(Lover%Li(2), Rho%Superket%Aa(ii), &
(ii == Rho%Superket%ll), Rho%Sl_local, &
Rho%Sl_right, errst=errst)
!if(prop_error('norm_mpdo : ptm_left_mpdo failed.', &
! errst=errst)) return
end do
call rho_kk(Tmp, Rho, Lover, 1, errst=errst)
!if(prop_error('norm_mpdo : rho_kk (2) failed.', &
! errst=errst)) return
rhonorm = real(trace(Tmp), KIND=rKind)
call destroy(Tmp)
call destroy(Lover%Li(2))
deallocate(Lover%Li)
end function norm_mpdo
"""
return
[docs]def norm_mpdoc():
"""
fortran-function - September 2017 (dj)
Calculate the norm of an MPDO, i.e., the trace.
**Arguments**
Rho : TYPE(mpdoc), inout
Calculate the trace of this density matrix.
LR : TYPE(tensorlistc), OPTIONAL, inout
If LR and kk given, the overlap can be used to speed-up the
calculation of the norm.
kk : INTEGER, OPTIONAL, in
The center of the LR overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_mpdoc(Rho, LR, kk, errst) result(rhonorm)
type(mpdoc), intent(inout) :: Rho
type(tensorlistc), intent(inout), optional :: LR
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
real(KIND=rKind) :: rhonorm
! Local variables
! ---------------
! for looping
integer :: ii
! tensors for contractions
type(tensorc) :: Tmp
! Tensor for overlap
type(tensorlistc) :: Lover
if(present(LR) .and. present(kk)) then
! Use given overlap
! -----------------
call rho_kk(Tmp, Rho, LR, kk, errst=errst)
!if(prop_error('norm_mpdoc : rho_kk (1) failed.', &
! errst=errst)) return
rhonorm = real(trace(Tmp), KIND=rKind)
call destroy(Tmp)
return
end if
! Have to calculate overlap
! -------------------------
allocate(Lover%Li(2))
do ii = Rho%Superket%ll, 2, (-1)
call ptm_left_mpdo(Lover%Li(2), Rho%Superket%Aa(ii), &
(ii == Rho%Superket%ll), Rho%Sl_local, &
Rho%Sl_right, errst=errst)
!if(prop_error('norm_mpdoc : ptm_left_mpdo failed.', &
! errst=errst)) return
end do
call rho_kk(Tmp, Rho, Lover, 1, errst=errst)
!if(prop_error('norm_mpdoc : rho_kk (2) failed.', &
! errst=errst)) return
rhonorm = real(trace(Tmp), KIND=rKind)
call destroy(Tmp)
call destroy(Lover%Li(2))
deallocate(Lover%Li)
end function norm_mpdoc
"""
return
[docs]def norm_qmpdo():
"""
fortran-function - September 2017 (dj)
Calculate the norm of an MPDO, i.e., the trace.
**Arguments**
Rho : TYPE(qmpdo), inout
Calculate the trace of this density matrix.
LR : TYPE(qtensorlist), OPTIONAL, inout
If LR and kk given, the overlap can be used to speed-up the
calculation of the norm.
kk : INTEGER, OPTIONAL, in
The center of the LR overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_qmpdo(Rho, LR, kk, errst) result(rhonorm)
type(qmpdo), intent(inout) :: Rho
type(qtensorlist), intent(inout), optional :: LR
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
real(KIND=rKind) :: rhonorm
! Local variables
! ---------------
! for looping
integer :: ii
! tensors for contractions
type(qtensor) :: Tmp
! Tensor for overlap
type(qtensorlist) :: Lover
if(present(LR) .and. present(kk)) then
! Use given overlap
! -----------------
call rho_kk(Tmp, Rho, LR, kk, errst=errst)
!if(prop_error('norm_qmpdo : rho_kk (1) failed.', &
! errst=errst)) return
rhonorm = real(trace(Tmp), KIND=rKind)
call destroy(Tmp)
return
end if
! Have to calculate overlap
! -------------------------
allocate(Lover%Li(2))
do ii = Rho%Superket%ll, 2, (-1)
call ptm_left_mpdo(Lover%Li(2), Rho%Superket%Aa(ii), &
(ii == Rho%Superket%ll), Rho%Sl_local, &
Rho%Sl_right, errst=errst)
!if(prop_error('norm_qmpdo : ptm_left_mpdo failed.', &
! errst=errst)) return
end do
call rho_kk(Tmp, Rho, Lover, 1, errst=errst)
!if(prop_error('norm_qmpdo : rho_kk (2) failed.', &
! errst=errst)) return
rhonorm = real(trace(Tmp), KIND=rKind)
call destroy(Tmp)
call destroy(Lover%Li(2))
deallocate(Lover%Li)
end function norm_qmpdo
"""
return
[docs]def norm_qmpdoc():
"""
fortran-function - September 2017 (dj)
Calculate the norm of an MPDO, i.e., the trace.
**Arguments**
Rho : TYPE(qmpdoc), inout
Calculate the trace of this density matrix.
LR : TYPE(qtensorclist), OPTIONAL, inout
If LR and kk given, the overlap can be used to speed-up the
calculation of the norm.
kk : INTEGER, OPTIONAL, in
The center of the LR overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_qmpdoc(Rho, LR, kk, errst) result(rhonorm)
type(qmpdoc), intent(inout) :: Rho
type(qtensorclist), intent(inout), optional :: LR
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
real(KIND=rKind) :: rhonorm
! Local variables
! ---------------
! for looping
integer :: ii
! tensors for contractions
type(qtensorc) :: Tmp
! Tensor for overlap
type(qtensorclist) :: Lover
if(present(LR) .and. present(kk)) then
! Use given overlap
! -----------------
call rho_kk(Tmp, Rho, LR, kk, errst=errst)
!if(prop_error('norm_qmpdoc : rho_kk (1) failed.', &
! errst=errst)) return
rhonorm = real(trace(Tmp), KIND=rKind)
call destroy(Tmp)
return
end if
! Have to calculate overlap
! -------------------------
allocate(Lover%Li(2))
do ii = Rho%Superket%ll, 2, (-1)
call ptm_left_mpdo(Lover%Li(2), Rho%Superket%Aa(ii), &
(ii == Rho%Superket%ll), Rho%Sl_local, &
Rho%Sl_right, errst=errst)
!if(prop_error('norm_qmpdoc : ptm_left_mpdo failed.', &
! errst=errst)) return
end do
call rho_kk(Tmp, Rho, Lover, 1, errst=errst)
!if(prop_error('norm_qmpdoc : rho_kk (2) failed.', &
! errst=errst)) return
rhonorm = real(trace(Tmp), KIND=rKind)
call destroy(Tmp)
call destroy(Lover%Li(2))
deallocate(Lover%Li)
end function norm_qmpdoc
"""
return
[docs]def ptm_left_mpdo_tensor():
"""
fortran-subroutine - September 2017 (dj)
Propagation of transfer matrix for MPDO, e.g. necessary for measurements.
This is the left-moving version.
**Arguments**
Mat : TYPE(tensor), inout
On exit, new transfer matrix for the corresponding tensor.
Tranfer matrix is actually a vector for MPDOs.
Tens : TYPE(tensor), inout
Represents the tensor of the corresponding site. It is
a rank-3 tensor.
leftmost : LOGICAL, in
Flag if the rightmost site is built (true), otherwise false.
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
Matin : TYPE(tensor), OPTIONAL, inout
Transfer matrix of the previous site. Only referenced if
not rightmost.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpdo_tensor(Mat, Tens, rightmost, Sl_local, &
Sl_right, Matin, errst)
type(tensor), intent(inout) :: Mat, Tens
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_local, Sl_right
type(tensor), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensor) :: Tmp, Tmp2
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
call copy(Tmp2, Tens)
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_tensor : split (1) '//&
! 'failed.', 'MPDOOps_include.f90:1678', errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_tensor : pcontr (1) '//&
! 'failed.', errst=errst)) return
call split(Tmp, 2, Sl_local, errst=errst)
!if(prop_error('ptm_left_mpdo_tensor : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1686', errst=errst)) return
call pcontr(Mat, Tmp, [2], [3], errst=errst)
!if(prop_error('ptm_left_mpdo_tensor : pcontr (2) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
call destroy(Tmp2)
return
end if
! Real transfer matrix
! --------------------
! Step 1
if(present(Matin)) then
call contr(Tmp, Tens, Matin, [3], [1], errst=errst)
else
call contr(Tmp, Tens, Mat, [3], [1], errst=errst)
end if
!if(prop_error('ptm_left_mpdo_tensor : contr (2) '//&
! 'failed.', errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2
call split(Tmp, 2, Sl_local, errst=errst)
!if(prop_error('ptm_left_mpdo_tensor : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1714', errst=errst)) return
call pcontr(Mat, Tmp, [2], [3], errst=errst)
!if(prop_error('ptm_left_mpdo_tensor : contr (3) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
end subroutine ptm_left_mpdo_tensor
"""
return
[docs]def ptm_left_mpdo_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Propagation of transfer matrix for MPDO, e.g. necessary for measurements.
This is the left-moving version.
**Arguments**
Mat : TYPE(tensorc), inout
On exit, new transfer matrix for the corresponding tensor.
Tranfer matrix is actually a vector for MPDOs.
Tens : TYPE(tensorc), inout
Represents the tensor of the corresponding site. It is
a rank-3 tensor.
leftmost : LOGICAL, in
Flag if the rightmost site is built (true), otherwise false.
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
Matin : TYPE(tensorc), OPTIONAL, inout
Transfer matrix of the previous site. Only referenced if
not rightmost.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpdo_tensorc(Mat, Tens, rightmost, Sl_local, &
Sl_right, Matin, errst)
type(tensorc), intent(inout) :: Mat, Tens
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_local, Sl_right
type(tensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensorc) :: Tmp, Tmp2
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
call copy(Tmp2, Tens)
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc : split (1) '//&
! 'failed.', 'MPDOOps_include.f90:1678', errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc : pcontr (1) '//&
! 'failed.', errst=errst)) return
call split(Tmp, 2, Sl_local, errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1686', errst=errst)) return
call pcontr(Mat, Tmp, [2], [3], errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc : pcontr (2) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
call destroy(Tmp2)
return
end if
! Real transfer matrix
! --------------------
! Step 1
if(present(Matin)) then
call contr(Tmp, Tens, Matin, [3], [1], errst=errst)
else
call contr(Tmp, Tens, Mat, [3], [1], errst=errst)
end if
!if(prop_error('ptm_left_mpdo_tensorc : contr (2) '//&
! 'failed.', errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2
call split(Tmp, 2, Sl_local, errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1714', errst=errst)) return
call pcontr(Mat, Tmp, [2], [3], errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc : contr (3) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
end subroutine ptm_left_mpdo_tensorc
"""
return
[docs]def ptm_left_mpdo_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Propagation of transfer matrix for MPDO, e.g. necessary for measurements.
This is the left-moving version.
**Arguments**
Mat : TYPE(qtensor), inout
On exit, new transfer matrix for the corresponding tensor.
Tranfer matrix is actually a vector for MPDOs.
Tens : TYPE(qtensor), inout
Represents the tensor of the corresponding site. It is
a rank-3 tensor.
leftmost : LOGICAL, in
Flag if the rightmost site is built (true), otherwise false.
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
Matin : TYPE(qtensor), OPTIONAL, inout
Transfer matrix of the previous site. Only referenced if
not rightmost.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpdo_qtensor(Mat, Tens, rightmost, Sl_local, &
Sl_right, Matin, errst)
type(qtensor), intent(inout) :: Mat, Tens
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_local, Sl_right
type(qtensor), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensor) :: Tmp, Tmp2
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
call copy(Tmp2, Tens)
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor : split (1) '//&
! 'failed.', 'MPDOOps_include.f90:1678', errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor : pcontr (1) '//&
! 'failed.', errst=errst)) return
call split(Tmp, 2, Sl_local, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1686', errst=errst)) return
call pcontr(Mat, Tmp, [2], [3], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor : pcontr (2) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
call destroy(Tmp2)
return
end if
! Real transfer matrix
! --------------------
! Step 1
if(present(Matin)) then
call contr(Tmp, Tens, Matin, [3], [1], errst=errst)
else
call contr(Tmp, Tens, Mat, [3], [1], errst=errst)
end if
!if(prop_error('ptm_left_mpdo_qtensor : contr (2) '//&
! 'failed.', errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2
call split(Tmp, 2, Sl_local, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1714', errst=errst)) return
call pcontr(Mat, Tmp, [2], [3], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor : contr (3) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
end subroutine ptm_left_mpdo_qtensor
"""
return
[docs]def ptm_left_mpdo_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Propagation of transfer matrix for MPDO, e.g. necessary for measurements.
This is the left-moving version.
**Arguments**
Mat : TYPE(qtensorc), inout
On exit, new transfer matrix for the corresponding tensor.
Tranfer matrix is actually a vector for MPDOs.
Tens : TYPE(qtensorc), inout
Represents the tensor of the corresponding site. It is
a rank-3 tensor.
leftmost : LOGICAL, in
Flag if the rightmost site is built (true), otherwise false.
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
Matin : TYPE(qtensorc), OPTIONAL, inout
Transfer matrix of the previous site. Only referenced if
not rightmost.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpdo_qtensorc(Mat, Tens, rightmost, Sl_local, &
Sl_right, Matin, errst)
type(qtensorc), intent(inout) :: Mat, Tens
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_local, Sl_right
type(qtensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensorc) :: Tmp, Tmp2
!if(present(errst)) errst = 0
if(rightmost) then
! Initialize
! ----------
call copy(Tmp2, Tens)
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc : split (1) '//&
! 'failed.', 'MPDOOps_include.f90:1678', errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc : pcontr (1) '//&
! 'failed.', errst=errst)) return
call split(Tmp, 2, Sl_local, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1686', errst=errst)) return
call pcontr(Mat, Tmp, [2], [3], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc : pcontr (2) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
call destroy(Tmp2)
return
end if
! Real transfer matrix
! --------------------
! Step 1
if(present(Matin)) then
call contr(Tmp, Tens, Matin, [3], [1], errst=errst)
else
call contr(Tmp, Tens, Mat, [3], [1], errst=errst)
end if
!if(prop_error('ptm_left_mpdo_qtensorc : contr (2) '//&
! 'failed.', errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2
call split(Tmp, 2, Sl_local, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1714', errst=errst)) return
call pcontr(Mat, Tmp, [2], [3], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc : contr (3) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
end subroutine ptm_left_mpdo_qtensorc
"""
return
[docs]def ptm_left_mpo_mpdo_tensor_tensor():
"""
fortran-subroutine - November 2017 (dj)
Build the transfer matrix for a site between a density matrix
represented as MPDO and an MPO.
**Arguments**
Mat : TYPE(tensorlist), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Tenskk : TYPE(tensor), inout
Represents the density matrix of the MPDO on this site.
Hmat : TYPE(tensor), in
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.
Sl_right : TYPE(splitlink), in
Contains the information to split the link to the right of the MPDO.
Matin : TYPE(tensorlist), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if
rightmost is true.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_mpdo_tensor_tensor(Mat, Tenskk, Hmat, &
rightmost, Sl_right, Matin, errst)
type(tensorlist), intent(inout) :: Mat
type(tensor), intent(inout) :: Tenskk
type(sr_matrix_tensor), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_right
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, Tmp2
! indices for fusing operators
integer, dimension(2, 1) :: fidx
!if(present(errst)) errst = 0
fidx(:, 1) = [1, 2]
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call copy(Tmp2, Tenskk)
! -> Close link to the right <-
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_tensor_tensor'//&
! ' : split failed.', 'MPDOOps_include.f90:1823', &
! errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_tensor_tensor'//&
! ' : pcontr failed.', 'MPDOOps_include.f90:1828', &
! errst=errst)) return
call destroy(Tmp2)
! -> Contract MPO matrices <-
do kk = 1, bd
call copy(Tmp2, Hmat%Row(kk)%Op(1))
call transposed(Tmp2)
call fuse(Tmp2, fidx, '0')
call contr(Mat%Li(kk), Tmp, Tmp2, [2], [1], errst=errst)
!if(prop_error('ptm_left_mpdo_tensor_tensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1842', &
! errst=errst)) return
call destroy(Tmp2)
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with tensor of the site
! -------------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tens(ii), Tenskk, Matin%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_tensor_tensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1864', &
! errst=errst)) return
end do
else
do ii = 1, bd
call contr(Tens(ii), Tenskk, Mat%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_tensor_tensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1873', &
! errst=errst)) return
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_mpdo(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpdo_tensor_tensor'//&
! ' : contrmpol_mpdo failed.', 'MPDOOps_include.f90:1891', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_mpdo_tensor_tensor
"""
return
[docs]def ptm_left_mpo_mpdo_tensorc_tensor():
"""
fortran-subroutine - November 2017 (dj)
Build the transfer matrix for a site between a density matrix
represented as MPDO and an MPO.
**Arguments**
Mat : TYPE(tensorlistc), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Tenskk : TYPE(tensorc), inout
Represents the density matrix of the MPDO on this site.
Hmat : TYPE(tensorc), in
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.
Sl_right : TYPE(splitlink), in
Contains the information to split the link to the right of the MPDO.
Matin : TYPE(tensorlistc), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if
rightmost is true.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_mpdo_tensorc_tensor(Mat, Tenskk, Hmat, &
rightmost, Sl_right, Matin, errst)
type(tensorlistc), intent(inout) :: Mat
type(tensorc), intent(inout) :: Tenskk
type(sr_matrix_tensor), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_right
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, Tmp2
! indices for fusing operators
integer, dimension(2, 1) :: fidx
!if(present(errst)) errst = 0
fidx(:, 1) = [1, 2]
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call copy(Tmp2, Tenskk)
! -> Close link to the right <-
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensor'//&
! ' : split failed.', 'MPDOOps_include.f90:1823', &
! errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensor'//&
! ' : pcontr failed.', 'MPDOOps_include.f90:1828', &
! errst=errst)) return
call destroy(Tmp2)
! -> Contract MPO matrices <-
do kk = 1, bd
call copy(Tmp2, Hmat%Row(kk)%Op(1))
call transposed(Tmp2)
call fuse(Tmp2, fidx, '0')
call contr(Mat%Li(kk), Tmp, Tmp2, [2], [1], errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1842', &
! errst=errst)) return
call destroy(Tmp2)
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with tensor of the site
! -------------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tens(ii), Tenskk, Matin%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1864', &
! errst=errst)) return
end do
else
do ii = 1, bd
call contr(Tens(ii), Tenskk, Mat%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1873', &
! errst=errst)) return
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_mpdo(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensor'//&
! ' : contrmpol_mpdo failed.', 'MPDOOps_include.f90:1891', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_mpdo_tensorc_tensor
"""
return
[docs]def ptm_left_mpo_mpdo_tensorc_tensorc():
"""
fortran-subroutine - November 2017 (dj)
Build the transfer matrix for a site between a density matrix
represented as MPDO and an MPO.
**Arguments**
Mat : TYPE(tensorlistc), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Tenskk : TYPE(tensorc), inout
Represents the density matrix of the MPDO on this site.
Hmat : TYPE(tensorc), in
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.
Sl_right : TYPE(splitlink), in
Contains the information to split the link to the right of the MPDO.
Matin : TYPE(tensorlistc), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if
rightmost is true.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_mpdo_tensorc_tensorc(Mat, Tenskk, Hmat, &
rightmost, Sl_right, Matin, errst)
type(tensorlistc), intent(inout) :: Mat
type(tensorc), intent(inout) :: Tenskk
type(sr_matrix_tensorc), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_right
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, Tmp2
! indices for fusing operators
integer, dimension(2, 1) :: fidx
!if(present(errst)) errst = 0
fidx(:, 1) = [1, 2]
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call copy(Tmp2, Tenskk)
! -> Close link to the right <-
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensorc'//&
! ' : split failed.', 'MPDOOps_include.f90:1823', &
! errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensorc'//&
! ' : pcontr failed.', 'MPDOOps_include.f90:1828', &
! errst=errst)) return
call destroy(Tmp2)
! -> Contract MPO matrices <-
do kk = 1, bd
call copy(Tmp2, Hmat%Row(kk)%Op(1))
call transposed(Tmp2)
call fuse(Tmp2, fidx, '0')
call contr(Mat%Li(kk), Tmp, Tmp2, [2], [1], errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensorc'//&
! ' : contr failed.', 'MPDOOps_include.f90:1842', &
! errst=errst)) return
call destroy(Tmp2)
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with tensor of the site
! -------------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tens(ii), Tenskk, Matin%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensorc'//&
! ' : contr failed.', 'MPDOOps_include.f90:1864', &
! errst=errst)) return
end do
else
do ii = 1, bd
call contr(Tens(ii), Tenskk, Mat%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensorc'//&
! ' : contr failed.', 'MPDOOps_include.f90:1873', &
! errst=errst)) return
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_mpdo(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpdo_tensorc_tensorc'//&
! ' : contrmpol_mpdo failed.', 'MPDOOps_include.f90:1891', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_mpdo_tensorc_tensorc
"""
return
[docs]def ptm_left_mpo_mpdo_qtensor_qtensor():
"""
fortran-subroutine - November 2017 (dj)
Build the transfer matrix for a site between a density matrix
represented as MPDO and an MPO.
**Arguments**
Mat : TYPE(qtensorlist), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Tenskk : TYPE(qtensor), inout
Represents the density matrix of the MPDO on this site.
Hmat : TYPE(qtensor), in
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.
Sl_right : TYPE(splitlink), in
Contains the information to split the link to the right of the MPDO.
Matin : TYPE(qtensorlist), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if
rightmost is true.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_mpdo_qtensor_qtensor(Mat, Tenskk, Hmat, &
rightmost, Sl_right, Matin, errst)
type(qtensorlist), intent(inout) :: Mat
type(qtensor), intent(inout) :: Tenskk
type(sr_matrix_qtensor), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_right
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, Tmp2
! indices for fusing operators
integer, dimension(2, 1) :: fidx
!if(present(errst)) errst = 0
fidx(:, 1) = [1, 2]
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call copy(Tmp2, Tenskk)
! -> Close link to the right <-
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor_qtensor'//&
! ' : split failed.', 'MPDOOps_include.f90:1823', &
! errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor_qtensor'//&
! ' : pcontr failed.', 'MPDOOps_include.f90:1828', &
! errst=errst)) return
call destroy(Tmp2)
! -> Contract MPO matrices <-
do kk = 1, bd
call copy(Tmp2, Hmat%Row(kk)%Op(1))
call transposed(Tmp2)
call fuse(Tmp2, fidx, '0')
call contr(Mat%Li(kk), Tmp, Tmp2, [2], [1], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor_qtensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1842', &
! errst=errst)) return
call destroy(Tmp2)
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with tensor of the site
! -------------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tens(ii), Tenskk, Matin%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor_qtensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1864', &
! errst=errst)) return
end do
else
do ii = 1, bd
call contr(Tens(ii), Tenskk, Mat%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor_qtensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1873', &
! errst=errst)) return
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_mpdo(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensor_qtensor'//&
! ' : contrmpol_mpdo failed.', 'MPDOOps_include.f90:1891', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_mpdo_qtensor_qtensor
"""
return
[docs]def ptm_left_mpo_mpdo_qtensorc_qtensor():
"""
fortran-subroutine - November 2017 (dj)
Build the transfer matrix for a site between a density matrix
represented as MPDO and an MPO.
**Arguments**
Mat : TYPE(qtensorclist), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Tenskk : TYPE(qtensorc), inout
Represents the density matrix of the MPDO on this site.
Hmat : TYPE(qtensorc), in
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.
Sl_right : TYPE(splitlink), in
Contains the information to split the link to the right of the MPDO.
Matin : TYPE(qtensorclist), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if
rightmost is true.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_mpdo_qtensorc_qtensor(Mat, Tenskk, Hmat, &
rightmost, Sl_right, Matin, errst)
type(qtensorclist), intent(inout) :: Mat
type(qtensorc), intent(inout) :: Tenskk
type(sr_matrix_qtensor), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_right
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, Tmp2
! indices for fusing operators
integer, dimension(2, 1) :: fidx
!if(present(errst)) errst = 0
fidx(:, 1) = [1, 2]
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call copy(Tmp2, Tenskk)
! -> Close link to the right <-
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensor'//&
! ' : split failed.', 'MPDOOps_include.f90:1823', &
! errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensor'//&
! ' : pcontr failed.', 'MPDOOps_include.f90:1828', &
! errst=errst)) return
call destroy(Tmp2)
! -> Contract MPO matrices <-
do kk = 1, bd
call copy(Tmp2, Hmat%Row(kk)%Op(1))
call transposed(Tmp2)
call fuse(Tmp2, fidx, '0')
call contr(Mat%Li(kk), Tmp, Tmp2, [2], [1], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1842', &
! errst=errst)) return
call destroy(Tmp2)
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with tensor of the site
! -------------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tens(ii), Tenskk, Matin%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1864', &
! errst=errst)) return
end do
else
do ii = 1, bd
call contr(Tens(ii), Tenskk, Mat%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensor'//&
! ' : contr failed.', 'MPDOOps_include.f90:1873', &
! errst=errst)) return
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_mpdo(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensor'//&
! ' : contrmpol_mpdo failed.', 'MPDOOps_include.f90:1891', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_mpdo_qtensorc_qtensor
"""
return
[docs]def ptm_left_mpo_mpdo_qtensorc_qtensorc():
"""
fortran-subroutine - November 2017 (dj)
Build the transfer matrix for a site between a density matrix
represented as MPDO and an MPO.
**Arguments**
Mat : TYPE(qtensorclist), inout
On exit, new transfer matrix. If 'Matin' is not given, this is treated
as incoming transfer matrix.
Tenskk : TYPE(qtensorc), inout
Represents the density matrix of the MPDO on this site.
Hmat : TYPE(qtensorc), in
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.
Sl_right : TYPE(splitlink), in
Contains the information to split the link to the right of the MPDO.
Matin : TYPE(qtensorclist), OPTIONAL, in
Transfer matrix of the site to the right. Not referenced if
rightmost is true.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_left_mpo_mpdo_qtensorc_qtensorc(Mat, Tenskk, Hmat, &
rightmost, Sl_right, Matin, errst)
type(qtensorclist), intent(inout) :: Mat
type(qtensorc), intent(inout) :: Tenskk
type(sr_matrix_qtensorc), intent(inout) :: Hmat
logical, intent(in) :: rightmost
type(splitlink), intent(in) :: Sl_right
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, Tmp2
! indices for fusing operators
integer, dimension(2, 1) :: fidx
!if(present(errst)) errst = 0
fidx(:, 1) = [1, 2]
if(rightmost) then
! Initialize
! ----------
bd = Hmat%rbd
allocate(Mat%Li(bd))
call copy(Tmp2, Tenskk)
! -> Close link to the right <-
call split(Tmp2, 3, Sl_right, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensorc'//&
! ' : split failed.', 'MPDOOps_include.f90:1823', &
! errst=errst)) return
call pcontr(Tmp, Tmp2, [3], [4], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensorc'//&
! ' : pcontr failed.', 'MPDOOps_include.f90:1828', &
! errst=errst)) return
call destroy(Tmp2)
! -> Contract MPO matrices <-
do kk = 1, bd
call copy(Tmp2, Hmat%Row(kk)%Op(1))
call transposed(Tmp2)
call fuse(Tmp2, fidx, '0')
call contr(Mat%Li(kk), Tmp, Tmp2, [2], [1], errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensorc'//&
! ' : contr failed.', 'MPDOOps_include.f90:1842', &
! errst=errst)) return
call destroy(Tmp2)
end do
call destroy(Tmp)
return
end if
! 1) Contract transfer matrix Mat with tensor of the site
! -------------------------------------------------------
bd = Hmat%cbd
allocate(Tens(bd))
if(present(Matin)) then
do ii = 1, bd
call contr(Tens(ii), Tenskk, Matin%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensorc'//&
! ' : contr failed.', 'MPDOOps_include.f90:1864', &
! errst=errst)) return
end do
else
do ii = 1, bd
call contr(Tens(ii), Tenskk, Mat%Li(ii), [3], [1], &
errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensorc'//&
! ' : contr failed.', 'MPDOOps_include.f90:1873', &
! errst=errst)) return
call destroy(Mat%Li(ii))
end do
deallocate(Mat%Li)
end if
! 2) Contract MPO to final tensor
! -------------------------------
bd = Hmat%rbd
allocate(Mat%Li(bd))
do kk = 1, bd
call contractmpol_mpdo(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
!if(prop_error('ptm_left_mpdo_qtensorc_qtensorc'//&
! ' : contrmpol_mpdo failed.', 'MPDOOps_include.f90:1891', &
! errst=errst)) return
end do
do kk = 1, Hmat%cbd
call destroy(Tens(kk))
end do
deallocate(Tens)
end subroutine ptm_left_mpo_mpdo_qtensorc_qtensorc
"""
return
[docs]def ptm_right_mpdo_tensor():
"""
fortran-subroutine - September 2017 (dj)
Propagation of transfer matrix for MPDO, e.g. necessary for measurements.
This is the right-moving version.
**Arguments**
Mat : TYPE(tensor), inout
On exit, new transfer matrix for the corresponding tensor.
Tranfer matrix is actually a vector for MPDOs.
Tens : TYPE(tensor), inout
Represents the tensor of the corresponding site. It is
a rank-3 tensor.
leftmost : LOGICAL, in
Flag if the leftmost site is built (true), otherwise false.
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
Matin : TYPE(tensor), OPTIONAL, inout
Transfer matrix of the previous site. Only referenced if
not leftmost.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_mpdo_tensor(Mat, Tens, leftmost, Sl_local, &
Sl_left, Matin, errst)
type(tensor), intent(inout) :: Mat, Tens
logical, intent(in) :: leftmost
type(splitlink), intent(in) :: Sl_local, Sl_left
type(tensor), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensor) :: Tmp, Tmp2
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call copy(Tmp2, Tens)
call split(Tmp2, 1, Sl_left, errst=errst)
!if(prop_error('ptm_right_mpdo_tensor : split (1) '//&
! 'failed.', 'MPDOOps_include.f90:1981', errst=errst)) return
call pcontr(Tmp, Tmp2, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_tensor : pcontr (1) '//&
! 'failed.', errst=errst)) return
call split(Tmp, 1, Sl_local, errst=errst)
!if(prop_error('ptm_right_mpdo_tensor : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1989', errst=errst)) return
call pcontr(Mat, Tmp, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_tensor : contr (2) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
call destroy(Tmp2)
return
end if
! Real transfer matrix
! --------------------
! Step 1:
if(present(Matin)) then
call contr(Tmp, Matin, Tens, [1], [1], errst=errst)
else
call contr(Tmp, Mat, Tens, [1], [1], errst=errst)
end if
!if(prop_error('ptm_right_mpdo_tensor : contr (1) '//&
! 'failed.', errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2
call split(Tmp, 1, Sl_local, errst=errst)
!if(prop_error('ptm_right_mpdo_tensor : split (3) '//&
! 'failed.', 'MPDOOps_include.f90:2017', errst=errst)) return
call pcontr(Mat, Tmp, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_tensor : pcontr (3) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
end subroutine ptm_right_mpdo_tensor
"""
return
[docs]def ptm_right_mpdo_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Propagation of transfer matrix for MPDO, e.g. necessary for measurements.
This is the right-moving version.
**Arguments**
Mat : TYPE(tensorc), inout
On exit, new transfer matrix for the corresponding tensor.
Tranfer matrix is actually a vector for MPDOs.
Tens : TYPE(tensorc), inout
Represents the tensor of the corresponding site. It is
a rank-3 tensor.
leftmost : LOGICAL, in
Flag if the leftmost site is built (true), otherwise false.
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
Matin : TYPE(tensorc), OPTIONAL, inout
Transfer matrix of the previous site. Only referenced if
not leftmost.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_mpdo_tensorc(Mat, Tens, leftmost, Sl_local, &
Sl_left, Matin, errst)
type(tensorc), intent(inout) :: Mat, Tens
logical, intent(in) :: leftmost
type(splitlink), intent(in) :: Sl_local, Sl_left
type(tensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(tensorc) :: Tmp, Tmp2
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call copy(Tmp2, Tens)
call split(Tmp2, 1, Sl_left, errst=errst)
!if(prop_error('ptm_right_mpdo_tensorc : split (1) '//&
! 'failed.', 'MPDOOps_include.f90:1981', errst=errst)) return
call pcontr(Tmp, Tmp2, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_tensorc : pcontr (1) '//&
! 'failed.', errst=errst)) return
call split(Tmp, 1, Sl_local, errst=errst)
!if(prop_error('ptm_right_mpdo_tensorc : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1989', errst=errst)) return
call pcontr(Mat, Tmp, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_tensorc : contr (2) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
call destroy(Tmp2)
return
end if
! Real transfer matrix
! --------------------
! Step 1:
if(present(Matin)) then
call contr(Tmp, Matin, Tens, [1], [1], errst=errst)
else
call contr(Tmp, Mat, Tens, [1], [1], errst=errst)
end if
!if(prop_error('ptm_right_mpdo_tensorc : contr (1) '//&
! 'failed.', errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2
call split(Tmp, 1, Sl_local, errst=errst)
!if(prop_error('ptm_right_mpdo_tensorc : split (3) '//&
! 'failed.', 'MPDOOps_include.f90:2017', errst=errst)) return
call pcontr(Mat, Tmp, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_tensorc : pcontr (3) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
end subroutine ptm_right_mpdo_tensorc
"""
return
[docs]def ptm_right_mpdo_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Propagation of transfer matrix for MPDO, e.g. necessary for measurements.
This is the right-moving version.
**Arguments**
Mat : TYPE(qtensor), inout
On exit, new transfer matrix for the corresponding tensor.
Tranfer matrix is actually a vector for MPDOs.
Tens : TYPE(qtensor), inout
Represents the tensor of the corresponding site. It is
a rank-3 tensor.
leftmost : LOGICAL, in
Flag if the leftmost site is built (true), otherwise false.
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
Matin : TYPE(qtensor), OPTIONAL, inout
Transfer matrix of the previous site. Only referenced if
not leftmost.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_mpdo_qtensor(Mat, Tens, leftmost, Sl_local, &
Sl_left, Matin, errst)
type(qtensor), intent(inout) :: Mat, Tens
logical, intent(in) :: leftmost
type(splitlink), intent(in) :: Sl_local, Sl_left
type(qtensor), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensor) :: Tmp, Tmp2
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call copy(Tmp2, Tens)
call split(Tmp2, 1, Sl_left, errst=errst)
!if(prop_error('ptm_right_mpdo_qtensor : split (1) '//&
! 'failed.', 'MPDOOps_include.f90:1981', errst=errst)) return
call pcontr(Tmp, Tmp2, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_qtensor : pcontr (1) '//&
! 'failed.', errst=errst)) return
call split(Tmp, 1, Sl_local, errst=errst)
!if(prop_error('ptm_right_mpdo_qtensor : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1989', errst=errst)) return
call pcontr(Mat, Tmp, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_qtensor : contr (2) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
call destroy(Tmp2)
return
end if
! Real transfer matrix
! --------------------
! Step 1:
if(present(Matin)) then
call contr(Tmp, Matin, Tens, [1], [1], errst=errst)
else
call contr(Tmp, Mat, Tens, [1], [1], errst=errst)
end if
!if(prop_error('ptm_right_mpdo_qtensor : contr (1) '//&
! 'failed.', errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2
call split(Tmp, 1, Sl_local, errst=errst)
!if(prop_error('ptm_right_mpdo_qtensor : split (3) '//&
! 'failed.', 'MPDOOps_include.f90:2017', errst=errst)) return
call pcontr(Mat, Tmp, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_qtensor : pcontr (3) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
end subroutine ptm_right_mpdo_qtensor
"""
return
[docs]def ptm_right_mpdo_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Propagation of transfer matrix for MPDO, e.g. necessary for measurements.
This is the right-moving version.
**Arguments**
Mat : TYPE(qtensorc), inout
On exit, new transfer matrix for the corresponding tensor.
Tranfer matrix is actually a vector for MPDOs.
Tens : TYPE(qtensorc), inout
Represents the tensor of the corresponding site. It is
a rank-3 tensor.
leftmost : LOGICAL, in
Flag if the leftmost site is built (true), otherwise false.
Sl_local : TYPE(splitlink), in
Information how to split the local Hilbert space of the MPDO
back into the (MPS) local Hilbert space.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
Matin : TYPE(qtensorc), OPTIONAL, inout
Transfer matrix of the previous site. Only referenced if
not leftmost.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine ptm_right_mpdo_qtensorc(Mat, Tens, leftmost, Sl_local, &
Sl_left, Matin, errst)
type(qtensorc), intent(inout) :: Mat, Tens
logical, intent(in) :: leftmost
type(splitlink), intent(in) :: Sl_local, Sl_left
type(qtensorc), intent(inout), optional :: Matin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor for contraction
type(qtensorc) :: Tmp, Tmp2
!if(present(errst)) errst = 0
if(leftmost) then
! Initialize
! ----------
call copy(Tmp2, Tens)
call split(Tmp2, 1, Sl_left, errst=errst)
!if(prop_error('ptm_right_mpdo_qtensorc : split (1) '//&
! 'failed.', 'MPDOOps_include.f90:1981', errst=errst)) return
call pcontr(Tmp, Tmp2, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_qtensorc : pcontr (1) '//&
! 'failed.', errst=errst)) return
call split(Tmp, 1, Sl_local, errst=errst)
!if(prop_error('ptm_right_mpdo_qtensorc : split (2) '//&
! 'failed.', 'MPDOOps_include.f90:1989', errst=errst)) return
call pcontr(Mat, Tmp, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_qtensorc : contr (2) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
call destroy(Tmp2)
return
end if
! Real transfer matrix
! --------------------
! Step 1:
if(present(Matin)) then
call contr(Tmp, Matin, Tens, [1], [1], errst=errst)
else
call contr(Tmp, Mat, Tens, [1], [1], errst=errst)
end if
!if(prop_error('ptm_right_mpdo_qtensorc : contr (1) '//&
! 'failed.', errst=errst)) return
if(.not. present(Matin)) call destroy(Mat)
! Step 2
call split(Tmp, 1, Sl_local, errst=errst)
!if(prop_error('ptm_right_mpdo_qtensorc : split (3) '//&
! 'failed.', 'MPDOOps_include.f90:2017', errst=errst)) return
call pcontr(Mat, Tmp, [1], [2], errst=errst)
!if(prop_error('ptm_right_mpdo_qtensorc : pcontr (3) '//&
! 'failed.', errst=errst)) return
call destroy(Tmp)
end subroutine ptm_right_mpdo_qtensorc
"""
return
[docs]def purity_mpdo():
"""
fortran-function - September 2017 (dj)
Calculate the purity of a MPDO.
**Arguments**
Rho : TYPE(mpdo), in
Calculate purity of this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function purity_mpdo(Rho, errst) result(pur)
type(mpdo), intent(inout) :: Rho
integer, intent(out), optional :: errst
real(KIND=rKind) :: pur
! No local variables
! ------------------
!if(present(errst)) errst = 0
pur = norm(Rho%Superket)
end function purity_mpdo
"""
return
[docs]def purity_mpdoc():
"""
fortran-function - September 2017 (dj)
Calculate the purity of a MPDO.
**Arguments**
Rho : TYPE(mpdoc), in
Calculate purity of this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function purity_mpdoc(Rho, errst) result(pur)
type(mpdoc), intent(inout) :: Rho
integer, intent(out), optional :: errst
real(KIND=rKind) :: pur
! No local variables
! ------------------
!if(present(errst)) errst = 0
pur = norm(Rho%Superket)
end function purity_mpdoc
"""
return
[docs]def purity_qmpdo():
"""
fortran-function - September 2017 (dj)
Calculate the purity of a MPDO.
**Arguments**
Rho : TYPE(qmpdo), in
Calculate purity of this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function purity_qmpdo(Rho, errst) result(pur)
type(qmpdo), intent(inout) :: Rho
integer, intent(out), optional :: errst
real(KIND=rKind) :: pur
! No local variables
! ------------------
!if(present(errst)) errst = 0
pur = norm(Rho%Superket)
end function purity_qmpdo
"""
return
[docs]def purity_qmpdoc():
"""
fortran-function - September 2017 (dj)
Calculate the purity of a MPDO.
**Arguments**
Rho : TYPE(qmpdoc), in
Calculate purity of this density matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function purity_qmpdoc(Rho, errst) result(pur)
type(qmpdoc), intent(inout) :: Rho
integer, intent(out), optional :: errst
real(KIND=rKind) :: pur
! No local variables
! ------------------
!if(present(errst)) errst = 0
pur = norm(Rho%Superket)
end function purity_qmpdoc
"""
return
[docs]def read_mpdo():
"""
fortran-subroutine - September 2017 (dj)
Read an MPDO given a filename and a unit (assuming you know the type already).
**Arguments**
Rho : TYPE(mpdo), in
Read MPDO in file to this MPDO
flnm : CHARACTER(100), in
the MPDO 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
MPDO in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read MPDO; 1 : type of MPDO does not correspond type of the MPDO
in the file (only checked for skip1st2=false).
**Details**
Currently, it is just reading in the Superket-MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_mpdo(Rho, flnm, unit, form, skip, errst)
type(mpdo), 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 MPDO
logical :: is_real, is_q
! duplette for optional arguments
logical :: skip_
!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_mpdo: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
call read(Rho%Superket, flnm, unit, form, skip=.true., closeunit=.false.)
! Read all splitlinks
call read(Rho%Sl_left, unit, form)
call read(Rho%Sl_right, unit, form)
call read(Rho%Sl_local, unit, form)
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_mpdo: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
call read(Rho%Superket, flnm, unit, form, skip=.true., closeunit=.false.)
! Read all the splitlinks
call read(Rho%Sl_left, unit, form)
call read(Rho%Sl_right, unit, form)
call read(Rho%Sl_local, unit, form)
else
!errst = raise_error('read_mpdo: unallowed formatting.', &
! 99, errst=errst)
return
end if
close(unit)
end subroutine read_mpdo
"""
return
[docs]def read_mpdoc():
"""
fortran-subroutine - September 2017 (dj)
Read an MPDO given a filename and a unit (assuming you know the type already).
**Arguments**
Rho : TYPE(mpdoc), in
Read MPDO in file to this MPDO
flnm : CHARACTER(100), in
the MPDO 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
MPDO in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read MPDO; 1 : type of MPDO does not correspond type of the MPDO
in the file (only checked for skip1st2=false).
**Details**
Currently, it is just reading in the Superket-MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_mpdoc(Rho, flnm, unit, form, skip, errst)
type(mpdoc), 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 MPDO
logical :: is_real, is_q
! duplette for optional arguments
logical :: skip_
!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_mpdoc: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
call read(Rho%Superket, flnm, unit, form, skip=.true., closeunit=.false.)
! Read all splitlinks
call read(Rho%Sl_left, unit, form)
call read(Rho%Sl_right, unit, form)
call read(Rho%Sl_local, unit, form)
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_mpdoc: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
call read(Rho%Superket, flnm, unit, form, skip=.true., closeunit=.false.)
! Read all the splitlinks
call read(Rho%Sl_left, unit, form)
call read(Rho%Sl_right, unit, form)
call read(Rho%Sl_local, unit, form)
else
!errst = raise_error('read_mpdoc: unallowed formatting.', &
! 99, errst=errst)
return
end if
close(unit)
end subroutine read_mpdoc
"""
return
[docs]def read_qmpdo():
"""
fortran-subroutine - September 2017 (dj)
Read an MPDO given a filename and a unit (assuming you know the type already).
**Arguments**
Rho : TYPE(qmpdo), in
Read MPDO in file to this MPDO
flnm : CHARACTER(100), in
the MPDO 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
MPDO in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read MPDO; 1 : type of MPDO does not correspond type of the MPDO
in the file (only checked for skip1st2=false).
**Details**
Currently, it is just reading in the Superket-MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qmpdo(Rho, flnm, unit, form, skip, errst)
type(qmpdo), 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 MPDO
logical :: is_real, is_q
! duplette for optional arguments
logical :: skip_
!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_qmpdo: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
call read(Rho%Superket, flnm, unit, form, skip=.true., closeunit=.false.)
! Read all splitlinks
call read(Rho%Sl_left, unit, form)
call read(Rho%Sl_right, unit, form)
call read(Rho%Sl_local, unit, form)
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_qmpdo: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
call read(Rho%Superket, flnm, unit, form, skip=.true., closeunit=.false.)
! Read all the splitlinks
call read(Rho%Sl_left, unit, form)
call read(Rho%Sl_right, unit, form)
call read(Rho%Sl_local, unit, form)
else
!errst = raise_error('read_qmpdo: unallowed formatting.', &
! 99, errst=errst)
return
end if
close(unit)
end subroutine read_qmpdo
"""
return
[docs]def read_qmpdoc():
"""
fortran-subroutine - September 2017 (dj)
Read an MPDO given a filename and a unit (assuming you know the type already).
**Arguments**
Rho : TYPE(qmpdoc), in
Read MPDO in file to this MPDO
flnm : CHARACTER(100), in
the MPDO 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
MPDO in the file, real/complex, no symm/symmetries).
Default to .false.
errflag : INTEGER, out
0 : could read MPDO; 1 : type of MPDO does not correspond type of the MPDO
in the file (only checked for skip1st2=false).
**Details**
Currently, it is just reading in the Superket-MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qmpdoc(Rho, flnm, unit, form, skip, errst)
type(qmpdoc), 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 MPDO
logical :: is_real, is_q
! duplette for optional arguments
logical :: skip_
!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_qmpdoc: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
call read(Rho%Superket, flnm, unit, form, skip=.true., closeunit=.false.)
! Read all splitlinks
call read(Rho%Sl_left, unit, form)
call read(Rho%Sl_right, unit, form)
call read(Rho%Sl_local, unit, form)
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_qmpdoc: type mismatch.', &
! 99, errst=errst)
return
end if
!else
! Assume the user knows what he is doing and everything is ok.
end if
call read(Rho%Superket, flnm, unit, form, skip=.true., closeunit=.false.)
! Read all the splitlinks
call read(Rho%Sl_left, unit, form)
call read(Rho%Sl_right, unit, form)
call read(Rho%Sl_local, unit, form)
else
!errst = raise_error('read_qmpdoc: unallowed formatting.', &
! 99, errst=errst)
return
end if
close(unit)
end subroutine read_qmpdoc
"""
return
[docs]def rho_kk_mpdo():
"""
fortran-subroutine - September 2017 (dj)
Calculate the single-site reduced density matrix for an MPDO.
**Arguments**
Rhokk : TYPE(tensor), out
On exit, the reduced density matrix on site kk of the
density matrix.
Rho : TYPE(mpdo), out
The complete density matrix represented as MPDO.
LR : TYPE(tensorlist), out
The overlaps of the MPDO. They are needed, as their is no
gauge useful for calculating the reduced density matrices.
kk : INTEGER, out
Calculate reduced density matrix for this site. Must be
the center of the LR overlaps.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_kk_mpdo(Rhokk, Rho, LR, kk, errst)
type(tensor), intent(out) :: Rhokk
type(mpdo), intent(inout) :: Rho
type(tensorlist), intent(inout) :: LR
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor needed for permutation
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
call contr(Tmpa, LR%Li(kk - 1), Rho%Superket%Aa(kk), [1], [1], &
errst=errst)
!if(prop_error('rho_kk_mpdo : contr (1) failed.', &
! errst=errst)) return
else
call copy(Tmpb, Rho%Superket%Aa(kk))
call split(Tmpb, 1, Rho%Sl_left, errst=errst)
!if(prop_error('rho_kk_mpdo : split (1) failed.', &
! 'MPDOOps_include.f90:2280', errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('rho_kk_mpdo : pcontr (1) failed.', &
! errst=errst)) return
call destroy(Tmpb)
end if
if(kk < Rho%Superket%ll) then
call contr(Rhokk, Tmpa, LR%Li(kk + 1), [2], [1])
!if(prop_error('rho_kk_mpdo : contr (2) failed.', &
! errst=errst)) return
else
call split(Tmpa, 2, Rho%Sl_right, errst=errst)
!if(prop_error('rho_kk_mpdo : split (2) failed.', &
! 'MPDOOps_include.f90:2296', errst=errst)) return
call pcontr(Rhokk, Tmpa, [2], [3], errst=errst)
!if(prop_error('rho_kk_mpdo : pcontr (1) failed.', &
! errst=errst)) return
end if
call destroy(Tmpa)
call split(Rhokk, [Rho%Sl_local], errst=errst)
!if(prop_error('rho_kk_mpdo : split (3) failed.', &
! 'MPDOOps_include.f90:2307', errst=errst)) return
! Set hashes for rho
!call set_hash(Rhokk, [1])
!call sort(Rhokk)
end subroutine rho_kk_mpdo
"""
return
[docs]def rho_kk_mpdoc():
"""
fortran-subroutine - September 2017 (dj)
Calculate the single-site reduced density matrix for an MPDO.
**Arguments**
Rhokk : TYPE(tensorc), out
On exit, the reduced density matrix on site kk of the
density matrix.
Rho : TYPE(mpdoc), out
The complete density matrix represented as MPDO.
LR : TYPE(tensorlistc), out
The overlaps of the MPDO. They are needed, as their is no
gauge useful for calculating the reduced density matrices.
kk : INTEGER, out
Calculate reduced density matrix for this site. Must be
the center of the LR overlaps.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_kk_mpdoc(Rhokk, Rho, LR, kk, errst)
type(tensorc), intent(out) :: Rhokk
type(mpdoc), intent(inout) :: Rho
type(tensorlistc), intent(inout) :: LR
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor needed for permutation
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
call contr(Tmpa, LR%Li(kk - 1), Rho%Superket%Aa(kk), [1], [1], &
errst=errst)
!if(prop_error('rho_kk_mpdoc : contr (1) failed.', &
! errst=errst)) return
else
call copy(Tmpb, Rho%Superket%Aa(kk))
call split(Tmpb, 1, Rho%Sl_left, errst=errst)
!if(prop_error('rho_kk_mpdoc : split (1) failed.', &
! 'MPDOOps_include.f90:2280', errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('rho_kk_mpdoc : pcontr (1) failed.', &
! errst=errst)) return
call destroy(Tmpb)
end if
if(kk < Rho%Superket%ll) then
call contr(Rhokk, Tmpa, LR%Li(kk + 1), [2], [1])
!if(prop_error('rho_kk_mpdoc : contr (2) failed.', &
! errst=errst)) return
else
call split(Tmpa, 2, Rho%Sl_right, errst=errst)
!if(prop_error('rho_kk_mpdoc : split (2) failed.', &
! 'MPDOOps_include.f90:2296', errst=errst)) return
call pcontr(Rhokk, Tmpa, [2], [3], errst=errst)
!if(prop_error('rho_kk_mpdoc : pcontr (1) failed.', &
! errst=errst)) return
end if
call destroy(Tmpa)
call split(Rhokk, [Rho%Sl_local], errst=errst)
!if(prop_error('rho_kk_mpdoc : split (3) failed.', &
! 'MPDOOps_include.f90:2307', errst=errst)) return
! Set hashes for rho
!call set_hash(Rhokk, [1])
!call sort(Rhokk)
end subroutine rho_kk_mpdoc
"""
return
[docs]def rho_kk_qmpdo():
"""
fortran-subroutine - September 2017 (dj)
Calculate the single-site reduced density matrix for an MPDO.
**Arguments**
Rhokk : TYPE(qtensor), out
On exit, the reduced density matrix on site kk of the
density matrix.
Rho : TYPE(qmpdo), out
The complete density matrix represented as MPDO.
LR : TYPE(qtensorlist), out
The overlaps of the MPDO. They are needed, as their is no
gauge useful for calculating the reduced density matrices.
kk : INTEGER, out
Calculate reduced density matrix for this site. Must be
the center of the LR overlaps.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_kk_qmpdo(Rhokk, Rho, LR, kk, errst)
type(qtensor), intent(out) :: Rhokk
type(qmpdo), intent(inout) :: Rho
type(qtensorlist), intent(inout) :: LR
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor needed for permutation
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
call contr(Tmpa, LR%Li(kk - 1), Rho%Superket%Aa(kk), [1], [1], &
errst=errst)
!if(prop_error('rho_kk_qmpdo : contr (1) failed.', &
! errst=errst)) return
else
call copy(Tmpb, Rho%Superket%Aa(kk))
call split(Tmpb, 1, Rho%Sl_left, errst=errst)
!if(prop_error('rho_kk_qmpdo : split (1) failed.', &
! 'MPDOOps_include.f90:2280', errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('rho_kk_qmpdo : pcontr (1) failed.', &
! errst=errst)) return
call destroy(Tmpb)
end if
if(kk < Rho%Superket%ll) then
call contr(Rhokk, Tmpa, LR%Li(kk + 1), [2], [1])
!if(prop_error('rho_kk_qmpdo : contr (2) failed.', &
! errst=errst)) return
else
call split(Tmpa, 2, Rho%Sl_right, errst=errst)
!if(prop_error('rho_kk_qmpdo : split (2) failed.', &
! 'MPDOOps_include.f90:2296', errst=errst)) return
call pcontr(Rhokk, Tmpa, [2], [3], errst=errst)
!if(prop_error('rho_kk_qmpdo : pcontr (1) failed.', &
! errst=errst)) return
end if
call destroy(Tmpa)
call split(Rhokk, [Rho%Sl_local], errst=errst)
!if(prop_error('rho_kk_qmpdo : split (3) failed.', &
! 'MPDOOps_include.f90:2307', errst=errst)) return
! Set hashes for rho
call set_hash(Rhokk, [1])
call sort(Rhokk)
end subroutine rho_kk_qmpdo
"""
return
[docs]def rho_kk_qmpdoc():
"""
fortran-subroutine - September 2017 (dj)
Calculate the single-site reduced density matrix for an MPDO.
**Arguments**
Rhokk : TYPE(qtensorc), out
On exit, the reduced density matrix on site kk of the
density matrix.
Rho : TYPE(qmpdoc), out
The complete density matrix represented as MPDO.
LR : TYPE(qtensorclist), out
The overlaps of the MPDO. They are needed, as their is no
gauge useful for calculating the reduced density matrices.
kk : INTEGER, out
Calculate reduced density matrix for this site. Must be
the center of the LR overlaps.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rho_kk_qmpdoc(Rhokk, Rho, LR, kk, errst)
type(qtensorc), intent(out) :: Rhokk
type(qmpdoc), intent(inout) :: Rho
type(qtensorclist), intent(inout) :: LR
integer, intent(in) :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensor needed for permutation
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
if(kk > 1) then
call contr(Tmpa, LR%Li(kk - 1), Rho%Superket%Aa(kk), [1], [1], &
errst=errst)
!if(prop_error('rho_kk_qmpdoc : contr (1) failed.', &
! errst=errst)) return
else
call copy(Tmpb, Rho%Superket%Aa(kk))
call split(Tmpb, 1, Rho%Sl_left, errst=errst)
!if(prop_error('rho_kk_qmpdoc : split (1) failed.', &
! 'MPDOOps_include.f90:2280', errst=errst)) return
call pcontr(Tmpa, Tmpb, [1], [2], errst=errst)
!if(prop_error('rho_kk_qmpdoc : pcontr (1) failed.', &
! errst=errst)) return
call destroy(Tmpb)
end if
if(kk < Rho%Superket%ll) then
call contr(Rhokk, Tmpa, LR%Li(kk + 1), [2], [1])
!if(prop_error('rho_kk_qmpdoc : contr (2) failed.', &
! errst=errst)) return
else
call split(Tmpa, 2, Rho%Sl_right, errst=errst)
!if(prop_error('rho_kk_qmpdoc : split (2) failed.', &
! 'MPDOOps_include.f90:2296', errst=errst)) return
call pcontr(Rhokk, Tmpa, [2], [3], errst=errst)
!if(prop_error('rho_kk_qmpdoc : pcontr (1) failed.', &
! errst=errst)) return
end if
call destroy(Tmpa)
call split(Rhokk, [Rho%Sl_local], errst=errst)
!if(prop_error('rho_kk_qmpdoc : split (3) failed.', &
! 'MPDOOps_include.f90:2307', errst=errst)) return
! Set hashes for rho
call set_hash(Rhokk, [1])
call sort(Rhokk)
end subroutine rho_kk_qmpdoc
"""
return
[docs]def rhoij_init_mpdo_tensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize the measurement for the two-site reduced density matrix. It
builds the left overlap leaving the local Hilbert space uncontracted and
as a single link.
**Arguments**
Tenskk : TYPE(tensor), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensor), inout
LR is the left-right overlap of the MPDO.
kk : INTEGER, in
Site index of the first site of the reduced density matrix. Necessary
to address the correct LR overlap. kk must be the center of the LR
overlap.
Theta : TYPE(tensor), inout
On exit, contraction of the tensor on site kk with the LR overlap.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_mpdo_tensor(Tenskk, LR, kk, Theta, Sl_left, errst)
type(tensor), intent(inout) :: Tenskk
type(tensorlist), intent(inout) :: LR
integer, intent(in) :: kk
type(tensor), intent(out) :: Theta
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! dimension of local Hilbert space
!integer :: dim
! temporary tensor
type(tensor) :: Tmp
!if(present(errst)) errst = 0
!dim = int(sqrt(1.0_rKind * Tenskk%dl(2)))
if(kk > 1) then
call contr(Theta, LR%Li(kk -1), Tenskk, [1], [1])
else
call copy(Tmp, Tenskk)
call split(Tmp, 1, Sl_left, errst=errst)
!if(prop_error('rhoij_init_mpdo_tensor : split '//&
! 'failed.', 'MPDOOps_include.f90:2392', errst=errst)) return
call pcontr(Theta, Tmp, [1], [2], errst=errst)
!if(prop_error('rhoij_init_mpdo_tensor : pcontr '//&
! 'failed.', 'MPDOOps_include.f90:2396', errst=errst)) return
call destroy(Tmp)
end if
end subroutine rhoij_init_mpdo_tensor
"""
return
[docs]def rhoij_init_mpdo_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize the measurement for the two-site reduced density matrix. It
builds the left overlap leaving the local Hilbert space uncontracted and
as a single link.
**Arguments**
Tenskk : TYPE(tensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(tensorc), inout
LR is the left-right overlap of the MPDO.
kk : INTEGER, in
Site index of the first site of the reduced density matrix. Necessary
to address the correct LR overlap. kk must be the center of the LR
overlap.
Theta : TYPE(tensorc), inout
On exit, contraction of the tensor on site kk with the LR overlap.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_mpdo_tensorc(Tenskk, LR, kk, Theta, Sl_left, errst)
type(tensorc), intent(inout) :: Tenskk
type(tensorlistc), intent(inout) :: LR
integer, intent(in) :: kk
type(tensorc), intent(out) :: Theta
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! dimension of local Hilbert space
!integer :: dim
! temporary tensor
type(tensorc) :: Tmp
!if(present(errst)) errst = 0
!dim = int(sqrt(1.0_rKind * Tenskk%dl(2)))
if(kk > 1) then
call contr(Theta, LR%Li(kk -1), Tenskk, [1], [1])
else
call copy(Tmp, Tenskk)
call split(Tmp, 1, Sl_left, errst=errst)
!if(prop_error('rhoij_init_mpdo_tensorc : split '//&
! 'failed.', 'MPDOOps_include.f90:2392', errst=errst)) return
call pcontr(Theta, Tmp, [1], [2], errst=errst)
!if(prop_error('rhoij_init_mpdo_tensorc : pcontr '//&
! 'failed.', 'MPDOOps_include.f90:2396', errst=errst)) return
call destroy(Tmp)
end if
end subroutine rhoij_init_mpdo_tensorc
"""
return
[docs]def rhoij_init_mpdo_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Initialize the measurement for the two-site reduced density matrix. It
builds the left overlap leaving the local Hilbert space uncontracted and
as a single link.
**Arguments**
Tenskk : TYPE(qtensor), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensor), inout
LR is the left-right overlap of the MPDO.
kk : INTEGER, in
Site index of the first site of the reduced density matrix. Necessary
to address the correct LR overlap. kk must be the center of the LR
overlap.
Theta : TYPE(qtensor), inout
On exit, contraction of the tensor on site kk with the LR overlap.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_mpdo_qtensor(Tenskk, LR, kk, Theta, Sl_left, errst)
type(qtensor), intent(inout) :: Tenskk
type(qtensorlist), intent(inout) :: LR
integer, intent(in) :: kk
type(qtensor), intent(out) :: Theta
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! dimension of local Hilbert space
!integer :: dim
! temporary tensor
type(qtensor) :: Tmp
!if(present(errst)) errst = 0
!dim = int(sqrt(1.0_rKind * Tenskk%dl(2)))
if(kk > 1) then
call contr(Theta, LR%Li(kk -1), Tenskk, [1], [1])
else
call copy(Tmp, Tenskk)
call split(Tmp, 1, Sl_left, errst=errst)
!if(prop_error('rhoij_init_mpdo_qtensor : split '//&
! 'failed.', 'MPDOOps_include.f90:2392', errst=errst)) return
call pcontr(Theta, Tmp, [1], [2], errst=errst)
!if(prop_error('rhoij_init_mpdo_qtensor : pcontr '//&
! 'failed.', 'MPDOOps_include.f90:2396', errst=errst)) return
call destroy(Tmp)
end if
end subroutine rhoij_init_mpdo_qtensor
"""
return
[docs]def rhoij_init_mpdo_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Initialize the measurement for the two-site reduced density matrix. It
builds the left overlap leaving the local Hilbert space uncontracted and
as a single link.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Rank-3 tensor representing site kk in the superket of the MPDO.
LR : TYPE(qtensorc), inout
LR is the left-right overlap of the MPDO.
kk : INTEGER, in
Site index of the first site of the reduced density matrix. Necessary
to address the correct LR overlap. kk must be the center of the LR
overlap.
Theta : TYPE(qtensorc), inout
On exit, contraction of the tensor on site kk with the LR overlap.
Sl_left : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_mpdo_qtensorc(Tenskk, LR, kk, Theta, Sl_left, errst)
type(qtensorc), intent(inout) :: Tenskk
type(qtensorclist), intent(inout) :: LR
integer, intent(in) :: kk
type(qtensorc), intent(out) :: Theta
type(splitlink), intent(in) :: Sl_left
integer, intent(out), optional :: errst
! Local variables
! ---------------
! dimension of local Hilbert space
!integer :: dim
! temporary tensor
type(qtensorc) :: Tmp
!if(present(errst)) errst = 0
!dim = int(sqrt(1.0_rKind * Tenskk%dl(2)))
if(kk > 1) then
call contr(Theta, LR%Li(kk -1), Tenskk, [1], [1])
else
call copy(Tmp, Tenskk)
call split(Tmp, 1, Sl_left, errst=errst)
!if(prop_error('rhoij_init_mpdo_qtensorc : split '//&
! 'failed.', 'MPDOOps_include.f90:2392', errst=errst)) return
call pcontr(Theta, Tmp, [1], [2], errst=errst)
!if(prop_error('rhoij_init_mpdo_qtensorc : pcontr '//&
! 'failed.', 'MPDOOps_include.f90:2396', errst=errst)) return
call destroy(Tmp)
end if
end subroutine rhoij_init_mpdo_qtensorc
"""
return
[docs]def rhoij_meas_mpdo_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
Rank-3 tensor representing site jj in the superket of the MPDO.
LR : TYPE(tensorlist), inout
Left-right overlap of the MPDO.
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.).
Sl_local : TYPE(splitlink), in
Defines the splitting of the local dimension link in the MPDO.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
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_mpdo_tensor_tensor(Rhosij, Tensjj, LR, &
ii, jj, ll, Theta, PhaseOp, hasphase, Sl_local, Sl_right, skip, errst)
type(tensor), dimension(:, :), intent(inout) :: Rhosij
type(tensor), intent(inout) :: Tensjj
type(tensorlist), intent(inout) :: LR
integer, intent(in) :: ii, jj, ll
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! 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
if(jj < ll) then
call contr(Tmpa, Tensjj, LR%Li(jj + 1), [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensor_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2532', errst=errst)) return
else
call copy(Tmpb, Tensjj)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensor_'//&
! 'tensor: split (1) failed.', &
! 'MPDOOps_include.f90:2539', errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensor_'//&
! 'tensor: pcontr (1) failed.', &
! 'MPDOOps_include.f90:2544', errst=errst)) return
call destroy(Tmpb)
end if
call contr(Rhosij(ii, jj), Theta, Tmpa, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensor_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2552', errst=errst)) return
call split(Rhosij(ii, jj), [Sl_local, Sl_local])
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensor_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2568', errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-ldket-chi
fidx(:, 1) = [1, 2]
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0')
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensor_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2581', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensor_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2590', errst=errst)) return
call destroy(Theta)
! Tmp as ket-bra-ldket-chi
call split(Tmpa, 2, Sl_local)
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensor_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2599', errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mpdo_tensor_tensor
"""
return
[docs]def rhoij_meas_mpdo_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
Rank-3 tensor representing site jj in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
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.).
Sl_local : TYPE(splitlink), in
Defines the splitting of the local dimension link in the MPDO.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
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_mpdo_tensorc_tensor(Rhosij, Tensjj, LR, &
ii, jj, ll, Theta, PhaseOp, hasphase, Sl_local, Sl_right, skip, errst)
type(tensorc), dimension(:, :), intent(inout) :: Rhosij
type(tensorc), intent(inout) :: Tensjj
type(tensorlistc), intent(inout) :: LR
integer, intent(in) :: ii, jj, ll
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! 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
if(jj < ll) then
call contr(Tmpa, Tensjj, LR%Li(jj + 1), [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2532', errst=errst)) return
else
call copy(Tmpb, Tensjj)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensor: split (1) failed.', &
! 'MPDOOps_include.f90:2539', errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensor: pcontr (1) failed.', &
! 'MPDOOps_include.f90:2544', errst=errst)) return
call destroy(Tmpb)
end if
call contr(Rhosij(ii, jj), Theta, Tmpa, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2552', errst=errst)) return
call split(Rhosij(ii, jj), [Sl_local, Sl_local])
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2568', errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-ldket-chi
fidx(:, 1) = [1, 2]
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0')
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2581', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2590', errst=errst)) return
call destroy(Theta)
! Tmp as ket-bra-ldket-chi
call split(Tmpa, 2, Sl_local)
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensor: contr failed.', &
! 'MPDOOps_include.f90:2599', errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mpdo_tensorc_tensor
"""
return
[docs]def rhoij_meas_mpdo_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
Rank-3 tensor representing site jj in the superket of the MPDO.
LR : TYPE(tensorlistc), inout
Left-right overlap of the MPDO.
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.).
Sl_local : TYPE(splitlink), in
Defines the splitting of the local dimension link in the MPDO.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
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_mpdo_tensorc_tensorc(Rhosij, Tensjj, LR, &
ii, jj, ll, Theta, PhaseOp, hasphase, Sl_local, Sl_right, skip, errst)
type(tensorc), dimension(:, :), intent(inout) :: Rhosij
type(tensorc), intent(inout) :: Tensjj
type(tensorlistc), intent(inout) :: LR
integer, intent(in) :: ii, jj, ll
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! 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
if(jj < ll) then
call contr(Tmpa, Tensjj, LR%Li(jj + 1), [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensorc: contr failed.', &
! 'MPDOOps_include.f90:2532', errst=errst)) return
else
call copy(Tmpb, Tensjj)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensorc: split (1) failed.', &
! 'MPDOOps_include.f90:2539', errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensorc: pcontr (1) failed.', &
! 'MPDOOps_include.f90:2544', errst=errst)) return
call destroy(Tmpb)
end if
call contr(Rhosij(ii, jj), Theta, Tmpa, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensorc: contr failed.', &
! 'MPDOOps_include.f90:2552', errst=errst)) return
call split(Rhosij(ii, jj), [Sl_local, Sl_local])
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensorc: contr failed.', &
! 'MPDOOps_include.f90:2568', errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-ldket-chi
fidx(:, 1) = [1, 2]
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0')
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensorc: contr failed.', &
! 'MPDOOps_include.f90:2581', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensorc: contr failed.', &
! 'MPDOOps_include.f90:2590', errst=errst)) return
call destroy(Theta)
! Tmp as ket-bra-ldket-chi
call split(Tmpa, 2, Sl_local)
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('rhoij_meas_mpdo_tensorc_'//&
! 'tensorc: contr failed.', &
! 'MPDOOps_include.f90:2599', errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mpdo_tensorc_tensorc
"""
return
[docs]def rhoij_meas_mpdo_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
Rank-3 tensor representing site jj in the superket of the MPDO.
LR : TYPE(qtensorlist), inout
Left-right overlap of the MPDO.
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.).
Sl_local : TYPE(splitlink), in
Defines the splitting of the local dimension link in the MPDO.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
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_mpdo_qtensor_qtensor(Rhosij, Tensjj, LR, &
ii, jj, ll, Theta, PhaseOp, hasphase, Sl_local, Sl_right, skip, errst)
type(qtensor), dimension(:, :), intent(inout) :: Rhosij
type(qtensor), intent(inout) :: Tensjj
type(qtensorlist), intent(inout) :: LR
integer, intent(in) :: ii, jj, ll
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! 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
if(jj < ll) then
call contr(Tmpa, Tensjj, LR%Li(jj + 1), [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensor_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2532', errst=errst)) return
else
call copy(Tmpb, Tensjj)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensor_'//&
! 'qtensor: split (1) failed.', &
! 'MPDOOps_include.f90:2539', errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensor_'//&
! 'qtensor: pcontr (1) failed.', &
! 'MPDOOps_include.f90:2544', errst=errst)) return
call destroy(Tmpb)
end if
call contr(Rhosij(ii, jj), Theta, Tmpa, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensor_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2552', errst=errst)) return
call split(Rhosij(ii, jj), [Sl_local, Sl_local])
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensor_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2568', errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-ldket-chi
fidx(:, 1) = [1, 2]
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0')
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensor_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2581', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensor_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2590', errst=errst)) return
call destroy(Theta)
! Tmp as ket-bra-ldket-chi
call split(Tmpa, 2, Sl_local)
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensor_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2599', errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mpdo_qtensor_qtensor
"""
return
[docs]def rhoij_meas_mpdo_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
Rank-3 tensor representing site jj in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
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.).
Sl_local : TYPE(splitlink), in
Defines the splitting of the local dimension link in the MPDO.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
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_mpdo_qtensorc_qtensor(Rhosij, Tensjj, LR, &
ii, jj, ll, Theta, PhaseOp, hasphase, Sl_local, Sl_right, skip, errst)
type(qtensorc), dimension(:, :), intent(inout) :: Rhosij
type(qtensorc), intent(inout) :: Tensjj
type(qtensorclist), intent(inout) :: LR
integer, intent(in) :: ii, jj, ll
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! 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
if(jj < ll) then
call contr(Tmpa, Tensjj, LR%Li(jj + 1), [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2532', errst=errst)) return
else
call copy(Tmpb, Tensjj)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensor: split (1) failed.', &
! 'MPDOOps_include.f90:2539', errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensor: pcontr (1) failed.', &
! 'MPDOOps_include.f90:2544', errst=errst)) return
call destroy(Tmpb)
end if
call contr(Rhosij(ii, jj), Theta, Tmpa, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2552', errst=errst)) return
call split(Rhosij(ii, jj), [Sl_local, Sl_local])
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2568', errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-ldket-chi
fidx(:, 1) = [1, 2]
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0')
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2581', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2590', errst=errst)) return
call destroy(Theta)
! Tmp as ket-bra-ldket-chi
call split(Tmpa, 2, Sl_local)
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensor: contr failed.', &
! 'MPDOOps_include.f90:2599', errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mpdo_qtensorc_qtensor
"""
return
[docs]def rhoij_meas_mpdo_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
Rank-3 tensor representing site jj in the superket of the MPDO.
LR : TYPE(qtensorclist), inout
Left-right overlap of the MPDO.
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.).
Sl_local : TYPE(splitlink), in
Defines the splitting of the local dimension link in the MPDO.
Sl_right : TYPE(splitlink), in
Information how to split the link to the right of the MPDO.
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_mpdo_qtensorc_qtensorc(Rhosij, Tensjj, LR, &
ii, jj, ll, Theta, PhaseOp, hasphase, Sl_local, Sl_right, skip, errst)
type(qtensorc), dimension(:, :), intent(inout) :: Rhosij
type(qtensorc), intent(inout) :: Tensjj
type(qtensorclist), intent(inout) :: LR
integer, intent(in) :: ii, jj, ll
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
type(splitlink), intent(in) :: Sl_local, Sl_right
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 1) :: fidx
! 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
if(jj < ll) then
call contr(Tmpa, Tensjj, LR%Li(jj + 1), [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'MPDOOps_include.f90:2532', errst=errst)) return
else
call copy(Tmpb, Tensjj)
call split(Tmpb, 3, Sl_right, errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensorc: split (1) failed.', &
! 'MPDOOps_include.f90:2539', errst=errst)) return
call pcontr(Tmpa, Tmpb, [3], [4], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensorc: pcontr (1) failed.', &
! 'MPDOOps_include.f90:2544', errst=errst)) return
call destroy(Tmpb)
end if
call contr(Rhosij(ii, jj), Theta, Tmpa, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'MPDOOps_include.f90:2552', errst=errst)) return
call split(Rhosij(ii, jj), [Sl_local, Sl_local])
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'MPDOOps_include.f90:2568', errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-ldket-chi
fidx(:, 1) = [1, 2]
call copy(Tmpb, PhaseOp)
call transposed(Tmpb)
call fuse(Tmpb, fidx, '0')
call contr(Theta, Tmpa, Tmpb, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'MPDOOps_include.f90:2581', errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Tensjj, [2], [1], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'MPDOOps_include.f90:2590', errst=errst)) return
call destroy(Theta)
! Tmp as ket-bra-ldket-chi
call split(Tmpa, 2, Sl_local)
call pcontr(Theta, Tmpa, [2], [3], errst=errst)
!if(prop_error('rhoij_meas_mpdo_qtensorc_'//&
! 'qtensorc: contr failed.', &
! 'MPDOOps_include.f90:2599', errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mpdo_qtensorc_qtensorc
"""
return
[docs]def setuplr_mpdo():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left-right overlap of an MPDO.
**Arguments**
LR : TYPE(tensorlist), inout
List of overlaps for the MPDO.
Rho : TYPE(mpdo), inout
The MPDO to build the overlaps for.
kk : INTEGER, OPTIONAL, inout
The center of the overlaps, default to 1.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine setuplr_mpdo(LR, Rho, kk, errst)
type(tensorlist), intent(inout) :: LR
type(mpdo), intent(inout) :: Rho
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! initial center for LR overlap
integer :: kin
!if(present(errst)) errst = 0
kin = 1
if(present(kk)) kin = kk
allocate(LR%Li(Rho%Superket%ll))
! From site 1 to site (kin - 1)
! -----------------------------
if(kin > 1) then
call ptm_right_mpdo(LR%Li(1), Rho%Superket%Aa(1), .true., &
Rho%Sl_local, Rho%Sl_left, errst=errst)
!if(prop_error('setuplr_mpdo : ptm_right_mpdo (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = 2, (kin - 1)
call ptm_right_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .false., &
Rho%Sl_local, Rho%Sl_left, &
Matin=LR%Li(ii - 1), errst=errst)
!if(prop_error('setuplr_mpdo : ptm_right_mpdo (2) '//&
! 'failed.', errst=errst)) return
end do
! From site ll to site (kin + 1)
! ------------------------------
if(kin < Rho%Superket%ll) then
ii = Rho%Superket%ll
call ptm_left_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .true., &
Rho%Sl_local, Rho%Sl_right, errst=errst)
!if(prop_error('setuplr_mpdo : ptm_left_mpdo (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = (Rho%Superket%ll - 1), (kin + 1), (-1)
call ptm_left_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .false., &
Rho%Sl_local, Rho%Sl_right, &
Matin=LR%Li(ii + 1), errst=errst)
!if(prop_error('setuplr_mpdo : ptm_left_mpdo (1) '//&
! 'failed.', errst=errst)) return
end do
! Set center to dummy to allocate everything
ii = 1
if(kin == 1) ii = ii + 1
call copy(LR%Li(kin), LR%Li(ii))
end subroutine setuplr_mpdo
"""
return
[docs]def setuplr_mpdoc():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left-right overlap of an MPDO.
**Arguments**
LR : TYPE(tensorlistc), inout
List of overlaps for the MPDO.
Rho : TYPE(mpdoc), inout
The MPDO to build the overlaps for.
kk : INTEGER, OPTIONAL, inout
The center of the overlaps, default to 1.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine setuplr_mpdoc(LR, Rho, kk, errst)
type(tensorlistc), intent(inout) :: LR
type(mpdoc), intent(inout) :: Rho
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! initial center for LR overlap
integer :: kin
!if(present(errst)) errst = 0
kin = 1
if(present(kk)) kin = kk
allocate(LR%Li(Rho%Superket%ll))
! From site 1 to site (kin - 1)
! -----------------------------
if(kin > 1) then
call ptm_right_mpdo(LR%Li(1), Rho%Superket%Aa(1), .true., &
Rho%Sl_local, Rho%Sl_left, errst=errst)
!if(prop_error('setuplr_mpdoc : ptm_right_mpdo (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = 2, (kin - 1)
call ptm_right_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .false., &
Rho%Sl_local, Rho%Sl_left, &
Matin=LR%Li(ii - 1), errst=errst)
!if(prop_error('setuplr_mpdoc : ptm_right_mpdo (2) '//&
! 'failed.', errst=errst)) return
end do
! From site ll to site (kin + 1)
! ------------------------------
if(kin < Rho%Superket%ll) then
ii = Rho%Superket%ll
call ptm_left_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .true., &
Rho%Sl_local, Rho%Sl_right, errst=errst)
!if(prop_error('setuplr_mpdoc : ptm_left_mpdo (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = (Rho%Superket%ll - 1), (kin + 1), (-1)
call ptm_left_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .false., &
Rho%Sl_local, Rho%Sl_right, &
Matin=LR%Li(ii + 1), errst=errst)
!if(prop_error('setuplr_mpdoc : ptm_left_mpdo (1) '//&
! 'failed.', errst=errst)) return
end do
! Set center to dummy to allocate everything
ii = 1
if(kin == 1) ii = ii + 1
call copy(LR%Li(kin), LR%Li(ii))
end subroutine setuplr_mpdoc
"""
return
[docs]def setuplr_qmpdo():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left-right overlap of an MPDO.
**Arguments**
LR : TYPE(qtensorlist), inout
List of overlaps for the MPDO.
Rho : TYPE(qmpdo), inout
The MPDO to build the overlaps for.
kk : INTEGER, OPTIONAL, inout
The center of the overlaps, default to 1.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine setuplr_qmpdo(LR, Rho, kk, errst)
type(qtensorlist), intent(inout) :: LR
type(qmpdo), intent(inout) :: Rho
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! initial center for LR overlap
integer :: kin
!if(present(errst)) errst = 0
kin = 1
if(present(kk)) kin = kk
allocate(LR%Li(Rho%Superket%ll))
! From site 1 to site (kin - 1)
! -----------------------------
if(kin > 1) then
call ptm_right_mpdo(LR%Li(1), Rho%Superket%Aa(1), .true., &
Rho%Sl_local, Rho%Sl_left, errst=errst)
!if(prop_error('setuplr_qmpdo : ptm_right_mpdo (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = 2, (kin - 1)
call ptm_right_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .false., &
Rho%Sl_local, Rho%Sl_left, &
Matin=LR%Li(ii - 1), errst=errst)
!if(prop_error('setuplr_qmpdo : ptm_right_mpdo (2) '//&
! 'failed.', errst=errst)) return
end do
! From site ll to site (kin + 1)
! ------------------------------
if(kin < Rho%Superket%ll) then
ii = Rho%Superket%ll
call ptm_left_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .true., &
Rho%Sl_local, Rho%Sl_right, errst=errst)
!if(prop_error('setuplr_qmpdo : ptm_left_mpdo (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = (Rho%Superket%ll - 1), (kin + 1), (-1)
call ptm_left_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .false., &
Rho%Sl_local, Rho%Sl_right, &
Matin=LR%Li(ii + 1), errst=errst)
!if(prop_error('setuplr_qmpdo : ptm_left_mpdo (1) '//&
! 'failed.', errst=errst)) return
end do
! Set center to dummy to allocate everything
ii = 1
if(kin == 1) ii = ii + 1
call copy(LR%Li(kin), LR%Li(ii))
end subroutine setuplr_qmpdo
"""
return
[docs]def setuplr_qmpdoc():
"""
fortran-subroutine - September 2017 (dj)
Initialize the left-right overlap of an MPDO.
**Arguments**
LR : TYPE(qtensorclist), inout
List of overlaps for the MPDO.
Rho : TYPE(qmpdoc), inout
The MPDO to build the overlaps for.
kk : INTEGER, OPTIONAL, inout
The center of the overlaps, default to 1.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine setuplr_qmpdoc(LR, Rho, kk, errst)
type(qtensorclist), intent(inout) :: LR
type(qmpdoc), intent(inout) :: Rho
integer, intent(in), optional :: kk
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! initial center for LR overlap
integer :: kin
!if(present(errst)) errst = 0
kin = 1
if(present(kk)) kin = kk
allocate(LR%Li(Rho%Superket%ll))
! From site 1 to site (kin - 1)
! -----------------------------
if(kin > 1) then
call ptm_right_mpdo(LR%Li(1), Rho%Superket%Aa(1), .true., &
Rho%Sl_local, Rho%Sl_left, errst=errst)
!if(prop_error('setuplr_qmpdoc : ptm_right_mpdo (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = 2, (kin - 1)
call ptm_right_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .false., &
Rho%Sl_local, Rho%Sl_left, &
Matin=LR%Li(ii - 1), errst=errst)
!if(prop_error('setuplr_qmpdoc : ptm_right_mpdo (2) '//&
! 'failed.', errst=errst)) return
end do
! From site ll to site (kin + 1)
! ------------------------------
if(kin < Rho%Superket%ll) then
ii = Rho%Superket%ll
call ptm_left_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .true., &
Rho%Sl_local, Rho%Sl_right, errst=errst)
!if(prop_error('setuplr_qmpdoc : ptm_left_mpdo (1) '//&
! 'failed.', errst=errst)) return
end if
do ii = (Rho%Superket%ll - 1), (kin + 1), (-1)
call ptm_left_mpdo(LR%Li(ii), Rho%Superket%Aa(ii), .false., &
Rho%Sl_local, Rho%Sl_right, &
Matin=LR%Li(ii + 1), errst=errst)
!if(prop_error('setuplr_qmpdoc : ptm_left_mpdo (1) '//&
! 'failed.', errst=errst)) return
end do
! Set center to dummy to allocate everything
ii = 1
if(kin == 1) ii = ii + 1
call copy(LR%Li(kin), LR%Li(ii))
end subroutine setuplr_qmpdoc
"""
return
[docs]def transposed_mpdo():
"""
fortran-subroutine - June 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Rho : TYPE(MPS_TYPE), inout
Permute MPDO sites in-place. Error can be introduced
due to SVDs.
perm : INTEGER(\*), in
Permutation array has length equal to the number of
sites L in the MPS with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_mpdo(Rho, perm, trunc, ncut, cerr, errst)
type(mpdo), intent(inout) :: Rho
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
!if(present(errst)) errst = 0
call transposed(Rho%Superket, perm, trunc, ncut, cerr, errst=errst)
!if(prop_error('transposed_mpdo : transposed failed.', &
! 'MPDOOps_include.f90:2782', errst=errst)) return
end subroutine transposed_mpdo
"""
return
[docs]def transposed_mpdoc():
"""
fortran-subroutine - June 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Rho : TYPE(MPS_TYPE), inout
Permute MPDO sites in-place. Error can be introduced
due to SVDs.
perm : INTEGER(\*), in
Permutation array has length equal to the number of
sites L in the MPS with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_mpdoc(Rho, perm, trunc, ncut, cerr, errst)
type(mpdoc), intent(inout) :: Rho
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
!if(present(errst)) errst = 0
call transposed(Rho%Superket, perm, trunc, ncut, cerr, errst=errst)
!if(prop_error('transposed_mpdoc : transposed failed.', &
! 'MPDOOps_include.f90:2782', errst=errst)) return
end subroutine transposed_mpdoc
"""
return
[docs]def transposed_qmpdo():
"""
fortran-subroutine - June 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Rho : TYPE(MPS_TYPE), inout
Permute MPDO sites in-place. Error can be introduced
due to SVDs.
perm : INTEGER(\*), in
Permutation array has length equal to the number of
sites L in the MPS with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_qmpdo(Rho, perm, trunc, ncut, cerr, errst)
type(qmpdo), intent(inout) :: Rho
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
!if(present(errst)) errst = 0
call transposed(Rho%Superket, perm, trunc, ncut, cerr, errst=errst)
!if(prop_error('transposed_qmpdo : transposed failed.', &
! 'MPDOOps_include.f90:2782', errst=errst)) return
end subroutine transposed_qmpdo
"""
return
[docs]def transposed_qmpdoc():
"""
fortran-subroutine - June 2018 (dj)
Permute the local Hilbert spaces.
**Arguments**
Rho : TYPE(MPS_TYPE), inout
Permute MPDO sites in-place. Error can be introduced
due to SVDs.
perm : INTEGER(\*), in
Permutation array has length equal to the number of
sites L in the MPS with unique entries 1 to L.
trunc : REAL, OPTIONAL, in
Keep infidelity below trunc (infidelity is sum of squared discarded
singular values for MPS). Default does not truncate.
ncut : INTEGER, OPTIONAL, in
Maximal bond dimension / number of singular values. Default is
keeping all singular values.
cerr : REAL, OPTIONAL, inout
Cumulative error from SVDs.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_qmpdoc(Rho, perm, trunc, ncut, cerr, errst)
type(qmpdoc), intent(inout) :: Rho
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
!if(present(errst)) errst = 0
call transposed(Rho%Superket, perm, trunc, ncut, cerr, errst=errst)
!if(prop_error('transposed_qmpdoc : transposed failed.', &
! 'MPDOOps_include.f90:2782', errst=errst)) return
end subroutine transposed_qmpdoc
"""
return
[docs]def updatelr_mpdo():
"""
fortran-subroutine - September 2017 (dj)
Shift the left right overlap by one site.
**Arguments**
LR : TYPE(tensorlist), inout
The list of overlaps for the MPDO.
Rho : TYPE(mpdo), inout
The MPDO to update the overlap.
kk : INTEGER, in
New center for the left-right overlap.
sense : INTEGER, in
Move center of the left-right overlap to the right for
sense > 0 and to the left for sense < 0.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine updatelr_mpdo(LR, Rho, kk, sense, errst)
type(tensorlist), intent(inout) :: LR
type(mpdo), intent(inout) :: Rho
integer, intent(in) :: kk, sense
integer, intent(out), optional :: errst
! No local variables
! ------------------
call destroy(LR%Li(kk))
if(kk == 1) then
call ptm_right_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), .true., &
Rho%Sl_local, Rho%Sl_left, errst=errst)
!if(prop_error('updatelr_mpdo : ptm_right_mpdo '//&
! '(1) failed.', errst=errst)) return
elseif(kk == Rho%Superket%ll) then
call ptm_left_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), .true., &
Rho%Sl_local, Rho%Sl_right, errst=errst)
!if(prop_error('updatelr_mpdo : ptm_left_mpdo '//&
! '(1) failed.', errst=errst)) return
elseif(sense > 0) then
call ptm_right_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), (kk == 1), &
Rho%Sl_local, Rho%Sl_left, &
Matin=LR%Li(kk - 1), errst=errst)
!if(prop_error('updatelr_mpdo : ptm_right_mpdo '//&
! '(2) failed.', errst=errst)) return
else
call ptm_left_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), &
(kk == Rho%Superket%ll), Rho%Sl_local, &
Rho%Sl_right, Matin=LR%Li(kk + 1), &
errst=errst)
!if(prop_error('updatelr_mpdo : ptm_left_mpdo '//&
! '(2) failed.', errst=errst)) return
end if
end subroutine updatelr_mpdo
"""
return
[docs]def updatelr_mpdoc():
"""
fortran-subroutine - September 2017 (dj)
Shift the left right overlap by one site.
**Arguments**
LR : TYPE(tensorlistc), inout
The list of overlaps for the MPDO.
Rho : TYPE(mpdoc), inout
The MPDO to update the overlap.
kk : INTEGER, in
New center for the left-right overlap.
sense : INTEGER, in
Move center of the left-right overlap to the right for
sense > 0 and to the left for sense < 0.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine updatelr_mpdoc(LR, Rho, kk, sense, errst)
type(tensorlistc), intent(inout) :: LR
type(mpdoc), intent(inout) :: Rho
integer, intent(in) :: kk, sense
integer, intent(out), optional :: errst
! No local variables
! ------------------
call destroy(LR%Li(kk))
if(kk == 1) then
call ptm_right_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), .true., &
Rho%Sl_local, Rho%Sl_left, errst=errst)
!if(prop_error('updatelr_mpdoc : ptm_right_mpdo '//&
! '(1) failed.', errst=errst)) return
elseif(kk == Rho%Superket%ll) then
call ptm_left_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), .true., &
Rho%Sl_local, Rho%Sl_right, errst=errst)
!if(prop_error('updatelr_mpdoc : ptm_left_mpdo '//&
! '(1) failed.', errst=errst)) return
elseif(sense > 0) then
call ptm_right_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), (kk == 1), &
Rho%Sl_local, Rho%Sl_left, &
Matin=LR%Li(kk - 1), errst=errst)
!if(prop_error('updatelr_mpdoc : ptm_right_mpdo '//&
! '(2) failed.', errst=errst)) return
else
call ptm_left_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), &
(kk == Rho%Superket%ll), Rho%Sl_local, &
Rho%Sl_right, Matin=LR%Li(kk + 1), &
errst=errst)
!if(prop_error('updatelr_mpdoc : ptm_left_mpdo '//&
! '(2) failed.', errst=errst)) return
end if
end subroutine updatelr_mpdoc
"""
return
[docs]def updatelr_qmpdo():
"""
fortran-subroutine - September 2017 (dj)
Shift the left right overlap by one site.
**Arguments**
LR : TYPE(qtensorlist), inout
The list of overlaps for the MPDO.
Rho : TYPE(qmpdo), inout
The MPDO to update the overlap.
kk : INTEGER, in
New center for the left-right overlap.
sense : INTEGER, in
Move center of the left-right overlap to the right for
sense > 0 and to the left for sense < 0.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine updatelr_qmpdo(LR, Rho, kk, sense, errst)
type(qtensorlist), intent(inout) :: LR
type(qmpdo), intent(inout) :: Rho
integer, intent(in) :: kk, sense
integer, intent(out), optional :: errst
! No local variables
! ------------------
call destroy(LR%Li(kk))
if(kk == 1) then
call ptm_right_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), .true., &
Rho%Sl_local, Rho%Sl_left, errst=errst)
!if(prop_error('updatelr_qmpdo : ptm_right_mpdo '//&
! '(1) failed.', errst=errst)) return
elseif(kk == Rho%Superket%ll) then
call ptm_left_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), .true., &
Rho%Sl_local, Rho%Sl_right, errst=errst)
!if(prop_error('updatelr_qmpdo : ptm_left_mpdo '//&
! '(1) failed.', errst=errst)) return
elseif(sense > 0) then
call ptm_right_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), (kk == 1), &
Rho%Sl_local, Rho%Sl_left, &
Matin=LR%Li(kk - 1), errst=errst)
!if(prop_error('updatelr_qmpdo : ptm_right_mpdo '//&
! '(2) failed.', errst=errst)) return
else
call ptm_left_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), &
(kk == Rho%Superket%ll), Rho%Sl_local, &
Rho%Sl_right, Matin=LR%Li(kk + 1), &
errst=errst)
!if(prop_error('updatelr_qmpdo : ptm_left_mpdo '//&
! '(2) failed.', errst=errst)) return
end if
end subroutine updatelr_qmpdo
"""
return
[docs]def updatelr_qmpdoc():
"""
fortran-subroutine - September 2017 (dj)
Shift the left right overlap by one site.
**Arguments**
LR : TYPE(qtensorclist), inout
The list of overlaps for the MPDO.
Rho : TYPE(qmpdoc), inout
The MPDO to update the overlap.
kk : INTEGER, in
New center for the left-right overlap.
sense : INTEGER, in
Move center of the left-right overlap to the right for
sense > 0 and to the left for sense < 0.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine updatelr_qmpdoc(LR, Rho, kk, sense, errst)
type(qtensorclist), intent(inout) :: LR
type(qmpdoc), intent(inout) :: Rho
integer, intent(in) :: kk, sense
integer, intent(out), optional :: errst
! No local variables
! ------------------
call destroy(LR%Li(kk))
if(kk == 1) then
call ptm_right_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), .true., &
Rho%Sl_local, Rho%Sl_left, errst=errst)
!if(prop_error('updatelr_qmpdoc : ptm_right_mpdo '//&
! '(1) failed.', errst=errst)) return
elseif(kk == Rho%Superket%ll) then
call ptm_left_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), .true., &
Rho%Sl_local, Rho%Sl_right, errst=errst)
!if(prop_error('updatelr_qmpdoc : ptm_left_mpdo '//&
! '(1) failed.', errst=errst)) return
elseif(sense > 0) then
call ptm_right_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), (kk == 1), &
Rho%Sl_local, Rho%Sl_left, &
Matin=LR%Li(kk - 1), errst=errst)
!if(prop_error('updatelr_qmpdoc : ptm_right_mpdo '//&
! '(2) failed.', errst=errst)) return
else
call ptm_left_mpdo(LR%Li(kk), Rho%Superket%Aa(kk), &
(kk == Rho%Superket%ll), Rho%Sl_local, &
Rho%Sl_right, Matin=LR%Li(kk + 1), &
errst=errst)
!if(prop_error('updatelr_qmpdoc : ptm_left_mpdo '//&
! '(2) failed.', errst=errst)) return
end if
end subroutine updatelr_qmpdoc
"""
return
[docs]def write_mpdo():
"""
fortran-subroutine - September 2017 (dj)
Write an MPDO to file.
**Arguments**
Rho : TYPE(mpdo), in
save this MPDO
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_mpdo`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_mpdo(Rho, unit, form, errst)
type(mpdo), intent(in) :: Rho
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! No local variables
! ------------------
if(form == "6") then
write(unit, *) 'MPDO - Superket : '
call write(Rho%Superket, unit, form)
! Write header for splitlinks
write(unit, *) 'MPDO Splitlinks: left, right local'
elseif(form == 'H') then
! Open the formatted file
! -----------------------
call write(Rho%Superket, unit, form)
elseif(form == 'B') then
! Binary file
! -----------
call write(Rho%Superket, unit, form)
else
!errst = raise_error('write_mpdo: unallowed formatting.', &
! 99, errst=errst)
return
end if
! Write all the splitlinks
call write(Rho%Sl_left, unit, form)
call write(Rho%Sl_right, unit, form)
call write(Rho%Sl_local, unit, form)
end subroutine write_mpdo
"""
return
[docs]def write_mpdoc():
"""
fortran-subroutine - September 2017 (dj)
Write an MPDO to file.
**Arguments**
Rho : TYPE(mpdoc), in
save this MPDO
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_mpdoc`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_mpdoc(Rho, unit, form, errst)
type(mpdoc), intent(in) :: Rho
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! No local variables
! ------------------
if(form == "6") then
write(unit, *) 'MPDO - Superket : '
call write(Rho%Superket, unit, form)
! Write header for splitlinks
write(unit, *) 'MPDO Splitlinks: left, right local'
elseif(form == 'H') then
! Open the formatted file
! -----------------------
call write(Rho%Superket, unit, form)
elseif(form == 'B') then
! Binary file
! -----------
call write(Rho%Superket, unit, form)
else
!errst = raise_error('write_mpdoc: unallowed formatting.', &
! 99, errst=errst)
return
end if
! Write all the splitlinks
call write(Rho%Sl_left, unit, form)
call write(Rho%Sl_right, unit, form)
call write(Rho%Sl_local, unit, form)
end subroutine write_mpdoc
"""
return
[docs]def write_qmpdo():
"""
fortran-subroutine - September 2017 (dj)
Write an MPDO to file.
**Arguments**
Rho : TYPE(qmpdo), in
save this MPDO
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_qmpdo`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qmpdo(Rho, unit, form, errst)
type(qmpdo), intent(in) :: Rho
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! No local variables
! ------------------
if(form == "6") then
write(unit, *) 'MPDO - Superket : '
call write(Rho%Superket, unit, form)
! Write header for splitlinks
write(unit, *) 'MPDO Splitlinks: left, right local'
elseif(form == 'H') then
! Open the formatted file
! -----------------------
call write(Rho%Superket, unit, form)
elseif(form == 'B') then
! Binary file
! -----------
call write(Rho%Superket, unit, form)
else
!errst = raise_error('write_qmpdo: unallowed formatting.', &
! 99, errst=errst)
return
end if
! Write all the splitlinks
call write(Rho%Sl_left, unit, form)
call write(Rho%Sl_right, unit, form)
call write(Rho%Sl_local, unit, form)
end subroutine write_qmpdo
"""
return
[docs]def write_qmpdoc():
"""
fortran-subroutine - September 2017 (dj)
Write an MPDO to file.
**Arguments**
Rho : TYPE(qmpdoc), in
save this MPDO
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_qmpdoc`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qmpdoc(Rho, unit, form, errst)
type(qmpdoc), intent(in) :: Rho
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! No local variables
! ------------------
if(form == "6") then
write(unit, *) 'MPDO - Superket : '
call write(Rho%Superket, unit, form)
! Write header for splitlinks
write(unit, *) 'MPDO Splitlinks: left, right local'
elseif(form == 'H') then
! Open the formatted file
! -----------------------
call write(Rho%Superket, unit, form)
elseif(form == 'B') then
! Binary file
! -----------
call write(Rho%Superket, unit, form)
else
!errst = raise_error('write_qmpdoc: unallowed formatting.', &
! 99, errst=errst)
return
end if
! Write all the splitlinks
call write(Rho%Sl_left, unit, form)
call write(Rho%Sl_right, unit, form)
call write(Rho%Sl_local, unit, form)
end subroutine write_qmpdoc
"""
return