"""
Fortran module ObsOps: July 2017 (dj, updated)
Containing the operations for the measurement.
**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 |
+=================================+=============+=============+=============+
| destroy | x | | |
+---------------------------------+-------------+-------------+-------------+
| meas_psi_mpo_phi | x | | |
+---------------------------------+-------------+-------------+-------------+
| meas_mpo | x | | |
+---------------------------------+-------------+-------------+-------------+
| meas_rhoij_corr | x | | |
+---------------------------------+-------------+-------------+-------------+
| corr_init_mps | x | | |
+---------------------------------+-------------+-------------+-------------+
| and some more ... | | | |
+---------------------------------+-------------+-------------+-------------+
"""
[docs]def destroy_site_observables():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing site observables.
**Arguments**
Obj : TYPE(site_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_site_observables(Obj)
type(site_observables), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
!integer :: ii
if(Obj%nsite > 0) then
!do ii = 1, Obj%nsite
!call destroy(Obj%Si)
!end do
deallocate(Obj%Si, Obj%elem)
Obj%nsite = 0
end if
end subroutine destroy_site_observables
"""
return
[docs]def destroy_siteentropy_observables():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing site entropies.
**Arguments**
Obj : TYPE(siteentropy_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_siteentropy_observables(Obj)
type(siteentropy_observables), intent(inout) :: Obj
! No local variables
! ------------------
if(Obj%siteentr) then
deallocate(Obj%elem)
Obj%siteentr = .false.
end if
end subroutine destroy_siteentropy_observables
"""
return
[docs]def destroy_bondentropy_observables():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing bond entropies.
**Arguments**
Obj : TYPE(bondentropy_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_bondentropy_observables(Obj)
type(bondentropy_observables), intent(inout) :: Obj
! No local variables
! ------------------
if(Obj%bondentr) then
deallocate(Obj%elem)
Obj%bondentr = .false.
end if
end subroutine destroy_bondentropy_observables
"""
return
[docs]def destroy_corr_observables_real():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing correlations.
**Arguments**
Obj : TYPE(corr_observables_real), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_corr_observables_real(Obj)
type(corr_observables_real), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
!integer :: ii
if(Obj%ncorr > 0) then
!do ii = 1, Obj%ncorr
!call destroy(Obj%Corr)
!end do
deallocate(Obj%corrid, Obj%Corr, Obj%isherm, Obj%elem)
Obj%ncorr = 0
end if
end subroutine destroy_corr_observables_real
"""
return
[docs]def destroy_corr_observables_complex():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing correlations.
**Arguments**
Obj : TYPE(corr_observables_complex), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_corr_observables_complex(Obj)
type(corr_observables_complex), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
!integer :: ii
if(Obj%ncorr > 0) then
!do ii = 1, Obj%ncorr
!call destroy(Obj%Corr)
!end do
deallocate(Obj%corrid, Obj%Corr, Obj%isherm, Obj%elem)
Obj%ncorr = 0
end if
end subroutine destroy_corr_observables_complex
"""
return
[docs]def destroy_fcorr_observables_real():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing fermi correlations.
**Arguments**
Obj : TYPE(corr_observables_real), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_fcorr_observables_real(Obj)
type(corr_observables_real), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
!integer :: ii
if(Obj%ncorr > 0) then
!do ii = 1, Obj%ncorr
!call destroy(Obj%Corr)
!end do
deallocate(Obj%corrid, Obj%Corr, Obj%isherm)
Obj%fop = -1
Obj%ncorr = 0
end if
end subroutine destroy_fcorr_observables_real
"""
return
[docs]def destroy_fcorr_observables_complex():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing fermi correlations.
**Arguments**
Obj : TYPE(corr_observables_complex), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_fcorr_observables_complex(Obj)
type(corr_observables_complex), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
!integer :: ii
if(Obj%ncorr > 0) then
!do ii = 1, Obj%ncorr
!call destroy(Obj%Corr)
!end do
deallocate(Obj%corrid, Obj%Corr, Obj%isherm)
Obj%fop = -1
Obj%ncorr = 0
end if
end subroutine destroy_fcorr_observables_complex
"""
return
[docs]def destroy_string_observables():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing string correlations.
**Arguments**
Obj : TYPE(string_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_string_observables(Obj)
type(string_observables), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
!integer :: ii
if(Obj%nstring > 0) then
!do ii = 1, Obj%nstring
!call destroy(Obj%String)
!end do
deallocate(Obj%String, Obj%elem)
Obj%nstring = 0
end if
end subroutine destroy_string_observables
"""
return
[docs]def destroy_mpo_observables_mpo():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing MPO measurements.
**Arguments**
Obj : TYPE(mpo_observables_mpo), inout
Will be deallocated on exit.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_mpo_observables_mpo(Obj, unitmpo)
type(mpo_observables_mpo), intent(inout) :: Obj
integer, intent(in) :: unitmpo
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%nmpo > 0) then
do ii = 1, Obj%nmpo
call destroy(Obj%MPO(ii))
open(unit=unitmpo, file=trim(adjustl(Obj%Names(ii)%elem)), &
status='old', action='read')
close(unitmpo, status='delete')
end do
deallocate(Obj%MPO, Obj%Names, Obj%elem)
Obj%nmpo = 0
end if
end subroutine destroy_mpo_observables_mpo
"""
return
[docs]def destroy_mpo_observables_mpoc():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing MPO measurements.
**Arguments**
Obj : TYPE(mpo_observables_mpoc), inout
Will be deallocated on exit.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_mpo_observables_mpoc(Obj, unitmpo)
type(mpo_observables_mpoc), intent(inout) :: Obj
integer, intent(in) :: unitmpo
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%nmpo > 0) then
do ii = 1, Obj%nmpo
call destroy(Obj%MPO(ii))
open(unit=unitmpo, file=trim(adjustl(Obj%Names(ii)%elem)), &
status='old', action='read')
close(unitmpo, status='delete')
end do
deallocate(Obj%MPO, Obj%Names, Obj%elem)
Obj%nmpo = 0
end if
end subroutine destroy_mpo_observables_mpoc
"""
return
[docs]def destroy_mpo_observables_qmpo():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing MPO measurements.
**Arguments**
Obj : TYPE(mpo_observables_qmpo), inout
Will be deallocated on exit.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_mpo_observables_qmpo(Obj, unitmpo)
type(mpo_observables_qmpo), intent(inout) :: Obj
integer, intent(in) :: unitmpo
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%nmpo > 0) then
do ii = 1, Obj%nmpo
call destroy(Obj%MPO(ii))
open(unit=unitmpo, file=trim(adjustl(Obj%Names(ii)%elem)), &
status='old', action='read')
close(unitmpo, status='delete')
end do
deallocate(Obj%MPO, Obj%Names, Obj%elem)
Obj%nmpo = 0
end if
end subroutine destroy_mpo_observables_qmpo
"""
return
[docs]def destroy_mpo_observables_qmpoc():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing MPO measurements.
**Arguments**
Obj : TYPE(mpo_observables_qmpoc), inout
Will be deallocated on exit.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_mpo_observables_qmpoc(Obj, unitmpo)
type(mpo_observables_qmpoc), intent(inout) :: Obj
integer, intent(in) :: unitmpo
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%nmpo > 0) then
do ii = 1, Obj%nmpo
call destroy(Obj%MPO(ii))
open(unit=unitmpo, file=trim(adjustl(Obj%Names(ii)%elem)), &
status='old', action='read')
close(unitmpo, status='delete')
end do
deallocate(Obj%MPO, Obj%Names, Obj%elem)
Obj%nmpo = 0
end if
end subroutine destroy_mpo_observables_qmpoc
"""
return
[docs]def destroy_rhoi_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing single site density matrices.
**Arguments**
Obj : TYPE(rhoi_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_rhoi_observables_tensor(Obj)
type(rhoi_observables_tensor), intent(inout) :: Obj
! No local variables
! ------------------
if(Obj%hasrho_i) then
deallocate(Obj%rho_i_i, Obj%Elem)
Obj%hasrho_i = .false.
end if
end subroutine destroy_rhoi_observables_tensor
"""
return
[docs]def destroy_rhoi_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing single site density matrices.
**Arguments**
Obj : TYPE(rhoi_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_rhoi_observables_tensorc(Obj)
type(rhoi_observables_tensorc), intent(inout) :: Obj
! No local variables
! ------------------
if(Obj%hasrho_i) then
deallocate(Obj%rho_i_i, Obj%Elem)
Obj%hasrho_i = .false.
end if
end subroutine destroy_rhoi_observables_tensorc
"""
return
[docs]def destroy_rhoij_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing two site density matrices.
**Arguments**
Obj : TYPE(rhoij_observables), inout
Will be deallocated on exit.
has_mi : LOGICAL, in
If the mutual information (True) is measured, all
two-site density matrices are set.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_rhoij_observables_tensor(Obj, has_mi)
type(rhoij_observables_tensor), intent(inout) :: Obj
logical, intent(in) :: has_mi
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%hasrho_ij) then
do ii = 1, size(Obj%rho_ij_is, 1)
deallocate(Obj%Rho_ij_js(ii)%elem)
end do
deallocate(Obj%rho_ij_is, Obj%Rho_ij_js, Obj%Elem)
Obj%hasrho_ij = .false.
elseif(has_mi) then
! Allocation due to mutual information measurement
deallocate(Obj%Elem)
end if
end subroutine destroy_rhoij_observables_tensor
"""
return
[docs]def destroy_rhoij_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing two site density matrices.
**Arguments**
Obj : TYPE(rhoij_observables), inout
Will be deallocated on exit.
has_mi : LOGICAL, in
If the mutual information (True) is measured, all
two-site density matrices are set.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_rhoij_observables_tensorc(Obj, has_mi)
type(rhoij_observables_tensorc), intent(inout) :: Obj
logical, intent(in) :: has_mi
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%hasrho_ij) then
do ii = 1, size(Obj%rho_ij_is, 1)
deallocate(Obj%Rho_ij_js(ii)%elem)
end do
deallocate(Obj%rho_ij_is, Obj%Rho_ij_js, Obj%Elem)
Obj%hasrho_ij = .false.
elseif(has_mi) then
! Allocation due to mutual information measurement
deallocate(Obj%Elem)
end if
end subroutine destroy_rhoij_observables_tensorc
"""
return
[docs]def destroy_rhoijk_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing a general reduced density matrices.
**Arguments**
Obj : TYPE(rhoijk_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_rhoijk_observables_tensor(Obj)
type(rhoijk_observables_tensor), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Obj%nn
deallocate(Obj%Sites(ii)%elem)
end do
deallocate(Obj%sizes, Obj%cont, Obj%Sites, Obj%Elem)
end subroutine destroy_rhoijk_observables_tensor
"""
return
[docs]def destroy_rhoijk_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing a general reduced density matrices.
**Arguments**
Obj : TYPE(rhoijk_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_rhoijk_observables_tensorc(Obj)
type(rhoijk_observables_tensorc), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Obj%nn
deallocate(Obj%Sites(ii)%elem)
end do
deallocate(Obj%sizes, Obj%cont, Obj%Sites, Obj%Elem)
end subroutine destroy_rhoijk_observables_tensorc
"""
return
[docs]def destroy_lambda_observables():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing the singular values.
**Arguments**
Obj : TYPE(lambda_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_lambda_observables(Obj)
type(lambda_observables), intent(inout) :: Obj
! No local variables
! ------------------
if(Obj%has_lambda) then
deallocate(Obj%lambda, Obj%Vecs)
Obj%has_lambda = .false.
end if
end subroutine destroy_lambda_observables
"""
return
[docs]def destroy_distance_psi_observables_mpsrc():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing the distance measures
to pure states.
**Arguments**
Obj : TYPE(lambda_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_distance_psi_observables_mpsrc(Obj)
type(distance_psi_observables_mpsrc), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%ndist > 0) then
do ii = 1, Obj%ndist
if(Obj%is_real(ii)) then
call destroy(Obj%Rpsi(ii))
else
call destroy(Obj%Cpsi(ii))
end if
end do
deallocate(Obj%Rpsi, Obj%Cpsi, Obj%is_real, Obj%elem)
Obj%ndist = 0
end if
end subroutine destroy_distance_psi_observables_mpsrc
"""
return
[docs]def destroy_distance_psi_observables_qmpsrc():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing the distance measures
to pure states.
**Arguments**
Obj : TYPE(lambda_observables), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_distance_psi_observables_qmpsrc(Obj)
type(distance_psi_observables_qmpsrc), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%ndist > 0) then
do ii = 1, Obj%ndist
if(Obj%is_real(ii)) then
call destroy(Obj%Rpsi(ii))
else
call destroy(Obj%Cpsi(ii))
end if
end do
deallocate(Obj%Rpsi, Obj%Cpsi, Obj%is_real, Obj%elem)
Obj%ndist = 0
end if
end subroutine destroy_distance_psi_observables_qmpsrc
"""
return
[docs]def destroy_corr2nn_observables_real():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing correlations.
**Arguments**
Obj : TYPE(corr_observables_real), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_corr2nn_observables_real(Obj)
type(corr2nn_observables_real), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
!integer :: ii
if(Obj%ncorr > 0) then
!do ii = 1, Obj%ncorr
!call destroy(Obj%Corr)
!end do
deallocate(Obj%isherm, Obj%weight, Obj%ops, Obj%elem)
Obj%ncorr = 0
end if
end subroutine destroy_corr2nn_observables_real
"""
return
[docs]def destroy_corr2nn_observables_complex():
"""
fortran-subroutine - August 2017 (dj)
Destroy the derived type storing correlations.
**Arguments**
Obj : TYPE(corr_observables_complex), inout
Will be deallocated on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_corr2nn_observables_complex(Obj)
type(corr2nn_observables_complex), intent(inout) :: Obj
! Local variables
! ---------------
! for looping
!integer :: ii
if(Obj%ncorr > 0) then
!do ii = 1, Obj%ncorr
!call destroy(Obj%Corr)
!end do
deallocate(Obj%isherm, Obj%weight, Obj%ops, Obj%elem)
Obj%ncorr = 0
end if
end subroutine destroy_corr2nn_observables_complex
"""
return
[docs]def destroy_obs_r():
"""
fortran-subroutine - August 2017 (dj)
Deallocate all measures.
**Arguments**
Obj : TYPE(obs_r), inout
All measures are deallocated on exit.
unit : INTEGER, in
Can open file with definition of the observables on this
unit in order to delete it.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_obs_r(Obj, unit, unitmpo)
type(obs_r), intent(inout) :: Obj
integer, intent(in) :: unit, unitmpo
! No local variables
! ------------------
call destroy_site_observables(Obj%SO)
call destroy_siteentropy_observables(Obj%SE)
call destroy_bondentropy_observables(Obj%BE)
call destroy_corr_observables_real(Obj%CO)
call destroy_fcorr_observables_real(Obj%FCO)
call destroy_string_observables(Obj%STO)
call destroy_mpo_observables_mpo(Obj%MO, unitmpo)
call destroy_rhoi_observables_tensor(Obj%Ri)
call destroy_rhoij_observables_tensor(Obj%Rij, Obj%MI%has_mi)
call destroy_rhoijk_observables_tensor(Obj%Rijk)
call destroy_mutualinformation_observables(Obj%MI)
call destroy_lambda_observables(Obj%LO)
call destroy_distance_psi_observables_mpsrc(Obj%DPO)
call destroy_corr2nn_observables_real(Obj%C2NN)
open(unit=unit, file=trim(adjustl(Obj%name)), action='read', &
status='old')
close(unit, status='delete')
Obj%name = ''
end subroutine destroy_obs_r
"""
return
[docs]def destroy_obs_c():
"""
fortran-subroutine - August 2017 (dj)
Deallocate all measures.
**Arguments**
Obj : TYPE(obs_c), inout
All measures are deallocated on exit.
unit : INTEGER, in
Can open file with definition of the observables on this
unit in order to delete it.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_obs_c(Obj, unit, unitmpo)
type(obs_c), intent(inout) :: Obj
integer, intent(in) :: unit, unitmpo
! No local variables
! ------------------
call destroy_site_observables(Obj%SO)
call destroy_siteentropy_observables(Obj%SE)
call destroy_bondentropy_observables(Obj%BE)
call destroy_corr_observables_complex(Obj%CO)
call destroy_fcorr_observables_complex(Obj%FCO)
call destroy_string_observables(Obj%STO)
call destroy_mpo_observables_mpo(Obj%MO, unitmpo)
call destroy_rhoi_observables_tensorc(Obj%Ri)
call destroy_rhoij_observables_tensorc(Obj%Rij, Obj%MI%has_mi)
call destroy_rhoijk_observables_tensorc(Obj%Rijk)
call destroy_mutualinformation_observables(Obj%MI)
call destroy_lambda_observables(Obj%LO)
call destroy_distance_psi_observables_mpsrc(Obj%DPO)
call destroy_corr2nn_observables_complex(Obj%C2NN)
open(unit=unit, file=trim(adjustl(Obj%name)), action='read', &
status='old')
close(unit, status='delete')
Obj%name = ''
end subroutine destroy_obs_c
"""
return
[docs]def destroy_obsc():
"""
fortran-subroutine - August 2017 (dj)
Deallocate all measures.
**Arguments**
Obj : TYPE(obsc), inout
All measures are deallocated on exit.
unit : INTEGER, in
Can open file with definition of the observables on this
unit in order to delete it.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_obsc(Obj, unit, unitmpo)
type(obsc), intent(inout) :: Obj
integer, intent(in) :: unit, unitmpo
! No local variables
! ------------------
call destroy_site_observables(Obj%SO)
call destroy_siteentropy_observables(Obj%SE)
call destroy_bondentropy_observables(Obj%BE)
call destroy_corr_observables_complex(Obj%CO)
call destroy_fcorr_observables_complex(Obj%FCO)
call destroy_string_observables(Obj%STO)
call destroy_mpo_observables_mpoc(Obj%MO, unitmpo)
call destroy_rhoi_observables_tensorc(Obj%Ri)
call destroy_rhoij_observables_tensorc(Obj%Rij, Obj%MI%has_mi)
call destroy_rhoijk_observables_tensorc(Obj%Rijk)
call destroy_mutualinformation_observables(Obj%MI)
call destroy_lambda_observables(Obj%LO)
call destroy_distance_psi_observables_mpsrc(Obj%DPO)
call destroy_corr2nn_observables_complex(Obj%C2NN)
open(unit=unit, file=trim(adjustl(Obj%name)), action='read', &
status='old')
close(unit, status='delete')
Obj%name = ''
end subroutine destroy_obsc
"""
return
[docs]def destroy_qobs_r():
"""
fortran-subroutine - August 2017 (dj)
Deallocate all measures.
**Arguments**
Obj : TYPE(qobs_r), inout
All measures are deallocated on exit.
unit : INTEGER, in
Can open file with definition of the observables on this
unit in order to delete it.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qobs_r(Obj, unit, unitmpo)
type(qobs_r), intent(inout) :: Obj
integer, intent(in) :: unit, unitmpo
! No local variables
! ------------------
call destroy_site_observables(Obj%SO)
call destroy_siteentropy_observables(Obj%SE)
call destroy_bondentropy_observables(Obj%BE)
call destroy_corr_observables_real(Obj%CO)
call destroy_fcorr_observables_real(Obj%FCO)
call destroy_string_observables(Obj%STO)
call destroy_mpo_observables_qmpo(Obj%MO, unitmpo)
call destroy_rhoi_observables_tensor(Obj%Ri)
call destroy_rhoij_observables_tensor(Obj%Rij, Obj%MI%has_mi)
call destroy_rhoijk_observables_tensor(Obj%Rijk)
call destroy_mutualinformation_observables(Obj%MI)
call destroy_lambda_observables(Obj%LO)
call destroy_distance_psi_observables_qmpsrc(Obj%DPO)
call destroy_corr2nn_observables_real(Obj%C2NN)
open(unit=unit, file=trim(adjustl(Obj%name)), action='read', &
status='old')
close(unit, status='delete')
Obj%name = ''
end subroutine destroy_qobs_r
"""
return
[docs]def destroy_qobs_c():
"""
fortran-subroutine - August 2017 (dj)
Deallocate all measures.
**Arguments**
Obj : TYPE(qobs_c), inout
All measures are deallocated on exit.
unit : INTEGER, in
Can open file with definition of the observables on this
unit in order to delete it.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qobs_c(Obj, unit, unitmpo)
type(qobs_c), intent(inout) :: Obj
integer, intent(in) :: unit, unitmpo
! No local variables
! ------------------
call destroy_site_observables(Obj%SO)
call destroy_siteentropy_observables(Obj%SE)
call destroy_bondentropy_observables(Obj%BE)
call destroy_corr_observables_complex(Obj%CO)
call destroy_fcorr_observables_complex(Obj%FCO)
call destroy_string_observables(Obj%STO)
call destroy_mpo_observables_qmpo(Obj%MO, unitmpo)
call destroy_rhoi_observables_tensorc(Obj%Ri)
call destroy_rhoij_observables_tensorc(Obj%Rij, Obj%MI%has_mi)
call destroy_rhoijk_observables_tensorc(Obj%Rijk)
call destroy_mutualinformation_observables(Obj%MI)
call destroy_lambda_observables(Obj%LO)
call destroy_distance_psi_observables_qmpsrc(Obj%DPO)
call destroy_corr2nn_observables_complex(Obj%C2NN)
open(unit=unit, file=trim(adjustl(Obj%name)), action='read', &
status='old')
close(unit, status='delete')
Obj%name = ''
end subroutine destroy_qobs_c
"""
return
[docs]def destroy_qobsc():
"""
fortran-subroutine - August 2017 (dj)
Deallocate all measures.
**Arguments**
Obj : TYPE(qobsc), inout
All measures are deallocated on exit.
unit : INTEGER, in
Can open file with definition of the observables on this
unit in order to delete it.
unitmpo : INTEGER, in
Can open file with MPO on this unit in order to delete it.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qobsc(Obj, unit, unitmpo)
type(qobsc), intent(inout) :: Obj
integer, intent(in) :: unit, unitmpo
! No local variables
! ------------------
call destroy_site_observables(Obj%SO)
call destroy_siteentropy_observables(Obj%SE)
call destroy_bondentropy_observables(Obj%BE)
call destroy_corr_observables_complex(Obj%CO)
call destroy_fcorr_observables_complex(Obj%FCO)
call destroy_string_observables(Obj%STO)
call destroy_mpo_observables_qmpoc(Obj%MO, unitmpo)
call destroy_rhoi_observables_tensorc(Obj%Ri)
call destroy_rhoij_observables_tensorc(Obj%Rij, Obj%MI%has_mi)
call destroy_rhoijk_observables_tensorc(Obj%Rijk)
call destroy_mutualinformation_observables(Obj%MI)
call destroy_lambda_observables(Obj%LO)
call destroy_distance_psi_observables_qmpsrc(Obj%DPO)
call destroy_corr2nn_observables_complex(Obj%C2NN)
open(unit=unit, file=trim(adjustl(Obj%name)), action='read', &
status='old')
close(unit, status='delete')
Obj%name = ''
end subroutine destroy_qobsc
"""
return
[docs]def meas_psi_mpo_phi_mps_mpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle \psi \\mid H \\mid \phi \\rangle` using the MPO
form of :math:`H`.
**Arguments**
val : REAL_OR_COMPLEX, out
result of the measurement
H : TYPE(mpo), inout
The MPO to be measured.
psiA : TYPE(mps), inout
First state to calculate the overlap.
psiB : TYPE(mps), inout
Second state to calculate the overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_psi_mpo_phi_mps_mpo(val, Ham, Psi, Phi, errst)
real(KIND=rKind), intent(out) :: val
type(mpo), intent(inout) :: Ham
type(mps), intent(inout) :: Psi, Phi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlist) :: Lmat
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Phi%Aa(Phi%ll), .true., errst=errst)
!if(prop_error('meas_psi_mpo_phi_mps_mpo : '//&
! ' ptm_left_mpo (1) failed.', 'ObsOps_include.f90:657', &
! errst=errst)) return
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Phi%Aa(ii), .false.)
!if(prop_error('meas_psi_mpo_phi_mps_mpo : '//&
! ' ptm_left_mpo (2) failed.', 'ObsOps_include.f90:664', &
! errst=errst)) return
end do
val = trace(Lmat%Li(1))
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_psi_mpo_phi_mps_mpo
"""
return
[docs]def meas_psi_mpo_phi_mpsc_mpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle \psi \\mid H \\mid \phi \\rangle` using the MPO
form of :math:`H`.
**Arguments**
val : REAL_OR_COMPLEX, out
result of the measurement
H : TYPE(mpo), inout
The MPO to be measured.
psiA : TYPE(mpsc), inout
First state to calculate the overlap.
psiB : TYPE(mpsc), inout
Second state to calculate the overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_psi_mpo_phi_mpsc_mpo(val, Ham, Psi, Phi, errst)
complex(KIND=rKind), intent(out) :: val
type(mpo), intent(inout) :: Ham
type(mpsc), intent(inout) :: Psi, Phi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlistc) :: Lmat
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Phi%Aa(Phi%ll), .true., errst=errst)
!if(prop_error('meas_psi_mpo_phi_mpsc_mpo : '//&
! ' ptm_left_mpo (1) failed.', 'ObsOps_include.f90:657', &
! errst=errst)) return
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Phi%Aa(ii), .false.)
!if(prop_error('meas_psi_mpo_phi_mpsc_mpo : '//&
! ' ptm_left_mpo (2) failed.', 'ObsOps_include.f90:664', &
! errst=errst)) return
end do
val = trace(Lmat%Li(1))
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_psi_mpo_phi_mpsc_mpo
"""
return
[docs]def meas_psi_mpo_phi_mpsc_mpoc():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle \psi \\mid H \\mid \phi \\rangle` using the MPO
form of :math:`H`.
**Arguments**
val : REAL_OR_COMPLEX, out
result of the measurement
H : TYPE(mpoc), inout
The MPO to be measured.
psiA : TYPE(mpsc), inout
First state to calculate the overlap.
psiB : TYPE(mpsc), inout
Second state to calculate the overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_psi_mpo_phi_mpsc_mpoc(val, Ham, Psi, Phi, errst)
complex(KIND=rKind), intent(out) :: val
type(mpoc), intent(inout) :: Ham
type(mpsc), intent(inout) :: Psi, Phi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlistc) :: Lmat
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Phi%Aa(Phi%ll), .true., errst=errst)
!if(prop_error('meas_psi_mpo_phi_mpsc_mpoc : '//&
! ' ptm_left_mpo (1) failed.', 'ObsOps_include.f90:657', &
! errst=errst)) return
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Phi%Aa(ii), .false.)
!if(prop_error('meas_psi_mpo_phi_mpsc_mpoc : '//&
! ' ptm_left_mpo (2) failed.', 'ObsOps_include.f90:664', &
! errst=errst)) return
end do
val = trace(Lmat%Li(1))
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_psi_mpo_phi_mpsc_mpoc
"""
return
[docs]def meas_psi_mpo_phi_qmps_qmpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle \psi \\mid H \\mid \phi \\rangle` using the MPO
form of :math:`H`.
**Arguments**
val : REAL_OR_COMPLEX, out
result of the measurement
H : TYPE(qmpo), inout
The MPO to be measured.
psiA : TYPE(qmps), inout
First state to calculate the overlap.
psiB : TYPE(qmps), inout
Second state to calculate the overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_psi_mpo_phi_qmps_qmpo(val, Ham, Psi, Phi, errst)
real(KIND=rKind), intent(out) :: val
type(qmpo), intent(inout) :: Ham
type(qmps), intent(inout) :: Psi, Phi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorlist) :: Lmat
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Phi%Aa(Phi%ll), .true., errst=errst)
!if(prop_error('meas_psi_mpo_phi_qmps_qmpo : '//&
! ' ptm_left_mpo (1) failed.', 'ObsOps_include.f90:657', &
! errst=errst)) return
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Phi%Aa(ii), .false.)
!if(prop_error('meas_psi_mpo_phi_qmps_qmpo : '//&
! ' ptm_left_mpo (2) failed.', 'ObsOps_include.f90:664', &
! errst=errst)) return
end do
val = trace(Lmat%Li(1))
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_psi_mpo_phi_qmps_qmpo
"""
return
[docs]def meas_psi_mpo_phi_qmpsc_qmpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle \psi \\mid H \\mid \phi \\rangle` using the MPO
form of :math:`H`.
**Arguments**
val : REAL_OR_COMPLEX, out
result of the measurement
H : TYPE(qmpo), inout
The MPO to be measured.
psiA : TYPE(qmpsc), inout
First state to calculate the overlap.
psiB : TYPE(qmpsc), inout
Second state to calculate the overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_psi_mpo_phi_qmpsc_qmpo(val, Ham, Psi, Phi, errst)
complex(KIND=rKind), intent(out) :: val
type(qmpo), intent(inout) :: Ham
type(qmpsc), intent(inout) :: Psi, Phi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorclist) :: Lmat
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Phi%Aa(Phi%ll), .true., errst=errst)
!if(prop_error('meas_psi_mpo_phi_qmpsc_qmpo : '//&
! ' ptm_left_mpo (1) failed.', 'ObsOps_include.f90:657', &
! errst=errst)) return
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Phi%Aa(ii), .false.)
!if(prop_error('meas_psi_mpo_phi_qmpsc_qmpo : '//&
! ' ptm_left_mpo (2) failed.', 'ObsOps_include.f90:664', &
! errst=errst)) return
end do
val = trace(Lmat%Li(1))
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_psi_mpo_phi_qmpsc_qmpo
"""
return
[docs]def meas_psi_mpo_phi_qmpsc_qmpoc():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle \psi \\mid H \\mid \phi \\rangle` using the MPO
form of :math:`H`.
**Arguments**
val : REAL_OR_COMPLEX, out
result of the measurement
H : TYPE(qmpoc), inout
The MPO to be measured.
psiA : TYPE(qmpsc), inout
First state to calculate the overlap.
psiB : TYPE(qmpsc), inout
Second state to calculate the overlap.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_psi_mpo_phi_qmpsc_qmpoc(val, Ham, Psi, Phi, errst)
complex(KIND=rKind), intent(out) :: val
type(qmpoc), intent(inout) :: Ham
type(qmpsc), intent(inout) :: Psi, Phi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorclist) :: Lmat
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Phi%Aa(Phi%ll), .true., errst=errst)
!if(prop_error('meas_psi_mpo_phi_qmpsc_qmpoc : '//&
! ' ptm_left_mpo (1) failed.', 'ObsOps_include.f90:657', &
! errst=errst)) return
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Phi%Aa(ii), .false.)
!if(prop_error('meas_psi_mpo_phi_qmpsc_qmpoc : '//&
! ' ptm_left_mpo (2) failed.', 'ObsOps_include.f90:664', &
! errst=errst)) return
end do
val = trace(Lmat%Li(1))
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_psi_mpo_phi_qmpsc_qmpoc
"""
return
[docs]def meas_mpo_mps_mpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle H \\rangle` using the MPO form of :math:`H`.
**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.
Psi : TYPE(mps), inout
Measure this state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_mps_mpo(val, Ham, Psi, errst)
real(KIND=rKind), intent(out) :: val
type(mpo), intent(inout) :: Ham
type(mps), intent(inout) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlist) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Psi%Aa(Psi%ll), .true.)
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Psi%Aa(ii), .false.)
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_mps_mpo
"""
return
[docs]def meas_mpo_mpsc_mpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle H \\rangle` using the MPO form of :math:`H`.
**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.
Psi : TYPE(mpsc), inout
Measure this state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_mpsc_mpo(val, Ham, Psi, errst)
real(KIND=rKind), intent(out) :: val
type(mpo), intent(inout) :: Ham
type(mpsc), intent(inout) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlistc) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Psi%Aa(Psi%ll), .true.)
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Psi%Aa(ii), .false.)
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_mpsc_mpo
"""
return
[docs]def meas_mpo_mpsc_mpoc():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle H \\rangle` using the MPO form of :math:`H`.
**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.
Psi : TYPE(mpsc), inout
Measure this state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_mpsc_mpoc(val, Ham, Psi, errst)
real(KIND=rKind), intent(out) :: val
type(mpoc), intent(inout) :: Ham
type(mpsc), intent(inout) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(tensorlistc) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Psi%Aa(Psi%ll), .true.)
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Psi%Aa(ii), .false.)
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_mpsc_mpoc
"""
return
[docs]def meas_mpo_qmps_qmpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle H \\rangle` using the MPO form of :math:`H`.
**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.
Psi : TYPE(qmps), inout
Measure this state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qmps_qmpo(val, Ham, Psi, errst)
real(KIND=rKind), intent(out) :: val
type(qmpo), intent(inout) :: Ham
type(qmps), intent(inout) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorlist) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Psi%Aa(Psi%ll), .true.)
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Psi%Aa(ii), .false.)
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qmps_qmpo
"""
return
[docs]def meas_mpo_qmpsc_qmpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle H \\rangle` using the MPO form of :math:`H`.
**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.
Psi : TYPE(qmpsc), inout
Measure this state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qmpsc_qmpo(val, Ham, Psi, errst)
real(KIND=rKind), intent(out) :: val
type(qmpo), intent(inout) :: Ham
type(qmpsc), intent(inout) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorclist) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Psi%Aa(Psi%ll), .true.)
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Psi%Aa(ii), .false.)
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qmpsc_qmpo
"""
return
[docs]def meas_mpo_qmpsc_qmpoc():
"""
fortran-subroutine - July 2017 (dj, updated)
Compute :math:`\\langle H \\rangle` using the MPO form of :math:`H`.
**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.
Psi : TYPE(qmpsc), inout
Measure this state.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine meas_mpo_qmpsc_qmpoc(val, Ham, Psi, errst)
real(KIND=rKind), intent(out) :: val
type(qmpoc), intent(inout) :: Ham
type(qmpsc), intent(inout) :: Psi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Contracting the overlap
type(qtensorclist) :: Lmat
!if(present(errst)) errst = 0
! Last site
call ptm_left_mpo(Lmat, Psi%Aa(Psi%ll), Ham%Ws(Psi%ll), &
Psi%Aa(Psi%ll), .true.)
! Looping
do ii = (Psi%ll - 1), 1, (-1)
call ptm_left_mpo(Lmat, Psi%Aa(ii), Ham%Ws(ii), Psi%Aa(ii), .false.)
end do
val = real(trace(Lmat%Li(1)), KIND=rKind)
call destroy(Lmat%Li(1))
deallocate(Lmat%Li)
end subroutine meas_mpo_qmpsc_qmpoc
"""
return
[docs]def meas_rhoij_corr_tensor_tensor():
"""
fortran-function - November 2017 (dj)
Measure a correlation based on the reduced two site density matrix.
**Arguments**
Rhoij : TYPE(tensor), inout
On exit, the two-site reduced density matrix.
Opl : TYPE(tensor), inout
Operator for the first site.
Opr : TYPE(tensor), inout
Operator for the second site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function meas_rhoij_corr_tensor_tensor(Rhoij, Opl, Opr, &
errst) result(sc)
type(tensor), intent(inout) :: Rhoij
type(tensor), intent(inout) :: Opl, Opr
integer, intent(out), optional :: errst
real(KIND=rKind) :: sc
! Local variables
! ---------------
! temporary tensors for rho x operator
type(tensor) :: Rxo1, Rxo2
!if(present(errst)) errst = 0
call contr(Rxo1, Rhoij, Opr, [4], [1])
call contr(Rxo2, Rxo1, Opl, [3], [1])
call destroy(Rxo1)
call transposed(Rxo2, [1, 2, 4, 3], doperm=.true.)
call pcontr(Rxo1, Rxo2, [1, 2], [3, 4])
sc = get_scalar(Rxo1)
call destroy(Rxo1)
call destroy(Rxo2)
end function meas_rhoij_corr_tensor_tensor
"""
return
[docs]def meas_rhoij_corr_tensorc_tensor():
"""
fortran-function - November 2017 (dj)
Measure a correlation based on the reduced two site density matrix.
**Arguments**
Rhoij : TYPE(tensorc), inout
On exit, the two-site reduced density matrix.
Opl : TYPE(tensor), inout
Operator for the first site.
Opr : TYPE(tensor), inout
Operator for the second site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function meas_rhoij_corr_tensorc_tensor(Rhoij, Opl, Opr, &
errst) result(sc)
type(tensorc), intent(inout) :: Rhoij
type(tensor), intent(inout) :: Opl, Opr
integer, intent(out), optional :: errst
complex(KIND=rKind) :: sc
! Local variables
! ---------------
! temporary tensors for rho x operator
type(tensorc) :: Rxo1, Rxo2
!if(present(errst)) errst = 0
call contr(Rxo1, Rhoij, Opr, [4], [1])
call contr(Rxo2, Rxo1, Opl, [3], [1])
call destroy(Rxo1)
call transposed(Rxo2, [1, 2, 4, 3], doperm=.true.)
call pcontr(Rxo1, Rxo2, [1, 2], [3, 4])
sc = get_scalar(Rxo1)
call destroy(Rxo1)
call destroy(Rxo2)
end function meas_rhoij_corr_tensorc_tensor
"""
return
[docs]def meas_rhoij_corr_tensorc_tensorc():
"""
fortran-function - November 2017 (dj)
Measure a correlation based on the reduced two site density matrix.
**Arguments**
Rhoij : TYPE(tensorc), inout
On exit, the two-site reduced density matrix.
Opl : TYPE(tensorc), inout
Operator for the first site.
Opr : TYPE(tensorc), inout
Operator for the second site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function meas_rhoij_corr_tensorc_tensorc(Rhoij, Opl, Opr, &
errst) result(sc)
type(tensorc), intent(inout) :: Rhoij
type(tensorc), intent(inout) :: Opl, Opr
integer, intent(out), optional :: errst
complex(KIND=rKind) :: sc
! Local variables
! ---------------
! temporary tensors for rho x operator
type(tensorc) :: Rxo1, Rxo2
!if(present(errst)) errst = 0
call contr(Rxo1, Rhoij, Opr, [4], [1])
call contr(Rxo2, Rxo1, Opl, [3], [1])
call destroy(Rxo1)
call transposed(Rxo2, [1, 2, 4, 3], doperm=.true.)
call pcontr(Rxo1, Rxo2, [1, 2], [3, 4])
sc = get_scalar(Rxo1)
call destroy(Rxo1)
call destroy(Rxo2)
end function meas_rhoij_corr_tensorc_tensorc
"""
return
[docs]def meas_rhoij_corr_qtensor_qtensor():
"""
fortran-function - November 2017 (dj)
Measure a correlation based on the reduced two site density matrix.
**Arguments**
Rhoij : TYPE(qtensor), inout
On exit, the two-site reduced density matrix.
Opl : TYPE(qtensor), inout
Operator for the first site.
Opr : TYPE(qtensor), inout
Operator for the second site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function meas_rhoij_corr_qtensor_qtensor(Rhoij, Opl, Opr, &
errst) result(sc)
type(qtensor), intent(inout) :: Rhoij
type(qtensor), intent(inout) :: Opl, Opr
integer, intent(out), optional :: errst
real(KIND=rKind) :: sc
! Local variables
! ---------------
! temporary tensors for rho x operator
type(qtensor) :: Rxo1, Rxo2
!if(present(errst)) errst = 0
call contr(Rxo1, Rhoij, Opr, [4], [1])
call contr(Rxo2, Rxo1, Opl, [3], [1])
call destroy(Rxo1)
call transposed(Rxo2, [1, 2, 4, 3], doperm=.true.)
call pcontr(Rxo1, Rxo2, [1, 2], [3, 4])
sc = get_scalar(Rxo1)
call destroy(Rxo1)
call destroy(Rxo2)
end function meas_rhoij_corr_qtensor_qtensor
"""
return
[docs]def meas_rhoij_corr_qtensorc_qtensor():
"""
fortran-function - November 2017 (dj)
Measure a correlation based on the reduced two site density matrix.
**Arguments**
Rhoij : TYPE(qtensorc), inout
On exit, the two-site reduced density matrix.
Opl : TYPE(qtensor), inout
Operator for the first site.
Opr : TYPE(qtensor), inout
Operator for the second site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function meas_rhoij_corr_qtensorc_qtensor(Rhoij, Opl, Opr, &
errst) result(sc)
type(qtensorc), intent(inout) :: Rhoij
type(qtensor), intent(inout) :: Opl, Opr
integer, intent(out), optional :: errst
complex(KIND=rKind) :: sc
! Local variables
! ---------------
! temporary tensors for rho x operator
type(qtensorc) :: Rxo1, Rxo2
!if(present(errst)) errst = 0
call contr(Rxo1, Rhoij, Opr, [4], [1])
call contr(Rxo2, Rxo1, Opl, [3], [1])
call destroy(Rxo1)
call transposed(Rxo2, [1, 2, 4, 3], doperm=.true.)
call pcontr(Rxo1, Rxo2, [1, 2], [3, 4])
sc = get_scalar(Rxo1)
call destroy(Rxo1)
call destroy(Rxo2)
end function meas_rhoij_corr_qtensorc_qtensor
"""
return
[docs]def meas_rhoij_corr_qtensorc_qtensorc():
"""
fortran-function - November 2017 (dj)
Measure a correlation based on the reduced two site density matrix.
**Arguments**
Rhoij : TYPE(qtensorc), inout
On exit, the two-site reduced density matrix.
Opl : TYPE(qtensorc), inout
Operator for the first site.
Opr : TYPE(qtensorc), inout
Operator for the second site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function meas_rhoij_corr_qtensorc_qtensorc(Rhoij, Opl, Opr, &
errst) result(sc)
type(qtensorc), intent(inout) :: Rhoij
type(qtensorc), intent(inout) :: Opl, Opr
integer, intent(out), optional :: errst
complex(KIND=rKind) :: sc
! Local variables
! ---------------
! temporary tensors for rho x operator
type(qtensorc) :: Rxo1, Rxo2
!if(present(errst)) errst = 0
call contr(Rxo1, Rhoij, Opr, [4], [1])
call contr(Rxo2, Rxo1, Opl, [3], [1])
call destroy(Rxo1)
call transposed(Rxo2, [1, 2, 4, 3], doperm=.true.)
call pcontr(Rxo1, Rxo2, [1, 2], [3, 4])
sc = get_scalar(Rxo1)
call destroy(Rxo1)
call destroy(Rxo2)
end function meas_rhoij_corr_qtensorc_qtensorc
"""
return
[docs]def corr_init_mps_tensor_tensor():
"""
fortran-subroutine - August 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Psikk : TYPE(tensor), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensor), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mps_tensor_tensor(Psikk, Theta, Op)
type(tensor), intent(inout) :: Psikk
type(tensor), intent(out) :: Theta
type(tensor), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(tensor) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
end subroutine corr_init_mps_tensor_tensor
"""
return
[docs]def corr_init_mps_tensorc_tensor():
"""
fortran-subroutine - August 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Psikk : TYPE(tensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mps_tensorc_tensor(Psikk, Theta, Op)
type(tensorc), intent(inout) :: Psikk
type(tensorc), intent(out) :: Theta
type(tensor), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
end subroutine corr_init_mps_tensorc_tensor
"""
return
[docs]def corr_init_mps_tensorc_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Psikk : TYPE(tensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mps_tensorc_tensorc(Psikk, Theta, Op)
type(tensorc), intent(inout) :: Psikk
type(tensorc), intent(out) :: Theta
type(tensorc), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
end subroutine corr_init_mps_tensorc_tensorc
"""
return
[docs]def corr_init_mps_qtensor_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Psikk : TYPE(qtensor), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensor), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mps_qtensor_qtensor(Psikk, Theta, Op)
type(qtensor), intent(inout) :: Psikk
type(qtensor), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
end subroutine corr_init_mps_qtensor_qtensor
"""
return
[docs]def corr_init_mps_qtensorc_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Psikk : TYPE(qtensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mps_qtensorc_qtensor(Psikk, Theta, Op)
type(qtensorc), intent(inout) :: Psikk
type(qtensorc), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
end subroutine corr_init_mps_qtensorc_qtensor
"""
return
[docs]def corr_init_mps_qtensorc_qtensorc():
"""
fortran-subroutine - August 2017 (dj)
Initialize the left overlap for a right-moving correlation measure.
**Arguments**
Psikk : TYPE(qtensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_mps_qtensorc_qtensorc(Psikk, Theta, Op)
type(qtensorc), intent(inout) :: Psikk
type(qtensorc), intent(out) :: Theta
type(qtensorc), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
end subroutine corr_init_mps_qtensorc_qtensorc
"""
return
[docs]def corr_init_l_mps_tensor_tensor():
"""
fortran-subroutine - August 2017 (dj)
Calculate correlation with a left-moving contraction. Initialization of
the right overlap.
**Arguments**
Psikk : TYPE(tensor), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensor), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mps_tensor_tensor(Psikk, Theta, Op)
type(tensor), intent(inout) :: Psikk
type(tensor), intent(out) :: Theta
type(tensor), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(tensor) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
end subroutine corr_init_l_mps_tensor_tensor
"""
return
[docs]def corr_init_l_mps_tensorc_tensor():
"""
fortran-subroutine - August 2017 (dj)
Calculate correlation with a left-moving contraction. Initialization of
the right overlap.
**Arguments**
Psikk : TYPE(tensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mps_tensorc_tensor(Psikk, Theta, Op)
type(tensorc), intent(inout) :: Psikk
type(tensorc), intent(out) :: Theta
type(tensor), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
end subroutine corr_init_l_mps_tensorc_tensor
"""
return
[docs]def corr_init_l_mps_tensorc_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Calculate correlation with a left-moving contraction. Initialization of
the right overlap.
**Arguments**
Psikk : TYPE(tensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(tensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mps_tensorc_tensorc(Psikk, Theta, Op)
type(tensorc), intent(inout) :: Psikk
type(tensorc), intent(out) :: Theta
type(tensorc), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
end subroutine corr_init_l_mps_tensorc_tensorc
"""
return
[docs]def corr_init_l_mps_qtensor_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Calculate correlation with a left-moving contraction. Initialization of
the right overlap.
**Arguments**
Psikk : TYPE(qtensor), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensor), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mps_qtensor_qtensor(Psikk, Theta, Op)
type(qtensor), intent(inout) :: Psikk
type(qtensor), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
end subroutine corr_init_l_mps_qtensor_qtensor
"""
return
[docs]def corr_init_l_mps_qtensorc_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Calculate correlation with a left-moving contraction. Initialization of
the right overlap.
**Arguments**
Psikk : TYPE(qtensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mps_qtensorc_qtensor(Psikk, Theta, Op)
type(qtensorc), intent(inout) :: Psikk
type(qtensorc), intent(out) :: Theta
type(qtensor), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
end subroutine corr_init_l_mps_qtensorc_qtensor
"""
return
[docs]def corr_init_l_mps_qtensorc_qtensorc():
"""
fortran-subroutine - August 2017 (dj)
Calculate correlation with a left-moving contraction. Initialization of
the right overlap.
**Arguments**
Psikk : TYPE(qtensorc), inout
Tensor representing the first site of the correlation measurement.
Theta : TYPE(qtensorc), out
On exit, left overlap for correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_init_l_mps_qtensorc_qtensorc(Psikk, Theta, Op)
type(qtensorc), intent(inout) :: Psikk
type(qtensorc), intent(out) :: Theta
type(qtensorc), intent(inout) :: Op
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
! First index |ket>, second <bra|
call contr(Theta, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
end subroutine corr_init_l_mps_qtensorc_qtensorc
"""
return
[docs]def corr_meas_mps_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(tensor), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensor), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mps_tensor_tensor(vals, Psikk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
real(KIND=rKIND), intent(out) :: vals
type(tensor), intent(inout) :: Psikk
integer, intent(in) :: kk, ll
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb, errst=errst)
!if(prop_error('corr_meas_mps_tensor_tensor : '//&
! 'get_scalar failed,', 'ObsOps_include.f90:1016', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [1, 3], [1, 2], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [1, 2], [1, 2], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine corr_meas_mps_tensor_tensor
"""
return
[docs]def corr_meas_mps_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(tensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mps_tensorc_tensor(vals, Psikk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=rKIND), intent(out) :: vals
type(tensorc), intent(inout) :: Psikk
integer, intent(in) :: kk, ll
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb, errst=errst)
!if(prop_error('corr_meas_mps_tensorc_tensor : '//&
! 'get_scalar failed,', 'ObsOps_include.f90:1016', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [1, 3], [1, 2], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [1, 2], [1, 2], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine corr_meas_mps_tensorc_tensor
"""
return
[docs]def corr_meas_mps_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(tensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensorc), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mps_tensorc_tensorc(vals, Psikk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=rKIND), intent(out) :: vals
type(tensorc), intent(inout) :: Psikk
integer, intent(in) :: kk, ll
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb, errst=errst)
!if(prop_error('corr_meas_mps_tensorc_tensorc : '//&
! 'get_scalar failed,', 'ObsOps_include.f90:1016', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [1, 3], [1, 2], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [1, 2], [1, 2], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine corr_meas_mps_tensorc_tensorc
"""
return
[docs]def corr_meas_mps_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(qtensor), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensor), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mps_qtensor_qtensor(vals, Psikk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
real(KIND=rKIND), intent(out) :: vals
type(qtensor), intent(inout) :: Psikk
integer, intent(in) :: kk, ll
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb, errst=errst)
!if(prop_error('corr_meas_mps_qtensor_qtensor : '//&
! 'get_scalar failed,', 'ObsOps_include.f90:1016', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [1, 3], [1, 2], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [1, 2], [1, 2], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine corr_meas_mps_qtensor_qtensor
"""
return
[docs]def corr_meas_mps_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(qtensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mps_qtensorc_qtensor(vals, Psikk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=rKIND), intent(out) :: vals
type(qtensorc), intent(inout) :: Psikk
integer, intent(in) :: kk, ll
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb, errst=errst)
!if(prop_error('corr_meas_mps_qtensorc_qtensor : '//&
! 'get_scalar failed,', 'ObsOps_include.f90:1016', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [1, 3], [1, 2], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [1, 2], [1, 2], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine corr_meas_mps_qtensorc_qtensor
"""
return
[docs]def corr_meas_mps_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(qtensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
The left overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensorc), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_mps_qtensorc_qtensorc(vals, Psikk, kk, ll, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=rKIND), intent(out) :: vals
type(qtensorc), intent(inout) :: Psikk
integer, intent(in) :: kk, ll
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j,k with j < k
! ---------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [2, 3], [3, 2])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb, errst=errst)
!if(prop_error('corr_meas_mps_qtensorc_qtensorc : '//&
! 'get_scalar failed,', 'ObsOps_include.f90:1016', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk < ll) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [1, 3], [1, 2], transr='C')
call destroy(Tmpb)
elseif(kk < ll) then
! No phase
call contr(Tmpa, Theta, Psikk, [1], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [1, 2], [1, 2], transr='C')
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine corr_meas_mps_qtensorc_qtensorc
"""
return
[docs]def corr_meas_l_mps_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(tensor), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensor), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mps_tensor_tensor(vals, Psikk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
real(KIND=RKind), intent(out) :: vals
type(tensor), intent(inout) :: Psikk
integer, intent(in) :: kk
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with j < k
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
!if(prop_error('corr_meas_l_mps_tensor_tensor : '//&
! 'get_scalar failed.', 'ObsOps_include.f90:1147', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [3, 2], [2, 3], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [2, 3], [2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_mps_tensor_tensor
"""
return
[docs]def corr_meas_l_mps_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(tensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mps_tensorc_tensor(vals, Psikk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=RKind), intent(out) :: vals
type(tensorc), intent(inout) :: Psikk
integer, intent(in) :: kk
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with j < k
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
!if(prop_error('corr_meas_l_mps_tensorc_tensor : '//&
! 'get_scalar failed.', 'ObsOps_include.f90:1147', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [3, 2], [2, 3], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [2, 3], [2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_mps_tensorc_tensor
"""
return
[docs]def corr_meas_l_mps_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(tensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(tensorc), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(tensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(tensorc), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mps_tensorc_tensorc(vals, Psikk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=RKind), intent(out) :: vals
type(tensorc), intent(inout) :: Psikk
integer, intent(in) :: kk
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with j < k
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
!if(prop_error('corr_meas_l_mps_tensorc_tensorc : '//&
! 'get_scalar failed.', 'ObsOps_include.f90:1147', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [3, 2], [2, 3], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [2, 3], [2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_mps_tensorc_tensorc
"""
return
[docs]def corr_meas_l_mps_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(qtensor), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensor), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mps_qtensor_qtensor(vals, Psikk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
real(KIND=RKind), intent(out) :: vals
type(qtensor), intent(inout) :: Psikk
integer, intent(in) :: kk
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with j < k
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
!if(prop_error('corr_meas_l_mps_qtensor_qtensor : '//&
! 'get_scalar failed.', 'ObsOps_include.f90:1147', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [3, 2], [2, 3], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [2, 3], [2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_mps_qtensor_qtensor
"""
return
[docs]def corr_meas_l_mps_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(qtensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensor), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensor), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mps_qtensorc_qtensor(vals, Psikk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=RKind), intent(out) :: vals
type(qtensorc), intent(inout) :: Psikk
integer, intent(in) :: kk
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with j < k
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
!if(prop_error('corr_meas_l_mps_qtensorc_qtensor : '//&
! 'get_scalar failed.', 'ObsOps_include.f90:1147', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [3, 2], [2, 3], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [2, 3], [2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_mps_qtensorc_qtensor
"""
return
[docs]def corr_meas_l_mps_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Measurement process for correlations. Propagation of overlap for next measurement.
Left-moving version.
**Arguments**
vals : REAL, out
Outcome of the correlation measurement.
Psikk : TYPE(qtensorc), inout
Tensor representing site kk of the system.
kk : INTEGER, in
Site index of the current tensor.
ll : INTEGER, in
System size.
Theta : TYPE(qtensorc), inout
The right overlap starting on the first site of the
correlation measurement.
Op : TYPE(qtensorc), inout
Operator for the correlation measurement.
PhaseOp : TYPE(qtensorc), inout
Phase operator for propagation for the following
correlation measurements.
hasphase : LOGICAL, in
Flag if phase operator is contracted (.true.).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine corr_meas_l_mps_qtensorc_qtensorc(vals, Psikk, kk, &
Theta, Op, PhaseOp, hasphase, errst)
complex(KIND=RKind), intent(out) :: vals
type(qtensorc), intent(inout) :: Psikk
integer, intent(in) :: kk
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: Op, PhaseOp
logical, intent(in) :: hasphase
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
! 1) Calculate correlation j, k with j < k
! ----------------------------------------
! Need copy, Psikk will be permuted
call copy(Tmpa, Psikk)
call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
call destroy(Tmpa)
call contr(Tmpa, Psikk, Tmpb, [1, 2], [1, 3])
call destroy(Tmpb)
call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
vals = get_scalar(Tmpb)
!if(prop_error('corr_meas_l_mps_qtensorc_qtensorc : '//&
! 'get_scalar failed.', 'ObsOps_include.f90:1147', &
! errst=errst)) return
call destroy(Tmpb)
call destroy(Tmpa)
! 2) Propagate for the next site
! ------------------------------
if((kk > 1) .and. hasphase) then
! Has a phase operator to be contracted
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
call destroy(Tmpa)
call contr(Theta, Tmpb, Psikk, [3, 2], [2, 3], transr='C')
call destroy(Tmpb)
elseif(kk > 1) then
! No phase
call contr(Tmpa, Psikk, Theta, [3], [1])
call destroy(Theta)
call contr(Theta, Tmpa, Psikk, [2, 3], [2, 3], transr='C')
call destroy(Tmpa)
else
! Destroy - last call
call destroy(Theta)
end if
end subroutine corr_meas_l_mps_qtensorc_qtensorc
"""
return
[docs]def entropy_rho_kk_tensor():
"""
fortran-subroutine - August 2017 (dj)
Calculate the entropy of a single site density matrix. It uses
the natural logarithm.
**Arguments**
entropy : REAL, inout
On exit, the von-Neumann entropy of the single site. It uses the
natural log.
Rho : TYPE(tensor), inout
The density matrix for a single site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine entropy_rho_kk_tensor(entropy, Rho, errst)
real(KIND=rKind), intent(inout) :: entropy
type(tensor), intent(inout) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! for eigenvalues
real(KIND=rKind), dimension(:), allocatable :: ev
!if(present(errst)) errst = 0
allocate(ev(Rho%dl(1)))
call eigd_symm_real(Rho%elem(:Rho%dim), ev, Rho%dl(1), &
errst=errst)
!if(prop_error('entropy_rho_kk_tensor : eigd failed.', &
! 'ObsOps_include.f90:1229', errst=errst)) return
do ii = 1, Rho%dl(1)
if(ev(ii) > numzero) then
entropy = entropy - ev(ii) * log(ev(ii))
end if
end do
deallocate(ev)
end subroutine entropy_rho_kk_tensor
"""
return
[docs]def entropy_rho_kk_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Calculate the entropy of a single site density matrix. It uses
the natural logarithm.
**Arguments**
entropy : REAL, inout
On exit, the von-Neumann entropy of the single site. It uses the
natural log.
Rho : TYPE(tensorc), inout
The density matrix for a single site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine entropy_rho_kk_tensorc(entropy, Rho, errst)
real(KIND=rKind), intent(inout) :: entropy
type(tensorc), intent(inout) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! for eigenvalues
real(KIND=rKind), dimension(:), allocatable :: ev
!if(present(errst)) errst = 0
allocate(ev(Rho%dl(1)))
call eigd_symm_complex(Rho%elem(:Rho%dim), ev, Rho%dl(1), &
errst=errst)
!if(prop_error('entropy_rho_kk_tensorc : eigd failed.', &
! 'ObsOps_include.f90:1229', errst=errst)) return
do ii = 1, Rho%dl(1)
if(ev(ii) > numzero) then
entropy = entropy - ev(ii) * log(ev(ii))
end if
end do
deallocate(ev)
end subroutine entropy_rho_kk_tensorc
"""
return
[docs]def entropy_rho_kk_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Calculate the entropy of a single site density matrix. It uses
the natural logarithm.
**Arguments**
entropy : REAL, inout
On exit, the von-Neumann entropy of the single site. It uses the
natural log.
Rho : TYPE(qtensor), inout
The density matrix for a single site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine entropy_rho_kk_qtensor(entropy, Rho, errst)
real(KIND=rKind), intent(inout) :: entropy
type(qtensor), intent(inout) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! short-cut to dimension
integer :: dim
! for eigenvalues
real(KIND=rKind), dimension(:), allocatable :: ev
!if(present(errst)) errst = 0
do ii = 1, Rho%nb
dim = Rho%Data(ii)%Tens%dl(1)
allocate(ev(dim))
call eigd_symm_real(Rho%Data(ii)%Tens%elem(:dim**2), ev, &
dim, errst=errst)
!if(prop_error('entropy_rho_kk_qtensor : eigd failed.', &
! 'ObsOps_include.f90:1294', errst=errst)) return
do jj = 1, dim
if(ev(jj) > numzero) then
entropy = entropy - ev(jj) * log(ev(jj))
end if
end do
deallocate(ev)
end do
end subroutine entropy_rho_kk_qtensor
"""
return
[docs]def entropy_rho_kk_qtensorc():
"""
fortran-subroutine - August 2017 (dj)
Calculate the entropy of a single site density matrix. It uses
the natural logarithm.
**Arguments**
entropy : REAL, inout
On exit, the von-Neumann entropy of the single site. It uses the
natural log.
Rho : TYPE(qtensorc), inout
The density matrix for a single site.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine entropy_rho_kk_qtensorc(entropy, Rho, errst)
real(KIND=rKind), intent(inout) :: entropy
type(qtensorc), intent(inout) :: Rho
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! short-cut to dimension
integer :: dim
! for eigenvalues
real(KIND=rKind), dimension(:), allocatable :: ev
!if(present(errst)) errst = 0
do ii = 1, Rho%nb
dim = Rho%Data(ii)%Tens%dl(1)
allocate(ev(dim))
call eigd_symm_complex(Rho%Data(ii)%Tens%elem(:dim**2), ev, &
dim, errst=errst)
!if(prop_error('entropy_rho_kk_qtensorc : eigd failed.', &
! 'ObsOps_include.f90:1294', errst=errst)) return
do jj = 1, dim
if(ev(jj) > numzero) then
entropy = entropy - ev(jj) * log(ev(jj))
end if
end do
deallocate(ev)
end do
end subroutine entropy_rho_kk_qtensorc
"""
return
[docs]def lambdas_to_vec_tensor():
"""
fortran-subroutine - August 2017 (dj)
The version without symmetries provides a dummy interface resulting
in a simple copy of the singular values.
**Arguments**
Vec : TYPE(tensor), inout
On exit the singular values.
Lambdas : TYPE(tensor), in
Contains the singular values as stored in the MPS.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine lambdas_to_vec_tensor(Vec, Lambdas, errst)
type(tensor), intent(inout) :: Vec
type(tensor), intent(in) :: Lambdas
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
! No symmetries, reduces to a simple copy
call copy(Vec, Lambdas)
end subroutine lambdas_to_vec_tensor
"""
return
[docs]def lambdas_to_vec_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Combine the singular values for different quantum numbers to one vector.
**Arguments**
Vec : TYPE(tensor), inout
On exit the singular values.
Lambdas : TYPE(qtensor), in
Contains the singular values as stored in the MPS with symmetries.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine lambdas_to_vec_qtensor(Vec, Lambdas, errst)
type(tensor), intent(inout) :: Vec
type(qtensor), intent(in) :: Lambdas
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! index in total array
integer :: jj
! dimension of the vector without symmetries
integer :: dim
!if(present(errst)) errst = 0
dim = 0
do ii = 1, Lambdas%nb
dim = dim + Lambdas%Data(ii)%Tens%dl(1)
end do
call create(Vec, [dim])
jj = 0
do ii = 1, Lambdas%nb
Vec%elem((jj + 1):(jj + Lambdas%Data(ii)%Tens%dl(1))) = &
Lambdas%Data(ii)%Tens%elem(:Lambdas%Data(ii)%Tens%dim)
jj = jj + Lambdas%Data(ii)%Tens%dl(1)
end do
end subroutine lambdas_to_vec_qtensor
"""
return
[docs]def observe_mps_mpo():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an mps.
**Arguments**
Psi : TYPE(mps), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_mps_mpo(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(mps), intent(inout) :: Psi
type(tensorlist), intent(inout) :: Operators
type(obs_r), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(tensor) :: Rho
type(tensor), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensor) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(tensor) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
real(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(mps) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(tensor) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_mps_mpo : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_mps_mpo : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_mps_mpo : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_mps(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_mps_mpo '//&
! ': rhoij_meas_mps (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_mps_'//&
! 'mpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_mps_'//&
! 'mpo : rhoij_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mps_mpo '//&
! ': rhoij_meas_mps (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_mps_'//&
! 'mpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mps_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mps_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mps_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mps_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mps_mpo '//&
! ': corr_meas_mps (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mps_'//&
! 'mpo : corr_meas_'//&
! 'mps (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mps_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mps_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_mps_mpo '//&
! ': corr_meas_mps (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_mps_'//&
! 'mpo : corr_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mps_mpo: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mps_mpo: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_mps_mpo '//&
! ': corr_meas_mps (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_mps(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_mps_'//&
! 'mpo : corr_meas_'//&
! 'mps (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_mps(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_mps(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_mps_mpo : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_mps_mpo: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_mps_mpo
"""
return
[docs]def observe_mpsc_mpo():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an mps.
**Arguments**
Psi : TYPE(mpsc), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_mpsc_mpo(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(mpsc), intent(inout) :: Psi
type(tensorlist), intent(inout) :: Operators
type(obs_c), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(tensorc) :: Rho
type(tensorc), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensorc) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(tensorc) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
complex(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(mpsc) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(tensor) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_mpsc_mpo : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_mpsc_mpo : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_mpsc_mpo : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_mps(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_mpsc_mpo '//&
! ': rhoij_meas_mps (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpo : rhoij_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mpsc_mpo '//&
! ': rhoij_meas_mps (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mpsc_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mpsc_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mpsc_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mpsc_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mpsc_mpo '//&
! ': corr_meas_mps (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpo : corr_meas_'//&
! 'mps (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mpsc_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mpsc_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_mpsc_mpo '//&
! ': corr_meas_mps (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpo : corr_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mpsc_mpo: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mpsc_mpo: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_mpsc_mpo '//&
! ': corr_meas_mps (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_mps(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpo : corr_meas_'//&
! 'mps (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_mps(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_mps(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_mps_mpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_mpsc_mpo : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_mpsc_mpo : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_mpsc_mpo: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_mpsc_mpo
"""
return
[docs]def observe_mpsc_mpoc():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an mps.
**Arguments**
Psi : TYPE(mpsc), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_mpsc_mpoc(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(mpsc), intent(inout) :: Psi
type(tensorlistc), intent(inout) :: Operators
type(obsc), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(tensorc) :: Rho
type(tensorc), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensorc) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(tensorc) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
complex(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(mpsc) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(tensorc) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_mpsc_mpoc : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_mpsc_mpoc : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_mpsc_mpoc : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_mps(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_mpsc_mpoc '//&
! ': rhoij_meas_mps (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpoc : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpoc : rhoij_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mpsc_mpoc '//&
! ': rhoij_meas_mps (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpoc : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mpsc_mpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mpsc_mpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mpsc_mpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mpsc_mpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mpsc_mpoc '//&
! ': corr_meas_mps (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpoc : corr_meas_'//&
! 'mps (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mpsc_mpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mpsc_mpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_mpsc_mpoc '//&
! ': corr_meas_mps (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpoc : corr_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_mpsc_mpoc: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_mpsc_mpoc: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_mpsc_mpoc '//&
! ': corr_meas_mps (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_mps(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_mpsc_'//&
! 'mpoc : corr_meas_'//&
! 'mps (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_mps(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_mps_mpoc : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_mpoc : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_mps(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_mpoc : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_mps_mpoc : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_mpsc_mpoc : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_mpsc_mpoc : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_mpsc_mpoc: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_mpsc_mpoc
"""
return
[docs]def observe_qmps_qmpo():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an mps.
**Arguments**
Psi : TYPE(qmps), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_qmps_qmpo(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(qmps), intent(inout) :: Psi
type(qtensorlist), intent(inout) :: Operators
type(qobs_r), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(qtensor) :: Rho
type(qtensor), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensor) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(qtensor) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
real(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(qmps) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(qtensor) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qmps_qmpo : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qmps_qmpo : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_qmps_qmpo : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_mps(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_qmps_qmpo '//&
! ': rhoij_meas_mps (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_qmps_'//&
! 'qmpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_qmps_'//&
! 'qmpo : rhoij_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmps_qmpo '//&
! ': rhoij_meas_mps (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_qmps_'//&
! 'qmpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmps_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmps_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmps_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmps_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmps_qmpo '//&
! ': corr_meas_mps (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmps_'//&
! 'qmpo : corr_meas_'//&
! 'mps (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmps_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmps_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_qmps_qmpo '//&
! ': corr_meas_mps (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_qmps_'//&
! 'qmpo : corr_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmps_qmpo: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmps_qmpo: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qmps_qmpo '//&
! ': corr_meas_mps (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_mps(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qmps_'//&
! 'qmpo : corr_meas_'//&
! 'mps (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_mps(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_mps_qmpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_qmpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_mps(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_qmpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_mps_qmpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_qmps_qmpo : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_qmps_qmpo : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_qmps_qmpo: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_qmps_qmpo
"""
return
[docs]def observe_qmpsc_qmpo():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an mps.
**Arguments**
Psi : TYPE(qmpsc), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_qmpsc_qmpo(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(qmpsc), intent(inout) :: Psi
type(qtensorlist), intent(inout) :: Operators
type(qobs_c), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(qtensorc) :: Rho
type(qtensorc), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensorc) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(qtensorc) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
complex(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(qmpsc) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(qtensor) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qmpsc_qmpo : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qmpsc_qmpo : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_qmpsc_qmpo : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_mps(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_qmpsc_qmpo '//&
! ': rhoij_meas_mps (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpo : rhoij_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmpsc_qmpo '//&
! ': rhoij_meas_mps (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmpsc_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmpsc_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmpsc_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmpsc_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmpsc_qmpo '//&
! ': corr_meas_mps (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpo : corr_meas_'//&
! 'mps (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmpsc_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmpsc_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_qmpsc_qmpo '//&
! ': corr_meas_mps (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpo : corr_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmpsc_qmpo: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmpsc_qmpo: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qmpsc_qmpo '//&
! ': corr_meas_mps (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_mps(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpo : corr_meas_'//&
! 'mps (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_mps(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_mps_qmpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_qmpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_mps(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_qmpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_mps_qmpo : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_qmpsc_qmpo : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_qmpsc_qmpo : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_qmpsc_qmpo: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_qmpsc_qmpo
"""
return
[docs]def observe_qmpsc_qmpoc():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an mps.
**Arguments**
Psi : TYPE(qmpsc), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_qmpsc_qmpoc(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(qmpsc), intent(inout) :: Psi
type(qtensorclist), intent(inout) :: Operators
type(qobsc), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(qtensorc) :: Rho
type(qtensorc), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensorc) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(qtensorc) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
complex(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(qmpsc) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(qtensorc) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qmpsc_qmpoc : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qmpsc_qmpoc : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_qmpsc_qmpoc : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_mps(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_qmpsc_qmpoc '//&
! ': rhoij_meas_mps (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpoc : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_mps(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpoc : rhoij_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_mps(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmpsc_qmpoc '//&
! ': rhoij_meas_mps (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpoc : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmpsc_qmpoc '//&
! ': corr_meas_mps (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpoc : corr_meas_'//&
! 'mps (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_qmpsc_qmpoc '//&
! ': corr_meas_mps (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_mps(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpoc : corr_meas_'//&
! 'mps (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qmpsc_qmpoc '//&
! ': corr_meas_mps (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_mps(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qmpsc_'//&
! 'qmpoc : corr_meas_'//&
! 'mps (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_mps(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_mps(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_mps_qmpoc : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_qmpoc : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_mps(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_mps_qmpoc : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_mps(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_mps_qmpoc : '//&
! 'corr_meas_mps faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_qmpsc_qmpoc : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_qmpsc_qmpoc : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_qmpsc_qmpoc: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_qmpsc_qmpoc
"""
return
[docs]def observe_lptn_mpo():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an lptn.
**Arguments**
Psi : TYPE(lptn), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_lptn_mpo(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(lptn), intent(inout) :: Psi
type(tensorlist), intent(inout) :: Operators
type(obs_r), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(tensor) :: Rho
type(tensor), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensor) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(tensor) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
real(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(lptn) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(tensor) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_lptn_mpo : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_lptn_mpo : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_lptn_mpo : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_lptn(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_lptn_mpo '//&
! ': rhoij_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_lptn_'//&
! 'mpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_lptn_'//&
! 'mpo : rhoij_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptn_mpo '//&
! ': rhoij_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_lptn_'//&
! 'mpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptn_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptn_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptn_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptn_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptn_mpo '//&
! ': corr_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptn_'//&
! 'mpo : corr_meas_'//&
! 'lptn (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptn_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptn_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_lptn_mpo '//&
! ': corr_meas_lptn (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_lptn_'//&
! 'mpo : corr_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptn_mpo: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptn_mpo: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_lptn_mpo '//&
! ': corr_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_lptn_'//&
! 'mpo : corr_meas_'//&
! 'lptn (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_lptn(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_lptn(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_lptn_mpo : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_lptn_mpo: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_lptn_mpo
"""
return
[docs]def observe_lptnc_mpo():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an lptn.
**Arguments**
Psi : TYPE(lptnc), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_lptnc_mpo(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(lptnc), intent(inout) :: Psi
type(tensorlist), intent(inout) :: Operators
type(obs_c), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(tensorc) :: Rho
type(tensorc), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensorc) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(tensorc) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
complex(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(lptnc) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(tensor) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_lptnc_mpo : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_lptnc_mpo : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_lptnc_mpo : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_lptn(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_lptnc_mpo '//&
! ': rhoij_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpo : rhoij_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptnc_mpo '//&
! ': rhoij_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptnc_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptnc_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptnc_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptnc_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptnc_mpo '//&
! ': corr_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpo : corr_meas_'//&
! 'lptn (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptnc_mpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptnc_mpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_lptnc_mpo '//&
! ': corr_meas_lptn (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpo : corr_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptnc_mpo: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptnc_mpo: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_lptnc_mpo '//&
! ': corr_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpo : corr_meas_'//&
! 'lptn (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_lptn(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_lptn(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_lptn_mpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_lptnc_mpo : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_lptnc_mpo : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_lptnc_mpo: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_lptnc_mpo
"""
return
[docs]def observe_lptnc_mpoc():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an lptn.
**Arguments**
Psi : TYPE(lptnc), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_lptnc_mpoc(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(lptnc), intent(inout) :: Psi
type(tensorlistc), intent(inout) :: Operators
type(obsc), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(tensorc) :: Rho
type(tensorc), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensorc) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(tensorc) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
complex(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(lptnc) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(tensorc) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_lptnc_mpoc : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_lptnc_mpoc : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_lptnc_mpoc : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_lptn(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_lptnc_mpoc '//&
! ': rhoij_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpoc : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpoc : rhoij_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptnc_mpoc '//&
! ': rhoij_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpoc : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptnc_mpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptnc_mpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptnc_mpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptnc_mpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptnc_mpoc '//&
! ': corr_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpoc : corr_meas_'//&
! 'lptn (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptnc_mpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptnc_mpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_lptnc_mpoc '//&
! ': corr_meas_lptn (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpoc : corr_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_lptnc_mpoc: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_lptnc_mpoc: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_lptnc_mpoc '//&
! ': corr_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_lptnc_'//&
! 'mpoc : corr_meas_'//&
! 'lptn (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_lptn(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_lptn_mpoc : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_mpoc : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_lptn(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_mpoc : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_lptn_mpoc : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_lptnc_mpoc : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_lptnc_mpoc : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_lptnc_mpoc: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_lptnc_mpoc
"""
return
[docs]def observe_qlptn_qmpo():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an lptn.
**Arguments**
Psi : TYPE(qlptn), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_qlptn_qmpo(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(qlptn), intent(inout) :: Psi
type(qtensorlist), intent(inout) :: Operators
type(qobs_r), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(qtensor) :: Rho
type(qtensor), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensor) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(qtensor) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
real(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(qlptn) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(qtensor) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qlptn_qmpo : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qlptn_qmpo : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_qlptn_qmpo : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_lptn(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_qlptn_qmpo '//&
! ': rhoij_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_qlptn_'//&
! 'qmpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_qlptn_'//&
! 'qmpo : rhoij_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptn_qmpo '//&
! ': rhoij_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_qlptn_'//&
! 'qmpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptn_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptn_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptn_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptn_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptn_qmpo '//&
! ': corr_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptn_'//&
! 'qmpo : corr_meas_'//&
! 'lptn (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptn_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptn_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_qlptn_qmpo '//&
! ': corr_meas_lptn (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_qlptn_'//&
! 'qmpo : corr_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptn_qmpo: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptn_qmpo: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qlptn_qmpo '//&
! ': corr_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qlptn_'//&
! 'qmpo : corr_meas_'//&
! 'lptn (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_lptn(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_lptn_qmpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_qmpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_lptn(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_qmpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_lptn_qmpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_qlptn_qmpo : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_qlptn_qmpo : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_qlptn_qmpo: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_qlptn_qmpo
"""
return
[docs]def observe_qlptnc_qmpo():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an lptn.
**Arguments**
Psi : TYPE(qlptnc), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_qlptnc_qmpo(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(qlptnc), intent(inout) :: Psi
type(qtensorlist), intent(inout) :: Operators
type(qobs_c), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(qtensorc) :: Rho
type(qtensorc), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensorc) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(qtensorc) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
complex(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(qlptnc) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(qtensor) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qlptnc_qmpo : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qlptnc_qmpo : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_qlptnc_qmpo : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_lptn(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_qlptnc_qmpo '//&
! ': rhoij_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpo : rhoij_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptnc_qmpo '//&
! ': rhoij_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpo : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptnc_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptnc_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptnc_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptnc_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptnc_qmpo '//&
! ': corr_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpo : corr_meas_'//&
! 'lptn (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptnc_qmpo: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptnc_qmpo: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_qlptnc_qmpo '//&
! ': corr_meas_lptn (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpo : corr_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptnc_qmpo: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptnc_qmpo: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qlptnc_qmpo '//&
! ': corr_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpo : corr_meas_'//&
! 'lptn (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_lptn(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_lptn_qmpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_qmpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_lptn(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_qmpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_lptn_qmpo : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_qlptnc_qmpo : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_qlptnc_qmpo : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_qlptnc_qmpo: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_qlptnc_qmpo
"""
return
[docs]def observe_qlptnc_qmpoc():
"""
fortran-subroutine - Measure the observables `myObservables` and write to file for
an lptn.
**Arguments**
Psi : TYPE(qlptnc), inout
Measure this state.
Cp : TYPE(ConvParam), in
Most measurements do not depend on convergence parameters. But
the arbitrary reduced density matrices will access them as
possible permutations of local Hilbert spaces will need the
settings for splitting sites.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine observe_qlptnc_qmpoc(Psi, Operators, MyObs, &
obsname, baseout, timeevo_mps_delete, obsunit, &
energy, variance, converged, Imapper, Cp, time, le, qtid, errst)
type(qlptnc), intent(inout) :: Psi
type(qtensorclist), intent(inout) :: Operators
type(qobsc), intent(inout) :: MyObs
character(len=*), intent(in) :: obsname, baseout
character(len=*), intent(inout) :: timeevo_mps_delete
integer, intent(in) :: obsunit
real(KIND=rKind), intent(in) :: energy, variance
logical, intent(in) :: converged
type(imap), intent(in) :: Imapper
type(ConvParam), intent(in) :: Cp
real(KIND=rKind), intent(in), optional :: time
complex(KIND=rKind), intent(in), optional :: le
character(len=12), intent(in), optional :: qtid
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag if there is any measure shifting oc
logical :: anymeas
! flag if correlation matrix is transposed
logical :: fill_both
! flag for two-site density matrices
logical :: has_all_rhoij
! for looping
integer :: ii_, ii, jj, kk
! the order of looping
integer, dimension(:), allocatable :: loop
! saving an index
integer :: idx
! Storing density matrices
type(qtensorc) :: Rho
type(qtensorc), dimension(Psi%ll, Psi%ll) :: Rhoij
type(tensorc) :: Tmpij
! Saving position for interactive calls to correlations / 2 site rhos
integer :: idxinter
! Intermediate result for interactive calls to correlations
!type(MATRIX_TYPE) :: Linter
! Intermediate results for two-site density matrices
type(qtensorc) :: LTheta, RTheta, Tmptheta
! tracking error made in calculating general reduced density matrix
real(KIND=rKind) :: rhoerr
! Outcome of a correlation measurement / entropy
complex(KIND=rKind) :: sc
! Measure on a copy, then we do not have to canonize at the end
type(qlptnc) :: Phi
! For lambdas
type(tensor) :: Lambda
! For multiplying two operators (diagonal elements of correlations /
! Fermi phase operators)
TYPE(qtensorc) :: Tmp
! Format strings for write(*,*)
character(16) :: specstring
! Filename for writing out state
character(132) :: statename
!if(present(errst)) errst = 0
! Check if single site density matrix needs to be built
anymeas = .false.
anymeas = anymeas .or. (MyObs%SE%siteentr)
anymeas = anymeas .or. (MyObs%SO%nsite > 0)
anymeas = anymeas .or. (MyObs%CO%ncorr > 0)
anymeas = anymeas .or. (MyObs%FCO%ncorr > 0)
anymeas = anymeas .or. (MyObs%STO%nstring > 0)
anymeas = anymeas .or. (MyObs%Ri%hasrho_i)
anymeas = anymeas .or. (MyObs%MI%has_mi)
! Setup one loop from oc to ll and (oc - 1) to 1
if(anymeas) then
allocate(loop(Psi%ll))
ii = 1
do jj = Psi%oc, Psi%ll
loop(ii) = jj
ii = ii + 1
end do
do jj = (Psi%oc - 1), 1, (-1)
loop(ii) = jj
ii = ii + 1
end do
else
allocate(loop(0))
end if
! Make copy to save on orthogonalization
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qlptnc_qmpoc : copy (1) failed.', &
! 'ObsOps_include.f90:1554', errst=errst)) return
sites: do ii_ = 1, size(loop, 1)
ii = loop(ii_)
if(ii == Psi%oc - 1) then
! First entry of the backward loop
call destroy(Phi)
call copy(Phi, Psi, errst=errst)
!if(prop_error('observe_qlptnc_qmpoc : copy '// &
! '(2) failed.', 'ObsOps_include.f90:1563', &
! errst=errst)) return
end if
if(ii /= Phi%oc) call canonize_svd(Phi, ii)
! Save Lambdas
! ............
if(MyObs%LO%has_lambda .and. (ii /= Psi%ll)) then
idx = findtagindex(ii, MyObs%LO%lambda)
if(idx > 0) call lambdas_to_vec(MyObs%LO%Vecs(ii + 1), &
Phi%Lambda(ii + 1))
end if
! Save bond entropy
! .................
if(MyObs%BE%bondentr .and. is_set(Phi%Lambda(ii + 1))) then
call lambdas_to_vec(Lambda, Phi%Lambda(ii + 1))
Lambda%elem = Lambda%elem**2
do jj = 1, Lambda%dl(1)
if(Lambda%elem(jj) > numzero) then
MyObs%BE%elem(ii + 1) = MyObs%BE%elem(ii + 1) &
- Lambda%elem(jj) &
* log(Lambda%elem(jj))
end if
end do
call destroy(Lambda)
end if
call rho_kk(Rho, Phi, ii, errst=errst)
!if(prop_error('observe_qlptnc_qmpoc : rho_kk '// &
! 'failed.', 'ObsOps_include.f90:1600', errst=errst)) return
if(MyObs%Ri%hasrho_i) then
! Single site density matrices
! ............................
idx = findtagindex(ii, MyObs%Ri%rho_i_i)
if(idx > 0) call qmattomat(MyObs%Ri%Elem(ii), Rho, Imapper)
end if
has_all_rhoij = .false.
if(MyObs%MI%has_mi) then
! Two site density matrices (all of them)
! .........................
has_all_rhoij = .true.
if(ii /= Psi%ll) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
do jj = (ii + 1), Psi%ll
call rhoij_meas_lptn(Rhoij, Phi%Aa(jj), ii, jj, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
errst=errst)
!if(prop_error('observe_qlptnc_qmpoc '//&
! ': rhoij_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1627', errst=errst)) return
call qmattomat(MyObs%Rij%Elem(ii, jj), Rhoij(ii, jj), &
Imapper, errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpoc : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1633', &
! errst=errst)) return
end do
end if
elseif(MyObs%Rij%hasrho_ij) then
! Two site density matrices (selected)
! .........................
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
call rhoij_init_lptn(Phi%Aa(ii), Ltheta)
idxinter = ii
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
do kk = (idxinter + 1), &
(MyObs%Rij%Rho_ij_js(idx)%elem(jj) - 1)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, &
Psi%ll, Ltheta, Operators%Li(1), .false., &
skip=.true., errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpoc : rhoij_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1655', errst=errst)) return
end do
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call rhoij_meas_lptn(Rhoij, Phi%Aa(kk), ii, kk, Psi%ll, &
Ltheta, Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptnc_qmpoc '//&
! ': rhoij_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1663', errst=errst)) return
idxinter = kk
call qmattomat(MyObs%Rij%Elem(ii, kk), Rhoij(ii, kk), &
Imapper, errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpoc : qmattomat '//&
! 'failed.', 'ObsOps_include.f90:1671', &
! errst=errst)) return
end do
! Ltheta is automatically destroyed iff Psi%ll measured
if(idxinter /= Psi%ll) call destroy(Ltheta)
has_all_rhoij = (Psi%ll - ii &
== size(MyObs%Rij%Rho_ij_js(idx)%elem, 1))
end if
end if
! Correlation measurements
! ........................
if(has_all_rhoij) then
! Use two site density matrices
do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1695', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1700', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or))
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(.not. fill_both) then
! Off diagonal elements II
do kk = (ii + 1), Psi%ll
sc = meas_rhoij_corr(Rhoij(ii, kk), &
Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(MyObs%CO%Corr(jj)%ol))
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
end if
end do
else
! Have to propagate
corr: do jj = 1, MyObs%CO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(MyObs%CO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1752', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1757', &
! errst=errst)) return
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, ii, MyObs%CO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%CO%Corr(jj)%w
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%CO%Corr(jj)%or == MyObs%CO%Corr(jj)%ol)
! Off diagonal elements I
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%ol))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%or), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptnc_qmpoc '//&
! ': corr_meas_lptn (1) failed', &
! 'ObsOps_include.f90:1777', errst=errst)) return
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(ii, kk, MyObs%CO%corrid(jj)) + sc
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) + sc
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%CO%Corr(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%CO%Corr(jj)%ol), &
Operators%Li(1), .false., errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpoc : corr_meas_'//&
! 'lptn (1) failed', &
! 'ObsOps_include.f90:1802', errst=errst)) return
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) = &
MyObs%CO%elem(kk, ii, MyObs%CO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do corr
end if
! Fermi correlation terms
! .......................
if(.false.) then
! Use density matrices with Fermi phase
else
! Have to propagate
fcorr: do jj = 1, MyObs%FCO%ncorr
! Diagonal element
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%Corr(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: '//&
! 'contr failed.', 'ObsOps_include.f90:1828', &
! errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: '//&
! 'set_hash failed.', 'ObsOps_include.f90:1833', &
! errst=errst)) return
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, ii, MyObs%FCO%corrid(jj)) &
+ trace_rho_x_mat(Rho, Tmp) * MyObs%FCO%Corr(jj)%w
call destroy(Tmp)
! Off diagonal elements I
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), .true., errst=errst)
!if(prop_error('observe_qlptnc_qmpoc '//&
! ': corr_meas_lptn (2) failed', &
! 'ObsOps_include.f90:1853', errst=errst)) return
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(kk, ii, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
! Off diagonal elements II (due to phase operator, we
! can never use the previous measurement)
call contr(Tmp, Operators%Li(MyObs%FCO%Corr(jj)%or), &
Operators%Li(MyObs%FCO%fop), [2], [1])
call corr_init_lptn(Phi%Aa(ii), Ltheta, Tmp)
call destroy(Tmp)
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%FCO%Corr(jj)%ol), &
Operators%Li(MyObs%FCO%fop), .true., &
errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpoc : corr_meas_'//&
! 'lptn (2) failed', &
! 'ObsOps_include.f90:1878', errst=errst)) return
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) = &
MyObs%FCO%elem(ii, kk, MyObs%FCO%corrid(jj)) &
+ sc
end do
if(ii == Psi%ll) call destroy(Ltheta)
end do fcorr
end if
! String correlation functions
! ............................
scorr: do jj = 1, MyObs%STO%nstring
! Get diagonal components
call contr(Tmp, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%or), [2], [1], &
errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: '//&
! 'contr failed.', &
! 'ObsOps_include.f90:1900', errst=errst)) return
call set_hash(Tmp, [2], errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: '//&
! 'set_hash failed.', &
! 'ObsOps_include.f90:1905', errst=errst)) return
MyObs%STO%elem(ii, ii, jj) = &
MyObs%STO%String(jj)%w &
* real(trace_rho_x_mat(Rho, Tmp), KIND=rKind)
call destroy(Tmp)
! Check if correlation is identical
fill_both = (MyObs%STO%String(jj)%or == MyObs%STO%String(jj)%or)
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%STO%String(jj)%ol))
! Off-diagonal elements I
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%STO%String(jj)%or), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qlptnc_qmpoc '//&
! ': corr_meas_lptn (3) failed', &
! 'ObsOps_include.f90:1926', errst=errst)) return
MyObs%STO%elem(kk, ii, jj) = real(sc, KIND=rKind)
if(fill_both) then
! Can fill directly off diagonal elements II
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end if
end do
if(ii == Psi%ll) call destroy(Ltheta)
if(.not. fill_both) then
! Off-diagonal elements II
call corr_init_lptn(Phi%Aa(ii), Rtheta, &
Operators%Li(MyObs%STO%String(jj)%or))
do kk = (ii + 1), Psi%ll
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Rtheta, Operators%Li(MyObs%STO%String(jj)%ol), &
Operators%Li(MyObs%STO%String(jj)%od), &
.true., errst=errst)
!if(prop_error('observe_qlptnc_'//&
! 'qmpoc : corr_meas_'//&
! 'lptn (3) failed', &
! 'ObsOps_include.f90:1951', errst=errst)) return
MyObs%STO%elem(ii, kk, jj) = real(sc, KIND=rKind)
end do
if(ii == Psi%ll) call destroy(Ltheta)
end if
end do scorr
! Four-site 2-nearest-neighbor correlation
! ........................................
do jj = 1, MyObs%C2NN%ncorr
if(ii + 3 > Psi%ll) cycle
call corr_init_lptn(Phi%Aa(ii), Ltheta, &
Operators%Li(MyObs%C2NN%ops(1, jj)))
call corr_meas_lptn(sc, Phi%Aa(ii + 1), ii + 1, &
Psi%ll, Ltheta, Operators%Li(MyObs%C2NN%ops(2, jj)), &
Operators%Li(MyObs%C2NN%ops(2, jj)), .true., errst=errst)
!if(prop_error('observe_lptn_qmpoc : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1975', errst=errst)) return
do kk = (ii + 2), (Psi%ll - 1)
call copy(Tmptheta, Ltheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_qmpoc : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1986', errst=errst)) return
call corr_meas_lptn(sc, Phi%Aa(kk + 1), kk + 1, Psi%ll, &
Tmptheta, Operators%Li(MyObs%C2NN%ops(4, jj)), &
Operators%Li(MyObs%C2NN%ops(4, jj)), .true., &
errst=errst)
!if(prop_error('observe_lptn_qmpoc : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:1994', errst=errst)) return
MyObs%C2NN%elem(ii, kk, jj) = sc
if(kk + 1 < Psi%ll) call destroy(Tmptheta)
call corr_meas_lptn(sc, Phi%Aa(kk), kk, Psi%ll, &
Ltheta, Operators%Li(MyObs%C2NN%ops(3, jj)), &
Operators%Li(MyObs%C2NN%ops(3, jj)), .false., &
errst=errst)
!if(prop_error('observe_lptn_qmpoc : '//&
! 'corr_meas_lptn faield.', &
! 'ObsOps_include.f90:2006', errst=errst)) return
end do
! Is not destroyed automatically due to loop
call destroy(Ltheta)
end do
! Single-site observables
! .......................
local: do jj = 1, MyObs%SO%nsite
MyObs%SO%elem(ii, jj) = MyObs%SO%Si(jj)%w &
* real(trace_rho_x_mat(Rho, Operators%Li(MyObs%SO%Si(jj)%o)), KIND=rKind)
end do local
! Entropy single site (density matrix replaced with eigenvectors)
! ...................
if(MyObs%SE%siteentr) then
call entropy_rho_kk(MyObs%SE%elem(ii), Rho, errst=errst)
if(MyObs%MI%has_mi) then
MyObs%MI%elem(ii, ii) = MyObs%SE%elem(ii)
end if
elseif(MyObs%MI%has_mi) then
call entropy_rho_kk(MyObs%MI%elem(ii, ii), Rho, errst=errst)
end if
call destroy(Rho)
end do sites
deallocate(loop)
if(has_all_rhoij) then
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call destroy(Rhoij(ii, jj))
end do
end do
elseif(MyObs%Rij%hasrho_ij) then
do ii = 1, Psi%ll
idx = findtagindex(ii, MyObs%Rij%rho_ij_is)
if(idx > 0) then
do jj = 1, size(MyObs%Rij%Rho_ij_js(idx)%elem, 1)
kk = MyObs%Rij%Rho_ij_js(idx)%elem(jj)
call destroy(Rhoij(ii, kk))
end do
end if
end do
end if
! Two-site matrices of the mutual information
! ...........................................
if(MyObs%MI%has_mi) then
! Store dimension in idx
idx = 0
do ii = 1, (Psi%ll - 1)
do jj = (ii + 1), Psi%ll
call copy(Tmpij, MyObs%Rij%Elem(ii, jj), errst=errst)
!if(prop_error('observe_qlptnc_qmpoc : '// &
! 'copy failed.', 'ObsOps_include.f90:2072', &
! errst=errst)) return
call fuse(Tmpij, [3, 4])
call fuse(Tmpij, [1, 2])
idx = Tmpij%dl(1)
call entropy_rho_kk(MyObs%MI%elem(ii, jj), Tmpij, &
errst=errst)
call destroy(Tmpij)
MyObs%MI%elem(ii, jj) = - MyObs%MI%elem(ii, jj) &
+ MyObs%MI%elem(ii, ii) &
+ MyObs%MI%elem(jj, jj)
end do
end do
MyObs%MI%elem = MyObs%MI%elem / 2.0_rKind &
/ log(sqrt(1.0_rKind * idx))
end if
! Measurement of MPOs
! ...................
do jj = 1, MyObs%MO%nmpo
call meas_mpo(MyObs%MO%elem(jj), MyObs%MO%MPO(jj), Phi)
end do
! General reduced density matrices
! ................................
do jj = 1, MyObs%Rijk%nn
call rho_red(Rho, Phi, MyObs%Rijk%Sites(jj)%elem, &
(MyObs%Rijk%cont(jj) == 0), Cp%local_tol, &
Cp%max_bond_dimension, rhoerr, errst=errst)
!if(prop_error('observe_qlptnc_qmpoc : '//&
! 'rho_red failed.', 'ObsOps_include.f90:2108', &
! errst=errst)) return
call qmattomat(MyObs%Rijk%Elem(jj), Rho, Imapper)
call destroy(Rho)
end do
! Measurement of distances
! ........................
do jj = 1, MyObs%DPO%ndist
if(MyObs%DPO%is_real(jj)) then
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Rpsi(jj), &
dist_type='F')
else
MyObs%DPO%elem(jj) = distance(Phi, MyObs%DPO%Cpsi(jj), &
dist_type='F')
end if
end do
call destroy(Phi)
MyObs%chi = maxchi(Psi)
MyObs%kappa = maxkappa(Psi)
MyObs%energy = energy
MyObs%converged = converged
if(present(time)) then
MyObs%error = variance
MyObs%loschmidt = le
else
MyObs%variance = variance
end if
call write(obsname, obsunit, MyObs, Psi%ll, time, errst=errst)
!if(prop_error('observe_qlptnc_qmpoc: write failed.', &
! 'ObsOps_include.f90:2144', errst=errst)) return
! Save the state as observable
if(MyObs%state == 'B') then
! Build file name (cut .dat and append _State.bin instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.bin'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write', form='unformatted')
call write(Psi, obsunit, 'B')
close(obsunit)
elseif(MyObs%state == 'H') then
! Build file name (cut .dat and append _State.tn instead)
statename = obsname(:len(trim(adjustl(obsname))) - 4)//&
'_State.mps'
open(unit=obsunit, file=trim(statename), status='replace', &
action='write')
call write(Psi, obsunit, 'H')
close(obsunit)
end if
! Log files for restoring time evolutions
! ---------------------------------------
if(present(time)) then
! Save the MPS itself
write(specstring, '(E16.8E3)') time
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
qtid//".bin", status='replace', action='write', &
form='unformatted')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_psit"//trim(adjustl(specstring))//&
".bin", status='replace', action='write', &
form='unformatted')
end if
call write(Psi, obsunit, 'B')
close(obsunit)
! Write log file for restoring time evolution when necessary
if(present(qtid)) then
open(unit=obsunit, file=trim(adjustl(baseout))//&
qtid//"_time_last.dat", action='write', &
status='replace')
else
open(unit=obsunit, file=trim(adjustl(baseout))//&
"_time_last.dat", action='write', &
status='replace')
end if
write(ObsUnit, '(E30.15E3)') time
close(ObsUnit)
! Delete older MPS and store filename of this one
if(len(trim(timeevo_mps_delete)) > 0) then
open(unit=obsunit, file=trim(timeevo_mps_delete), status='old')
close(obsunit, status='delete')
end if
if(present(qtid)) then
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//qtid//".bin"
else
timeevo_mps_delete = trim(adjustl(baseout))//&
"_psit"// &
trim(adjustl(specstring))//".bin"
end if
end if
end subroutine observe_qlptnc_qmpoc
"""
return
[docs]def read_site_observables():
"""
fortran-subroutine - August 2017 (dj)
Read the site observables from an open file handle.
**Arguments**
Obj : TYPE(site_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_site_observables(Obj, unit, ll, errst)
type(site_observables), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%nsite
if(Obj%nsite > 0) then
allocate(Obj%Si(Obj%nsite), Obj%elem(ll, Obj%nsite))
do ii = 1, Obj%nsite
read(unit, '(1E30.15,1I16)') Obj%Si(ii)%w, Obj%Si(ii)%o
end do
end if
end subroutine read_site_observables
"""
return
[docs]def read_siteentropy_observables():
"""
fortran-subroutine - August 2017 (dj)
Read the site entropy observable from an open file handle.
**Arguments**
Obj : TYPE(siteentropy_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_siteentropy_observables(Obj, unit, ll, errst)
type(siteentropy_observables), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Read character for true/false
character :: bool
!if(present(errst)) errst = 0
read(unit, '(1A)') bool
Obj%siteentr = (bool == 'T')
if(Obj%siteentr) then
allocate(Obj%elem(ll))
Obj%elem = 0.0_rKind
if(verbose > 1) write(slog, *) 'Site entropy measured.'
end if
end subroutine read_siteentropy_observables
"""
return
[docs]def read_bondentropy_observables():
"""
fortran-subroutine - August 2017 (dj)
Read the bond entropy observable from an open file handle.
**Arguments**
Obj : TYPE(bondentropy_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_bondentropy_observables(Obj, unit, ll, errst)
type(bondentropy_observables), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Read character for true/false
character :: bool
!if(present(errst)) errst = 0
read(unit, '(1A)') bool
Obj%bondentr = (bool == 'T')
if(Obj%bondentr) then
allocate(Obj%elem(ll + 1))
Obj%elem = 0.0_rKind
if(verbose > 1) write(slog, *) 'Bond entropy measured.'
end if
end subroutine read_bondentropy_observables
"""
return
[docs]def read_corr_observables_real():
"""
fortran-subroutine - August 2017 (dj)
Read the correlation observables from an open file handle.
**Arguments**
Obj : TYPE(corr_observables_real), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_corr_observables_real(Obj, unit, ll, errst)
type(corr_observables_real), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary character for hermitian
character :: bool
!if(present(errst)) errst = 0
read(unit, '(2I16)') Obj%ncorr, Obj%nind
if(Obj%ncorr > 0) then
allocate(Obj%corrid(Obj%ncorr), Obj%Corr(Obj%ncorr), &
Obj%isherm(Obj%ncorr), Obj%elem(ll, ll, Obj%nind))
Obj%elem = 0.0_rKind
do ii = 1, Obj%ncorr
read(unit, '(1E30.15,3I16,1A)') Obj%Corr(ii)%w, &
Obj%Corr(ii)%ol, &
Obj%Corr(ii)%or, &
Obj%corrid(ii), &
bool
! Hermitian flag is for storing complex, so never for real
Obj%isherm(ii) = (bool == 'T') .or. ('real' == 'real')
end do
end if
end subroutine read_corr_observables_real
"""
return
[docs]def read_corr_observables_complex():
"""
fortran-subroutine - August 2017 (dj)
Read the correlation observables from an open file handle.
**Arguments**
Obj : TYPE(corr_observables_complex), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_corr_observables_complex(Obj, unit, ll, errst)
type(corr_observables_complex), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary character for hermitian
character :: bool
!if(present(errst)) errst = 0
read(unit, '(2I16)') Obj%ncorr, Obj%nind
if(Obj%ncorr > 0) then
allocate(Obj%corrid(Obj%ncorr), Obj%Corr(Obj%ncorr), &
Obj%isherm(Obj%ncorr), Obj%elem(ll, ll, Obj%nind))
Obj%elem = 0.0_rKind
do ii = 1, Obj%ncorr
read(unit, '(1E30.15,3I16,1A)') Obj%Corr(ii)%w, &
Obj%Corr(ii)%ol, &
Obj%Corr(ii)%or, &
Obj%corrid(ii), &
bool
! Hermitian flag is for storing complex, so never for real
Obj%isherm(ii) = (bool == 'T') .or. ('real' == 'complex')
end do
end if
end subroutine read_corr_observables_complex
"""
return
[docs]def read_fcorr_observables_real():
"""
fortran-subroutine - August 2017 (dj)
Read the Fermi correlation observables from an open file handle.
**Arguments**
Obj : TYPE(corr_observables_real), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_fcorr_observables_real(Obj, unit, ll, errst)
type(corr_observables_real), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary character for hermitian
character :: bool
!if(present(errst)) errst = 0
read(unit, '(2I16)') Obj%ncorr, Obj%nind
if(Obj%ncorr > 0) then
read(unit, '(1I16)') Obj%fop
allocate(Obj%corrid(Obj%ncorr), Obj%Corr(Obj%ncorr), &
Obj%isherm(Obj%ncorr), Obj%elem(ll, ll, Obj%nind))
Obj%elem = 0.0_rKind
do ii = 1, Obj%ncorr
read(unit, '(1E30.15,3I16,1A)') Obj%Corr(ii)%w, &
Obj%Corr(ii)%ol, &
Obj%Corr(ii)%or, &
Obj%corrid(ii), &
bool
Obj%isherm(ii) = (bool == 'T')
end do
end if
end subroutine read_fcorr_observables_real
"""
return
[docs]def read_fcorr_observables_complex():
"""
fortran-subroutine - August 2017 (dj)
Read the Fermi correlation observables from an open file handle.
**Arguments**
Obj : TYPE(corr_observables_complex), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_fcorr_observables_complex(Obj, unit, ll, errst)
type(corr_observables_complex), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary character for hermitian
character :: bool
!if(present(errst)) errst = 0
read(unit, '(2I16)') Obj%ncorr, Obj%nind
if(Obj%ncorr > 0) then
read(unit, '(1I16)') Obj%fop
allocate(Obj%corrid(Obj%ncorr), Obj%Corr(Obj%ncorr), &
Obj%isherm(Obj%ncorr), Obj%elem(ll, ll, Obj%nind))
Obj%elem = 0.0_rKind
do ii = 1, Obj%ncorr
read(unit, '(1E30.15,3I16,1A)') Obj%Corr(ii)%w, &
Obj%Corr(ii)%ol, &
Obj%Corr(ii)%or, &
Obj%corrid(ii), &
bool
Obj%isherm(ii) = (bool == 'T')
end do
end if
end subroutine read_fcorr_observables_complex
"""
return
[docs]def read_string_observables():
"""
fortran-subroutine - August 2017 (dj)
Read the string correlation observables from an open file handle.
**Arguments**
Obj : TYPE(string_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_string_observables(Obj, unit, ll, errst)
type(string_observables), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%nstring
if(Obj%nstring > 0) then
allocate(Obj%String(Obj%nstring), Obj%elem(ll, ll, Obj%nstring))
do ii = 1, Obj%nstring
read(unit, '(1E35.15,3I16)') Obj%String(ii)%w, &
Obj%String(ii)%ol, &
Obj%String(ii)%or, &
Obj%String(ii)%od
end do
end if
end subroutine read_string_observables
"""
return
[docs]def read_mpo_observables_mpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the MPO observables from an open file handle.
**Arguments**
Obj : TYPE(mpo_observables_mpo), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit.
ll : INTEGER, inout
number of sites in the system.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
Ops : TYPE(tensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_mpo_observables_mpo(Obj, unit, unitmpo, ll, &
writedir, Ops, Hparams, iop, errst)
type(mpo_observables_mpo), intent(out) :: Obj
integer, intent(in) :: unit, unitmpo, ll
character(len=132), intent(in) :: writedir
type(tensorlist), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Rule set
type(MPORuleSet) :: Rs
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%nmpo
if(Obj%nmpo > 0) then
allocate(Obj%MPO(Obj%nmpo), Obj%Names(Obj%nmpo), &
Obj%elem(Obj%nmpo))
do ii = 1, Obj%nmpo
read(unit, *) Obj%Names(ii)%elem
Obj%Names(ii)%elem = trim(adjustl(writedir))//'/'//&
trim(adjustl(Obj%Names(ii)%elem))
open(unit=unitmpo, file=trim(adjustl(Obj%Names(ii)%elem)), &
status='old', action='read')
call read(Rs, unitmpo)
close(unitmpo)
call ruleset_to_ham_mpo(Obj%MPO(ii), Rs, ll, Ops, Hparams, iop)
call destroy(Rs)
end do
end if
end subroutine read_mpo_observables_mpo
"""
return
[docs]def read_mpo_observables_mpoc():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the MPO observables from an open file handle.
**Arguments**
Obj : TYPE(mpo_observables_mpoc), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit.
ll : INTEGER, inout
number of sites in the system.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
Ops : TYPE(tensorlistc), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_mpo_observables_mpoc(Obj, unit, unitmpo, ll, &
writedir, Ops, Hparams, iop, errst)
type(mpo_observables_mpoc), intent(out) :: Obj
integer, intent(in) :: unit, unitmpo, ll
character(len=132), intent(in) :: writedir
type(tensorlistc), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Rule set
type(MPORuleSet) :: Rs
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%nmpo
if(Obj%nmpo > 0) then
allocate(Obj%MPO(Obj%nmpo), Obj%Names(Obj%nmpo), &
Obj%elem(Obj%nmpo))
do ii = 1, Obj%nmpo
read(unit, *) Obj%Names(ii)%elem
Obj%Names(ii)%elem = trim(adjustl(writedir))//'/'//&
trim(adjustl(Obj%Names(ii)%elem))
open(unit=unitmpo, file=trim(adjustl(Obj%Names(ii)%elem)), &
status='old', action='read')
call read(Rs, unitmpo)
close(unitmpo)
call ruleset_to_ham_mpo(Obj%MPO(ii), Rs, ll, Ops, Hparams, iop)
call destroy(Rs)
end do
end if
end subroutine read_mpo_observables_mpoc
"""
return
[docs]def read_mpo_observables_qmpo():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the MPO observables from an open file handle.
**Arguments**
Obj : TYPE(mpo_observables_qmpo), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit.
ll : INTEGER, inout
number of sites in the system.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
Ops : TYPE(qtensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_mpo_observables_qmpo(Obj, unit, unitmpo, ll, &
writedir, Ops, Hparams, iop, errst)
type(mpo_observables_qmpo), intent(out) :: Obj
integer, intent(in) :: unit, unitmpo, ll
character(len=132), intent(in) :: writedir
type(qtensorlist), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Rule set
type(MPORuleSet) :: Rs
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%nmpo
if(Obj%nmpo > 0) then
allocate(Obj%MPO(Obj%nmpo), Obj%Names(Obj%nmpo), &
Obj%elem(Obj%nmpo))
do ii = 1, Obj%nmpo
read(unit, *) Obj%Names(ii)%elem
Obj%Names(ii)%elem = trim(adjustl(writedir))//'/'//&
trim(adjustl(Obj%Names(ii)%elem))
open(unit=unitmpo, file=trim(adjustl(Obj%Names(ii)%elem)), &
status='old', action='read')
call read(Rs, unitmpo)
close(unitmpo)
call ruleset_to_ham_mpo(Obj%MPO(ii), Rs, ll, Ops, Hparams, iop)
call destroy(Rs)
end do
end if
end subroutine read_mpo_observables_qmpo
"""
return
[docs]def read_mpo_observables_qmpoc():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the MPO observables from an open file handle.
**Arguments**
Obj : TYPE(mpo_observables_qmpoc), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit.
ll : INTEGER, inout
number of sites in the system.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
Ops : TYPE(qtensorclist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_mpo_observables_qmpoc(Obj, unit, unitmpo, ll, &
writedir, Ops, Hparams, iop, errst)
type(mpo_observables_qmpoc), intent(out) :: Obj
integer, intent(in) :: unit, unitmpo, ll
character(len=132), intent(in) :: writedir
type(qtensorclist), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Rule set
type(MPORuleSet) :: Rs
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%nmpo
if(Obj%nmpo > 0) then
allocate(Obj%MPO(Obj%nmpo), Obj%Names(Obj%nmpo), &
Obj%elem(Obj%nmpo))
do ii = 1, Obj%nmpo
read(unit, *) Obj%Names(ii)%elem
Obj%Names(ii)%elem = trim(adjustl(writedir))//'/'//&
trim(adjustl(Obj%Names(ii)%elem))
open(unit=unitmpo, file=trim(adjustl(Obj%Names(ii)%elem)), &
status='old', action='read')
call read(Rs, unitmpo)
close(unitmpo)
call ruleset_to_ham_mpo(Obj%MPO(ii), Rs, ll, Ops, Hparams, iop)
call destroy(Rs)
end do
end if
end subroutine read_mpo_observables_qmpoc
"""
return
[docs]def read_rhoi_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Read the settings for the single site reduced density matrices from
an open file handle.
**Arguments**
Obj : TYPE(rhoi_observables_tensor), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_rhoi_observables_tensor(Obj, unit, ll, errst)
type(rhoi_observables_tensor), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! number of terms
integer :: nn
!if(present(errst)) errst = 0
read(unit, '(1I16)') nn
Obj%hasrho_i = (nn > 0)
if(Obj%hasrho_i) then
allocate(Obj%rho_i_i(nn), Obj%Elem(ll))
call read_n(Obj%rho_i_i, nn, unit)
if(verbose > 0) write(slog, *) 'Rho_i i vals', Obj%rho_i_i
end if
end subroutine read_rhoi_observables_tensor
"""
return
[docs]def read_rhoi_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Read the settings for the single site reduced density matrices from
an open file handle.
**Arguments**
Obj : TYPE(rhoi_observables_tensorc), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_rhoi_observables_tensorc(Obj, unit, ll, errst)
type(rhoi_observables_tensorc), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! number of terms
integer :: nn
!if(present(errst)) errst = 0
read(unit, '(1I16)') nn
Obj%hasrho_i = (nn > 0)
if(Obj%hasrho_i) then
allocate(Obj%rho_i_i(nn), Obj%Elem(ll))
call read_n(Obj%rho_i_i, nn, unit)
if(verbose > 0) write(slog, *) 'Rho_i i vals', Obj%rho_i_i
end if
end subroutine read_rhoi_observables_tensorc
"""
return
[docs]def read_rhoij_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Read the settings for the two-site reduced density matrices
from an open file handle.
**Arguments**
Obj : TYPE(string_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
has_mi : LOGICAL, in
If mutual information is measured (True), the workspace
for the two-site density matrices has to be allocated
independent of the settings of two-site reduced matrices.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_rhoij_observables_tensor(Obj, unit, ll, has_mi, errst)
type(rhoij_observables_tensor), intent(out) :: Obj
integer, intent(in) :: unit, ll
logical, intent(in) :: has_mi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! number of terms
integer :: nn, njs
!if(present(errst)) errst = 0
read(unit, '(1I16)') nn
Obj%hasrho_ij = (nn > 0)
if(Obj%hasrho_ij) then
allocate(Obj%rho_ij_is(nn), Obj%Rho_ij_js(nn), Obj%Elem(ll, ll))
do ii = 1, nn
read(unit, '(2I16)') njs, Obj%rho_ij_is(ii)
allocate(Obj%Rho_ij_js(ii)%elem(njs))
call read_n(Obj%Rho_ij_js(ii)%elem, njs, unit)
if(verbose > 1) write(slog, *) 'i val', Obj%rho_ij_is(ii), &
'js', Obj%Rho_ij_js(ii)%elem
end do
elseif(has_mi) then
! Have to allocate anyway for mutual information
allocate(Obj%Elem(ll, ll))
end if
end subroutine read_rhoij_observables_tensor
"""
return
[docs]def read_rhoij_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Read the settings for the two-site reduced density matrices
from an open file handle.
**Arguments**
Obj : TYPE(string_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
has_mi : LOGICAL, in
If mutual information is measured (True), the workspace
for the two-site density matrices has to be allocated
independent of the settings of two-site reduced matrices.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_rhoij_observables_tensorc(Obj, unit, ll, has_mi, errst)
type(rhoij_observables_tensorc), intent(out) :: Obj
integer, intent(in) :: unit, ll
logical, intent(in) :: has_mi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! number of terms
integer :: nn, njs
!if(present(errst)) errst = 0
read(unit, '(1I16)') nn
Obj%hasrho_ij = (nn > 0)
if(Obj%hasrho_ij) then
allocate(Obj%rho_ij_is(nn), Obj%Rho_ij_js(nn), Obj%Elem(ll, ll))
do ii = 1, nn
read(unit, '(2I16)') njs, Obj%rho_ij_is(ii)
allocate(Obj%Rho_ij_js(ii)%elem(njs))
call read_n(Obj%Rho_ij_js(ii)%elem, njs, unit)
if(verbose > 1) write(slog, *) 'i val', Obj%rho_ij_is(ii), &
'js', Obj%Rho_ij_js(ii)%elem
end do
elseif(has_mi) then
! Have to allocate anyway for mutual information
allocate(Obj%Elem(ll, ll))
end if
end subroutine read_rhoij_observables_tensorc
"""
return
[docs]def read_rhoijk_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Read the settings for the general reduced density matrices
from an open file handle.
**Arguments**
Obj : TYPE(rhoijk_observables_tensor), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_rhoijk_observables_tensor(Obj, unit, errst)
type(rhoijk_observables_tensor), intent(out) :: Obj
integer, intent(in) :: unit
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%nn
allocate(Obj%sizes(Obj%nn), Obj%cont(Obj%nn), Obj%Sites(Obj%nn), &
Obj%Elem(Obj%nn))
do ii = 1, Obj%nn
read(unit, '(2I16)') Obj%sizes(ii), Obj%cont(ii)
allocate(Obj%Sites(ii)%elem(Obj%sizes(ii)))
call read_n(Obj%Sites(ii)%elem, Obj%sizes(ii), unit)
end do
end subroutine read_rhoijk_observables_tensor
"""
return
[docs]def read_rhoijk_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Read the settings for the general reduced density matrices
from an open file handle.
**Arguments**
Obj : TYPE(rhoijk_observables_tensorc), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_rhoijk_observables_tensorc(Obj, unit, errst)
type(rhoijk_observables_tensorc), intent(out) :: Obj
integer, intent(in) :: unit
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%nn
allocate(Obj%sizes(Obj%nn), Obj%cont(Obj%nn), Obj%Sites(Obj%nn), &
Obj%Elem(Obj%nn))
do ii = 1, Obj%nn
read(unit, '(2I16)') Obj%sizes(ii), Obj%cont(ii)
allocate(Obj%Sites(ii)%elem(Obj%sizes(ii)))
call read_n(Obj%Sites(ii)%elem, Obj%sizes(ii), unit)
end do
end subroutine read_rhoijk_observables_tensorc
"""
return
[docs]def read_lambda_observables():
"""
fortran-subroutine - August 2017 (dj)
Read the setting for saving the singular values from an
open file handle.
**Arguments**
Obj : TYPE(lambda_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_lambda_observables(Obj, unit, ll, errst)
type(lambda_observables), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! number of Lambdas
integer :: nn
! Read character for true/false
character :: bool
!if(present(errst)) errst = 0
read(unit, '(1A)') bool
Obj%has_lambda = (bool == 'T')
if(Obj%has_lambda) then
read(unit, '(1I16)') nn
allocate(Obj%lambda(nn), Obj%Vecs(ll + 1))
call read_n(Obj%lambda, nn, unit)
if(verbose > 0) write(slog, *) 'Lambda vals at', Obj%lambda
end if
end subroutine read_lambda_observables
"""
return
[docs]def read_distance_psi_observables_mpsrc():
"""
fortran-subroutine - August 2017 (dj)
Read the distance measures to pure states from an open file handle.
**Arguments**
Obj : TYPE(lambda_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitpsi : INTEGER, in
Can open and read wave functions on this unit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_distance_psi_observables_mpsrc(Obj, unit, unitpsi, errst)
type(distance_psi_observables_mpsrc), intent(out) :: Obj
integer, intent(in) :: unit, unitpsi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! flag what kind of MPS
integer :: flag
! form
character :: form
! temporary filename
character(len=256) :: psifilename
! All the MPS
type(mps) :: Psi
type(mpsc) :: Psic
type(qmps) :: Psiq
type(qmpsc) :: Psicq
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%ndist
if(Obj%ndist > 0) then
allocate(Obj%Rpsi(Obj%ndist), Obj%Cpsi(Obj%ndist), &
Obj%is_real(Obj%ndist), Obj%elem(Obj%ndist))
Obj%elem = 0.0_rKind
do ii = 1, Obj%ndist
read(unit, '(256A)') psifilename
read(unit, *) form
call read(Psi, Psic, Psiq, Psicq, flag, psifilename, unitpsi, &
form, errst=errst)
if(flag == 0) then
! Real MPS
call copy(Obj%Rpsi(ii), Psi)
call destroy(Psi)
Obj%is_real(ii) = .true.
elseif(flag == 1) then
! Complex MPS
call copy(Obj%Cpsi(ii), Psic)
call destroy(Psic)
Obj%is_real(ii) = .false.
else
stop 'No match for Psi in distance measure.'
end if
end do
end if
end subroutine read_distance_psi_observables_mpsrc
"""
return
[docs]def read_distance_psi_observables_qmpsrc():
"""
fortran-subroutine - August 2017 (dj)
Read the distance measures to pure states from an open file handle.
**Arguments**
Obj : TYPE(lambda_observables), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitpsi : INTEGER, in
Can open and read wave functions on this unit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_distance_psi_observables_qmpsrc(Obj, unit, unitpsi, errst)
type(distance_psi_observables_qmpsrc), intent(out) :: Obj
integer, intent(in) :: unit, unitpsi
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! flag what kind of MPS
integer :: flag
! form
character :: form
! temporary filename
character(len=256) :: psifilename
! All the MPS
type(mps) :: Psi
type(mpsc) :: Psic
type(qmps) :: Psiq
type(qmpsc) :: Psicq
!if(present(errst)) errst = 0
read(unit, '(1I16)') Obj%ndist
if(Obj%ndist > 0) then
allocate(Obj%Rpsi(Obj%ndist), Obj%Cpsi(Obj%ndist), &
Obj%is_real(Obj%ndist), Obj%elem(Obj%ndist))
Obj%elem = 0.0_rKind
do ii = 1, Obj%ndist
read(unit, '(256A)') psifilename
read(unit, *) form
call read(Psi, Psic, Psiq, Psicq, flag, psifilename, unitpsi, &
form, errst=errst)
if(flag == 2) then
! Real MPS
call copy(Obj%Rpsi(ii), Psiq)
call destroy(Psiq)
Obj%is_real(ii) = .true.
elseif(flag == 3) then
! Complex MPS
call copy(Obj%Cpsi(ii), Psicq)
call destroy(Psicq)
Obj%is_real(ii) = .false.
else
stop 'No match for Psi in distance measure.'
end if
end do
end if
end subroutine read_distance_psi_observables_qmpsrc
"""
return
[docs]def read_state_observables():
"""
fortran-subroutine - November 2017 (dj)
Read the setting for writing out states at each measurement.
**Arguments**
obj : LOGICAL, inout
Status of writing out states (true == write state).
unit : INTEGER, in
Open file hanlde with position at the state measure.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_state_observables(obj, unit, errst)
character, intent(inout) :: obj
integer, intent(in) :: unit
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
read(unit, '(1A)') obj
end subroutine read_state_observables
"""
return
[docs]def read_corr2nn_observables_real():
"""
fortran-subroutine - August 2017 (dj)
Read the correlation observables for two pairs of nearest-neighbors
from an open file handle.
**Arguments**
Obj : TYPE(corr_observables_real), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_corr2nn_observables_real(Obj, unit, ll, errst)
type(corr2nn_observables_real), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary character for hermitian
character :: bool
!if(present(errst)) errst = 0
read(unit, '(I16)') Obj%ncorr
if(Obj%ncorr == 0) return
allocate(Obj%isherm(Obj%ncorr), Obj%weight(Obj%ncorr), &
Obj%ops(4, Obj%ncorr), Obj%elem(ll, ll, Obj%ncorr))
Obj%elem = 0.0_rKind
do ii = 1, Obj%ncorr
read(unit, '(1E30.15,4I16,1A)') Obj%weight(ii), &
Obj%ops(:, ii), &
bool
! Hermitian flag is for storing complex, so never for real
Obj%isherm(ii) = (bool == 'T') .or. ('real' == 'real')
end do
end subroutine read_corr2nn_observables_real
"""
return
[docs]def read_corr2nn_observables_complex():
"""
fortran-subroutine - August 2017 (dj)
Read the correlation observables for two pairs of nearest-neighbors
from an open file handle.
**Arguments**
Obj : TYPE(corr_observables_complex), inout
Read the settings for this measurement.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
ll : INTEGER, in
Number of system sites in order to allocate memory.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_corr2nn_observables_complex(Obj, unit, ll, errst)
type(corr2nn_observables_complex), intent(out) :: Obj
integer, intent(in) :: unit, ll
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary character for hermitian
character :: bool
!if(present(errst)) errst = 0
read(unit, '(I16)') Obj%ncorr
if(Obj%ncorr == 0) return
allocate(Obj%isherm(Obj%ncorr), Obj%weight(Obj%ncorr), &
Obj%ops(4, Obj%ncorr), Obj%elem(ll, ll, Obj%ncorr))
Obj%elem = 0.0_rKind
do ii = 1, Obj%ncorr
read(unit, '(1E30.15,4I16,1A)') Obj%weight(ii), &
Obj%ops(:, ii), &
bool
! Hermitian flag is for storing complex, so never for real
Obj%isherm(ii) = (bool == 'T') .or. ('real' == 'complex')
end do
end subroutine read_corr2nn_observables_complex
"""
return
[docs]def read_obs_r():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the settings for all observables.
**Arguments**
Obj : TYPE(obs_r), inout
The setting of the observables is stored in this variable.
flnm : CHARACTER(\*), in
Filename of the file with the settings for the observables.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit (for MPO measurements).
unitpsi : INTEGER, in
Can open and read wave functions for distance measures on this
unit.
ll : INTEGER, in
number of sites in the system.
Ops : TYPE(tensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_obs_r(Obj, flnm, writedir, unit, unitmpo, unitpsi, &
ll, Ops, Hparams, iop, errst)
type(obs_r), intent(out) :: Obj
character(len=132), intent(in) :: flnm
character(len=132), intent(in) :: writedir
integer, intent(in) :: unit, unitmpo, unitpsi, ll
type(tensorlist), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
Obj%static_eigenvalue = -9999999_rKind
Obj%hdf5_target_file = ''
Obj%quench_ii = ''
Obj%step_ii = ''
Obj%name = flnm
open(unit=unit, file=trim(adjustl(flnm)), action='read', &
status='old')
! Only referenced for iMPS
read(unit, '(1I16)') Obj%corr_range
call read_site_observables(Obj%SO, unit, ll, errst=errst)
!if(prop_error('read_obs_r : site failed.', &
! 'ObsOps_include.f90:4100', errst=errst)) return
call read_siteentropy_observables(Obj%SE, unit, ll, errst=errst)
!if(prop_error('read_obs_r : site entropy failed.', &
! 'ObsOps_include.f90:4104', errst=errst)) return
call read_bondentropy_observables(Obj%BE, unit, ll, errst=errst)
!if(prop_error('read_obs_r : bond entropy failed.', &
! 'ObsOps_include.f90:4108', errst=errst)) return
call read_corr_observables_real(Obj%CO, unit, ll, errst=errst)
!if(prop_error('read_obs_r : corr failed.', &
! 'ObsOps_include.f90:4112', errst=errst)) return
call read_fcorr_observables_real(Obj%FCO, unit, ll, errst=errst)
!if(prop_error('read_obs_r : fcorr failed.', &
! 'ObsOps_include.f90:4116', errst=errst)) return
call read_string_observables(Obj%STO, unit, ll, errst=errst)
!if(prop_error('read_obs_r : string failed.', &
! 'ObsOps_include.f90:4120', errst=errst)) return
call read_mpo_observables_mpo(Obj%MO, unit, unitmpo, ll, writedir, &
Ops, Hparams, iop, errst=errst)
!if(prop_error('read_obs_r : mpo failed.', &
! 'ObsOps_include.f90:4125', errst=errst)) return
call read_rhoi_observables_tensor(Obj%Ri, unit, ll, errst=errst)
!if(prop_error('read_obs_r : rhoi failed.', &
! 'ObsOps_include.f90:4129', errst=errst)) return
! Rhoij depends on mutual information - put to the end
call read_rhoijk_observables_tensor(Obj%Rijk, unit, errst=errst)
!if(prop_error('read_obs_r : rhoijk failed.', &
! 'ObsOps_include.f90:4135', errst=errst)) return
call read_mutualinformation_observables(Obj%MI, unit, ll, errst=errst)
!if(prop_error('read_obs_r : mi failed.', &
! 'ObsOps_include.f90:4139', errst=errst)) return
call read_lambda_observables(Obj%LO, unit, ll, errst=errst)
!if(prop_error('read_obs_r : lambda failed.', &
! 'ObsOps_include.f90:4143', errst=errst)) return
call read_distance_psi_observables_mpsrc(Obj%DPO, unit, unitpsi, &
errst=errst)
!if(prop_error('read_obs_r : distance psi failed.', &
! 'ObsOps_include.f90:4148', errst=errst)) return
call read_state_observables(Obj%state, unit, errst=errst)
!if(prop_error('read_obs_r : state failed.', &
! 'ObsOps_include.f90:4152', errst=errst)) return
call read_corr2nn_observables_real(Obj%C2NN, unit, ll, errst=errst)
!if(prop_error('read_obs_r : state failed.', &
! 'ObsOps_include.f90:4156', errst=errst)) return
call read_rhoij_observables_tensor(Obj%Rij, unit, ll, Obj%MI%has_mi, &
errst=errst)
!if(prop_error('read_obs_r : rhoij failed.', &
! 'ObsOps_include.f90:4161', errst=errst)) return
close(unit)
end subroutine read_obs_r
"""
return
[docs]def read_obs_c():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the settings for all observables.
**Arguments**
Obj : TYPE(obs_c), inout
The setting of the observables is stored in this variable.
flnm : CHARACTER(\*), in
Filename of the file with the settings for the observables.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit (for MPO measurements).
unitpsi : INTEGER, in
Can open and read wave functions for distance measures on this
unit.
ll : INTEGER, in
number of sites in the system.
Ops : TYPE(tensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_obs_c(Obj, flnm, writedir, unit, unitmpo, unitpsi, &
ll, Ops, Hparams, iop, errst)
type(obs_c), intent(out) :: Obj
character(len=132), intent(in) :: flnm
character(len=132), intent(in) :: writedir
integer, intent(in) :: unit, unitmpo, unitpsi, ll
type(tensorlist), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
Obj%static_eigenvalue = -9999999_rKind
Obj%hdf5_target_file = ''
Obj%quench_ii = ''
Obj%step_ii = ''
Obj%name = flnm
open(unit=unit, file=trim(adjustl(flnm)), action='read', &
status='old')
! Only referenced for iMPS
read(unit, '(1I16)') Obj%corr_range
call read_site_observables(Obj%SO, unit, ll, errst=errst)
!if(prop_error('read_obs_c : site failed.', &
! 'ObsOps_include.f90:4100', errst=errst)) return
call read_siteentropy_observables(Obj%SE, unit, ll, errst=errst)
!if(prop_error('read_obs_c : site entropy failed.', &
! 'ObsOps_include.f90:4104', errst=errst)) return
call read_bondentropy_observables(Obj%BE, unit, ll, errst=errst)
!if(prop_error('read_obs_c : bond entropy failed.', &
! 'ObsOps_include.f90:4108', errst=errst)) return
call read_corr_observables_complex(Obj%CO, unit, ll, errst=errst)
!if(prop_error('read_obs_c : corr failed.', &
! 'ObsOps_include.f90:4112', errst=errst)) return
call read_fcorr_observables_complex(Obj%FCO, unit, ll, errst=errst)
!if(prop_error('read_obs_c : fcorr failed.', &
! 'ObsOps_include.f90:4116', errst=errst)) return
call read_string_observables(Obj%STO, unit, ll, errst=errst)
!if(prop_error('read_obs_c : string failed.', &
! 'ObsOps_include.f90:4120', errst=errst)) return
call read_mpo_observables_mpo(Obj%MO, unit, unitmpo, ll, writedir, &
Ops, Hparams, iop, errst=errst)
!if(prop_error('read_obs_c : mpo failed.', &
! 'ObsOps_include.f90:4125', errst=errst)) return
call read_rhoi_observables_tensorc(Obj%Ri, unit, ll, errst=errst)
!if(prop_error('read_obs_c : rhoi failed.', &
! 'ObsOps_include.f90:4129', errst=errst)) return
! Rhoij depends on mutual information - put to the end
call read_rhoijk_observables_tensorc(Obj%Rijk, unit, errst=errst)
!if(prop_error('read_obs_c : rhoijk failed.', &
! 'ObsOps_include.f90:4135', errst=errst)) return
call read_mutualinformation_observables(Obj%MI, unit, ll, errst=errst)
!if(prop_error('read_obs_c : mi failed.', &
! 'ObsOps_include.f90:4139', errst=errst)) return
call read_lambda_observables(Obj%LO, unit, ll, errst=errst)
!if(prop_error('read_obs_c : lambda failed.', &
! 'ObsOps_include.f90:4143', errst=errst)) return
call read_distance_psi_observables_mpsrc(Obj%DPO, unit, unitpsi, &
errst=errst)
!if(prop_error('read_obs_c : distance psi failed.', &
! 'ObsOps_include.f90:4148', errst=errst)) return
call read_state_observables(Obj%state, unit, errst=errst)
!if(prop_error('read_obs_c : state failed.', &
! 'ObsOps_include.f90:4152', errst=errst)) return
call read_corr2nn_observables_complex(Obj%C2NN, unit, ll, errst=errst)
!if(prop_error('read_obs_c : state failed.', &
! 'ObsOps_include.f90:4156', errst=errst)) return
call read_rhoij_observables_tensorc(Obj%Rij, unit, ll, Obj%MI%has_mi, &
errst=errst)
!if(prop_error('read_obs_c : rhoij failed.', &
! 'ObsOps_include.f90:4161', errst=errst)) return
close(unit)
end subroutine read_obs_c
"""
return
[docs]def read_obsc():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the settings for all observables.
**Arguments**
Obj : TYPE(obsc), inout
The setting of the observables is stored in this variable.
flnm : CHARACTER(\*), in
Filename of the file with the settings for the observables.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit (for MPO measurements).
unitpsi : INTEGER, in
Can open and read wave functions for distance measures on this
unit.
ll : INTEGER, in
number of sites in the system.
Ops : TYPE(tensorlistc), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_obsc(Obj, flnm, writedir, unit, unitmpo, unitpsi, &
ll, Ops, Hparams, iop, errst)
type(obsc), intent(out) :: Obj
character(len=132), intent(in) :: flnm
character(len=132), intent(in) :: writedir
integer, intent(in) :: unit, unitmpo, unitpsi, ll
type(tensorlistc), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
Obj%static_eigenvalue = -9999999_rKind
Obj%hdf5_target_file = ''
Obj%quench_ii = ''
Obj%step_ii = ''
Obj%name = flnm
open(unit=unit, file=trim(adjustl(flnm)), action='read', &
status='old')
! Only referenced for iMPS
read(unit, '(1I16)') Obj%corr_range
call read_site_observables(Obj%SO, unit, ll, errst=errst)
!if(prop_error('read_obsc : site failed.', &
! 'ObsOps_include.f90:4100', errst=errst)) return
call read_siteentropy_observables(Obj%SE, unit, ll, errst=errst)
!if(prop_error('read_obsc : site entropy failed.', &
! 'ObsOps_include.f90:4104', errst=errst)) return
call read_bondentropy_observables(Obj%BE, unit, ll, errst=errst)
!if(prop_error('read_obsc : bond entropy failed.', &
! 'ObsOps_include.f90:4108', errst=errst)) return
call read_corr_observables_complex(Obj%CO, unit, ll, errst=errst)
!if(prop_error('read_obsc : corr failed.', &
! 'ObsOps_include.f90:4112', errst=errst)) return
call read_fcorr_observables_complex(Obj%FCO, unit, ll, errst=errst)
!if(prop_error('read_obsc : fcorr failed.', &
! 'ObsOps_include.f90:4116', errst=errst)) return
call read_string_observables(Obj%STO, unit, ll, errst=errst)
!if(prop_error('read_obsc : string failed.', &
! 'ObsOps_include.f90:4120', errst=errst)) return
call read_mpo_observables_mpoc(Obj%MO, unit, unitmpo, ll, writedir, &
Ops, Hparams, iop, errst=errst)
!if(prop_error('read_obsc : mpo failed.', &
! 'ObsOps_include.f90:4125', errst=errst)) return
call read_rhoi_observables_tensorc(Obj%Ri, unit, ll, errst=errst)
!if(prop_error('read_obsc : rhoi failed.', &
! 'ObsOps_include.f90:4129', errst=errst)) return
! Rhoij depends on mutual information - put to the end
call read_rhoijk_observables_tensorc(Obj%Rijk, unit, errst=errst)
!if(prop_error('read_obsc : rhoijk failed.', &
! 'ObsOps_include.f90:4135', errst=errst)) return
call read_mutualinformation_observables(Obj%MI, unit, ll, errst=errst)
!if(prop_error('read_obsc : mi failed.', &
! 'ObsOps_include.f90:4139', errst=errst)) return
call read_lambda_observables(Obj%LO, unit, ll, errst=errst)
!if(prop_error('read_obsc : lambda failed.', &
! 'ObsOps_include.f90:4143', errst=errst)) return
call read_distance_psi_observables_mpsrc(Obj%DPO, unit, unitpsi, &
errst=errst)
!if(prop_error('read_obsc : distance psi failed.', &
! 'ObsOps_include.f90:4148', errst=errst)) return
call read_state_observables(Obj%state, unit, errst=errst)
!if(prop_error('read_obsc : state failed.', &
! 'ObsOps_include.f90:4152', errst=errst)) return
call read_corr2nn_observables_complex(Obj%C2NN, unit, ll, errst=errst)
!if(prop_error('read_obsc : state failed.', &
! 'ObsOps_include.f90:4156', errst=errst)) return
call read_rhoij_observables_tensorc(Obj%Rij, unit, ll, Obj%MI%has_mi, &
errst=errst)
!if(prop_error('read_obsc : rhoij failed.', &
! 'ObsOps_include.f90:4161', errst=errst)) return
close(unit)
end subroutine read_obsc
"""
return
[docs]def read_qobs_r():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the settings for all observables.
**Arguments**
Obj : TYPE(qobs_r), inout
The setting of the observables is stored in this variable.
flnm : CHARACTER(\*), in
Filename of the file with the settings for the observables.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit (for MPO measurements).
unitpsi : INTEGER, in
Can open and read wave functions for distance measures on this
unit.
ll : INTEGER, in
number of sites in the system.
Ops : TYPE(qtensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qobs_r(Obj, flnm, writedir, unit, unitmpo, unitpsi, &
ll, Ops, Hparams, iop, errst)
type(qobs_r), intent(out) :: Obj
character(len=132), intent(in) :: flnm
character(len=132), intent(in) :: writedir
integer, intent(in) :: unit, unitmpo, unitpsi, ll
type(qtensorlist), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
Obj%static_eigenvalue = -9999999_rKind
Obj%hdf5_target_file = ''
Obj%quench_ii = ''
Obj%step_ii = ''
Obj%name = flnm
open(unit=unit, file=trim(adjustl(flnm)), action='read', &
status='old')
! Only referenced for iMPS
read(unit, '(1I16)') Obj%corr_range
call read_site_observables(Obj%SO, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : site failed.', &
! 'ObsOps_include.f90:4100', errst=errst)) return
call read_siteentropy_observables(Obj%SE, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : site entropy failed.', &
! 'ObsOps_include.f90:4104', errst=errst)) return
call read_bondentropy_observables(Obj%BE, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : bond entropy failed.', &
! 'ObsOps_include.f90:4108', errst=errst)) return
call read_corr_observables_real(Obj%CO, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : corr failed.', &
! 'ObsOps_include.f90:4112', errst=errst)) return
call read_fcorr_observables_real(Obj%FCO, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : fcorr failed.', &
! 'ObsOps_include.f90:4116', errst=errst)) return
call read_string_observables(Obj%STO, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : string failed.', &
! 'ObsOps_include.f90:4120', errst=errst)) return
call read_mpo_observables_qmpo(Obj%MO, unit, unitmpo, ll, writedir, &
Ops, Hparams, iop, errst=errst)
!if(prop_error('read_qobs_r : mpo failed.', &
! 'ObsOps_include.f90:4125', errst=errst)) return
call read_rhoi_observables_tensor(Obj%Ri, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : rhoi failed.', &
! 'ObsOps_include.f90:4129', errst=errst)) return
! Rhoij depends on mutual information - put to the end
call read_rhoijk_observables_tensor(Obj%Rijk, unit, errst=errst)
!if(prop_error('read_qobs_r : rhoijk failed.', &
! 'ObsOps_include.f90:4135', errst=errst)) return
call read_mutualinformation_observables(Obj%MI, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : mi failed.', &
! 'ObsOps_include.f90:4139', errst=errst)) return
call read_lambda_observables(Obj%LO, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : lambda failed.', &
! 'ObsOps_include.f90:4143', errst=errst)) return
call read_distance_psi_observables_qmpsrc(Obj%DPO, unit, unitpsi, &
errst=errst)
!if(prop_error('read_qobs_r : distance psi failed.', &
! 'ObsOps_include.f90:4148', errst=errst)) return
call read_state_observables(Obj%state, unit, errst=errst)
!if(prop_error('read_qobs_r : state failed.', &
! 'ObsOps_include.f90:4152', errst=errst)) return
call read_corr2nn_observables_real(Obj%C2NN, unit, ll, errst=errst)
!if(prop_error('read_qobs_r : state failed.', &
! 'ObsOps_include.f90:4156', errst=errst)) return
call read_rhoij_observables_tensor(Obj%Rij, unit, ll, Obj%MI%has_mi, &
errst=errst)
!if(prop_error('read_qobs_r : rhoij failed.', &
! 'ObsOps_include.f90:4161', errst=errst)) return
close(unit)
end subroutine read_qobs_r
"""
return
[docs]def read_qobs_c():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the settings for all observables.
**Arguments**
Obj : TYPE(qobs_c), inout
The setting of the observables is stored in this variable.
flnm : CHARACTER(\*), in
Filename of the file with the settings for the observables.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit (for MPO measurements).
unitpsi : INTEGER, in
Can open and read wave functions for distance measures on this
unit.
ll : INTEGER, in
number of sites in the system.
Ops : TYPE(qtensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qobs_c(Obj, flnm, writedir, unit, unitmpo, unitpsi, &
ll, Ops, Hparams, iop, errst)
type(qobs_c), intent(out) :: Obj
character(len=132), intent(in) :: flnm
character(len=132), intent(in) :: writedir
integer, intent(in) :: unit, unitmpo, unitpsi, ll
type(qtensorlist), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
Obj%static_eigenvalue = -9999999_rKind
Obj%hdf5_target_file = ''
Obj%quench_ii = ''
Obj%step_ii = ''
Obj%name = flnm
open(unit=unit, file=trim(adjustl(flnm)), action='read', &
status='old')
! Only referenced for iMPS
read(unit, '(1I16)') Obj%corr_range
call read_site_observables(Obj%SO, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : site failed.', &
! 'ObsOps_include.f90:4100', errst=errst)) return
call read_siteentropy_observables(Obj%SE, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : site entropy failed.', &
! 'ObsOps_include.f90:4104', errst=errst)) return
call read_bondentropy_observables(Obj%BE, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : bond entropy failed.', &
! 'ObsOps_include.f90:4108', errst=errst)) return
call read_corr_observables_complex(Obj%CO, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : corr failed.', &
! 'ObsOps_include.f90:4112', errst=errst)) return
call read_fcorr_observables_complex(Obj%FCO, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : fcorr failed.', &
! 'ObsOps_include.f90:4116', errst=errst)) return
call read_string_observables(Obj%STO, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : string failed.', &
! 'ObsOps_include.f90:4120', errst=errst)) return
call read_mpo_observables_qmpo(Obj%MO, unit, unitmpo, ll, writedir, &
Ops, Hparams, iop, errst=errst)
!if(prop_error('read_qobs_c : mpo failed.', &
! 'ObsOps_include.f90:4125', errst=errst)) return
call read_rhoi_observables_tensorc(Obj%Ri, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : rhoi failed.', &
! 'ObsOps_include.f90:4129', errst=errst)) return
! Rhoij depends on mutual information - put to the end
call read_rhoijk_observables_tensorc(Obj%Rijk, unit, errst=errst)
!if(prop_error('read_qobs_c : rhoijk failed.', &
! 'ObsOps_include.f90:4135', errst=errst)) return
call read_mutualinformation_observables(Obj%MI, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : mi failed.', &
! 'ObsOps_include.f90:4139', errst=errst)) return
call read_lambda_observables(Obj%LO, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : lambda failed.', &
! 'ObsOps_include.f90:4143', errst=errst)) return
call read_distance_psi_observables_qmpsrc(Obj%DPO, unit, unitpsi, &
errst=errst)
!if(prop_error('read_qobs_c : distance psi failed.', &
! 'ObsOps_include.f90:4148', errst=errst)) return
call read_state_observables(Obj%state, unit, errst=errst)
!if(prop_error('read_qobs_c : state failed.', &
! 'ObsOps_include.f90:4152', errst=errst)) return
call read_corr2nn_observables_complex(Obj%C2NN, unit, ll, errst=errst)
!if(prop_error('read_qobs_c : state failed.', &
! 'ObsOps_include.f90:4156', errst=errst)) return
call read_rhoij_observables_tensorc(Obj%Rij, unit, ll, Obj%MI%has_mi, &
errst=errst)
!if(prop_error('read_qobs_c : rhoij failed.', &
! 'ObsOps_include.f90:4161', errst=errst)) return
close(unit)
end subroutine read_qobs_c
"""
return
[docs]def read_qobsc():
"""
fortran-subroutine - July 2017 (dj, updated)
Read the settings for all observables.
**Arguments**
Obj : TYPE(qobsc), inout
The setting of the observables is stored in this variable.
flnm : CHARACTER(\*), in
Filename of the file with the settings for the observables.
writedir : CHARACTER(\*), in
Directory name with temporary files. Needed to contruct
MPO file names for MPO measures.
unit : INTEGER, in
Open file hanlde with position at the site entropy measures.
unitmpo : INTEGER, in
Open MPO file on this unit (for MPO measurements).
unitpsi : INTEGER, in
Can open and read wave functions for distance measures on this
unit.
ll : INTEGER, in
number of sites in the system.
Ops : TYPE(qtensorclist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qobsc(Obj, flnm, writedir, unit, unitmpo, unitpsi, &
ll, Ops, Hparams, iop, errst)
type(qobsc), intent(out) :: Obj
character(len=132), intent(in) :: flnm
character(len=132), intent(in) :: writedir
integer, intent(in) :: unit, unitmpo, unitpsi, ll
type(qtensorclist), intent(in) :: Ops
type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
integer, intent(in) :: iop
integer, intent(out), optional :: errst
! Local variables
! ---------------
Obj%static_eigenvalue = -9999999_rKind
Obj%hdf5_target_file = ''
Obj%quench_ii = ''
Obj%step_ii = ''
Obj%name = flnm
open(unit=unit, file=trim(adjustl(flnm)), action='read', &
status='old')
! Only referenced for iMPS
read(unit, '(1I16)') Obj%corr_range
call read_site_observables(Obj%SO, unit, ll, errst=errst)
!if(prop_error('read_qobsc : site failed.', &
! 'ObsOps_include.f90:4100', errst=errst)) return
call read_siteentropy_observables(Obj%SE, unit, ll, errst=errst)
!if(prop_error('read_qobsc : site entropy failed.', &
! 'ObsOps_include.f90:4104', errst=errst)) return
call read_bondentropy_observables(Obj%BE, unit, ll, errst=errst)
!if(prop_error('read_qobsc : bond entropy failed.', &
! 'ObsOps_include.f90:4108', errst=errst)) return
call read_corr_observables_complex(Obj%CO, unit, ll, errst=errst)
!if(prop_error('read_qobsc : corr failed.', &
! 'ObsOps_include.f90:4112', errst=errst)) return
call read_fcorr_observables_complex(Obj%FCO, unit, ll, errst=errst)
!if(prop_error('read_qobsc : fcorr failed.', &
! 'ObsOps_include.f90:4116', errst=errst)) return
call read_string_observables(Obj%STO, unit, ll, errst=errst)
!if(prop_error('read_qobsc : string failed.', &
! 'ObsOps_include.f90:4120', errst=errst)) return
call read_mpo_observables_qmpoc(Obj%MO, unit, unitmpo, ll, writedir, &
Ops, Hparams, iop, errst=errst)
!if(prop_error('read_qobsc : mpo failed.', &
! 'ObsOps_include.f90:4125', errst=errst)) return
call read_rhoi_observables_tensorc(Obj%Ri, unit, ll, errst=errst)
!if(prop_error('read_qobsc : rhoi failed.', &
! 'ObsOps_include.f90:4129', errst=errst)) return
! Rhoij depends on mutual information - put to the end
call read_rhoijk_observables_tensorc(Obj%Rijk, unit, errst=errst)
!if(prop_error('read_qobsc : rhoijk failed.', &
! 'ObsOps_include.f90:4135', errst=errst)) return
call read_mutualinformation_observables(Obj%MI, unit, ll, errst=errst)
!if(prop_error('read_qobsc : mi failed.', &
! 'ObsOps_include.f90:4139', errst=errst)) return
call read_lambda_observables(Obj%LO, unit, ll, errst=errst)
!if(prop_error('read_qobsc : lambda failed.', &
! 'ObsOps_include.f90:4143', errst=errst)) return
call read_distance_psi_observables_qmpsrc(Obj%DPO, unit, unitpsi, &
errst=errst)
!if(prop_error('read_qobsc : distance psi failed.', &
! 'ObsOps_include.f90:4148', errst=errst)) return
call read_state_observables(Obj%state, unit, errst=errst)
!if(prop_error('read_qobsc : state failed.', &
! 'ObsOps_include.f90:4152', errst=errst)) return
call read_corr2nn_observables_complex(Obj%C2NN, unit, ll, errst=errst)
!if(prop_error('read_qobsc : state failed.', &
! 'ObsOps_include.f90:4156', errst=errst)) return
call read_rhoij_observables_tensorc(Obj%Rij, unit, ll, Obj%MI%has_mi, &
errst=errst)
!if(prop_error('read_qobsc : rhoij failed.', &
! 'ObsOps_include.f90:4161', errst=errst)) return
close(unit)
end subroutine read_qobsc
"""
return
[docs]def rhoij_init_mps_tensor():
"""
fortran-subroutine - August 2017 (dj)
Initial contraction for the construction of two-site density matrices.
**Arguments**
Tenskk : TYPE(tensor), inout
Tensor representing the site kk, should be the orthgonality center.
Theta : TYPE(tensor), out
On exit, contraction of the tensor on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_mps_tensor(Psikk, Theta, errst)
type(tensor), intent(inout) :: Psikk
type(tensor), intent(out) :: Theta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary conjugate tensor
type(tensor) :: Tmp
!if(present(errst)) errst = 0
call copy(Tmp, Psikk, trans='C', errst=errst)
!if(prop_error('rhoij_init_mps_tensor: copy failed.', &
! 'ObsOps_include.f90:4207', errst=errst)) return
call contr(Theta, Psikk, Tmp, [1], [1], errst=errst)
!if(prop_error('rhoij_init_mps_tensor: contr failed.', &
! 'ObsOps_include.f90:4211', errst=errst)) return
call transposed(Theta, [1, 3, 2, 4], doperm=.true., errst=errst)
!if(prop_error('rhoij_init_mps_tensor: transposed failed.', &
! 'ObsOps_include.f90:4215', errst=errst)) return
call destroy(Tmp)
end subroutine rhoij_init_mps_tensor
"""
return
[docs]def rhoij_init_mps_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Initial contraction for the construction of two-site density matrices.
**Arguments**
Tenskk : TYPE(tensorc), inout
Tensor representing the site kk, should be the orthgonality center.
Theta : TYPE(tensorc), out
On exit, contraction of the tensor on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_mps_tensorc(Psikk, Theta, errst)
type(tensorc), intent(inout) :: Psikk
type(tensorc), intent(out) :: Theta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary conjugate tensor
type(tensorc) :: Tmp
!if(present(errst)) errst = 0
call copy(Tmp, Psikk, trans='C', errst=errst)
!if(prop_error('rhoij_init_mps_tensorc: copy failed.', &
! 'ObsOps_include.f90:4207', errst=errst)) return
call contr(Theta, Psikk, Tmp, [1], [1], errst=errst)
!if(prop_error('rhoij_init_mps_tensorc: contr failed.', &
! 'ObsOps_include.f90:4211', errst=errst)) return
call transposed(Theta, [1, 3, 2, 4], doperm=.true., errst=errst)
!if(prop_error('rhoij_init_mps_tensorc: transposed failed.', &
! 'ObsOps_include.f90:4215', errst=errst)) return
call destroy(Tmp)
end subroutine rhoij_init_mps_tensorc
"""
return
[docs]def rhoij_init_mps_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Initial contraction for the construction of two-site density matrices.
**Arguments**
Tenskk : TYPE(qtensor), inout
Tensor representing the site kk, should be the orthgonality center.
Theta : TYPE(qtensor), out
On exit, contraction of the tensor on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_mps_qtensor(Psikk, Theta, errst)
type(qtensor), intent(inout) :: Psikk
type(qtensor), intent(out) :: Theta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary conjugate tensor
type(qtensor) :: Tmp
!if(present(errst)) errst = 0
call copy(Tmp, Psikk, trans='C', errst=errst)
!if(prop_error('rhoij_init_mps_qtensor: copy failed.', &
! 'ObsOps_include.f90:4207', errst=errst)) return
call contr(Theta, Psikk, Tmp, [1], [1], errst=errst)
!if(prop_error('rhoij_init_mps_qtensor: contr failed.', &
! 'ObsOps_include.f90:4211', errst=errst)) return
call transposed(Theta, [1, 3, 2, 4], doperm=.true., errst=errst)
!if(prop_error('rhoij_init_mps_qtensor: transposed failed.', &
! 'ObsOps_include.f90:4215', errst=errst)) return
call destroy(Tmp)
end subroutine rhoij_init_mps_qtensor
"""
return
[docs]def rhoij_init_mps_qtensorc():
"""
fortran-subroutine - August 2017 (dj)
Initial contraction for the construction of two-site density matrices.
**Arguments**
Tenskk : TYPE(qtensorc), inout
Tensor representing the site kk, should be the orthgonality center.
Theta : TYPE(qtensorc), out
On exit, contraction of the tensor on site kk.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_init_mps_qtensorc(Psikk, Theta, errst)
type(qtensorc), intent(inout) :: Psikk
type(qtensorc), intent(out) :: Theta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Temporary conjugate tensor
type(qtensorc) :: Tmp
!if(present(errst)) errst = 0
call copy(Tmp, Psikk, trans='C', errst=errst)
!if(prop_error('rhoij_init_mps_qtensorc: copy failed.', &
! 'ObsOps_include.f90:4207', errst=errst)) return
call contr(Theta, Psikk, Tmp, [1], [1], errst=errst)
!if(prop_error('rhoij_init_mps_qtensorc: contr failed.', &
! 'ObsOps_include.f90:4211', errst=errst)) return
call transposed(Theta, [1, 3, 2, 4], doperm=.true., errst=errst)
!if(prop_error('rhoij_init_mps_qtensorc: transposed failed.', &
! 'ObsOps_include.f90:4215', errst=errst)) return
call destroy(Tmp)
end subroutine rhoij_init_mps_qtensorc
"""
return
[docs]def rhoij_meas_mps_tensor_tensor():
"""
fortran-subroutine - August 2017 (dj)
Build two-site density matrix and propagate for the next site.
**Arguments**
Rhosij : TYPE(tensor)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(tensor), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(tensor), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(tensor), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_mps_tensor_tensor(Rhosij, Psijj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(tensor), dimension(:, :), intent(inout) :: Rhosij
type(tensor), intent(inout) :: Psijj
integer, intent(in) :: ii, jj, ll
type(tensor), intent(inout) :: Theta
type(tensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(tensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call copy(Tmpb, Psijj, trans='C')
call contr(Tmpa, Psijj, Tmpb, [3], [3], errst=errst)
!if(prop_error('rhoij_meas_mps_tensor_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4324', &
! errst=errst)) return
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], errst=errst)
!if(prop_error('rhoij_meas_mps_tensor_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4329', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_tensor_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4345', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2], errst=errst)
!if(prop_error('rhoij_meas_mps_tensor_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4353', &
! errst=errst)) return
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-chiket'-ldket
call contr(Theta, Tmpb, Psijj, [3, 5], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_tensor_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4362', &
! errst=errst)) return
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_tensor_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4370', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Theta, Tmpa, Psijj, [3, 4], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_tensor_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4379', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mps_tensor_tensor
"""
return
[docs]def rhoij_meas_mps_tensorc_tensor():
"""
fortran-subroutine - August 2017 (dj)
Build two-site density matrix and propagate for the next site.
**Arguments**
Rhosij : TYPE(tensorc)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(tensorc), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(tensorc), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(tensor), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_mps_tensorc_tensor(Rhosij, Psijj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(tensorc), dimension(:, :), intent(inout) :: Rhosij
type(tensorc), intent(inout) :: Psijj
integer, intent(in) :: ii, jj, ll
type(tensorc), intent(inout) :: Theta
type(tensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call copy(Tmpb, Psijj, trans='C')
call contr(Tmpa, Psijj, Tmpb, [3], [3], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4324', &
! errst=errst)) return
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4329', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4345', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4353', &
! errst=errst)) return
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-chiket'-ldket
call contr(Theta, Tmpb, Psijj, [3, 5], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4362', &
! errst=errst)) return
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4370', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Theta, Tmpa, Psijj, [3, 4], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensor'//&
! ': contr failed.', 'ObsOps_include.f90:4379', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mps_tensorc_tensor
"""
return
[docs]def rhoij_meas_mps_tensorc_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Build two-site density matrix and propagate for the next site.
**Arguments**
Rhosij : TYPE(tensorc)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(tensorc), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(tensorc), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(tensorc), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_mps_tensorc_tensorc(Rhosij, Psijj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(tensorc), dimension(:, :), intent(inout) :: Rhosij
type(tensorc), intent(inout) :: Psijj
integer, intent(in) :: ii, jj, ll
type(tensorc), intent(inout) :: Theta
type(tensorc), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(tensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call copy(Tmpb, Psijj, trans='C')
call contr(Tmpa, Psijj, Tmpb, [3], [3], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4324', &
! errst=errst)) return
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4329', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4345', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4353', &
! errst=errst)) return
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-chiket'-ldket
call contr(Theta, Tmpb, Psijj, [3, 5], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4362', &
! errst=errst)) return
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4370', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Theta, Tmpa, Psijj, [3, 4], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_tensorc_tensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4379', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mps_tensorc_tensorc
"""
return
[docs]def rhoij_meas_mps_qtensor_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Build two-site density matrix and propagate for the next site.
**Arguments**
Rhosij : TYPE(qtensor)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(qtensor), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(qtensor), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(qtensor), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_mps_qtensor_qtensor(Rhosij, Psijj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(qtensor), dimension(:, :), intent(inout) :: Rhosij
type(qtensor), intent(inout) :: Psijj
integer, intent(in) :: ii, jj, ll
type(qtensor), intent(inout) :: Theta
type(qtensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(qtensor) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call copy(Tmpb, Psijj, trans='C')
call contr(Tmpa, Psijj, Tmpb, [3], [3], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensor_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4324', &
! errst=errst)) return
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensor_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4329', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensor_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4345', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensor_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4353', &
! errst=errst)) return
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-chiket'-ldket
call contr(Theta, Tmpb, Psijj, [3, 5], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_qtensor_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4362', &
! errst=errst)) return
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensor_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4370', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Theta, Tmpa, Psijj, [3, 4], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_qtensor_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4379', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mps_qtensor_qtensor
"""
return
[docs]def rhoij_meas_mps_qtensorc_qtensor():
"""
fortran-subroutine - August 2017 (dj)
Build two-site density matrix and propagate for the next site.
**Arguments**
Rhosij : TYPE(qtensorc)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(qtensorc), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(qtensorc), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(qtensor), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_mps_qtensorc_qtensor(Rhosij, Psijj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(qtensorc), dimension(:, :), intent(inout) :: Rhosij
type(qtensorc), intent(inout) :: Psijj
integer, intent(in) :: ii, jj, ll
type(qtensorc), intent(inout) :: Theta
type(qtensor), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call copy(Tmpb, Psijj, trans='C')
call contr(Tmpa, Psijj, Tmpb, [3], [3], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4324', &
! errst=errst)) return
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4329', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4345', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4353', &
! errst=errst)) return
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-chiket'-ldket
call contr(Theta, Tmpb, Psijj, [3, 5], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4362', &
! errst=errst)) return
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4370', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Theta, Tmpa, Psijj, [3, 4], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensor'//&
! ': contr failed.', 'ObsOps_include.f90:4379', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mps_qtensorc_qtensor
"""
return
[docs]def rhoij_meas_mps_qtensorc_qtensorc():
"""
fortran-subroutine - August 2017 (dj)
Build two-site density matrix and propagate for the next site.
**Arguments**
Rhosij : TYPE(qtensorc)(\*, \*), inout
Matrix containing two-site density matrices.
Tensjj : TYPE(qtensorc), inout
Tensor representing the current site to be contracted.
ii : INTEGER, inout
Index of the left site of the density matrix kept in Theta.
jj : INTEGER, inout
Index of the tensors Tensjj.
ll : INTEGER, inout
Number of sites in the system, used to detect when propagation is
stopped.
Theta : TYPE(qtensorc), inout
Tensor containing the contractions from the left part of
the system.
PhaseOp : TYPE(qtensorc), inout
Phase operator to be contracted within the propagation.
hasphase : LOGICAL, inout
Flag if phase operator is present (.true.).
skip : LOGICAL, OPTIONAL, inout
If present and true, the measurement of the density matrix is skiped
and it is only propagated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rhoij_meas_mps_qtensorc_qtensorc(Rhosij, Psijj, ii, jj, ll, &
Theta, PhaseOp, hasphase, skip, errst)
type(qtensorc), dimension(:, :), intent(inout) :: Rhosij
type(qtensorc), intent(inout) :: Psijj
integer, intent(in) :: ii, jj, ll
type(qtensorc), intent(inout) :: Theta
type(qtensorc), intent(inout) :: PhaseOp
logical, intent(in) :: hasphase
logical, intent(in), optional :: skip
integer, intent(out), optional :: errst
! Local variables
! ---------------
! duplicate of optional argument
logical :: skip_
! temporary tensors
type(qtensorc) :: Tmpa, Tmpb
!if(present(errst)) errst = 0
skip_ = .false.
if(present(skip)) skip_ = skip
! 1) Calculate density matrix i, j with i < j
! -------------------------------------------
if(.not. skip_) then
call copy(Tmpb, Psijj, trans='C')
call contr(Tmpa, Psijj, Tmpb, [3], [3], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4324', &
! errst=errst)) return
call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4329', &
! errst=errst)) return
call destroy(Tmpa)
call destroy(Tmpb)
call transposed(Rhosij(ii, jj), [1, 3, 2, 4], doperm=.true.)
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, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4345', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Tmpb, Tmpa, PhaseOp, [4], [2], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4353', &
! errst=errst)) return
call destroy(Tmpa)
! Tmpb has ket-bra-chibra-chiket'-ldket
call contr(Theta, Tmpb, Psijj, [3, 5], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4362', &
! errst=errst)) return
call destroy(Tmpb)
elseif(jj < ll) then
! No phase
call contr(Tmpa, Theta, Psijj, [3], [1], errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4370', &
! errst=errst)) return
call destroy(Theta)
! Tmpa has ket-bra-chibra-ldket-chiket'
call contr(Theta, Tmpa, Psijj, [3, 4], [1, 2], transr='C', &
errst=errst)
!if(prop_error('rhoij_meas_mps_qtensorc_qtensorc'//&
! ': contr failed.', 'ObsOps_include.f90:4379', &
! errst=errst)) return
call destroy(Tmpa)
else
! Destroy
call destroy(Theta)
end if
end subroutine rhoij_meas_mps_qtensorc_qtensorc
"""
return
[docs]def write_site_observables():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the site observables, if requested.
**Arguments**
Obj : TYPE(site_observables), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
specstring : CHARACTER(16), in
String specifier for ll floats, where ll is the system size.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_site_observables(Obj, unit, specstring)
type(site_observables), intent(inout) :: Obj
integer, intent(in) :: unit
character(16), intent(in) :: specstring
! Local variables
! ---------------
! for looping
integer :: jj
do jj = 1, Obj%nsite
write(unit, specstring) Obj%elem(:, jj)
end do
end subroutine write_site_observables
"""
return
[docs]def write_siteentropy_observables():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the site entropy, if requested.
**Arguments**
Obj : TYPE(siteentropy_observables), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
specstring : CHARACTER(16), in
String specifier for ll floats, where ll is the system size.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_siteentropy_observables(Obj, unit, specstring)
type(siteentropy_observables), intent(inout) :: Obj
integer, intent(in) :: unit
character(16), intent(in) :: specstring
! No local variables
! ------------------
if(Obj%siteentr) then
write(unit, specstring) Obj%elem
Obj%elem = 0.0_rKind
end if
end subroutine write_siteentropy_observables
"""
return
[docs]def write_bondentropy_observables():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the bond entropy, if requested.
**Arguments**
Obj : TYPE(bondentropy_observables), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_bondentropy_observables(Obj, unit)
type(bondentropy_observables), intent(inout) :: Obj
integer, intent(in) :: unit
! Local variables
! ---------------
! Format strings for write(*, *)
character(16) :: iwstring, specstring
if(Obj%bondentr) then
! Default string specifier for ll sites
write(iwstring, '(I4)') size(Obj%elem, 1)
specstring = "("//trim(adjustl(iwstring))//"E30.15E3)"
! And write data
write(unit, specstring) Obj%elem
Obj%elem = 0.0_rKind
end if
end subroutine write_bondentropy_observables
"""
return
[docs]def write_corr_observables_real():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the correlation measures, if requested.
**Arguments**
Obj : TYPE(corr_observables_real), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
specstring : CHARACTER(16), in
String specifier for ll floats, where ll is the system size.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_corr_observables_real(Obj, unit, specstring)
type(corr_observables_real), intent(inout) :: Obj
integer, intent(in) :: unit
character(16), intent(in) :: specstring
! Local variables
! ---------------
! for looping
integer :: ii, jj
do jj = 1, Obj%ncorr
if(Obj%isherm(jj)) then
write(unit, '(1A1)') 'R'
else
write(unit, '(1A1)') 'R'
end if
do ii = 1, size(Obj%elem, 1)
write(unit, specstring) real(Obj%elem(ii, :, jj), KIND=rKind)
!if(.not. Obj%isherm(jj)) then
! write(unit, specstring) aimag(Obj%elem(ii, :, jj))
!end if
end do
end do
if(Obj%ncorr > 0) Obj%elem = 0.0_rKind
end subroutine write_corr_observables_real
"""
return
[docs]def write_corr_observables_complex():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the correlation measures, if requested.
**Arguments**
Obj : TYPE(corr_observables_complex), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
specstring : CHARACTER(16), in
String specifier for ll floats, where ll is the system size.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_corr_observables_complex(Obj, unit, specstring)
type(corr_observables_complex), intent(inout) :: Obj
integer, intent(in) :: unit
character(16), intent(in) :: specstring
! Local variables
! ---------------
! for looping
integer :: ii, jj
do jj = 1, Obj%ncorr
if(Obj%isherm(jj)) then
write(unit, '(1A1)') 'R'
else
write(unit, '(1A1)') 'C'
end if
do ii = 1, size(Obj%elem, 1)
write(unit, specstring) real(Obj%elem(ii, :, jj), KIND=rKind)
if(.not. Obj%isherm(jj)) then
write(unit, specstring) aimag(Obj%elem(ii, :, jj))
end if
end do
end do
if(Obj%ncorr > 0) Obj%elem = 0.0_rKind
end subroutine write_corr_observables_complex
"""
return
[docs]def write_string_observables():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the string correlation measures, if requested.
**Arguments**
Obj : TYPE(string_observables), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
specstring : CHARACTER(16), in
String specifier for ll floats, where ll is the system size.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_string_observables(Obj, unit, specstring)
type(string_observables), intent(inout) :: Obj
integer, intent(in) :: unit
character(16), intent(in) :: specstring
! Local variables
! ---------------
! for looping
integer :: ii, jj
do jj = 1, Obj%nstring
do ii = 1, size(Obj%elem, 1)
write(unit, specstring) Obj%elem(ii, :, jj)
end do
end do
end subroutine write_string_observables
"""
return
[docs]def write_mpo_observables_mpo():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the MPO measurements, if requested.
**Arguments**
Obj : TYPE(mpo_observables_mpo), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_mpo_observables_mpo(Obj, unit)
type(mpo_observables_mpo), intent(inout) :: Obj
integer, intent(in) :: unit
! Local observables
! -----------------
integer :: jj
do jj = 1, Obj%nmpo
write(unit, '(1E30.15E3)') Obj%elem(jj)
end do
end subroutine write_mpo_observables_mpo
"""
return
[docs]def write_mpo_observables_mpoc():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the MPO measurements, if requested.
**Arguments**
Obj : TYPE(mpo_observables_mpoc), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_mpo_observables_mpoc(Obj, unit)
type(mpo_observables_mpoc), intent(inout) :: Obj
integer, intent(in) :: unit
! Local observables
! -----------------
integer :: jj
do jj = 1, Obj%nmpo
write(unit, '(1E30.15E3)') Obj%elem(jj)
end do
end subroutine write_mpo_observables_mpoc
"""
return
[docs]def write_mpo_observables_qmpo():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the MPO measurements, if requested.
**Arguments**
Obj : TYPE(mpo_observables_qmpo), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_mpo_observables_qmpo(Obj, unit)
type(mpo_observables_qmpo), intent(inout) :: Obj
integer, intent(in) :: unit
! Local observables
! -----------------
integer :: jj
do jj = 1, Obj%nmpo
write(unit, '(1E30.15E3)') Obj%elem(jj)
end do
end subroutine write_mpo_observables_qmpo
"""
return
[docs]def write_mpo_observables_qmpoc():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the MPO measurements, if requested.
**Arguments**
Obj : TYPE(mpo_observables_qmpoc), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_mpo_observables_qmpoc(Obj, unit)
type(mpo_observables_qmpoc), intent(inout) :: Obj
integer, intent(in) :: unit
! Local observables
! -----------------
integer :: jj
do jj = 1, Obj%nmpo
write(unit, '(1E30.15E3)') Obj%elem(jj)
end do
end subroutine write_mpo_observables_qmpoc
"""
return
[docs]def write_rhoi_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the single site reduced density matrices,
if requested.
**Arguments**
Obj : TYPE(rhoi_observables_tensor), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_rhoi_observables_tensor(Obj, unit)
type(rhoi_observables_tensor), intent(inout) :: Obj
integer, intent(in) :: unit
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%hasrho_i) then
do ii = 1, size(Obj%rho_i_i, 1)
call write_as_matrix(Obj%Elem(ii), unit)
call destroy(Obj%Elem(ii))
end do
end if
end subroutine write_rhoi_observables_tensor
"""
return
[docs]def write_rhoi_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the single site reduced density matrices,
if requested.
**Arguments**
Obj : TYPE(rhoi_observables_tensorc), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_rhoi_observables_tensorc(Obj, unit)
type(rhoi_observables_tensorc), intent(inout) :: Obj
integer, intent(in) :: unit
! Local variables
! ---------------
! for looping
integer :: ii
if(Obj%hasrho_i) then
do ii = 1, size(Obj%rho_i_i, 1)
call write_as_matrix(Obj%Elem(ii), unit)
call destroy(Obj%Elem(ii))
end do
end if
end subroutine write_rhoi_observables_tensorc
"""
return
[docs]def write_rhoij_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the two-site reduced density matrices,
if requested.
**Arguments**
Obj : TYPE(rhoij_observables_tensor), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
has_mi : LOGICAL, in
Measurement of the mutual information influences which
two-site entries have to be deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_rhoij_observables_tensor(Obj, unit, has_mi)
type(rhoij_observables_tensor), intent(inout) :: Obj
integer, intent(in) :: unit
logical, intent(in) :: has_mi
! Local variables
! ---------------
! for looping
integer :: ii, jj, iidx, jidx
if(Obj%hasrho_ij) then
do ii = 1, size(Obj%rho_ij_is, 1)
iidx = Obj%rho_ij_is(ii)
do jj =1, size(Obj%Rho_ij_js(ii)%elem, 1)
jidx = Obj%rho_ij_js(ii)%elem(jj)
! Reduce from rank 4 to matrix
call fuse(Obj%Elem(iidx, jidx), [3, 4])
call fuse(Obj%Elem(iidx, jidx), [1, 2])
call write_as_matrix(Obj%Elem(iidx, jidx), unit)
end do
end do
end if
! Deallocation depends as well on two-site density matrices
if(has_mi) then
do ii = 1, (size(Obj%Elem, 1) - 1)
do jj = (ii + 1), size(Obj%Elem, 1)
call destroy(Obj%Elem(ii, jj))
end do
end do
elseif(Obj%hasrho_ij) then
do ii = 1, size(Obj%rho_ij_is, 1)
iidx = Obj%rho_ij_is(ii)
do jj =1, size(Obj%Rho_ij_js(ii)%elem, 1)
jidx = Obj%rho_ij_js(ii)%elem(jj)
call destroy(Obj%Elem(iidx, jidx))
end do
end do
end if
end subroutine write_rhoij_observables_tensor
"""
return
[docs]def write_rhoij_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the two-site reduced density matrices,
if requested.
**Arguments**
Obj : TYPE(rhoij_observables_tensorc), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
has_mi : LOGICAL, in
Measurement of the mutual information influences which
two-site entries have to be deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_rhoij_observables_tensorc(Obj, unit, has_mi)
type(rhoij_observables_tensorc), intent(inout) :: Obj
integer, intent(in) :: unit
logical, intent(in) :: has_mi
! Local variables
! ---------------
! for looping
integer :: ii, jj, iidx, jidx
if(Obj%hasrho_ij) then
do ii = 1, size(Obj%rho_ij_is, 1)
iidx = Obj%rho_ij_is(ii)
do jj =1, size(Obj%Rho_ij_js(ii)%elem, 1)
jidx = Obj%rho_ij_js(ii)%elem(jj)
! Reduce from rank 4 to matrix
call fuse(Obj%Elem(iidx, jidx), [3, 4])
call fuse(Obj%Elem(iidx, jidx), [1, 2])
call write_as_matrix(Obj%Elem(iidx, jidx), unit)
end do
end do
end if
! Deallocation depends as well on two-site density matrices
if(has_mi) then
do ii = 1, (size(Obj%Elem, 1) - 1)
do jj = (ii + 1), size(Obj%Elem, 1)
call destroy(Obj%Elem(ii, jj))
end do
end do
elseif(Obj%hasrho_ij) then
do ii = 1, size(Obj%rho_ij_is, 1)
iidx = Obj%rho_ij_is(ii)
do jj =1, size(Obj%Rho_ij_js(ii)%elem, 1)
jidx = Obj%rho_ij_js(ii)%elem(jj)
call destroy(Obj%Elem(iidx, jidx))
end do
end do
end if
end subroutine write_rhoij_observables_tensorc
"""
return
[docs]def write_rhoijk_observables_tensor():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the general reduced density matrices,
if requested.
**Arguments**
Obj : TYPE(rhoijk_observables_tensor), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_rhoijk_observables_tensor(Obj, unit, errst)
type(rhoijk_observables_tensor), intent(inout) :: Obj
integer, intent(in) :: unit
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! indices for fusing
integer, dimension(:), allocatable :: fidx
!if(present(errst)) errst = 0
do ii = 1, Obj%nn
allocate(fidx(Obj%sizes(ii)))
! Reduce first set of indices
fidx = [(Obj%sizes(ii) + jj, jj = 1, Obj%sizes(ii))]
call fuse(Obj%Elem(ii), fidx, errst=errst)
!if(prop_error('write_rhoijk_observables_tensor: '//&
! 'fuse failed.', 'ObsOps_include.f90:4852', &
! errst=errst)) return
! Reduce second set of indices to matrix
fidx = [(jj, jj = 1, Obj%sizes(ii))]
call fuse(Obj%Elem(ii), fidx)
!if(prop_error('write_rhoijk_observables_tensor: '//&
! 'fuse failed.', 'ObsOps_include.f90:4859', &
! errst=errst)) return
! Write as density matrix on complete Hilbert space
call write_as_matrix(Obj%Elem(ii), unit)
deallocate(fidx)
call destroy(Obj%Elem(ii))
end do
end subroutine write_rhoijk_observables_tensor
"""
return
[docs]def write_rhoijk_observables_tensorc():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the general reduced density matrices,
if requested.
**Arguments**
Obj : TYPE(rhoijk_observables_tensorc), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_rhoijk_observables_tensorc(Obj, unit, errst)
type(rhoijk_observables_tensorc), intent(inout) :: Obj
integer, intent(in) :: unit
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! indices for fusing
integer, dimension(:), allocatable :: fidx
!if(present(errst)) errst = 0
do ii = 1, Obj%nn
allocate(fidx(Obj%sizes(ii)))
! Reduce first set of indices
fidx = [(Obj%sizes(ii) + jj, jj = 1, Obj%sizes(ii))]
call fuse(Obj%Elem(ii), fidx, errst=errst)
!if(prop_error('write_rhoijk_observables_tensorc: '//&
! 'fuse failed.', 'ObsOps_include.f90:4852', &
! errst=errst)) return
! Reduce second set of indices to matrix
fidx = [(jj, jj = 1, Obj%sizes(ii))]
call fuse(Obj%Elem(ii), fidx)
!if(prop_error('write_rhoijk_observables_tensorc: '//&
! 'fuse failed.', 'ObsOps_include.f90:4859', &
! errst=errst)) return
! Write as density matrix on complete Hilbert space
call write_as_matrix(Obj%Elem(ii), unit)
deallocate(fidx)
call destroy(Obj%Elem(ii))
end do
end subroutine write_rhoijk_observables_tensorc
"""
return
[docs]def write_lambda_observables():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the singular values, if requested.
**Arguments**
Obj : TYPE(lambda_observables), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_lambda_observables(Obj, unit)
type(lambda_observables), intent(inout) :: Obj
integer, intent(in) :: unit
! Local observables
! -----------------
! for looping
integer :: ii
! actual index
integer :: idx
! Format strings for write(*, *)
character(16) :: iwstring, specstring
if(Obj%has_lambda) then
do ii = 1, size(Obj%lambda, 1)
idx = Obj%lambda(ii) + 1
! String specifier
write(iwstring, '(I4)') Obj%Vecs(idx)%dim
specstring = "("//trim(adjustl(iwstring))//"E30.15E3)"
write(unit, '(1I16)') Obj%Vecs(idx)%dim
write(unit, specstring) Obj%Vecs(idx)%elem(:Obj%Vecs(idx)%dim)
call destroy(Obj%Vecs(idx))
end do
end if
end subroutine write_lambda_observables
"""
return
[docs]def write_distance_psi_observables_mpsrc():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the distance measures, if requested.
**Arguments**
Obj : TYPE(distance_psi_observables_mpsrc), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_distance_psi_observables_mpsrc(Obj, unit)
type(distance_psi_observables_mpsrc), intent(inout) :: Obj
integer, intent(in) :: unit
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Obj%ndist
write(unit, '(2E30.15E3)') Obj%elem(ii)
end do
end subroutine write_distance_psi_observables_mpsrc
"""
return
[docs]def write_distance_psi_observables_qmpsrc():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the distance measures, if requested.
**Arguments**
Obj : TYPE(distance_psi_observables_qmpsrc), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_distance_psi_observables_qmpsrc(Obj, unit)
type(distance_psi_observables_qmpsrc), intent(inout) :: Obj
integer, intent(in) :: unit
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, Obj%ndist
write(unit, '(2E30.15E3)') Obj%elem(ii)
end do
end subroutine write_distance_psi_observables_qmpsrc
"""
return
[docs]def write_corr2nn_observables_real():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the correlation measures of two pairs of nearest
neighbors, if requested.
**Arguments**
Obj : TYPE(corr_observables_real), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
specstring : CHARACTER(16), in
String specifier for ll floats, where ll is the system size.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_corr2nn_observables_real(Obj, unit, specstring)
type(corr2nn_observables_real), intent(inout) :: Obj
integer, intent(in) :: unit
character(16), intent(in) :: specstring
! Local variables
! ---------------
! for looping
integer :: ii, jj
do jj = 1, Obj%ncorr
if(Obj%isherm(jj)) then
write(unit, '(1A1)') 'R'
else
write(unit, '(1A1)') 'R'
end if
do ii = 1, size(Obj%elem, 1)
write(unit, specstring) real(Obj%elem(ii, :, jj), KIND=rKind)
!if(.not. Obj%isherm(jj)) then
! write(unit, specstring) aimag(Obj%elem(ii, :, jj))
!end if
end do
end do
if(Obj%ncorr > 0) Obj%elem = 0.0_rKind
end subroutine write_corr2nn_observables_real
"""
return
[docs]def write_corr2nn_observables_complex():
"""
fortran-subroutine - August 2017 (dj)
Write the results for the correlation measures of two pairs of nearest
neighbors, if requested.
**Arguments**
Obj : TYPE(corr_observables_complex), inout
Contains the settings about this measure and its results.
unit : INTEGER, in
Unit of the open file handle where results are written.
specstring : CHARACTER(16), in
String specifier for ll floats, where ll is the system size.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_corr2nn_observables_complex(Obj, unit, specstring)
type(corr2nn_observables_complex), intent(inout) :: Obj
integer, intent(in) :: unit
character(16), intent(in) :: specstring
! Local variables
! ---------------
! for looping
integer :: ii, jj
do jj = 1, Obj%ncorr
if(Obj%isherm(jj)) then
write(unit, '(1A1)') 'R'
else
write(unit, '(1A1)') 'C'
end if
do ii = 1, size(Obj%elem, 1)
write(unit, specstring) real(Obj%elem(ii, :, jj), KIND=rKind)
if(.not. Obj%isherm(jj)) then
write(unit, specstring) aimag(Obj%elem(ii, :, jj))
end if
end do
end do
if(Obj%ncorr > 0) Obj%elem = 0.0_rKind
end subroutine write_corr2nn_observables_complex
"""
return
[docs]def write_obs_r():
"""
fortran-subroutine - August 2017 (dj)
Write the results to a the file.
**Arguments**
obsname : CHARACTER(\*), in
This is the filename under which the observables should be stored.
unit : INTEGER, in
Open the file on this unit.
Obj : TYPE(obs_r), inout
Contains the measurements for all observables.
ll : INTEGER, in
Number of sites in the system.
time : REAL, OPTIONAL, in
If given, the measurement belongs to a time evolution.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_obs_r(obsname, unit, Obj, ll, time, errst)
integer, intent(in) :: ll
character(len=*), intent(in) :: obsname
integer, intent(in) :: unit
type(obs_r), intent(inout) :: Obj
real(KIND=rKind), intent(in), optional :: time
integer, intent(out), optional :: errst
! Local variables
! ---------------
logical :: do_hdf5
! Program
! -------
!if(present(errst)) errst = 0
do_hdf5 = len(trim(adjustl(Obj%hdf5_target_file))) > 0
if(do_hdf5) then
!call write_hdf5(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_obs_r: hdf5 failed.', &
! 'ObsOps_include.f90:5158', errst=errst)) return
errst = raise_error('write_obs_r: no HDF5.', 99, &
'ObsOps_include.f90:5161', errst=errst)
else
call write_file(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_obs_r: file failed.', &
! 'ObsOps_include.f90:5165', errst=errst)) return
end if
end subroutine write_obs_r
"""
return
[docs]def write_obs_c():
"""
fortran-subroutine - August 2017 (dj)
Write the results to a the file.
**Arguments**
obsname : CHARACTER(\*), in
This is the filename under which the observables should be stored.
unit : INTEGER, in
Open the file on this unit.
Obj : TYPE(obs_c), inout
Contains the measurements for all observables.
ll : INTEGER, in
Number of sites in the system.
time : REAL, OPTIONAL, in
If given, the measurement belongs to a time evolution.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_obs_c(obsname, unit, Obj, ll, time, errst)
integer, intent(in) :: ll
character(len=*), intent(in) :: obsname
integer, intent(in) :: unit
type(obs_c), intent(inout) :: Obj
real(KIND=rKind), intent(in), optional :: time
integer, intent(out), optional :: errst
! Local variables
! ---------------
logical :: do_hdf5
! Program
! -------
!if(present(errst)) errst = 0
do_hdf5 = len(trim(adjustl(Obj%hdf5_target_file))) > 0
if(do_hdf5) then
!call write_hdf5(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_obs_c: hdf5 failed.', &
! 'ObsOps_include.f90:5158', errst=errst)) return
errst = raise_error('write_obs_c: no HDF5.', 99, &
'ObsOps_include.f90:5161', errst=errst)
else
call write_file(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_obs_c: file failed.', &
! 'ObsOps_include.f90:5165', errst=errst)) return
end if
end subroutine write_obs_c
"""
return
[docs]def write_obsc():
"""
fortran-subroutine - August 2017 (dj)
Write the results to a the file.
**Arguments**
obsname : CHARACTER(\*), in
This is the filename under which the observables should be stored.
unit : INTEGER, in
Open the file on this unit.
Obj : TYPE(obsc), inout
Contains the measurements for all observables.
ll : INTEGER, in
Number of sites in the system.
time : REAL, OPTIONAL, in
If given, the measurement belongs to a time evolution.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_obsc(obsname, unit, Obj, ll, time, errst)
integer, intent(in) :: ll
character(len=*), intent(in) :: obsname
integer, intent(in) :: unit
type(obsc), intent(inout) :: Obj
real(KIND=rKind), intent(in), optional :: time
integer, intent(out), optional :: errst
! Local variables
! ---------------
logical :: do_hdf5
! Program
! -------
!if(present(errst)) errst = 0
do_hdf5 = len(trim(adjustl(Obj%hdf5_target_file))) > 0
if(do_hdf5) then
!call write_hdf5(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_obsc: hdf5 failed.', &
! 'ObsOps_include.f90:5158', errst=errst)) return
errst = raise_error('write_obsc: no HDF5.', 99, &
'ObsOps_include.f90:5161', errst=errst)
else
call write_file(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_obsc: file failed.', &
! 'ObsOps_include.f90:5165', errst=errst)) return
end if
end subroutine write_obsc
"""
return
[docs]def write_qobs_r():
"""
fortran-subroutine - August 2017 (dj)
Write the results to a the file.
**Arguments**
obsname : CHARACTER(\*), in
This is the filename under which the observables should be stored.
unit : INTEGER, in
Open the file on this unit.
Obj : TYPE(qobs_r), inout
Contains the measurements for all observables.
ll : INTEGER, in
Number of sites in the system.
time : REAL, OPTIONAL, in
If given, the measurement belongs to a time evolution.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qobs_r(obsname, unit, Obj, ll, time, errst)
integer, intent(in) :: ll
character(len=*), intent(in) :: obsname
integer, intent(in) :: unit
type(qobs_r), intent(inout) :: Obj
real(KIND=rKind), intent(in), optional :: time
integer, intent(out), optional :: errst
! Local variables
! ---------------
logical :: do_hdf5
! Program
! -------
!if(present(errst)) errst = 0
do_hdf5 = len(trim(adjustl(Obj%hdf5_target_file))) > 0
if(do_hdf5) then
!call write_hdf5(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_qobs_r: hdf5 failed.', &
! 'ObsOps_include.f90:5158', errst=errst)) return
errst = raise_error('write_qobs_r: no HDF5.', 99, &
'ObsOps_include.f90:5161', errst=errst)
else
call write_file(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_qobs_r: file failed.', &
! 'ObsOps_include.f90:5165', errst=errst)) return
end if
end subroutine write_qobs_r
"""
return
[docs]def write_qobs_c():
"""
fortran-subroutine - August 2017 (dj)
Write the results to a the file.
**Arguments**
obsname : CHARACTER(\*), in
This is the filename under which the observables should be stored.
unit : INTEGER, in
Open the file on this unit.
Obj : TYPE(qobs_c), inout
Contains the measurements for all observables.
ll : INTEGER, in
Number of sites in the system.
time : REAL, OPTIONAL, in
If given, the measurement belongs to a time evolution.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qobs_c(obsname, unit, Obj, ll, time, errst)
integer, intent(in) :: ll
character(len=*), intent(in) :: obsname
integer, intent(in) :: unit
type(qobs_c), intent(inout) :: Obj
real(KIND=rKind), intent(in), optional :: time
integer, intent(out), optional :: errst
! Local variables
! ---------------
logical :: do_hdf5
! Program
! -------
!if(present(errst)) errst = 0
do_hdf5 = len(trim(adjustl(Obj%hdf5_target_file))) > 0
if(do_hdf5) then
!call write_hdf5(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_qobs_c: hdf5 failed.', &
! 'ObsOps_include.f90:5158', errst=errst)) return
errst = raise_error('write_qobs_c: no HDF5.', 99, &
'ObsOps_include.f90:5161', errst=errst)
else
call write_file(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_qobs_c: file failed.', &
! 'ObsOps_include.f90:5165', errst=errst)) return
end if
end subroutine write_qobs_c
"""
return
[docs]def write_qobsc():
"""
fortran-subroutine - August 2017 (dj)
Write the results to a the file.
**Arguments**
obsname : CHARACTER(\*), in
This is the filename under which the observables should be stored.
unit : INTEGER, in
Open the file on this unit.
Obj : TYPE(qobsc), inout
Contains the measurements for all observables.
ll : INTEGER, in
Number of sites in the system.
time : REAL, OPTIONAL, in
If given, the measurement belongs to a time evolution.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qobsc(obsname, unit, Obj, ll, time, errst)
integer, intent(in) :: ll
character(len=*), intent(in) :: obsname
integer, intent(in) :: unit
type(qobsc), intent(inout) :: Obj
real(KIND=rKind), intent(in), optional :: time
integer, intent(out), optional :: errst
! Local variables
! ---------------
logical :: do_hdf5
! Program
! -------
!if(present(errst)) errst = 0
do_hdf5 = len(trim(adjustl(Obj%hdf5_target_file))) > 0
if(do_hdf5) then
!call write_hdf5(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_qobsc: hdf5 failed.', &
! 'ObsOps_include.f90:5158', errst=errst)) return
errst = raise_error('write_qobsc: no HDF5.', 99, &
'ObsOps_include.f90:5161', errst=errst)
else
call write_file(obsname, unit, Obj, ll, time=time, errst=errst)
!if(prop_error('write_file_qobsc: file failed.', &
! 'ObsOps_include.f90:5165', errst=errst)) return
end if
end subroutine write_qobsc
"""
return