ObsOps

Fortran module ObsOps: July 2017 (dj, updated)

Containing the operations for the measurement.

Authors

• 4. Jaschke

• 13. 12. 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 …

ObsOps_f90.destroy_site_observables()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing site observables.

Arguments

ObjTYPE(site_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_siteentropy_observables()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing site entropies.

Arguments

ObjTYPE(siteentropy_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_bondentropy_observables()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing bond entropies.

Arguments

ObjTYPE(bondentropy_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_corr_observables_real()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing correlations.

Arguments

ObjTYPE(corr_observables_real), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_corr_observables_complex()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing correlations.

Arguments

ObjTYPE(corr_observables_complex), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_fcorr_observables_real()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing fermi correlations.

Arguments

ObjTYPE(corr_observables_real), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_fcorr_observables_complex()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing fermi correlations.

Arguments

ObjTYPE(corr_observables_complex), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_string_observables()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing string correlations.

Arguments

ObjTYPE(string_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_mpo_observables_mpo()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing MPO measurements.

Arguments

ObjTYPE(mpo_observables_mpo), inout

Will be deallocated on exit.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_mpo_observables_mpoc()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing MPO measurements.

Arguments

ObjTYPE(mpo_observables_mpoc), inout

Will be deallocated on exit.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_mpo_observables_qmpo()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing MPO measurements.

Arguments

ObjTYPE(mpo_observables_qmpo), inout

Will be deallocated on exit.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_mpo_observables_qmpoc()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing MPO measurements.

Arguments

ObjTYPE(mpo_observables_qmpoc), inout

Will be deallocated on exit.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_rhoi_observables_tensor()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing single site density matrices.

Arguments

ObjTYPE(rhoi_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_rhoi_observables_tensorc()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing single site density matrices.

Arguments

ObjTYPE(rhoi_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_rhoij_observables_tensor()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing two site density matrices.

Arguments

ObjTYPE(rhoij_observables), inout

Will be deallocated on exit.

has_miLOGICAL, in

If the mutual information (True) is measured, all two-site density matrices are set.

Source Code

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

ObsOps_f90.destroy_rhoij_observables_tensorc()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing two site density matrices.

Arguments

ObjTYPE(rhoij_observables), inout

Will be deallocated on exit.

has_miLOGICAL, in

If the mutual information (True) is measured, all two-site density matrices are set.

Source Code

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

ObsOps_f90.destroy_rhoijk_observables_tensor()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing a general reduced density matrices.

Arguments

ObjTYPE(rhoijk_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_rhoijk_observables_tensorc()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing a general reduced density matrices.

Arguments

ObjTYPE(rhoijk_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_mutualinformation_observables()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing mutual information matrices.

Arguments

ObjTYPE(mutualinformation_observables), inout

Will be deallocated on exit.

Source Code

show / hide f90 code

  subroutine destroy_mutualinformation_observables(Obj)
      type(mutualinformation_observables), intent(inout) :: Obj

      ! No local variables
      ! ------------------

      if(Obj%has_mi) then
          deallocate(Obj%elem)

          Obj%has_mi = .false.
      end if

  end subroutine destroy_mutualinformation_observables

ObsOps_f90.destroy_lambda_observables()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing the singular values.

Arguments

ObjTYPE(lambda_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_distance_psi_observables_mpsrc()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing the distance measures to pure states.

Arguments

ObjTYPE(lambda_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_distance_psi_observables_qmpsrc()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing the distance measures to pure states.

Arguments

ObjTYPE(lambda_observables), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_corr2nn_observables_real()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing correlations.

Arguments

ObjTYPE(corr_observables_real), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_corr2nn_observables_complex()

fortran-subroutine - August 2017 (dj) Destroy the derived type storing correlations.

Arguments

ObjTYPE(corr_observables_complex), inout

Will be deallocated on exit.

Source Code

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

ObsOps_f90.destroy_obs_r()

fortran-subroutine - August 2017 (dj) Deallocate all measures.

Arguments

ObjTYPE(obs_r), inout

All measures are deallocated on exit.

unitINTEGER, in

Can open file with definition of the observables on this unit in order to delete it.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_obs_c()

fortran-subroutine - August 2017 (dj) Deallocate all measures.

Arguments

ObjTYPE(obs_c), inout

All measures are deallocated on exit.

unitINTEGER, in

Can open file with definition of the observables on this unit in order to delete it.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_obsc()

fortran-subroutine - August 2017 (dj) Deallocate all measures.

Arguments

ObjTYPE(obsc), inout

All measures are deallocated on exit.

unitINTEGER, in

Can open file with definition of the observables on this unit in order to delete it.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_qobs_r()

fortran-subroutine - August 2017 (dj) Deallocate all measures.

Arguments

ObjTYPE(qobs_r), inout

All measures are deallocated on exit.

unitINTEGER, in

Can open file with definition of the observables on this unit in order to delete it.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_qobs_c()

fortran-subroutine - August 2017 (dj) Deallocate all measures.

Arguments

ObjTYPE(qobs_c), inout

All measures are deallocated on exit.

unitINTEGER, in

Can open file with definition of the observables on this unit in order to delete it.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.destroy_qobsc()

fortran-subroutine - August 2017 (dj) Deallocate all measures.

Arguments

ObjTYPE(qobsc), inout

All measures are deallocated on exit.

unitINTEGER, in

Can open file with definition of the observables on this unit in order to delete it.

unitmpoINTEGER, in

Can open file with MPO on this unit in order to delete it.

Source Code

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

ObsOps_f90.meas_psi_mpo_phi_mps_mpo()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

result of the measurement

HTYPE(mpo), inout

The MPO to be measured.

psiATYPE(mps), inout

First state to calculate the overlap.

psiBTYPE(mps), inout

Second state to calculate the overlap.

Source Code

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

ObsOps_f90.meas_psi_mpo_phi_mpsc_mpo()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

result of the measurement

HTYPE(mpo), inout

The MPO to be measured.

psiATYPE(mpsc), inout

First state to calculate the overlap.

psiBTYPE(mpsc), inout

Second state to calculate the overlap.

Source Code

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

ObsOps_f90.meas_psi_mpo_phi_mpsc_mpoc()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

result of the measurement

HTYPE(mpoc), inout

The MPO to be measured.

psiATYPE(mpsc), inout

First state to calculate the overlap.

psiBTYPE(mpsc), inout

Second state to calculate the overlap.

Source Code

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

ObsOps_f90.meas_psi_mpo_phi_qmps_qmpo()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

result of the measurement

HTYPE(qmpo), inout

The MPO to be measured.

psiATYPE(qmps), inout

First state to calculate the overlap.

psiBTYPE(qmps), inout

Second state to calculate the overlap.

Source Code

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

ObsOps_f90.meas_psi_mpo_phi_qmpsc_qmpo()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

result of the measurement

HTYPE(qmpo), inout

The MPO to be measured.

psiATYPE(qmpsc), inout

First state to calculate the overlap.

psiBTYPE(qmpsc), inout

Second state to calculate the overlap.

Source Code

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

ObsOps_f90.meas_psi_mpo_phi_qmpsc_qmpoc()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

result of the measurement

HTYPE(qmpoc), inout

The MPO to be measured.

psiATYPE(qmpsc), inout

First state to calculate the overlap.

psiBTYPE(qmpsc), inout

Second state to calculate the overlap.

Source Code

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

ObsOps_f90.meas_mpo_mps_mpo()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

Result of the measurement of the MPO applied to Psi.

HTYPE(mpo), inout

Representation of the MPO to be measured.

PsiTYPE(mps), inout

Measure this state.

Source Code

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

ObsOps_f90.meas_mpo_mpsc_mpo()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

Result of the measurement of the MPO applied to Psi.

HTYPE(mpo), inout

Representation of the MPO to be measured.

PsiTYPE(mpsc), inout

Measure this state.

Source Code

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

ObsOps_f90.meas_mpo_mpsc_mpoc()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

Result of the measurement of the MPO applied to Psi.

HTYPE(mpoc), inout

Representation of the MPO to be measured.

PsiTYPE(mpsc), inout

Measure this state.

Source Code

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

ObsOps_f90.meas_mpo_qmps_qmpo()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

Result of the measurement of the MPO applied to Psi.

HTYPE(qmpo), inout

Representation of the MPO to be measured.

PsiTYPE(qmps), inout

Measure this state.

Source Code

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

ObsOps_f90.meas_mpo_qmpsc_qmpo()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

Result of the measurement of the MPO applied to Psi.

HTYPE(qmpo), inout

Representation of the MPO to be measured.

PsiTYPE(qmpsc), inout

Measure this state.

Source Code

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

ObsOps_f90.meas_mpo_qmpsc_qmpoc()

fortran-subroutine - July 2017 (dj, updated) Compute using the MPO form of .

Arguments

valREAL_OR_COMPLEX, out

Result of the measurement of the MPO applied to Psi.

HTYPE(qmpoc), inout

Representation of the MPO to be measured.

PsiTYPE(qmpsc), inout

Measure this state.

Source Code

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

ObsOps_f90.meas_rhoij_corr_tensor_tensor()

fortran-function - November 2017 (dj) Measure a correlation based on the reduced two site density matrix.

Arguments

RhoijTYPE(tensor), inout

On exit, the two-site reduced density matrix.

OplTYPE(tensor), inout

Operator for the first site.

OprTYPE(tensor), inout

Operator for the second site.

Source Code

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

ObsOps_f90.meas_rhoij_corr_tensorc_tensor()

fortran-function - November 2017 (dj) Measure a correlation based on the reduced two site density matrix.

Arguments

RhoijTYPE(tensorc), inout

On exit, the two-site reduced density matrix.

OplTYPE(tensor), inout

Operator for the first site.

OprTYPE(tensor), inout

Operator for the second site.

Source Code

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

ObsOps_f90.meas_rhoij_corr_tensorc_tensorc()

fortran-function - November 2017 (dj) Measure a correlation based on the reduced two site density matrix.

Arguments

RhoijTYPE(tensorc), inout

On exit, the two-site reduced density matrix.

OplTYPE(tensorc), inout

Operator for the first site.

OprTYPE(tensorc), inout

Operator for the second site.

Source Code

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

ObsOps_f90.meas_rhoij_corr_qtensor_qtensor()

fortran-function - November 2017 (dj) Measure a correlation based on the reduced two site density matrix.

Arguments

RhoijTYPE(qtensor), inout

On exit, the two-site reduced density matrix.

OplTYPE(qtensor), inout

Operator for the first site.

OprTYPE(qtensor), inout

Operator for the second site.

Source Code

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

ObsOps_f90.meas_rhoij_corr_qtensorc_qtensor()

fortran-function - November 2017 (dj) Measure a correlation based on the reduced two site density matrix.

Arguments

RhoijTYPE(qtensorc), inout

On exit, the two-site reduced density matrix.

OplTYPE(qtensor), inout

Operator for the first site.

OprTYPE(qtensor), inout

Operator for the second site.

Source Code

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

ObsOps_f90.meas_rhoij_corr_qtensorc_qtensorc()

fortran-function - November 2017 (dj) Measure a correlation based on the reduced two site density matrix.

Arguments

RhoijTYPE(qtensorc), inout

On exit, the two-site reduced density matrix.

OplTYPE(qtensorc), inout

Operator for the first site.

OprTYPE(qtensorc), inout

Operator for the second site.

Source Code

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

ObsOps_f90.corr_init_mps_tensor_tensor()

fortran-subroutine - August 2017 (dj) Initialize the left overlap for a right-moving correlation measure.

Arguments

PsikkTYPE(tensor), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(tensor), out

On exit, left overlap for correlation measurement.

OpTYPE(tensor), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_mps_tensorc_tensor()

fortran-subroutine - August 2017 (dj) Initialize the left overlap for a right-moving correlation measure.

Arguments

PsikkTYPE(tensorc), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(tensorc), out

On exit, left overlap for correlation measurement.

OpTYPE(tensor), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_mps_tensorc_tensorc()

fortran-subroutine - August 2017 (dj) Initialize the left overlap for a right-moving correlation measure.

Arguments

PsikkTYPE(tensorc), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(tensorc), out

On exit, left overlap for correlation measurement.

OpTYPE(tensorc), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_mps_qtensor_qtensor()

fortran-subroutine - August 2017 (dj) Initialize the left overlap for a right-moving correlation measure.

Arguments

PsikkTYPE(qtensor), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(qtensor), out

On exit, left overlap for correlation measurement.

OpTYPE(qtensor), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_mps_qtensorc_qtensor()

fortran-subroutine - August 2017 (dj) Initialize the left overlap for a right-moving correlation measure.

Arguments

PsikkTYPE(qtensorc), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(qtensorc), out

On exit, left overlap for correlation measurement.

OpTYPE(qtensor), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_mps_qtensorc_qtensorc()

fortran-subroutine - August 2017 (dj) Initialize the left overlap for a right-moving correlation measure.

Arguments

PsikkTYPE(qtensorc), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(qtensorc), out

On exit, left overlap for correlation measurement.

OpTYPE(qtensorc), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_l_mps_tensor_tensor()

fortran-subroutine - August 2017 (dj) Calculate correlation with a left-moving contraction. Initialization of the right overlap.

Arguments

PsikkTYPE(tensor), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(tensor), out

On exit, left overlap for correlation measurement.

OpTYPE(tensor), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_l_mps_tensorc_tensor()

fortran-subroutine - August 2017 (dj) Calculate correlation with a left-moving contraction. Initialization of the right overlap.

Arguments

PsikkTYPE(tensorc), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(tensorc), out

On exit, left overlap for correlation measurement.

OpTYPE(tensor), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_l_mps_tensorc_tensorc()

fortran-subroutine - August 2017 (dj) Calculate correlation with a left-moving contraction. Initialization of the right overlap.

Arguments

PsikkTYPE(tensorc), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(tensorc), out

On exit, left overlap for correlation measurement.

OpTYPE(tensorc), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_l_mps_qtensor_qtensor()

fortran-subroutine - August 2017 (dj) Calculate correlation with a left-moving contraction. Initialization of the right overlap.

Arguments

PsikkTYPE(qtensor), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(qtensor), out

On exit, left overlap for correlation measurement.

OpTYPE(qtensor), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_l_mps_qtensorc_qtensor()

fortran-subroutine - August 2017 (dj) Calculate correlation with a left-moving contraction. Initialization of the right overlap.

Arguments

PsikkTYPE(qtensorc), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(qtensorc), out

On exit, left overlap for correlation measurement.

OpTYPE(qtensor), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_init_l_mps_qtensorc_qtensorc()

fortran-subroutine - August 2017 (dj) Calculate correlation with a left-moving contraction. Initialization of the right overlap.

Arguments

PsikkTYPE(qtensorc), inout

Tensor representing the first site of the correlation measurement.

ThetaTYPE(qtensorc), out

On exit, left overlap for correlation measurement.

OpTYPE(qtensorc), inout

Operator for the correlation measurement on site kk.

Source Code

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

ObsOps_f90.corr_meas_mps_tensor_tensor()

fortran-subroutine - September 2017 (dj) Measurement process for correlations. Propagation of overlap for next measurement.

Arguments

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(tensor), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(tensor), inout

The left overlap starting on the first site of the correlation measurement.

OpTYPE(tensor), inout

Operator for the correlation measurement.

PhaseOpTYPE(tensor), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.corr_meas_mps_tensorc_tensor()

fortran-subroutine - September 2017 (dj) Measurement process for correlations. Propagation of overlap for next measurement.

Arguments

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(tensorc), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(tensorc), inout

The left overlap starting on the first site of the correlation measurement.

OpTYPE(tensor), inout

Operator for the correlation measurement.

PhaseOpTYPE(tensor), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.corr_meas_mps_tensorc_tensorc()

fortran-subroutine - September 2017 (dj) Measurement process for correlations. Propagation of overlap for next measurement.

Arguments

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(tensorc), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(tensorc), inout

The left overlap starting on the first site of the correlation measurement.

OpTYPE(tensorc), inout

Operator for the correlation measurement.

PhaseOpTYPE(tensorc), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.corr_meas_mps_qtensor_qtensor()

fortran-subroutine - September 2017 (dj) Measurement process for correlations. Propagation of overlap for next measurement.

Arguments

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(qtensor), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(qtensor), inout

The left overlap starting on the first site of the correlation measurement.

OpTYPE(qtensor), inout

Operator for the correlation measurement.

PhaseOpTYPE(qtensor), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.corr_meas_mps_qtensorc_qtensor()

fortran-subroutine - September 2017 (dj) Measurement process for correlations. Propagation of overlap for next measurement.

Arguments

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(qtensorc), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(qtensorc), inout

The left overlap starting on the first site of the correlation measurement.

OpTYPE(qtensor), inout

Operator for the correlation measurement.

PhaseOpTYPE(qtensor), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.corr_meas_mps_qtensorc_qtensorc()

fortran-subroutine - September 2017 (dj) Measurement process for correlations. Propagation of overlap for next measurement.

Arguments

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(qtensorc), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(qtensorc), inout

The left overlap starting on the first site of the correlation measurement.

OpTYPE(qtensorc), inout

Operator for the correlation measurement.

PhaseOpTYPE(qtensorc), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.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

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(tensor), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(tensor), inout

The right overlap starting on the first site of the correlation measurement.

OpTYPE(tensor), inout

Operator for the correlation measurement.

PhaseOpTYPE(tensor), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.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

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(tensorc), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(tensorc), inout

The right overlap starting on the first site of the correlation measurement.

OpTYPE(tensor), inout

Operator for the correlation measurement.

PhaseOpTYPE(tensor), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.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

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(tensorc), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(tensorc), inout

The right overlap starting on the first site of the correlation measurement.

OpTYPE(tensorc), inout

Operator for the correlation measurement.

PhaseOpTYPE(tensorc), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.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

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(qtensor), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(qtensor), inout

The right overlap starting on the first site of the correlation measurement.

OpTYPE(qtensor), inout

Operator for the correlation measurement.

PhaseOpTYPE(qtensor), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.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

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(qtensorc), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(qtensorc), inout

The right overlap starting on the first site of the correlation measurement.

OpTYPE(qtensor), inout

Operator for the correlation measurement.

PhaseOpTYPE(qtensor), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.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

valsREAL, out

Outcome of the correlation measurement.

PsikkTYPE(qtensorc), inout

Tensor representing site kk of the system.

kkINTEGER, in

Site index of the current tensor.

llINTEGER, in

System size.

ThetaTYPE(qtensorc), inout

The right overlap starting on the first site of the correlation measurement.

OpTYPE(qtensorc), inout

Operator for the correlation measurement.

PhaseOpTYPE(qtensorc), inout

Phase operator for propagation for the following correlation measurements.

hasphaseLOGICAL, in

Flag if phase operator is contracted (.true.).

Source Code

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

ObsOps_f90.entropy_rho_kk_tensor()

fortran-subroutine - August 2017 (dj) Calculate the entropy of a single site density matrix. It uses the natural logarithm.

Arguments

entropyREAL, inout

On exit, the von-Neumann entropy of the single site. It uses the natural log.

RhoTYPE(tensor), inout

The density matrix for a single site.

Source Code

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

ObsOps_f90.entropy_rho_kk_tensorc()

fortran-subroutine - August 2017 (dj) Calculate the entropy of a single site density matrix. It uses the natural logarithm.

Arguments

entropyREAL, inout

On exit, the von-Neumann entropy of the single site. It uses the natural log.

RhoTYPE(tensorc), inout

The density matrix for a single site.

Source Code

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

ObsOps_f90.entropy_rho_kk_qtensor()

fortran-subroutine - August 2017 (dj) Calculate the entropy of a single site density matrix. It uses the natural logarithm.

Arguments

entropyREAL, inout

On exit, the von-Neumann entropy of the single site. It uses the natural log.

RhoTYPE(qtensor), inout

The density matrix for a single site.

Source Code

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

ObsOps_f90.entropy_rho_kk_qtensorc()

fortran-subroutine - August 2017 (dj) Calculate the entropy of a single site density matrix. It uses the natural logarithm.

Arguments

entropyREAL, inout

On exit, the von-Neumann entropy of the single site. It uses the natural log.

RhoTYPE(qtensorc), inout

The density matrix for a single site.

Source Code

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

ObsOps_f90.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

VecTYPE(tensor), inout

On exit the singular values.

LambdasTYPE(tensor), in

Contains the singular values as stored in the MPS.

Source Code

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

ObsOps_f90.lambdas_to_vec_qtensor()

fortran-subroutine - August 2017 (dj) Combine the singular values for different quantum numbers to one vector.

Arguments

VecTYPE(tensor), inout

On exit the singular values.

LambdasTYPE(qtensor), in

Contains the singular values as stored in the MPS with symmetries.

Source Code

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

ObsOps_f90.observe_mps_mpo()

fortran-subroutine - Measure the observables myObservables and write to file for an mps.

Arguments

PsiTYPE(mps), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_mpsc_mpo()

fortran-subroutine - Measure the observables myObservables and write to file for an mps.

Arguments

PsiTYPE(mpsc), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_mpsc_mpoc()

fortran-subroutine - Measure the observables myObservables and write to file for an mps.

Arguments

PsiTYPE(mpsc), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_qmps_qmpo()

fortran-subroutine - Measure the observables myObservables and write to file for an mps.

Arguments

PsiTYPE(qmps), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_qmpsc_qmpo()

fortran-subroutine - Measure the observables myObservables and write to file for an mps.

Arguments

PsiTYPE(qmpsc), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_qmpsc_qmpoc()

fortran-subroutine - Measure the observables myObservables and write to file for an mps.

Arguments

PsiTYPE(qmpsc), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_lptn_mpo()

fortran-subroutine - Measure the observables myObservables and write to file for an lptn.

Arguments

PsiTYPE(lptn), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_lptnc_mpo()

fortran-subroutine - Measure the observables myObservables and write to file for an lptn.

Arguments

PsiTYPE(lptnc), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_lptnc_mpoc()

fortran-subroutine - Measure the observables myObservables and write to file for an lptn.

Arguments

PsiTYPE(lptnc), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_qlptn_qmpo()

fortran-subroutine - Measure the observables myObservables and write to file for an lptn.

Arguments

PsiTYPE(qlptn), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_qlptnc_qmpo()

fortran-subroutine - Measure the observables myObservables and write to file for an lptn.

Arguments

PsiTYPE(qlptnc), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.observe_qlptnc_qmpoc()

fortran-subroutine - Measure the observables myObservables and write to file for an lptn.

Arguments

PsiTYPE(qlptnc), inout

Measure this state.

CpTYPE(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

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

ObsOps_f90.read_site_observables()

fortran-subroutine - August 2017 (dj) Read the site observables from an open file handle.

Arguments

ObjTYPE(site_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_siteentropy_observables()

fortran-subroutine - August 2017 (dj) Read the site entropy observable from an open file handle.

Arguments

ObjTYPE(siteentropy_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_bondentropy_observables()

fortran-subroutine - August 2017 (dj) Read the bond entropy observable from an open file handle.

Arguments

ObjTYPE(bondentropy_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_corr_observables_real()

fortran-subroutine - August 2017 (dj) Read the correlation observables from an open file handle.

Arguments

ObjTYPE(corr_observables_real), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_corr_observables_complex()

fortran-subroutine - August 2017 (dj) Read the correlation observables from an open file handle.

Arguments

ObjTYPE(corr_observables_complex), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_fcorr_observables_real()

fortran-subroutine - August 2017 (dj) Read the Fermi correlation observables from an open file handle.

Arguments

ObjTYPE(corr_observables_real), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_fcorr_observables_complex()

fortran-subroutine - August 2017 (dj) Read the Fermi correlation observables from an open file handle.

Arguments

ObjTYPE(corr_observables_complex), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_string_observables()

fortran-subroutine - August 2017 (dj) Read the string correlation observables from an open file handle.

Arguments

ObjTYPE(string_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_mpo_observables_mpo()

fortran-subroutine - July 2017 (dj, updated) Read the MPO observables from an open file handle.

Arguments

ObjTYPE(mpo_observables_mpo), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit.

llINTEGER, inout

number of sites in the system.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

OpsTYPE(tensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.read_mpo_observables_mpoc()

fortran-subroutine - July 2017 (dj, updated) Read the MPO observables from an open file handle.

Arguments

ObjTYPE(mpo_observables_mpoc), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit.

llINTEGER, inout

number of sites in the system.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

OpsTYPE(tensorlistc), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.read_mpo_observables_qmpo()

fortran-subroutine - July 2017 (dj, updated) Read the MPO observables from an open file handle.

Arguments

ObjTYPE(mpo_observables_qmpo), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit.

llINTEGER, inout

number of sites in the system.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

OpsTYPE(qtensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.read_mpo_observables_qmpoc()

fortran-subroutine - July 2017 (dj, updated) Read the MPO observables from an open file handle.

Arguments

ObjTYPE(mpo_observables_qmpoc), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit.

llINTEGER, inout

number of sites in the system.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

OpsTYPE(qtensorclist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.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

ObjTYPE(rhoi_observables_tensor), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.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

ObjTYPE(rhoi_observables_tensorc), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.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

ObjTYPE(string_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

has_miLOGICAL, 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

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

ObsOps_f90.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

ObjTYPE(string_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

has_miLOGICAL, 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

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

ObsOps_f90.read_rhoijk_observables_tensor()

fortran-subroutine - August 2017 (dj) Read the settings for the general reduced density matrices from an open file handle.

Arguments

ObjTYPE(rhoijk_observables_tensor), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

Source Code

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

ObsOps_f90.read_rhoijk_observables_tensorc()

fortran-subroutine - August 2017 (dj) Read the settings for the general reduced density matrices from an open file handle.

Arguments

ObjTYPE(rhoijk_observables_tensorc), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

Source Code

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

ObsOps_f90.read_mutualinformation_observables()

fortran-subroutine - August 2017 (dj) Read the setting for the mutual information from an open file handle.

Arguments

ObjTYPE(mutualinformation_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

show / hide f90 code

  subroutine read_mutualinformation_observables(Obj, unit, ll, errst)
      type(mutualinformation_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%has_mi = (bool == 'T')

      if(Obj%has_mi) then
          allocate(Obj%elem(ll, ll))
          Obj%elem = 0.0_rKind
      end if

      if(verbose > 1) write(slog, *) 'Mutual information measured.'

  end subroutine read_mutualinformation_observables

ObsOps_f90.read_lambda_observables()

fortran-subroutine - August 2017 (dj) Read the setting for saving the singular values from an open file handle.

Arguments

ObjTYPE(lambda_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_distance_psi_observables_mpsrc()

fortran-subroutine - August 2017 (dj) Read the distance measures to pure states from an open file handle.

Arguments

ObjTYPE(lambda_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitpsiINTEGER, in

Can open and read wave functions on this unit.

Source Code

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

ObsOps_f90.read_distance_psi_observables_qmpsrc()

fortran-subroutine - August 2017 (dj) Read the distance measures to pure states from an open file handle.

Arguments

ObjTYPE(lambda_observables), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitpsiINTEGER, in

Can open and read wave functions on this unit.

Source Code

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

ObsOps_f90.read_state_observables()

fortran-subroutine - November 2017 (dj) Read the setting for writing out states at each measurement.

Arguments

objLOGICAL, inout

Status of writing out states (true == write state).

unitINTEGER, in

Open file hanlde with position at the state measure.

Source Code

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

ObsOps_f90.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

ObjTYPE(corr_observables_real), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.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

ObjTYPE(corr_observables_complex), inout

Read the settings for this measurement.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

llINTEGER, in

Number of system sites in order to allocate memory.

Source Code

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

ObsOps_f90.read_obs_r()

fortran-subroutine - July 2017 (dj, updated) Read the settings for all observables.

Arguments

ObjTYPE(obs_r), inout

The setting of the observables is stored in this variable.

flnmCHARACTER(*), in

Filename of the file with the settings for the observables.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit (for MPO measurements).

unitpsiINTEGER, in

Can open and read wave functions for distance measures on this unit.

llINTEGER, in

number of sites in the system.

OpsTYPE(tensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.read_obs_c()

fortran-subroutine - July 2017 (dj, updated) Read the settings for all observables.

Arguments

ObjTYPE(obs_c), inout

The setting of the observables is stored in this variable.

flnmCHARACTER(*), in

Filename of the file with the settings for the observables.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit (for MPO measurements).

unitpsiINTEGER, in

Can open and read wave functions for distance measures on this unit.

llINTEGER, in

number of sites in the system.

OpsTYPE(tensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.read_obsc()

fortran-subroutine - July 2017 (dj, updated) Read the settings for all observables.

Arguments

ObjTYPE(obsc), inout

The setting of the observables is stored in this variable.

flnmCHARACTER(*), in

Filename of the file with the settings for the observables.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit (for MPO measurements).

unitpsiINTEGER, in

Can open and read wave functions for distance measures on this unit.

llINTEGER, in

number of sites in the system.

OpsTYPE(tensorlistc), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.read_qobs_r()

fortran-subroutine - July 2017 (dj, updated) Read the settings for all observables.

Arguments

ObjTYPE(qobs_r), inout

The setting of the observables is stored in this variable.

flnmCHARACTER(*), in

Filename of the file with the settings for the observables.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit (for MPO measurements).

unitpsiINTEGER, in

Can open and read wave functions for distance measures on this unit.

llINTEGER, in

number of sites in the system.

OpsTYPE(qtensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.read_qobs_c()

fortran-subroutine - July 2017 (dj, updated) Read the settings for all observables.

Arguments

ObjTYPE(qobs_c), inout

The setting of the observables is stored in this variable.

flnmCHARACTER(*), in

Filename of the file with the settings for the observables.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit (for MPO measurements).

unitpsiINTEGER, in

Can open and read wave functions for distance measures on this unit.

llINTEGER, in

number of sites in the system.

OpsTYPE(qtensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.read_qobsc()

fortran-subroutine - July 2017 (dj, updated) Read the settings for all observables.

Arguments

ObjTYPE(qobsc), inout

The setting of the observables is stored in this variable.

flnmCHARACTER(*), in

Filename of the file with the settings for the observables.

writedirCHARACTER(*), in

Directory name with temporary files. Needed to contruct MPO file names for MPO measures.

unitINTEGER, in

Open file hanlde with position at the site entropy measures.

unitmpoINTEGER, in

Open MPO file on this unit (for MPO measurements).

unitpsiINTEGER, in

Can open and read wave functions for distance measures on this unit.

llINTEGER, in

number of sites in the system.

OpsTYPE(qtensorclist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

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

ObsOps_f90.rhoij_init_mps_tensor()

fortran-subroutine - August 2017 (dj) Initial contraction for the construction of two-site density matrices.

Arguments

TenskkTYPE(tensor), inout

Tensor representing the site kk, should be the orthgonality center.

ThetaTYPE(tensor), out

On exit, contraction of the tensor on site kk.

Source Code

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

ObsOps_f90.rhoij_init_mps_tensorc()

fortran-subroutine - August 2017 (dj) Initial contraction for the construction of two-site density matrices.

Arguments

TenskkTYPE(tensorc), inout

Tensor representing the site kk, should be the orthgonality center.

ThetaTYPE(tensorc), out

On exit, contraction of the tensor on site kk.

Source Code

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

ObsOps_f90.rhoij_init_mps_qtensor()

fortran-subroutine - August 2017 (dj) Initial contraction for the construction of two-site density matrices.

Arguments

TenskkTYPE(qtensor), inout

Tensor representing the site kk, should be the orthgonality center.

ThetaTYPE(qtensor), out

On exit, contraction of the tensor on site kk.

Source Code

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

ObsOps_f90.rhoij_init_mps_qtensorc()

fortran-subroutine - August 2017 (dj) Initial contraction for the construction of two-site density matrices.

Arguments

TenskkTYPE(qtensorc), inout

Tensor representing the site kk, should be the orthgonality center.

ThetaTYPE(qtensorc), out

On exit, contraction of the tensor on site kk.

Source Code

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

ObsOps_f90.rhoij_meas_mps_tensor_tensor()

fortran-subroutine - August 2017 (dj) Build two-site density matrix and propagate for the next site.

Arguments

RhosijTYPE(tensor)(*, *), inout

Matrix containing two-site density matrices.

TensjjTYPE(tensor), inout

Tensor representing the current site to be contracted.

iiINTEGER, inout

Index of the left site of the density matrix kept in Theta.

jjINTEGER, inout

Index of the tensors Tensjj.

llINTEGER, inout

Number of sites in the system, used to detect when propagation is stopped.

ThetaTYPE(tensor), inout

Tensor containing the contractions from the left part of the system.

PhaseOpTYPE(tensor), inout

Phase operator to be contracted within the propagation.

hasphaseLOGICAL, inout

Flag if phase operator is present (.true.).

skipLOGICAL, OPTIONAL, inout

If present and true, the measurement of the density matrix is skiped and it is only propagated.

Source Code

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

ObsOps_f90.rhoij_meas_mps_tensorc_tensor()

fortran-subroutine - August 2017 (dj) Build two-site density matrix and propagate for the next site.

Arguments

RhosijTYPE(tensorc)(*, *), inout

Matrix containing two-site density matrices.

TensjjTYPE(tensorc), inout

Tensor representing the current site to be contracted.

iiINTEGER, inout

Index of the left site of the density matrix kept in Theta.

jjINTEGER, inout

Index of the tensors Tensjj.

llINTEGER, inout

Number of sites in the system, used to detect when propagation is stopped.

ThetaTYPE(tensorc), inout

Tensor containing the contractions from the left part of the system.

PhaseOpTYPE(tensor), inout

Phase operator to be contracted within the propagation.

hasphaseLOGICAL, inout

Flag if phase operator is present (.true.).

skipLOGICAL, OPTIONAL, inout

If present and true, the measurement of the density matrix is skiped and it is only propagated.

Source Code

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

ObsOps_f90.rhoij_meas_mps_tensorc_tensorc()

fortran-subroutine - August 2017 (dj) Build two-site density matrix and propagate for the next site.

Arguments

RhosijTYPE(tensorc)(*, *), inout

Matrix containing two-site density matrices.

TensjjTYPE(tensorc), inout

Tensor representing the current site to be contracted.

iiINTEGER, inout

Index of the left site of the density matrix kept in Theta.

jjINTEGER, inout

Index of the tensors Tensjj.

llINTEGER, inout

Number of sites in the system, used to detect when propagation is stopped.

ThetaTYPE(tensorc), inout

Tensor containing the contractions from the left part of the system.

PhaseOpTYPE(tensorc), inout

Phase operator to be contracted within the propagation.

hasphaseLOGICAL, inout

Flag if phase operator is present (.true.).

skipLOGICAL, OPTIONAL, inout

If present and true, the measurement of the density matrix is skiped and it is only propagated.

Source Code

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

ObsOps_f90.rhoij_meas_mps_qtensor_qtensor()

fortran-subroutine - August 2017 (dj) Build two-site density matrix and propagate for the next site.

Arguments

RhosijTYPE(qtensor)(*, *), inout

Matrix containing two-site density matrices.

TensjjTYPE(qtensor), inout

Tensor representing the current site to be contracted.

iiINTEGER, inout

Index of the left site of the density matrix kept in Theta.

jjINTEGER, inout

Index of the tensors Tensjj.

llINTEGER, inout

Number of sites in the system, used to detect when propagation is stopped.

ThetaTYPE(qtensor), inout

Tensor containing the contractions from the left part of the system.

PhaseOpTYPE(qtensor), inout

Phase operator to be contracted within the propagation.

hasphaseLOGICAL, inout

Flag if phase operator is present (.true.).

skipLOGICAL, OPTIONAL, inout

If present and true, the measurement of the density matrix is skiped and it is only propagated.

Source Code

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

ObsOps_f90.rhoij_meas_mps_qtensorc_qtensor()

fortran-subroutine - August 2017 (dj) Build two-site density matrix and propagate for the next site.

Arguments

RhosijTYPE(qtensorc)(*, *), inout

Matrix containing two-site density matrices.

TensjjTYPE(qtensorc), inout

Tensor representing the current site to be contracted.

iiINTEGER, inout

Index of the left site of the density matrix kept in Theta.

jjINTEGER, inout

Index of the tensors Tensjj.

llINTEGER, inout

Number of sites in the system, used to detect when propagation is stopped.

ThetaTYPE(qtensorc), inout

Tensor containing the contractions from the left part of the system.

PhaseOpTYPE(qtensor), inout

Phase operator to be contracted within the propagation.

hasphaseLOGICAL, inout

Flag if phase operator is present (.true.).

skipLOGICAL, OPTIONAL, inout

If present and true, the measurement of the density matrix is skiped and it is only propagated.

Source Code

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

ObsOps_f90.rhoij_meas_mps_qtensorc_qtensorc()

fortran-subroutine - August 2017 (dj) Build two-site density matrix and propagate for the next site.

Arguments

RhosijTYPE(qtensorc)(*, *), inout

Matrix containing two-site density matrices.

TensjjTYPE(qtensorc), inout

Tensor representing the current site to be contracted.

iiINTEGER, inout

Index of the left site of the density matrix kept in Theta.

jjINTEGER, inout

Index of the tensors Tensjj.

llINTEGER, inout

Number of sites in the system, used to detect when propagation is stopped.

ThetaTYPE(qtensorc), inout

Tensor containing the contractions from the left part of the system.

PhaseOpTYPE(qtensorc), inout

Phase operator to be contracted within the propagation.

hasphaseLOGICAL, inout

Flag if phase operator is present (.true.).

skipLOGICAL, OPTIONAL, inout

If present and true, the measurement of the density matrix is skiped and it is only propagated.

Source Code

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

ObsOps_f90.write_site_observables()

fortran-subroutine - August 2017 (dj) Write the results for the site observables, if requested.

Arguments

ObjTYPE(site_observables), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

specstringCHARACTER(16), in

String specifier for ll floats, where ll is the system size.

Source Code

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

ObsOps_f90.write_siteentropy_observables()

fortran-subroutine - August 2017 (dj) Write the results for the site entropy, if requested.

Arguments

ObjTYPE(siteentropy_observables), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

specstringCHARACTER(16), in

String specifier for ll floats, where ll is the system size.

Source Code

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

ObsOps_f90.write_bondentropy_observables()

fortran-subroutine - August 2017 (dj) Write the results for the bond entropy, if requested.

Arguments

ObjTYPE(bondentropy_observables), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_corr_observables_real()

fortran-subroutine - August 2017 (dj) Write the results for the correlation measures, if requested.

Arguments

ObjTYPE(corr_observables_real), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

specstringCHARACTER(16), in

String specifier for ll floats, where ll is the system size.

Source Code

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

ObsOps_f90.write_corr_observables_complex()

fortran-subroutine - August 2017 (dj) Write the results for the correlation measures, if requested.

Arguments

ObjTYPE(corr_observables_complex), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

specstringCHARACTER(16), in

String specifier for ll floats, where ll is the system size.

Source Code

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

ObsOps_f90.write_string_observables()

fortran-subroutine - August 2017 (dj) Write the results for the string correlation measures, if requested.

Arguments

ObjTYPE(string_observables), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

specstringCHARACTER(16), in

String specifier for ll floats, where ll is the system size.

Source Code

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

ObsOps_f90.write_mpo_observables_mpo()

fortran-subroutine - August 2017 (dj) Write the results for the MPO measurements, if requested.

Arguments

ObjTYPE(mpo_observables_mpo), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_mpo_observables_mpoc()

fortran-subroutine - August 2017 (dj) Write the results for the MPO measurements, if requested.

Arguments

ObjTYPE(mpo_observables_mpoc), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_mpo_observables_qmpo()

fortran-subroutine - August 2017 (dj) Write the results for the MPO measurements, if requested.

Arguments

ObjTYPE(mpo_observables_qmpo), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_mpo_observables_qmpoc()

fortran-subroutine - August 2017 (dj) Write the results for the MPO measurements, if requested.

Arguments

ObjTYPE(mpo_observables_qmpoc), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_rhoi_observables_tensor()

fortran-subroutine - August 2017 (dj) Write the results for the single site reduced density matrices, if requested.

Arguments

ObjTYPE(rhoi_observables_tensor), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_rhoi_observables_tensorc()

fortran-subroutine - August 2017 (dj) Write the results for the single site reduced density matrices, if requested.

Arguments

ObjTYPE(rhoi_observables_tensorc), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_rhoij_observables_tensor()

fortran-subroutine - August 2017 (dj) Write the results for the two-site reduced density matrices, if requested.

Arguments

ObjTYPE(rhoij_observables_tensor), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

has_miLOGICAL, in

Measurement of the mutual information influences which two-site entries have to be deallocated.

Source Code

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

ObsOps_f90.write_rhoij_observables_tensorc()

fortran-subroutine - August 2017 (dj) Write the results for the two-site reduced density matrices, if requested.

Arguments

ObjTYPE(rhoij_observables_tensorc), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

has_miLOGICAL, in

Measurement of the mutual information influences which two-site entries have to be deallocated.

Source Code

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

ObsOps_f90.write_rhoijk_observables_tensor()

fortran-subroutine - August 2017 (dj) Write the results for the general reduced density matrices, if requested.

Arguments

ObjTYPE(rhoijk_observables_tensor), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_rhoijk_observables_tensorc()

fortran-subroutine - August 2017 (dj) Write the results for the general reduced density matrices, if requested.

Arguments

ObjTYPE(rhoijk_observables_tensorc), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_mutualinformation_observables()

fortran-subroutine - August 2017 (dj) Write the results for the mutual information, if requested.

Arguments

ObjTYPE(mutualinformation_observables), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

llINTEGER, in

Number of sites in the system.

specstringCHARACTER(16), in

String specifier for ll floats, where ll is the system size.

Source Code

show / hide f90 code

  subroutine write_mutualinformation_observables(Obj, unit, ll, specstring)
      type(mutualinformation_observables), intent(inout) :: Obj
      integer, intent(in) :: unit, ll
      character(16), intent(in) :: specstring

      ! Local variables
      ! ---------------

      ! for looping
      integer :: ii

      if(Obj%has_mi) then
          do ii = 1, ll
              write(unit, specstring) Obj%elem(ii, :)
          end do

          Obj%elem = 0.0_rKind
      end if

  end subroutine write_mutualinformation_observables

ObsOps_f90.write_lambda_observables()

fortran-subroutine - August 2017 (dj) Write the results for the singular values, if requested.

Arguments

ObjTYPE(lambda_observables), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_distance_psi_observables_mpsrc()

fortran-subroutine - August 2017 (dj) Write the results for the distance measures, if requested.

Arguments

ObjTYPE(distance_psi_observables_mpsrc), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.write_distance_psi_observables_qmpsrc()

fortran-subroutine - August 2017 (dj) Write the results for the distance measures, if requested.

Arguments

ObjTYPE(distance_psi_observables_qmpsrc), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

Source Code

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

ObsOps_f90.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

ObjTYPE(corr_observables_real), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

specstringCHARACTER(16), in

String specifier for ll floats, where ll is the system size.

Source Code

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

ObsOps_f90.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

ObjTYPE(corr_observables_complex), inout

Contains the settings about this measure and its results.

unitINTEGER, in

Unit of the open file handle where results are written.

specstringCHARACTER(16), in

String specifier for ll floats, where ll is the system size.

Source Code

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

ObsOps_f90.write_obs_r()

fortran-subroutine - August 2017 (dj) Write the results to a the file.

Arguments

obsnameCHARACTER(*), in

This is the filename under which the observables should be stored.

unitINTEGER, in

Open the file on this unit.

ObjTYPE(obs_r), inout

Contains the measurements for all observables.

llINTEGER, in

Number of sites in the system.

timeREAL, OPTIONAL, in

If given, the measurement belongs to a time evolution.

Source Code

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

ObsOps_f90.write_obs_c()

fortran-subroutine - August 2017 (dj) Write the results to a the file.

Arguments

obsnameCHARACTER(*), in

This is the filename under which the observables should be stored.

unitINTEGER, in

Open the file on this unit.

ObjTYPE(obs_c), inout

Contains the measurements for all observables.

llINTEGER, in

Number of sites in the system.

timeREAL, OPTIONAL, in

If given, the measurement belongs to a time evolution.

Source Code

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

ObsOps_f90.write_obsc()

fortran-subroutine - August 2017 (dj) Write the results to a the file.

Arguments

obsnameCHARACTER(*), in

This is the filename under which the observables should be stored.

unitINTEGER, in

Open the file on this unit.

ObjTYPE(obsc), inout

Contains the measurements for all observables.

llINTEGER, in

Number of sites in the system.

timeREAL, OPTIONAL, in

If given, the measurement belongs to a time evolution.

Source Code

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

ObsOps_f90.write_qobs_r()

fortran-subroutine - August 2017 (dj) Write the results to a the file.

Arguments

obsnameCHARACTER(*), in

This is the filename under which the observables should be stored.

unitINTEGER, in

Open the file on this unit.

ObjTYPE(qobs_r), inout

Contains the measurements for all observables.

llINTEGER, in

Number of sites in the system.

timeREAL, OPTIONAL, in

If given, the measurement belongs to a time evolution.

Source Code

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

ObsOps_f90.write_qobs_c()

fortran-subroutine - August 2017 (dj) Write the results to a the file.

Arguments

obsnameCHARACTER(*), in

This is the filename under which the observables should be stored.

unitINTEGER, in

Open the file on this unit.

ObjTYPE(qobs_c), inout

Contains the measurements for all observables.

llINTEGER, in

Number of sites in the system.

timeREAL, OPTIONAL, in

If given, the measurement belongs to a time evolution.

Source Code

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

ObsOps_f90.write_qobsc()

fortran-subroutine - August 2017 (dj) Write the results to a the file.

Arguments

obsnameCHARACTER(*), in

This is the filename under which the observables should be stored.

unitINTEGER, in

Open the file on this unit.

ObjTYPE(qobsc), inout

Contains the measurements for all observables.

llINTEGER, in

Number of sites in the system.

timeREAL, OPTIONAL, in

If given, the measurement belongs to a time evolution.

Source Code

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