LPTNOps

Fortran module LPTNOps: September 2017 (dj, updated)

Containing basic operations for local purified tensor networks (LPTN)

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
build_kraus_first_order	X
canonize	X
canonize_svd	X
check	X
copy	X
corr_init_lptn	X
corr_init_l_lptn	X
corr_meas_lptn	X
corr_meas_l_lptn	X
create	X
destroy	X
fidelity	X
gaugesite_qr	X
gaugesite_rq	X
gaugesite_rsvd	X
gaugesite_lsvd	X
maxchi	X
maxkappa	X
meas_mpo (dummy)	X
norm	X
randomize	X
rho_kk	X
rhoij_init_lptn	X
rhoij_meas_lptn	X
scale	X
write	X
purity	X
read	X
print	X
orthonormalize	X

LPTNOps_f90.apply_kraus_tensorc()

fortran-subroutine - September 2017 (dj) Contract a set of Kraus operators with the tensor for a site and compress.

Arguments

TensTYPE(tensorc), inout

On entry, tensor representing the site in the LPTN, on exit tensor of the site after application of the Kraus operators.

KrausTYPE(tensorc), inout

Kraus operators represented as rank-3 tensor.

max_kappaINTEGER, in

The hard-cut off for the kappa bond dimension.

local_tolREAL, in

Local tolerance for cutting singular values.

renormCHARACTER, in

Control on renormalization of the singular values.

cerrREAL, inout

Cumulative error. The error from the splitting inside this subroutine is added.

Source Code

show / hide f90 code

  subroutine apply_kraus_tensorc(Tens, Kraus, max_kappa, local_tol, &
                                     renorm, cerr, errst)
      type(tensorc), intent(inout) :: Tens
      type(tensorc), intent(inout) :: Kraus
      integer, intent(in) :: max_kappa
      real(KIND=rKind), intent(in) :: local_tol
      character, intent(in) :: renorm
      real(KIND=rKind), intent(inout) :: cerr
      integer, intent(out), optional :: errst

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

      ! error from a single split
      real(KIND=rKind) :: err

      ! temporary tensors
      type(tensorc) :: Tmp, Vtens

      ! singular values
      type(tensor) :: Lam

      ! IF SYMMETRY --> set quantum number of third leg
      call contr(Tmp, Tens, Kraus, [2], [2], errst=errst)!permout=[1, 4, 3, 2, 5], &
                 !errst=errst)
      !if(prop_error('apply_kraus_tensorc : contr failed.', &
      !              'LPTNOps_include.f90:78', errst=errst)) return

      call transposed(Tmp, [1, 4, 3, 2, 5], doperm=.true.)
      call destroy(Tens)

      call split(Tens, Lam, Vtens, Tmp, [1, 2, 3], [4, 5], multlr=-1, &
                 trunc=local_tol, ncut=max_kappa, &
                 err=err, renorm=renorm, method='Y', errst=errst)
      !if(prop_error('apply_kraus_tensorc : split failed.', &
      !              errst=errst)) return

      cerr = cerr + err
      call destroy(Lam)
      call destroy(Tmp)
      call destroy(Vtens)

      call transposed(Tens, perm=[1, 2, 4, 3], doperm=.true.)

      ! IF SYMMETRY --> unset quantum number on third leg

  end subroutine apply_kraus_tensorc

LPTNOps_f90.apply_kraus_qtensorc()

fortran-subroutine - September 2017 (dj) Contract a set of Kraus operators with the tensor for a site and compress.

Arguments

TensTYPE(qtensorc), inout

On entry, tensor representing the site in the LPTN, on exit tensor of the site after application of the Kraus operators.

KrausTYPE(qtensorc), inout

Kraus operators represented as rank-3 tensor.

max_kappaINTEGER, in

The hard-cut off for the kappa bond dimension.

local_tolREAL, in

Local tolerance for cutting singular values.

renormCHARACTER, in

Control on renormalization of the singular values.

cerrREAL, inout

Cumulative error. The error from the splitting inside this subroutine is added.

Source Code

show / hide f90 code

  subroutine apply_kraus_qtensorc(Tens, Kraus, max_kappa, local_tol, &
                                     renorm, cerr, errst)
      type(qtensorc), intent(inout) :: Tens
      type(qtensorc), intent(inout) :: Kraus
      integer, intent(in) :: max_kappa
      real(KIND=rKind), intent(in) :: local_tol
      character, intent(in) :: renorm
      real(KIND=rKind), intent(inout) :: cerr
      integer, intent(out), optional :: errst

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

      ! error from a single split
      real(KIND=rKind) :: err

      ! temporary tensors
      type(qtensorc) :: Tmp, Vtens

      ! singular values
      type(qtensor) :: Lam

      ! IF SYMMETRY --> set quantum number of third leg
      call contr(Tmp, Tens, Kraus, [2], [2], errst=errst)!permout=[1, 4, 3, 2, 5], &
                 !errst=errst)
      !if(prop_error('apply_kraus_qtensorc : contr failed.', &
      !              'LPTNOps_include.f90:78', errst=errst)) return

      call transposed(Tmp, [1, 4, 3, 2, 5], doperm=.true.)
      call destroy(Tens)

      call split(Tens, Lam, Vtens, Tmp, [1, 2, 3], [4, 5], multlr=-1, &
                 trunc=local_tol, ncut=max_kappa, &
                 err=err, renorm=renorm, method='Y', errst=errst)
      !if(prop_error('apply_kraus_qtensorc : split failed.', &
      !              errst=errst)) return

      cerr = cerr + err
      call destroy(Lam)
      call destroy(Tmp)
      call destroy(Vtens)

      call transposed(Tens, perm=[1, 2, 4, 3], doperm=.true.)

      ! IF SYMMETRY --> unset quantum number on third leg

  end subroutine apply_kraus_qtensorc

LPTNOps_f90.canonize_lptn()

fortran-subroutine - June 2017 (dj, updated) Canonize the LPTN with gauged matrices.

Arguments

RhoTYPE(lptn), inout

Bring this LPTN into a canonical form using QR decompositions.

k0INTEGER, in

This is the new orthogonality center for the LPTN.

klINTEGER, OPTIONAL, in

This optional argument can provide the information where to start with gauging the LPTN from the left side of the LPTN. If not given, the maximum of the 1 and the present orthogonality center is choosen.

krINTEGER, OPTIONAL, in

This optional argument can provide the information where to start with gauging the LPTN from the right side of the LPTN. If not given, the minimum of the system size and the present orthogonality center is choosen.

Details

Put the LPTN into the canonical form where all matrices to the left of (optionally down to ) are gauged according to the left-handed condition and all matrices to the right of (optionally up to ) are gauged according to the right-handed condition for OBC. This routine uses the QR decomposition - the fastest method - but it is not rank revealing and so inappropriate for compression. Additionally, the Schmidt coefficients are not returned and so entropies cannot be computed.

Source Code

show / hide f90 code

  subroutine canonize_lptn(Rho, k0, kl, kr, errst)
      type(lptn), intent(inout) :: Rho
      integer, intent(in) :: k0
      integer, intent(in), optional :: kl, kr
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Start of the loop from the left and right
      integer :: kleft, kright

      !if((k0 < 1) .or. (k0 > Rho%ll)) then
      !    errst = raise_error('canonize_lptn : k0 not valid ', &
      !                        99, errst=errst)
      !    return
      !end if

      ! Find begin of canonization from the left
      if(present(kl)) then
          kleft = kl
      else
          kleft = max(1, Rho%oc)
      end if

      ! Find begin of canonization from the right
      if(present(kr)) then
          kright = kr
      else
          kright = min(Rho%ll, Rho%oc)
      end if

      !if(kleft < 1) then
      !    errst = raise_error('canonize_lptn : kl < 1', &
      !                        99, errst=errst)
      !    return
      !end if

      !if(kright > Rho%ll) then
      !    errst = raise_error('canonize_lptn : kr > ll', &
      !                        99, errst=errst)
      !    return
      !end if

      do ii = kleft, (k0 - 1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_qr(Rho%Aa(ii), Rho%Aa(ii + 1), errst=errst)
          !if(prop_error('canonize_lptn: qr failed', &
          !              errst=errst)) return

          Rho%can(ii) = 'l'
          Rho%can(ii + 1) = 'c'

          call set_q_kappa(Rho%Aa(ii))
      end do

      do ii = kright, (k0 + 1), (-1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_rq(Rho%Aa(ii - 1), Rho%Aa(ii), errst=errst)
          !if(prop_error('canonize_lptn: rq failed', &
          !              errst=errst)) return

          Rho%can(ii - 1) = 'c'
          Rho%can(ii) = 'r'

          call set_q_kappa(Rho%Aa(ii))
      end do

      Rho%oc = k0

  end subroutine canonize_lptn

LPTNOps_f90.canonize_svd_lptn()

fortran-subroutine - June 2017 (dj, updated) Put the LPTN into a canonical form using SVD.

Arguments

RhoTYPE(lptn), inout

LPTN to be canonized with SVDs. Updated on exit.

k0INTEGER, in

The new orthogonality center on exit is at the site k0. All matrices to the left and right are gauged accordingly.

klINTEGER, OPTIONAL, in

start SVD from the left on this site. If not present SVD start at site 1 or the ortogonality center.

krINTEGER, OPTIONAL, in

start SVD from the right on this site. If not present, SVD starts on the last site or the orthogonality center.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Details

Put the LPTN into the canonical form where all matrices to the left of (optionally down to ) are gauged according to the left-handed condition and all matrices to the right of (optionally up to ) are gauged according to the right-handed condition for OBC. This routine uses the SVD decomposition, which is rank revealing and so appropriate for compression. Additionally, the Schmidt coefficients are returned and so entropies can be computed.

Source Code

show / hide f90 code

  subroutine canonize_svd_lptn(Rho, k0, kl, kr, trunc, ncut, errst)
      type(lptn), intent(inout) :: Rho
      integer , intent(in) :: k0
      integer, intent(in), optional :: kl, kr
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Start of the loop from the left and right
      integer :: kleft, kright

      !if(present(errst)) errst = 0

      ! Find begin of canonization from the left
      if(present(kl)) then
          kleft = kl
      else
          kleft = max(1, Rho%oc)
      end if

      ! Find begin of canonization from the right
      if(present(kr)) then
          kright = kr
      else
          kright = min(Rho%ll, Rho%oc)
      end if

      do ii = kleft, (k0 - 1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_rsvd(Rho%Aa(ii), Rho%Lambda(ii), Rho%Aa(ii + 1), &
                              Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
                              errst=errst)
          !if(prop_error('canonize_svd_lptn: gaugesite_rsvd failed', &
          !              errst=errst)) return

          Rho%can(ii) = 'l'
          Rho%can(ii + 1) = 'c'

          call set_q_kappa(Rho%Aa(ii))
      end do

      do ii = kright, (k0 + 1), (-1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_lsvd(Rho%Aa(ii - 1), Rho%Lambda(ii), Rho%Aa(ii), &
                              Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
                              errst=errst)
          !if(prop_error('canonize_svd_lptn: gaugesite_lsvd failed', &
          !              errst=errst)) return

          Rho%can(ii - 1) = 'c'
          Rho%can(ii) = 'r'

          call set_q_kappa(Rho%Aa(ii))
      end do

      Rho%oc = k0

  end subroutine canonize_svd_lptn

LPTNOps_f90.canonize_lptnc()

fortran-subroutine - June 2017 (dj, updated) Canonize the LPTN with gauged matrices.

Arguments

RhoTYPE(lptnc), inout

Bring this LPTN into a canonical form using QR decompositions.

k0INTEGER, in

This is the new orthogonality center for the LPTN.

klINTEGER, OPTIONAL, in

This optional argument can provide the information where to start with gauging the LPTN from the left side of the LPTN. If not given, the maximum of the 1 and the present orthogonality center is choosen.

krINTEGER, OPTIONAL, in

This optional argument can provide the information where to start with gauging the LPTN from the right side of the LPTN. If not given, the minimum of the system size and the present orthogonality center is choosen.

Details

Put the LPTN into the canonical form where all matrices to the left of (optionally down to ) are gauged according to the left-handed condition and all matrices to the right of (optionally up to ) are gauged according to the right-handed condition for OBC. This routine uses the QR decomposition - the fastest method - but it is not rank revealing and so inappropriate for compression. Additionally, the Schmidt coefficients are not returned and so entropies cannot be computed.

Source Code

show / hide f90 code

  subroutine canonize_lptnc(Rho, k0, kl, kr, errst)
      type(lptnc), intent(inout) :: Rho
      integer, intent(in) :: k0
      integer, intent(in), optional :: kl, kr
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Start of the loop from the left and right
      integer :: kleft, kright

      !if((k0 < 1) .or. (k0 > Rho%ll)) then
      !    errst = raise_error('canonize_lptnc : k0 not valid ', &
      !                        99, errst=errst)
      !    return
      !end if

      ! Find begin of canonization from the left
      if(present(kl)) then
          kleft = kl
      else
          kleft = max(1, Rho%oc)
      end if

      ! Find begin of canonization from the right
      if(present(kr)) then
          kright = kr
      else
          kright = min(Rho%ll, Rho%oc)
      end if

      !if(kleft < 1) then
      !    errst = raise_error('canonize_lptnc : kl < 1', &
      !                        99, errst=errst)
      !    return
      !end if

      !if(kright > Rho%ll) then
      !    errst = raise_error('canonize_lptnc : kr > ll', &
      !                        99, errst=errst)
      !    return
      !end if

      do ii = kleft, (k0 - 1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_qr(Rho%Aa(ii), Rho%Aa(ii + 1), errst=errst)
          !if(prop_error('canonize_lptnc: qr failed', &
          !              errst=errst)) return

          Rho%can(ii) = 'l'
          Rho%can(ii + 1) = 'c'

          call set_q_kappa(Rho%Aa(ii))
      end do

      do ii = kright, (k0 + 1), (-1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_rq(Rho%Aa(ii - 1), Rho%Aa(ii), errst=errst)
          !if(prop_error('canonize_lptnc: rq failed', &
          !              errst=errst)) return

          Rho%can(ii - 1) = 'c'
          Rho%can(ii) = 'r'

          call set_q_kappa(Rho%Aa(ii))
      end do

      Rho%oc = k0

  end subroutine canonize_lptnc

LPTNOps_f90.canonize_svd_lptnc()

fortran-subroutine - June 2017 (dj, updated) Put the LPTN into a canonical form using SVD.

Arguments

RhoTYPE(lptnc), inout

LPTN to be canonized with SVDs. Updated on exit.

k0INTEGER, in

The new orthogonality center on exit is at the site k0. All matrices to the left and right are gauged accordingly.

klINTEGER, OPTIONAL, in

start SVD from the left on this site. If not present SVD start at site 1 or the ortogonality center.

krINTEGER, OPTIONAL, in

start SVD from the right on this site. If not present, SVD starts on the last site or the orthogonality center.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Details

Put the LPTN into the canonical form where all matrices to the left of (optionally down to ) are gauged according to the left-handed condition and all matrices to the right of (optionally up to ) are gauged according to the right-handed condition for OBC. This routine uses the SVD decomposition, which is rank revealing and so appropriate for compression. Additionally, the Schmidt coefficients are returned and so entropies can be computed.

Source Code

show / hide f90 code

  subroutine canonize_svd_lptnc(Rho, k0, kl, kr, trunc, ncut, errst)
      type(lptnc), intent(inout) :: Rho
      integer , intent(in) :: k0
      integer, intent(in), optional :: kl, kr
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Start of the loop from the left and right
      integer :: kleft, kright

      !if(present(errst)) errst = 0

      ! Find begin of canonization from the left
      if(present(kl)) then
          kleft = kl
      else
          kleft = max(1, Rho%oc)
      end if

      ! Find begin of canonization from the right
      if(present(kr)) then
          kright = kr
      else
          kright = min(Rho%ll, Rho%oc)
      end if

      do ii = kleft, (k0 - 1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_rsvd(Rho%Aa(ii), Rho%Lambda(ii), Rho%Aa(ii + 1), &
                              Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
                              errst=errst)
          !if(prop_error('canonize_svd_lptnc: gaugesite_rsvd failed', &
          !              errst=errst)) return

          Rho%can(ii) = 'l'
          Rho%can(ii + 1) = 'c'

          call set_q_kappa(Rho%Aa(ii))
      end do

      do ii = kright, (k0 + 1), (-1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_lsvd(Rho%Aa(ii - 1), Rho%Lambda(ii), Rho%Aa(ii), &
                              Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
                              errst=errst)
          !if(prop_error('canonize_svd_lptnc: gaugesite_lsvd failed', &
          !              errst=errst)) return

          Rho%can(ii - 1) = 'c'
          Rho%can(ii) = 'r'

          call set_q_kappa(Rho%Aa(ii))
      end do

      Rho%oc = k0

  end subroutine canonize_svd_lptnc

LPTNOps_f90.canonize_qlptn()

fortran-subroutine - June 2017 (dj, updated) Canonize the LPTN with gauged matrices.

Arguments

RhoTYPE(qlptn), inout

Bring this LPTN into a canonical form using QR decompositions.

k0INTEGER, in

This is the new orthogonality center for the LPTN.

klINTEGER, OPTIONAL, in

This optional argument can provide the information where to start with gauging the LPTN from the left side of the LPTN. If not given, the maximum of the 1 and the present orthogonality center is choosen.

krINTEGER, OPTIONAL, in

This optional argument can provide the information where to start with gauging the LPTN from the right side of the LPTN. If not given, the minimum of the system size and the present orthogonality center is choosen.

Details

Put the LPTN into the canonical form where all matrices to the left of (optionally down to ) are gauged according to the left-handed condition and all matrices to the right of (optionally up to ) are gauged according to the right-handed condition for OBC. This routine uses the QR decomposition - the fastest method - but it is not rank revealing and so inappropriate for compression. Additionally, the Schmidt coefficients are not returned and so entropies cannot be computed.

Source Code

show / hide f90 code

  subroutine canonize_qlptn(Rho, k0, kl, kr, errst)
      type(qlptn), intent(inout) :: Rho
      integer, intent(in) :: k0
      integer, intent(in), optional :: kl, kr
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Start of the loop from the left and right
      integer :: kleft, kright

      !if((k0 < 1) .or. (k0 > Rho%ll)) then
      !    errst = raise_error('canonize_qlptn : k0 not valid ', &
      !                        99, errst=errst)
      !    return
      !end if

      ! Find begin of canonization from the left
      if(present(kl)) then
          kleft = kl
      else
          kleft = max(1, Rho%oc)
      end if

      ! Find begin of canonization from the right
      if(present(kr)) then
          kright = kr
      else
          kright = min(Rho%ll, Rho%oc)
      end if

      !if(kleft < 1) then
      !    errst = raise_error('canonize_qlptn : kl < 1', &
      !                        99, errst=errst)
      !    return
      !end if

      !if(kright > Rho%ll) then
      !    errst = raise_error('canonize_qlptn : kr > ll', &
      !                        99, errst=errst)
      !    return
      !end if

      do ii = kleft, (k0 - 1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_qr(Rho%Aa(ii), Rho%Aa(ii + 1), errst=errst)
          !if(prop_error('canonize_qlptn: qr failed', &
          !              errst=errst)) return

          Rho%can(ii) = 'l'
          Rho%can(ii + 1) = 'c'

          call set_q_kappa(Rho%Aa(ii))
      end do

      do ii = kright, (k0 + 1), (-1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_rq(Rho%Aa(ii - 1), Rho%Aa(ii), errst=errst)
          !if(prop_error('canonize_qlptn: rq failed', &
          !              errst=errst)) return

          Rho%can(ii - 1) = 'c'
          Rho%can(ii) = 'r'

          call set_q_kappa(Rho%Aa(ii))
      end do

      Rho%oc = k0

  end subroutine canonize_qlptn

LPTNOps_f90.canonize_svd_qlptn()

fortran-subroutine - June 2017 (dj, updated) Put the LPTN into a canonical form using SVD.

Arguments

RhoTYPE(qlptn), inout

LPTN to be canonized with SVDs. Updated on exit.

k0INTEGER, in

The new orthogonality center on exit is at the site k0. All matrices to the left and right are gauged accordingly.

klINTEGER, OPTIONAL, in

start SVD from the left on this site. If not present SVD start at site 1 or the ortogonality center.

krINTEGER, OPTIONAL, in

start SVD from the right on this site. If not present, SVD starts on the last site or the orthogonality center.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Details

Put the LPTN into the canonical form where all matrices to the left of (optionally down to ) are gauged according to the left-handed condition and all matrices to the right of (optionally up to ) are gauged according to the right-handed condition for OBC. This routine uses the SVD decomposition, which is rank revealing and so appropriate for compression. Additionally, the Schmidt coefficients are returned and so entropies can be computed.

Source Code

show / hide f90 code

  subroutine canonize_svd_qlptn(Rho, k0, kl, kr, trunc, ncut, errst)
      type(qlptn), intent(inout) :: Rho
      integer , intent(in) :: k0
      integer, intent(in), optional :: kl, kr
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Start of the loop from the left and right
      integer :: kleft, kright

      !if(present(errst)) errst = 0

      ! Find begin of canonization from the left
      if(present(kl)) then
          kleft = kl
      else
          kleft = max(1, Rho%oc)
      end if

      ! Find begin of canonization from the right
      if(present(kr)) then
          kright = kr
      else
          kright = min(Rho%ll, Rho%oc)
      end if

      do ii = kleft, (k0 - 1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_rsvd(Rho%Aa(ii), Rho%Lambda(ii), Rho%Aa(ii + 1), &
                              Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
                              errst=errst)
          !if(prop_error('canonize_svd_qlptn: gaugesite_rsvd failed', &
          !              errst=errst)) return

          Rho%can(ii) = 'l'
          Rho%can(ii + 1) = 'c'

          call set_q_kappa(Rho%Aa(ii))
      end do

      do ii = kright, (k0 + 1), (-1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_lsvd(Rho%Aa(ii - 1), Rho%Lambda(ii), Rho%Aa(ii), &
                              Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
                              errst=errst)
          !if(prop_error('canonize_svd_qlptn: gaugesite_lsvd failed', &
          !              errst=errst)) return

          Rho%can(ii - 1) = 'c'
          Rho%can(ii) = 'r'

          call set_q_kappa(Rho%Aa(ii))
      end do

      Rho%oc = k0

  end subroutine canonize_svd_qlptn

LPTNOps_f90.canonize_qlptnc()

fortran-subroutine - June 2017 (dj, updated) Canonize the LPTN with gauged matrices.

Arguments

RhoTYPE(qlptnc), inout

Bring this LPTN into a canonical form using QR decompositions.

k0INTEGER, in

This is the new orthogonality center for the LPTN.

klINTEGER, OPTIONAL, in

This optional argument can provide the information where to start with gauging the LPTN from the left side of the LPTN. If not given, the maximum of the 1 and the present orthogonality center is choosen.

krINTEGER, OPTIONAL, in

This optional argument can provide the information where to start with gauging the LPTN from the right side of the LPTN. If not given, the minimum of the system size and the present orthogonality center is choosen.

Details

Put the LPTN into the canonical form where all matrices to the left of (optionally down to ) are gauged according to the left-handed condition and all matrices to the right of (optionally up to ) are gauged according to the right-handed condition for OBC. This routine uses the QR decomposition - the fastest method - but it is not rank revealing and so inappropriate for compression. Additionally, the Schmidt coefficients are not returned and so entropies cannot be computed.

Source Code

show / hide f90 code

  subroutine canonize_qlptnc(Rho, k0, kl, kr, errst)
      type(qlptnc), intent(inout) :: Rho
      integer, intent(in) :: k0
      integer, intent(in), optional :: kl, kr
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Start of the loop from the left and right
      integer :: kleft, kright

      !if((k0 < 1) .or. (k0 > Rho%ll)) then
      !    errst = raise_error('canonize_qlptnc : k0 not valid ', &
      !                        99, errst=errst)
      !    return
      !end if

      ! Find begin of canonization from the left
      if(present(kl)) then
          kleft = kl
      else
          kleft = max(1, Rho%oc)
      end if

      ! Find begin of canonization from the right
      if(present(kr)) then
          kright = kr
      else
          kright = min(Rho%ll, Rho%oc)
      end if

      !if(kleft < 1) then
      !    errst = raise_error('canonize_qlptnc : kl < 1', &
      !                        99, errst=errst)
      !    return
      !end if

      !if(kright > Rho%ll) then
      !    errst = raise_error('canonize_qlptnc : kr > ll', &
      !                        99, errst=errst)
      !    return
      !end if

      do ii = kleft, (k0 - 1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_qr(Rho%Aa(ii), Rho%Aa(ii + 1), errst=errst)
          !if(prop_error('canonize_qlptnc: qr failed', &
          !              errst=errst)) return

          Rho%can(ii) = 'l'
          Rho%can(ii + 1) = 'c'

          call set_q_kappa(Rho%Aa(ii))
      end do

      do ii = kright, (k0 + 1), (-1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_rq(Rho%Aa(ii - 1), Rho%Aa(ii), errst=errst)
          !if(prop_error('canonize_qlptnc: rq failed', &
          !              errst=errst)) return

          Rho%can(ii - 1) = 'c'
          Rho%can(ii) = 'r'

          call set_q_kappa(Rho%Aa(ii))
      end do

      Rho%oc = k0

  end subroutine canonize_qlptnc

LPTNOps_f90.canonize_svd_qlptnc()

fortran-subroutine - June 2017 (dj, updated) Put the LPTN into a canonical form using SVD.

Arguments

RhoTYPE(qlptnc), inout

LPTN to be canonized with SVDs. Updated on exit.

k0INTEGER, in

The new orthogonality center on exit is at the site k0. All matrices to the left and right are gauged accordingly.

klINTEGER, OPTIONAL, in

start SVD from the left on this site. If not present SVD start at site 1 or the ortogonality center.

krINTEGER, OPTIONAL, in

start SVD from the right on this site. If not present, SVD starts on the last site or the orthogonality center.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Details

Put the LPTN into the canonical form where all matrices to the left of (optionally down to ) are gauged according to the left-handed condition and all matrices to the right of (optionally up to ) are gauged according to the right-handed condition for OBC. This routine uses the SVD decomposition, which is rank revealing and so appropriate for compression. Additionally, the Schmidt coefficients are returned and so entropies can be computed.

Source Code

show / hide f90 code

  subroutine canonize_svd_qlptnc(Rho, k0, kl, kr, trunc, ncut, errst)
      type(qlptnc), intent(inout) :: Rho
      integer , intent(in) :: k0
      integer, intent(in), optional :: kl, kr
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Start of the loop from the left and right
      integer :: kleft, kright

      !if(present(errst)) errst = 0

      ! Find begin of canonization from the left
      if(present(kl)) then
          kleft = kl
      else
          kleft = max(1, Rho%oc)
      end if

      ! Find begin of canonization from the right
      if(present(kr)) then
          kright = kr
      else
          kright = min(Rho%ll, Rho%oc)
      end if

      do ii = kleft, (k0 - 1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_rsvd(Rho%Aa(ii), Rho%Lambda(ii), Rho%Aa(ii + 1), &
                              Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
                              errst=errst)
          !if(prop_error('canonize_svd_qlptnc: gaugesite_rsvd failed', &
          !              errst=errst)) return

          Rho%can(ii) = 'l'
          Rho%can(ii + 1) = 'c'

          call set_q_kappa(Rho%Aa(ii))
      end do

      do ii = kright, (k0 + 1), (-1)
          call set_0_kappa(Rho%Aa(ii))

          call gaugesite_lsvd(Rho%Aa(ii - 1), Rho%Lambda(ii), Rho%Aa(ii), &
                              Rho%haslambda(ii), trunc=trunc, ncut=ncut, &
                              errst=errst)
          !if(prop_error('canonize_svd_qlptnc: gaugesite_lsvd failed', &
          !              errst=errst)) return

          Rho%can(ii - 1) = 'c'
          Rho%can(ii) = 'r'

          call set_q_kappa(Rho%Aa(ii))
      end do

      Rho%oc = k0

  end subroutine canonize_svd_qlptnc

LPTNOps_f90.check_lptn()

fortran-subroutine - August 2017 (dj) Run basic checks on LPTN, such as left-right unitary and normed.

Arguments

RhoTYPE(lptn), in

Run checks on this LPTN.

Source Code

show / hide f90 code

  subroutine check_lptn(Rho, errst)
      type(lptn), intent(in) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Check norm of orthgonality center
      real(KIND=rKind) :: normoc

      ! temporary tensor to keep Rho intent(in)
      type(tensor) :: Tmp

      ! tensor to check if tensor are left/right unitary
      type(tensor) :: Tens

      ! string to store more information
      character(len=64) :: info

      normoc = norm(Rho%Aa(Rho%oc))
      !if(abs(normoc -  1.0_rKind) > 1e-14_rKind) then
      !    print *, 'failed norm', normoc
      !CHEK_     write(info, '(1E30.15)') normoc
      !    errst = raise_error('check_lptn : norm failed '//&
      !                        trim(adjustl(info)), 99, errst=errst)
      !    return
      !end if
      if(abs(normoc -  1.0_rKind) > 1e-14_rKind) stop 'check_lptn: norm.'

      do ii = (Rho%oc + 1), Rho%ll
          call copy(Tmp, Rho%Aa(ii))
          call contr(Tens, Tmp, Tmp, [2, 3, 4], [2, 3, 4], &
                     transr='C', errst=errst)
          !if(prop_error('check_lptn : contr (1) failed.', &
          !              errst=errst)) return

          !if(.not. is_eye(Tens)) then
          !    write(info, '(1I5)') ii
          !    errst = raise_error('check_lptn : unitary failed '//&
          !                        trim(adjustl(info)), 99, errst=errst)
          !    return
          !end if
          if(.not. is_eye(Tens)) stop 'check_lptn: unitary failed (1).'

          call destroy(Tmp)
          call destroy(Tens)
      end do

      do ii = 1, (Rho%oc - 1)
          call copy(Tmp, Rho%Aa(ii))
          call contr(Tens, Tmp, Tmp, [1, 2, 3], [1, 2, 3], &
                     transr='C', errst=errst)
          !if(prop_error('check_lptn : contr (2) failed.', &
          !              errst=errst)) return

          !if(.not. is_eye(Tens)) then
          !    write(info, '(1I5)') ii
          !    errst = raise_error('check_lptn : unitary failed '//&
          !                        trim(adjustl(info)), 99, errst=errst)
          !    return
          !end if
          if(.not. is_eye(Tens)) stop 'check_lptn: unitary failed (2).'

          call destroy(Tmp)
          call destroy(Tens)
      end do

  end subroutine check_lptn

LPTNOps_f90.check_lptnc()

fortran-subroutine - August 2017 (dj) Run basic checks on LPTN, such as left-right unitary and normed.

Arguments

RhoTYPE(lptnc), in

Run checks on this LPTN.

Source Code

show / hide f90 code

  subroutine check_lptnc(Rho, errst)
      type(lptnc), intent(in) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Check norm of orthgonality center
      real(KIND=rKind) :: normoc

      ! temporary tensor to keep Rho intent(in)
      type(tensorc) :: Tmp

      ! tensor to check if tensor are left/right unitary
      type(tensorc) :: Tens

      ! string to store more information
      character(len=64) :: info

      normoc = norm(Rho%Aa(Rho%oc))
      !if(abs(normoc -  1.0_rKind) > 1e-14_rKind) then
      !    print *, 'failed norm', normoc
      !CHEK_     write(info, '(1E30.15)') normoc
      !    errst = raise_error('check_lptnc : norm failed '//&
      !                        trim(adjustl(info)), 99, errst=errst)
      !    return
      !end if
      if(abs(normoc -  1.0_rKind) > 1e-14_rKind) stop 'check_lptnc: norm.'

      do ii = (Rho%oc + 1), Rho%ll
          call copy(Tmp, Rho%Aa(ii))
          call contr(Tens, Tmp, Tmp, [2, 3, 4], [2, 3, 4], &
                     transr='C', errst=errst)
          !if(prop_error('check_lptnc : contr (1) failed.', &
          !              errst=errst)) return

          !if(.not. is_eye(Tens)) then
          !    write(info, '(1I5)') ii
          !    errst = raise_error('check_lptnc : unitary failed '//&
          !                        trim(adjustl(info)), 99, errst=errst)
          !    return
          !end if
          if(.not. is_eye(Tens)) stop 'check_lptnc: unitary failed (1).'

          call destroy(Tmp)
          call destroy(Tens)
      end do

      do ii = 1, (Rho%oc - 1)
          call copy(Tmp, Rho%Aa(ii))
          call contr(Tens, Tmp, Tmp, [1, 2, 3], [1, 2, 3], &
                     transr='C', errst=errst)
          !if(prop_error('check_lptnc : contr (2) failed.', &
          !              errst=errst)) return

          !if(.not. is_eye(Tens)) then
          !    write(info, '(1I5)') ii
          !    errst = raise_error('check_lptnc : unitary failed '//&
          !                        trim(adjustl(info)), 99, errst=errst)
          !    return
          !end if
          if(.not. is_eye(Tens)) stop 'check_lptnc: unitary failed (2).'

          call destroy(Tmp)
          call destroy(Tens)
      end do

  end subroutine check_lptnc

LPTNOps_f90.check_qlptn()

fortran-subroutine - August 2017 (dj) Run basic checks on LPTN, such as left-right unitary and normed.

Arguments

RhoTYPE(qlptn), in

Run checks on this LPTN.

Source Code

show / hide f90 code

  subroutine check_qlptn(Rho, errst)
      type(qlptn), intent(in) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Check norm of orthgonality center
      real(KIND=rKind) :: normoc

      ! temporary tensor to keep Rho intent(in)
      type(qtensor) :: Tmp

      ! tensor to check if tensor are left/right unitary
      type(qtensor) :: Tens

      ! string to store more information
      character(len=64) :: info

      normoc = norm(Rho%Aa(Rho%oc))
      !if(abs(normoc -  1.0_rKind) > 1e-14_rKind) then
      !    print *, 'failed norm', normoc
      !CHEK_     write(info, '(1E30.15)') normoc
      !    errst = raise_error('check_qlptn : norm failed '//&
      !                        trim(adjustl(info)), 99, errst=errst)
      !    return
      !end if
      if(abs(normoc -  1.0_rKind) > 1e-14_rKind) stop 'check_qlptn: norm.'

      do ii = (Rho%oc + 1), Rho%ll
          call copy(Tmp, Rho%Aa(ii))
          call contr(Tens, Tmp, Tmp, [2, 3, 4], [2, 3, 4], &
                     transr='C', errst=errst)
          !if(prop_error('check_qlptn : contr (1) failed.', &
          !              errst=errst)) return

          !if(.not. is_eye(Tens)) then
          !    write(info, '(1I5)') ii
          !    errst = raise_error('check_qlptn : unitary failed '//&
          !                        trim(adjustl(info)), 99, errst=errst)
          !    return
          !end if
          if(.not. is_eye(Tens)) stop 'check_qlptn: unitary failed (1).'

          call destroy(Tmp)
          call destroy(Tens)
      end do

      do ii = 1, (Rho%oc - 1)
          call copy(Tmp, Rho%Aa(ii))
          call contr(Tens, Tmp, Tmp, [1, 2, 3], [1, 2, 3], &
                     transr='C', errst=errst)
          !if(prop_error('check_qlptn : contr (2) failed.', &
          !              errst=errst)) return

          !if(.not. is_eye(Tens)) then
          !    write(info, '(1I5)') ii
          !    errst = raise_error('check_qlptn : unitary failed '//&
          !                        trim(adjustl(info)), 99, errst=errst)
          !    return
          !end if
          if(.not. is_eye(Tens)) stop 'check_qlptn: unitary failed (2).'

          call destroy(Tmp)
          call destroy(Tens)
      end do

  end subroutine check_qlptn

LPTNOps_f90.check_qlptnc()

fortran-subroutine - August 2017 (dj) Run basic checks on LPTN, such as left-right unitary and normed.

Arguments

RhoTYPE(qlptnc), in

Run checks on this LPTN.

Source Code

show / hide f90 code

  subroutine check_qlptnc(Rho, errst)
      type(qlptnc), intent(in) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Check norm of orthgonality center
      real(KIND=rKind) :: normoc

      ! temporary tensor to keep Rho intent(in)
      type(qtensorc) :: Tmp

      ! tensor to check if tensor are left/right unitary
      type(qtensorc) :: Tens

      ! string to store more information
      character(len=64) :: info

      normoc = norm(Rho%Aa(Rho%oc))
      !if(abs(normoc -  1.0_rKind) > 1e-14_rKind) then
      !    print *, 'failed norm', normoc
      !CHEK_     write(info, '(1E30.15)') normoc
      !    errst = raise_error('check_qlptnc : norm failed '//&
      !                        trim(adjustl(info)), 99, errst=errst)
      !    return
      !end if
      if(abs(normoc -  1.0_rKind) > 1e-14_rKind) stop 'check_qlptnc: norm.'

      do ii = (Rho%oc + 1), Rho%ll
          call copy(Tmp, Rho%Aa(ii))
          call contr(Tens, Tmp, Tmp, [2, 3, 4], [2, 3, 4], &
                     transr='C', errst=errst)
          !if(prop_error('check_qlptnc : contr (1) failed.', &
          !              errst=errst)) return

          !if(.not. is_eye(Tens)) then
          !    write(info, '(1I5)') ii
          !    errst = raise_error('check_qlptnc : unitary failed '//&
          !                        trim(adjustl(info)), 99, errst=errst)
          !    return
          !end if
          if(.not. is_eye(Tens)) stop 'check_qlptnc: unitary failed (1).'

          call destroy(Tmp)
          call destroy(Tens)
      end do

      do ii = 1, (Rho%oc - 1)
          call copy(Tmp, Rho%Aa(ii))
          call contr(Tens, Tmp, Tmp, [1, 2, 3], [1, 2, 3], &
                     transr='C', errst=errst)
          !if(prop_error('check_qlptnc : contr (2) failed.', &
          !              errst=errst)) return

          !if(.not. is_eye(Tens)) then
          !    write(info, '(1I5)') ii
          !    errst = raise_error('check_qlptnc : unitary failed '//&
          !                        trim(adjustl(info)), 99, errst=errst)
          !    return
          !end if
          if(.not. is_eye(Tens)) stop 'check_qlptnc: unitary failed (2).'

          call destroy(Tmp)
          call destroy(Tens)
      end do

  end subroutine check_qlptnc

LPTNOps_f90.copy_lptn_lptn()

fortran-subroutine - September 2017 (dj, updated) Make a copy of a LPTN

Arguments

Rho_newTYPE(LPTN_TYPE), out

Store a copy of Rho_old here.

Rho_inTYPE(LPTN_TYPE), in

Copy this LPTN

Source Code

show / hide f90 code

  subroutine copy_lptn_lptn(Rho_new, Rho_in, errst)
      type(lptn), intent(out) :: Rho_new
      type(lptn), intent(in) :: Rho_in
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Rho_new%ll = Rho_in%ll
      Rho_new%oc = Rho_in%oc

      allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
               Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))

      ! Copy the arrays outside the loop
      Rho_new%can = Rho_in%can
      Rho_new%haslambda = Rho_in%haslambda

      do ii = 1, Rho_new%ll
          call copy(Rho_new%AA(ii), Rho_in%AA(ii))

          if(Rho_new%haslambda(ii)) then
              call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
          end if
      end do

      if((Rho_new%haslambda(Rho_new%ll + 1))) then
          call copy(Rho_new%Lambda(Rho_new%ll + 1), &
                    Rho_in%Lambda(Rho_new%ll + 1))
      end if

  end subroutine copy_lptn_lptn

LPTNOps_f90.copy_lptnc_lptnc()

fortran-subroutine - September 2017 (dj, updated) Make a copy of a LPTN

Arguments

Rho_newTYPE(LPTN_TYPE), out

Store a copy of Rho_old here.

Rho_inTYPE(LPTN_TYPE), in

Copy this LPTN

Source Code

show / hide f90 code

  subroutine copy_lptnc_lptnc(Rho_new, Rho_in, errst)
      type(lptnc), intent(out) :: Rho_new
      type(lptnc), intent(in) :: Rho_in
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Rho_new%ll = Rho_in%ll
      Rho_new%oc = Rho_in%oc

      allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
               Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))

      ! Copy the arrays outside the loop
      Rho_new%can = Rho_in%can
      Rho_new%haslambda = Rho_in%haslambda

      do ii = 1, Rho_new%ll
          call copy(Rho_new%AA(ii), Rho_in%AA(ii))

          if(Rho_new%haslambda(ii)) then
              call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
          end if
      end do

      if((Rho_new%haslambda(Rho_new%ll + 1))) then
          call copy(Rho_new%Lambda(Rho_new%ll + 1), &
                    Rho_in%Lambda(Rho_new%ll + 1))
      end if

  end subroutine copy_lptnc_lptnc

LPTNOps_f90.copy_qlptn_qlptn()

fortran-subroutine - September 2017 (dj, updated) Make a copy of a LPTN

Arguments

Rho_newTYPE(LPTN_TYPE), out

Store a copy of Rho_old here.

Rho_inTYPE(LPTN_TYPE), in

Copy this LPTN

Source Code

show / hide f90 code

  subroutine copy_qlptn_qlptn(Rho_new, Rho_in, errst)
      type(qlptn), intent(out) :: Rho_new
      type(qlptn), intent(in) :: Rho_in
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Rho_new%ll = Rho_in%ll
      Rho_new%oc = Rho_in%oc

      allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
               Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))

      ! Copy the arrays outside the loop
      Rho_new%can = Rho_in%can
      Rho_new%haslambda = Rho_in%haslambda

      do ii = 1, Rho_new%ll
          call copy(Rho_new%AA(ii), Rho_in%AA(ii))

          if(Rho_new%haslambda(ii)) then
              call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
          end if
      end do

      if((Rho_new%haslambda(Rho_new%ll + 1))) then
          call copy(Rho_new%Lambda(Rho_new%ll + 1), &
                    Rho_in%Lambda(Rho_new%ll + 1))
      end if

  end subroutine copy_qlptn_qlptn

LPTNOps_f90.copy_qlptnc_qlptnc()

fortran-subroutine - September 2017 (dj, updated) Make a copy of a LPTN

Arguments

Rho_newTYPE(LPTN_TYPE), out

Store a copy of Rho_old here.

Rho_inTYPE(LPTN_TYPE), in

Copy this LPTN

Source Code

show / hide f90 code

  subroutine copy_qlptnc_qlptnc(Rho_new, Rho_in, errst)
      type(qlptnc), intent(out) :: Rho_new
      type(qlptnc), intent(in) :: Rho_in
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Rho_new%ll = Rho_in%ll
      Rho_new%oc = Rho_in%oc

      allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
               Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))

      ! Copy the arrays outside the loop
      Rho_new%can = Rho_in%can
      Rho_new%haslambda = Rho_in%haslambda

      do ii = 1, Rho_new%ll
          call copy(Rho_new%AA(ii), Rho_in%AA(ii))

          if(Rho_new%haslambda(ii)) then
              call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
          end if
      end do

      if((Rho_new%haslambda(Rho_new%ll + 1))) then
          call copy(Rho_new%Lambda(Rho_new%ll + 1), &
                    Rho_in%Lambda(Rho_new%ll + 1))
      end if

  end subroutine copy_qlptnc_qlptnc

LPTNOps_f90.copy_lptnc_lptn()

fortran-subroutine - September 2017 (dj, updated) Make a copy of a LPTN

Arguments

Rho_newTYPE(LPTN_TYPE), out

Store a copy of Rho_old here.

Rho_inTYPE(LPTN_TYPE), in

Copy this LPTN

Source Code

show / hide f90 code

  subroutine copy_lptnc_lptn(Rho_new, Rho_in, errst)
      type(lptnc), intent(out) :: Rho_new
      type(lptn), intent(in) :: Rho_in
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Rho_new%ll = Rho_in%ll
      Rho_new%oc = Rho_in%oc

      allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
               Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))

      ! Copy the arrays outside the loop
      Rho_new%can = Rho_in%can
      Rho_new%haslambda = Rho_in%haslambda

      do ii = 1, Rho_new%ll
          call copy(Rho_new%AA(ii), Rho_in%AA(ii))

          if(Rho_new%haslambda(ii)) then
              call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
          end if
      end do

      if((Rho_new%haslambda(Rho_new%ll + 1))) then
          call copy(Rho_new%Lambda(Rho_new%ll + 1), &
                    Rho_in%Lambda(Rho_new%ll + 1))
      end if

  end subroutine copy_lptnc_lptn

LPTNOps_f90.copy_qlptnc_qlptn()

fortran-subroutine - September 2017 (dj, updated) Make a copy of a LPTN

Arguments

Rho_newTYPE(LPTN_TYPE), out

Store a copy of Rho_old here.

Rho_inTYPE(LPTN_TYPE), in

Copy this LPTN

Source Code

show / hide f90 code

  subroutine copy_qlptnc_qlptn(Rho_new, Rho_in, errst)
      type(qlptnc), intent(out) :: Rho_new
      type(qlptn), intent(in) :: Rho_in
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Rho_new%ll = Rho_in%ll
      Rho_new%oc = Rho_in%oc

      allocate(Rho_new%AA(Rho_new%ll), Rho_new%haslambda(Rho_new%ll + 1), &
               Rho_new%Lambda(Rho_new%ll + 1), Rho_new%can(Rho_new%ll))

      ! Copy the arrays outside the loop
      Rho_new%can = Rho_in%can
      Rho_new%haslambda = Rho_in%haslambda

      do ii = 1, Rho_new%ll
          call copy(Rho_new%AA(ii), Rho_in%AA(ii))

          if(Rho_new%haslambda(ii)) then
              call copy(Rho_new%lambda(ii), Rho_in%lambda(ii))
          end if
      end do

      if((Rho_new%haslambda(Rho_new%ll + 1))) then
          call copy(Rho_new%Lambda(Rho_new%ll + 1), &
                    Rho_in%Lambda(Rho_new%ll + 1))
      end if

  end subroutine copy_qlptnc_qlptn

LPTNOps_f90.copy_lptn_mps()

fortran-subroutine - September 2017 (dj) Copy an MPS wave function Psi to a LPTN density matrix Rho.

Arguments

RhoTYPE(lptn), inout

Copy MPS into this LPTN.

PsiTYPE(mps), in

MPS to be converted to an LPTN

scalarREAL, OPTIONAL, in

Scale Rho by a factor.

Source Code

show / hide f90 code

  subroutine copy_lptn_mps(Rho, Psi, scalar, errst)
      type(lptn), intent(inout) :: Rho
      type(mps), intent(in) :: Psi
      real(KIND=rKind), intent(in), optional :: scalar
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      Rho%ll = Psi%ll
      Rho%oc = Psi%oc

      allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
               Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))

      Rho%can = Psi%can
      Rho%haslambda = Psi%haslambda

      do ii = 1, Psi%ll
          call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
          !if(prop_error('copy_lptn_mps : copy '//&
          !              '(1) failed.', errst=errst)) return

          call add_dummylink(Rho%Aa(ii), 3, errst=errst)
          !if(prop_error('copy_lptn_mps : add_dummylink '//&
          !              'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
      end do

      do ii = 1, (Psi%ll + 1)
          if(Psi%haslambda(ii)) then
              call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
              !if(prop_error('copy_lptn_mps : copy '//&
              !              '(2) failed.', errst=errst)) return
          end if
      end do

      if(present(scalar)) then
          ! Could be more efficient inside loop
          call scale(scalar, Rho)
      end if

  end subroutine copy_lptn_mps

LPTNOps_f90.copy_lptnc_mps()

fortran-subroutine - September 2017 (dj) Copy an MPS wave function Psi to a LPTN density matrix Rho.

Arguments

RhoTYPE(lptnc), inout

Copy MPS into this LPTN.

PsiTYPE(mps), in

MPS to be converted to an LPTN

scalarREAL, OPTIONAL, in

Scale Rho by a factor.

Source Code

show / hide f90 code

  subroutine copy_lptnc_mps(Rho, Psi, scalar, errst)
      type(lptnc), intent(inout) :: Rho
      type(mps), intent(in) :: Psi
      real(KIND=rKind), intent(in), optional :: scalar
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      Rho%ll = Psi%ll
      Rho%oc = Psi%oc

      allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
               Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))

      Rho%can = Psi%can
      Rho%haslambda = Psi%haslambda

      do ii = 1, Psi%ll
          call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
          !if(prop_error('copy_lptnc_mps : copy '//&
          !              '(1) failed.', errst=errst)) return

          call add_dummylink(Rho%Aa(ii), 3, errst=errst)
          !if(prop_error('copy_lptnc_mps : add_dummylink '//&
          !              'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
      end do

      do ii = 1, (Psi%ll + 1)
          if(Psi%haslambda(ii)) then
              call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
              !if(prop_error('copy_lptnc_mps : copy '//&
              !              '(2) failed.', errst=errst)) return
          end if
      end do

      if(present(scalar)) then
          ! Could be more efficient inside loop
          call scale(scalar, Rho)
      end if

  end subroutine copy_lptnc_mps

LPTNOps_f90.copy_lptnc_mpsc()

fortran-subroutine - September 2017 (dj) Copy an MPS wave function Psi to a LPTN density matrix Rho.

Arguments

RhoTYPE(lptnc), inout

Copy MPS into this LPTN.

PsiTYPE(mpsc), in

MPS to be converted to an LPTN

scalarREAL, OPTIONAL, in

Scale Rho by a factor.

Source Code

show / hide f90 code

  subroutine copy_lptnc_mpsc(Rho, Psi, scalar, errst)
      type(lptnc), intent(inout) :: Rho
      type(mpsc), intent(in) :: Psi
      real(KIND=rKind), intent(in), optional :: scalar
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      Rho%ll = Psi%ll
      Rho%oc = Psi%oc

      allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
               Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))

      Rho%can = Psi%can
      Rho%haslambda = Psi%haslambda

      do ii = 1, Psi%ll
          call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
          !if(prop_error('copy_lptnc_mpsc : copy '//&
          !              '(1) failed.', errst=errst)) return

          call add_dummylink(Rho%Aa(ii), 3, errst=errst)
          !if(prop_error('copy_lptnc_mpsc : add_dummylink '//&
          !              'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
      end do

      do ii = 1, (Psi%ll + 1)
          if(Psi%haslambda(ii)) then
              call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
              !if(prop_error('copy_lptnc_mpsc : copy '//&
              !              '(2) failed.', errst=errst)) return
          end if
      end do

      if(present(scalar)) then
          ! Could be more efficient inside loop
          call scale(scalar, Rho)
      end if

  end subroutine copy_lptnc_mpsc

LPTNOps_f90.copy_qlptn_qmps()

fortran-subroutine - September 2017 (dj) Copy an MPS wave function Psi to a LPTN density matrix Rho.

Arguments

RhoTYPE(qlptn), inout

Copy MPS into this LPTN.

PsiTYPE(qmps), in

MPS to be converted to an LPTN

scalarREAL, OPTIONAL, in

Scale Rho by a factor.

Source Code

show / hide f90 code

  subroutine copy_qlptn_qmps(Rho, Psi, scalar, errst)
      type(qlptn), intent(inout) :: Rho
      type(qmps), intent(in) :: Psi
      real(KIND=rKind), intent(in), optional :: scalar
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      Rho%ll = Psi%ll
      Rho%oc = Psi%oc

      allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
               Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))

      Rho%can = Psi%can
      Rho%haslambda = Psi%haslambda

      do ii = 1, Psi%ll
          call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
          !if(prop_error('copy_qlptn_qmps : copy '//&
          !              '(1) failed.', errst=errst)) return

          call add_dummylink(Rho%Aa(ii), 3, errst=errst)
          !if(prop_error('copy_qlptn_qmps : add_dummylink '//&
          !              'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
      end do

      do ii = 1, (Psi%ll + 1)
          if(Psi%haslambda(ii)) then
              call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
              !if(prop_error('copy_qlptn_qmps : copy '//&
              !              '(2) failed.', errst=errst)) return
          end if
      end do

      if(present(scalar)) then
          ! Could be more efficient inside loop
          call scale(scalar, Rho)
      end if

  end subroutine copy_qlptn_qmps

LPTNOps_f90.copy_qlptnc_qmps()

fortran-subroutine - September 2017 (dj) Copy an MPS wave function Psi to a LPTN density matrix Rho.

Arguments

RhoTYPE(qlptnc), inout

Copy MPS into this LPTN.

PsiTYPE(qmps), in

MPS to be converted to an LPTN

scalarREAL, OPTIONAL, in

Scale Rho by a factor.

Source Code

show / hide f90 code

  subroutine copy_qlptnc_qmps(Rho, Psi, scalar, errst)
      type(qlptnc), intent(inout) :: Rho
      type(qmps), intent(in) :: Psi
      real(KIND=rKind), intent(in), optional :: scalar
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      Rho%ll = Psi%ll
      Rho%oc = Psi%oc

      allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
               Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))

      Rho%can = Psi%can
      Rho%haslambda = Psi%haslambda

      do ii = 1, Psi%ll
          call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
          !if(prop_error('copy_qlptnc_qmps : copy '//&
          !              '(1) failed.', errst=errst)) return

          call add_dummylink(Rho%Aa(ii), 3, errst=errst)
          !if(prop_error('copy_qlptnc_qmps : add_dummylink '//&
          !              'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
      end do

      do ii = 1, (Psi%ll + 1)
          if(Psi%haslambda(ii)) then
              call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
              !if(prop_error('copy_qlptnc_qmps : copy '//&
              !              '(2) failed.', errst=errst)) return
          end if
      end do

      if(present(scalar)) then
          ! Could be more efficient inside loop
          call scale(scalar, Rho)
      end if

  end subroutine copy_qlptnc_qmps

LPTNOps_f90.copy_qlptnc_qmpsc()

fortran-subroutine - September 2017 (dj) Copy an MPS wave function Psi to a LPTN density matrix Rho.

Arguments

RhoTYPE(qlptnc), inout

Copy MPS into this LPTN.

PsiTYPE(qmpsc), in

MPS to be converted to an LPTN

scalarREAL, OPTIONAL, in

Scale Rho by a factor.

Source Code

show / hide f90 code

  subroutine copy_qlptnc_qmpsc(Rho, Psi, scalar, errst)
      type(qlptnc), intent(inout) :: Rho
      type(qmpsc), intent(in) :: Psi
      real(KIND=rKind), intent(in), optional :: scalar
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      Rho%ll = Psi%ll
      Rho%oc = Psi%oc

      allocate(Rho%AA(Rho%ll), Rho%haslambda(Rho%ll + 1), &
               Rho%Lambda(Rho%ll + 1), Rho%can(Rho%ll))

      Rho%can = Psi%can
      Rho%haslambda = Psi%haslambda

      do ii = 1, Psi%ll
          call copy(Rho%Aa(ii), Psi%Aa(ii), errst=errst)
          !if(prop_error('copy_qlptnc_qmpsc : copy '//&
          !              '(1) failed.', errst=errst)) return

          call add_dummylink(Rho%Aa(ii), 3, errst=errst)
          !if(prop_error('copy_qlptnc_qmpsc : add_dummylink '//&
          !              'failed.', 'LPTNOps_include.f90:578', errst=errst)) return
      end do

      do ii = 1, (Psi%ll + 1)
          if(Psi%haslambda(ii)) then
              call copy(Rho%Lambda(ii), Psi%Lambda(ii), errst=errst)
              !if(prop_error('copy_qlptnc_qmpsc : copy '//&
              !              '(2) failed.', errst=errst)) return
          end if
      end do

      if(present(scalar)) then
          ! Could be more efficient inside loop
          call scale(scalar, Rho)
      end if

  end subroutine copy_qlptnc_qmpsc

LPTNOps_f90.corr_init_lptn_tensor_tensor()

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

Arguments

TenskkTYPE(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_lptn_tensor_tensor(Tenskk, Theta, Op, errst)
      type(tensor), intent(inout) :: Tenskk
      type(tensor), intent(out) :: Theta
      type(tensor), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensor) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

  end subroutine corr_init_lptn_tensor_tensor

LPTNOps_f90.corr_init_lptn_tensorc_tensor()

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

Arguments

TenskkTYPE(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_lptn_tensorc_tensor(Tenskk, Theta, Op, errst)
      type(tensorc), intent(inout) :: Tenskk
      type(tensorc), intent(out) :: Theta
      type(tensor), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

  end subroutine corr_init_lptn_tensorc_tensor

LPTNOps_f90.corr_init_lptn_tensorc_tensorc()

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

Arguments

TenskkTYPE(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_lptn_tensorc_tensorc(Tenskk, Theta, Op, errst)
      type(tensorc), intent(inout) :: Tenskk
      type(tensorc), intent(out) :: Theta
      type(tensorc), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

  end subroutine corr_init_lptn_tensorc_tensorc

LPTNOps_f90.corr_init_lptn_qtensor_qtensor()

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

Arguments

TenskkTYPE(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_lptn_qtensor_qtensor(Tenskk, Theta, Op, errst)
      type(qtensor), intent(inout) :: Tenskk
      type(qtensor), intent(out) :: Theta
      type(qtensor), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensor) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

  end subroutine corr_init_lptn_qtensor_qtensor

LPTNOps_f90.corr_init_lptn_qtensorc_qtensor()

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

Arguments

TenskkTYPE(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_lptn_qtensorc_qtensor(Tenskk, Theta, Op, errst)
      type(qtensorc), intent(inout) :: Tenskk
      type(qtensorc), intent(out) :: Theta
      type(qtensor), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

  end subroutine corr_init_lptn_qtensorc_qtensor

LPTNOps_f90.corr_init_lptn_qtensorc_qtensorc()

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

Arguments

TenskkTYPE(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_lptn_qtensorc_qtensorc(Tenskk, Theta, Op, errst)
      type(qtensorc), intent(inout) :: Tenskk
      type(qtensorc), intent(out) :: Theta
      type(qtensorc), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

  end subroutine corr_init_lptn_qtensorc_qtensorc

LPTNOps_f90.corr_init_l_lptn_tensor_tensor()

fortran-subroutine - September 2017 (dj) Calculate the correlation with a left-moving contraction. This is the initialization.

Arguments

TenskkTYPE(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_lptn_tensor_tensor(Tenskk, Theta, Op, errst)
      type(tensor), intent(inout) :: Tenskk
      type(tensor), intent(out) :: Theta
      type(tensor), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensor) :: Tmpa, Tmpb

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

  end subroutine corr_init_l_lptn_tensor_tensor

LPTNOps_f90.corr_init_l_lptn_tensorc_tensor()

fortran-subroutine - September 2017 (dj) Calculate the correlation with a left-moving contraction. This is the initialization.

Arguments

TenskkTYPE(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_lptn_tensorc_tensor(Tenskk, Theta, Op, errst)
      type(tensorc), intent(inout) :: Tenskk
      type(tensorc), intent(out) :: Theta
      type(tensor), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

  end subroutine corr_init_l_lptn_tensorc_tensor

LPTNOps_f90.corr_init_l_lptn_tensorc_tensorc()

fortran-subroutine - September 2017 (dj) Calculate the correlation with a left-moving contraction. This is the initialization.

Arguments

TenskkTYPE(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_lptn_tensorc_tensorc(Tenskk, Theta, Op, errst)
      type(tensorc), intent(inout) :: Tenskk
      type(tensorc), intent(out) :: Theta
      type(tensorc), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

  end subroutine corr_init_l_lptn_tensorc_tensorc

LPTNOps_f90.corr_init_l_lptn_qtensor_qtensor()

fortran-subroutine - September 2017 (dj) Calculate the correlation with a left-moving contraction. This is the initialization.

Arguments

TenskkTYPE(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_lptn_qtensor_qtensor(Tenskk, Theta, Op, errst)
      type(qtensor), intent(inout) :: Tenskk
      type(qtensor), intent(out) :: Theta
      type(qtensor), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensor) :: Tmpa, Tmpb

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

  end subroutine corr_init_l_lptn_qtensor_qtensor

LPTNOps_f90.corr_init_l_lptn_qtensorc_qtensor()

fortran-subroutine - September 2017 (dj) Calculate the correlation with a left-moving contraction. This is the initialization.

Arguments

TenskkTYPE(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_lptn_qtensorc_qtensor(Tenskk, Theta, Op, errst)
      type(qtensorc), intent(inout) :: Tenskk
      type(qtensorc), intent(out) :: Theta
      type(qtensor), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

  end subroutine corr_init_l_lptn_qtensorc_qtensor

LPTNOps_f90.corr_init_l_lptn_qtensorc_qtensorc()

fortran-subroutine - September 2017 (dj) Calculate the correlation with a left-moving contraction. This is the initialization.

Arguments

TenskkTYPE(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_lptn_qtensorc_qtensorc(Tenskk, Theta, Op, errst)
      type(qtensorc), intent(inout) :: Tenskk
      type(qtensorc), intent(out) :: Theta
      type(qtensorc), intent(inout) :: Op
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')

      ! First index |ket>, second <bra|
      call contr(Theta, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

  end subroutine corr_init_l_lptn_qtensorc_qtensorc

LPTNOps_f90.corr_meas_lptn_tensor_tensor()

fortran-subroutine - September 2017 (dj) Measure correlation and propagate. Right-moving version.

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_tensor_tensor(vals, Tenskk, kk, ll, &
       Theta, Op, PhaseOp, hasphase, errst)
      real(KIND=rKIND), intent(out) :: vals
      type(tensor), intent(inout) :: Tenskk
      integer, intent(in) :: kk, ll
      type(tensor), intent(inout) :: Theta
      type(tensor), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensor) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j,k with j < k
      ! ---------------------------------------

      ! Need copy, Tenskk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)

      call destroy(Tmpb)
      call destroy(Tmpa)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
          call destroy(Tmpb)
      elseif(kk < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - this was the last site
          call destroy(Theta)
      end if

  end subroutine corr_meas_lptn_tensor_tensor

LPTNOps_f90.corr_meas_lptn_tensorc_tensor()

fortran-subroutine - September 2017 (dj) Measure correlation and propagate. Right-moving version.

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_tensorc_tensor(vals, Tenskk, kk, ll, &
       Theta, Op, PhaseOp, hasphase, errst)
      complex(KIND=rKIND), intent(out) :: vals
      type(tensorc), intent(inout) :: Tenskk
      integer, intent(in) :: kk, ll
      type(tensorc), intent(inout) :: Theta
      type(tensor), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j,k with j < k
      ! ---------------------------------------

      ! Need copy, Tenskk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)

      call destroy(Tmpb)
      call destroy(Tmpa)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
          call destroy(Tmpb)
      elseif(kk < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - this was the last site
          call destroy(Theta)
      end if

  end subroutine corr_meas_lptn_tensorc_tensor

LPTNOps_f90.corr_meas_lptn_tensorc_tensorc()

fortran-subroutine - September 2017 (dj) Measure correlation and propagate. Right-moving version.

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_tensorc_tensorc(vals, Tenskk, kk, ll, &
       Theta, Op, PhaseOp, hasphase, errst)
      complex(KIND=rKIND), intent(out) :: vals
      type(tensorc), intent(inout) :: Tenskk
      integer, intent(in) :: kk, ll
      type(tensorc), intent(inout) :: Theta
      type(tensorc), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j,k with j < k
      ! ---------------------------------------

      ! Need copy, Tenskk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)

      call destroy(Tmpb)
      call destroy(Tmpa)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
          call destroy(Tmpb)
      elseif(kk < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - this was the last site
          call destroy(Theta)
      end if

  end subroutine corr_meas_lptn_tensorc_tensorc

LPTNOps_f90.corr_meas_lptn_qtensor_qtensor()

fortran-subroutine - September 2017 (dj) Measure correlation and propagate. Right-moving version.

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_qtensor_qtensor(vals, Tenskk, kk, ll, &
       Theta, Op, PhaseOp, hasphase, errst)
      real(KIND=rKIND), intent(out) :: vals
      type(qtensor), intent(inout) :: Tenskk
      integer, intent(in) :: kk, ll
      type(qtensor), intent(inout) :: Theta
      type(qtensor), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensor) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j,k with j < k
      ! ---------------------------------------

      ! Need copy, Tenskk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)

      call destroy(Tmpb)
      call destroy(Tmpa)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
          call destroy(Tmpb)
      elseif(kk < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - this was the last site
          call destroy(Theta)
      end if

  end subroutine corr_meas_lptn_qtensor_qtensor

LPTNOps_f90.corr_meas_lptn_qtensorc_qtensor()

fortran-subroutine - September 2017 (dj) Measure correlation and propagate. Right-moving version.

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_qtensorc_qtensor(vals, Tenskk, kk, ll, &
       Theta, Op, PhaseOp, hasphase, errst)
      complex(KIND=rKIND), intent(out) :: vals
      type(qtensorc), intent(inout) :: Tenskk
      integer, intent(in) :: kk, ll
      type(qtensorc), intent(inout) :: Theta
      type(qtensor), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j,k with j < k
      ! ---------------------------------------

      ! Need copy, Tenskk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)

      call destroy(Tmpb)
      call destroy(Tmpa)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
          call destroy(Tmpb)
      elseif(kk < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - this was the last site
          call destroy(Theta)
      end if

  end subroutine corr_meas_lptn_qtensorc_qtensor

LPTNOps_f90.corr_meas_lptn_qtensorc_qtensorc()

fortran-subroutine - September 2017 (dj) Measure correlation and propagate. Right-moving version.

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_qtensorc_qtensorc(vals, Tenskk, kk, ll, &
       Theta, Op, PhaseOp, hasphase, errst)
      complex(KIND=rKIND), intent(out) :: vals
      type(qtensorc), intent(inout) :: Tenskk
      integer, intent(in) :: kk, ll
      type(qtensorc), intent(inout) :: Theta
      type(qtensorc), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j,k with j < k
      ! ---------------------------------------

      ! Need copy, Tenskk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [2, 3, 4], [4, 2, 3])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)

      call destroy(Tmpb)
      call destroy(Tmpa)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [1, 4, 2], [1, 2, 3], transr='C')
          call destroy(Tmpb)
      elseif(kk < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tenskk, [1], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [1, 2, 3], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - this was the last site
          call destroy(Theta)
      end if

  end subroutine corr_meas_lptn_qtensorc_qtensorc

LPTNOps_f90.corr_meas_l_lptn_tensor_tensor()

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

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_tensor_tensor(vals, Tenskk, kk, &
       Theta, Op, PhaseOp, hasphase, errst)
      real(KIND=RKind), intent(out) :: vals
      type(tensor), intent(inout) :: Tenskk
      integer, intent(in) :: kk
      type(tensor), intent(inout) :: Theta
      type(tensor), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensor) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j, k with k < j
      ! ----------------------------------------

      ! Need copy, Psikk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)
      call destroy(Tmpa)
      call destroy(Tmpb)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk > 1) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
          call destroy(Tmpb)

      elseif(kk > 1) then
          ! No phase
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - last call
          call destroy(Theta)
      end if

  end subroutine corr_meas_l_lptn_tensor_tensor

LPTNOps_f90.corr_meas_l_lptn_tensorc_tensor()

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

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_tensorc_tensor(vals, Tenskk, kk, &
       Theta, Op, PhaseOp, hasphase, errst)
      complex(KIND=RKind), intent(out) :: vals
      type(tensorc), intent(inout) :: Tenskk
      integer, intent(in) :: kk
      type(tensorc), intent(inout) :: Theta
      type(tensor), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j, k with k < j
      ! ----------------------------------------

      ! Need copy, Psikk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)
      call destroy(Tmpa)
      call destroy(Tmpb)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk > 1) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
          call destroy(Tmpb)

      elseif(kk > 1) then
          ! No phase
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - last call
          call destroy(Theta)
      end if

  end subroutine corr_meas_l_lptn_tensorc_tensor

LPTNOps_f90.corr_meas_l_lptn_tensorc_tensorc()

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

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_tensorc_tensorc(vals, Tenskk, kk, &
       Theta, Op, PhaseOp, hasphase, errst)
      complex(KIND=RKind), intent(out) :: vals
      type(tensorc), intent(inout) :: Tenskk
      integer, intent(in) :: kk
      type(tensorc), intent(inout) :: Theta
      type(tensorc), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j, k with k < j
      ! ----------------------------------------

      ! Need copy, Psikk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)
      call destroy(Tmpa)
      call destroy(Tmpb)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk > 1) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
          call destroy(Tmpb)

      elseif(kk > 1) then
          ! No phase
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - last call
          call destroy(Theta)
      end if

  end subroutine corr_meas_l_lptn_tensorc_tensorc

LPTNOps_f90.corr_meas_l_lptn_qtensor_qtensor()

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

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_qtensor_qtensor(vals, Tenskk, kk, &
       Theta, Op, PhaseOp, hasphase, errst)
      real(KIND=RKind), intent(out) :: vals
      type(qtensor), intent(inout) :: Tenskk
      integer, intent(in) :: kk
      type(qtensor), intent(inout) :: Theta
      type(qtensor), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensor) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j, k with k < j
      ! ----------------------------------------

      ! Need copy, Psikk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)
      call destroy(Tmpa)
      call destroy(Tmpb)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk > 1) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
          call destroy(Tmpb)

      elseif(kk > 1) then
          ! No phase
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - last call
          call destroy(Theta)
      end if

  end subroutine corr_meas_l_lptn_qtensor_qtensor

LPTNOps_f90.corr_meas_l_lptn_qtensorc_qtensor()

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

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_qtensorc_qtensor(vals, Tenskk, kk, &
       Theta, Op, PhaseOp, hasphase, errst)
      complex(KIND=RKind), intent(out) :: vals
      type(qtensorc), intent(inout) :: Tenskk
      integer, intent(in) :: kk
      type(qtensorc), intent(inout) :: Theta
      type(qtensor), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j, k with k < j
      ! ----------------------------------------

      ! Need copy, Psikk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)
      call destroy(Tmpa)
      call destroy(Tmpb)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk > 1) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
          call destroy(Tmpb)

      elseif(kk > 1) then
          ! No phase
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - last call
          call destroy(Theta)
      end if

  end subroutine corr_meas_l_lptn_qtensorc_qtensor

LPTNOps_f90.corr_meas_l_lptn_qtensorc_qtensorc()

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

Arguments

valsREAL, out

Outcome of the correlation measurement.

TenskkTYPE(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_lptn_qtensorc_qtensorc(vals, Tenskk, kk, &
       Theta, Op, PhaseOp, hasphase, errst)
      complex(KIND=RKind), intent(out) :: vals
      type(qtensorc), intent(inout) :: Tenskk
      integer, intent(in) :: kk
      type(qtensorc), intent(inout) :: Theta
      type(qtensorc), intent(inout) :: Op, PhaseOp
      logical, intent(in) :: hasphase
      integer, intent(out), optional :: errst

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

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! 1) Calculate correlation j, k with k < j
      ! ----------------------------------------

      ! Need copy, Psikk will be permuted
      call copy(Tmpa, Tenskk)
      call contr(Tmpb, Tmpa, Op, [2], [1], transl='C')
      call destroy(Tmpa)

      call contr(Tmpa, Tenskk, Tmpb, [1, 2, 3], [1, 4, 2])
      call destroy(Tmpb)

      call contr(Tmpb, Theta, Tmpa, [1, 2], [1, 2])
      vals = get_scalar(Tmpb)
      call destroy(Tmpa)
      call destroy(Tmpb)

      ! 2) Propagate for the next site
      ! ------------------------------

      if((kk > 1) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Tmpb, Tmpa, PhaseOp, [2], [2])
          call destroy(Tmpa)

          call contr(Theta, Tmpb, Tenskk, [4, 2, 3], [2, 3, 4], transr='C')
          call destroy(Tmpb)

      elseif(kk > 1) then
          ! No phase
          call contr(Tmpa, Tenskk, Theta, [4], [1])
          call destroy(Theta)

          call contr(Theta, Tmpa, Tenskk, [2, 3, 4], [2, 3, 4], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy - last call
          call destroy(Theta)
      end if

  end subroutine corr_meas_l_lptn_qtensorc_qtensorc

LPTNOps_f90.create_lptn()

fortran-subroutine - December 2014 (dj) Initialize LPTN

Arguments

RhoTYPE(lptn), out

LPTN to be initialized

llINTEGER, in

number of sites in the system

fillCHARACTER, in

‘N’ : allocate, but do not initialize ‘Z’ : fill with zeros ‘O’ : fill with ones ‘I’ : start with the identity / maximally mixed state (chi and kappa not necessary) ‘R’ : random numbers

ddINTEGER(*), in

dimension of the local Hilbert space SIZE(dd) = 1 : all sites have the same size SIZE(dd) = ll: site dependent local Hilbert space

chiINTEGER(*), OPTIONAL, in

dimension of the bond dimension to nearest neighbor SIZE(chi) = 1 : all sites have the same bond dimension boundary effects are considered SIZE(chi) = ll - 1: site dependent bond dimension, boundary effects have to be considered in the array.

kappaINTEGER(*), OPTIONAL, in

dimension of the kraus link to complex conjugated tensor SIZE(kappa) = 1 : all sites have the same bond dimension SIZE(kappa) = ll: site dependent Kraus dimension

Source Code

show / hide f90 code

  subroutine create_lptn(Rho, ll, fill, dd, chi, kappa)
      type(lptn), intent(out) :: Rho
      integer, intent(in) :: ll
      character, intent(in) :: fill
      integer, dimension(:), intent(in) :: dd
      integer, dimension(:), intent(in), optional ::chi, kappa

      ! for looping
      integer :: ii, jj, kk

      ! arrays with the dimensions used
      integer, dimension(ll) :: dd_, kappa_
      integer, dimension(ll+1) :: chi_

      Rho%ll = ll

      allocate(Rho%AA(ll), Rho%haslambda(ll + 1), Rho%Lambda(ll + 1), &
               Rho%can(ll))

      ! To-do: set haslambda, Lambda, oc, can in most cases
      ! To-do: set boundary effects for chi

      ! Fill the arrays with the dimensions
      ! ===================================

      if(size(dd) == 1) then
          dd_ = dd(1)
      else
          dd_ = dd
      end if

      if(present(chi)) then
          if(size(chi) == 1) then
              chi_ = chi(1)
          else
              chi_(1) = 1
              chi_(2:ll) = chi
              chi_(ll + 1) = 1
          end if
      else
          chi_ = 1
      end if

      if(present(kappa)) then
         if(size(kappa) == 1) then
             kappa_ = kappa(1)
         else
             kappa_ = kappa
         end if
      else
          kappa_ = 1
      end if

      ! Fill the tensors
      ! ================

      if(fill == 'N') then
          ! Only allocate, but do not initialize
          ! ------------------------------------

          do ii = 1, ll
              call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
                       chi_(ii + 1)])
          end do

          Rho%oc = -1
          Rho%can = 'n'
          Rho%haslambda = .false.

      elseif(fill == 'Z') then
          ! Fill the LPTN with zeros
          ! ------------------------

          do ii = 1, ll
              call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
                          chi_(ii + 1)], init='0')
          end do

          Rho%oc = -1
          Rho%can = 'n'
          Rho%haslambda = .false.

      elseif(fill == 'I') then
          ! Identity / maximally mixed state
          ! --------------------------------

          ! all other sites
          do ii = 1, ll
              call create(Rho%AA(ii), [1, dd_(ii), dd_(ii), 1])

              kk = 1
              do jj = 1, dd_(ii)
                  Rho%AA(ii)%elem(kk) = sqrt(1.0_rKind / dd_(ii))
                  kk = kk + dd_(ii) + 1
              end do
          end do

          ! Set canonization
          Rho%oc = 1
          Rho%can = 'r'
          Rho%can(1) = 'c'
          Rho%haslambda = .false.

          ! Set Schmidt values
          do ii = 2, ll
              allocate(Rho%Lambda(ii)%elem(1))
              Rho%Lambda(ii)%elem(1) = 1.0_rKind
              Rho%haslambda(ii) = .true.
          end do

      elseif(fill == 'O') then
          ! Fill the LPTN with ones
          ! ------------------------

          stop 'Init_LPTNc: ones not implemented.'

      elseif(fill == 'R') then
          ! Fill with Random numbers
          ! ------------------------

          do ii = 1, ll
              call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
                                       chi_(ii + 1)], init='R')
          end do

          ! Set canonization
          Rho%oc = 1
          Rho%can = 'r'
          Rho%can(1) = 'c'
          Rho%haslambda = .false.

          ! And canonize it
          call canonize(Rho, 1)

      else
          stop 'Init_LPTNc: bad argument for fill'
      end if

  end subroutine create_lptn

LPTNOps_f90.create_lptnc()

fortran-subroutine - December 2014 (dj) Initialize LPTN

Arguments

RhoTYPE(lptnc), out

LPTN to be initialized

llINTEGER, in

number of sites in the system

fillCHARACTER, in

‘N’ : allocate, but do not initialize ‘Z’ : fill with zeros ‘O’ : fill with ones ‘I’ : start with the identity / maximally mixed state (chi and kappa not necessary) ‘R’ : random numbers

ddINTEGER(*), in

dimension of the local Hilbert space SIZE(dd) = 1 : all sites have the same size SIZE(dd) = ll: site dependent local Hilbert space

chiINTEGER(*), OPTIONAL, in

dimension of the bond dimension to nearest neighbor SIZE(chi) = 1 : all sites have the same bond dimension boundary effects are considered SIZE(chi) = ll - 1: site dependent bond dimension, boundary effects have to be considered in the array.

kappaINTEGER(*), OPTIONAL, in

dimension of the kraus link to complex conjugated tensor SIZE(kappa) = 1 : all sites have the same bond dimension SIZE(kappa) = ll: site dependent Kraus dimension

Source Code

show / hide f90 code

  subroutine create_lptnc(Rho, ll, fill, dd, chi, kappa)
      type(lptnc), intent(out) :: Rho
      integer, intent(in) :: ll
      character, intent(in) :: fill
      integer, dimension(:), intent(in) :: dd
      integer, dimension(:), intent(in), optional ::chi, kappa

      ! for looping
      integer :: ii, jj, kk

      ! arrays with the dimensions used
      integer, dimension(ll) :: dd_, kappa_
      integer, dimension(ll+1) :: chi_

      Rho%ll = ll

      allocate(Rho%AA(ll), Rho%haslambda(ll + 1), Rho%Lambda(ll + 1), &
               Rho%can(ll))

      ! To-do: set haslambda, Lambda, oc, can in most cases
      ! To-do: set boundary effects for chi

      ! Fill the arrays with the dimensions
      ! ===================================

      if(size(dd) == 1) then
          dd_ = dd(1)
      else
          dd_ = dd
      end if

      if(present(chi)) then
          if(size(chi) == 1) then
              chi_ = chi(1)
          else
              chi_(1) = 1
              chi_(2:ll) = chi
              chi_(ll + 1) = 1
          end if
      else
          chi_ = 1
      end if

      if(present(kappa)) then
         if(size(kappa) == 1) then
             kappa_ = kappa(1)
         else
             kappa_ = kappa
         end if
      else
          kappa_ = 1
      end if

      ! Fill the tensors
      ! ================

      if(fill == 'N') then
          ! Only allocate, but do not initialize
          ! ------------------------------------

          do ii = 1, ll
              call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
                       chi_(ii + 1)])
          end do

          Rho%oc = -1
          Rho%can = 'n'
          Rho%haslambda = .false.

      elseif(fill == 'Z') then
          ! Fill the LPTN with zeros
          ! ------------------------

          do ii = 1, ll
              call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
                          chi_(ii + 1)], init='0')
          end do

          Rho%oc = -1
          Rho%can = 'n'
          Rho%haslambda = .false.

      elseif(fill == 'I') then
          ! Identity / maximally mixed state
          ! --------------------------------

          ! all other sites
          do ii = 1, ll
              call create(Rho%AA(ii), [1, dd_(ii), dd_(ii), 1])

              kk = 1
              do jj = 1, dd_(ii)
                  Rho%AA(ii)%elem(kk) = sqrt(1.0_rKind / dd_(ii))
                  kk = kk + dd_(ii) + 1
              end do
          end do

          ! Set canonization
          Rho%oc = 1
          Rho%can = 'r'
          Rho%can(1) = 'c'
          Rho%haslambda = .false.

          ! Set Schmidt values
          do ii = 2, ll
              allocate(Rho%Lambda(ii)%elem(1))
              Rho%Lambda(ii)%elem(1) = 1.0_rKind
              Rho%haslambda(ii) = .true.
          end do

      elseif(fill == 'O') then
          ! Fill the LPTN with ones
          ! ------------------------

          stop 'Init_LPTNc: ones not implemented.'

      elseif(fill == 'R') then
          ! Fill with Random numbers
          ! ------------------------

          do ii = 1, ll
              call create(Rho%AA(ii), [chi_(ii), dd_(ii), kappa_(ii), &
                                       chi_(ii + 1)], init='R')
          end do

          ! Set canonization
          Rho%oc = 1
          Rho%can = 'r'
          Rho%can(1) = 'c'
          Rho%haslambda = .false.

          ! And canonize it
          call canonize(Rho, 1)

      else
          stop 'Init_LPTNc: bad argument for fill'
      end if

  end subroutine create_lptnc

LPTNOps_f90.destroy_lptn()

fortran-subroutine - September 2017 (dj, updated) Deallocate a LPTN

Arguments

RhoTYPE(lptn), inout

deallocate the LPTN

Source Code

show / hide f90 code

  subroutine destroy_lptn(Rho)
      type(lptn), intent(inout) :: Rho

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

      ! for looping
      integer :: ii

      do ii = 1, Rho%ll
          call destroy(Rho%AA(ii))

          if(Rho%haslambda(ii)) then
              call destroy(Rho%Lambda(ii))
          end if
      end do

      if(Rho%haslambda(Rho%ll + 1)) then
          call destroy(Rho%Lambda(Rho%ll + 1))
      end if

      deallocate(Rho%haslambda, Rho%Lambda, Rho%can, Rho%AA)

      Rho%ll = -1

  end subroutine destroy_lptn

LPTNOps_f90.destroy_lptnc()

fortran-subroutine - September 2017 (dj, updated) Deallocate a LPTN

Arguments

RhoTYPE(lptnc), inout

deallocate the LPTN

Source Code

show / hide f90 code

  subroutine destroy_lptnc(Rho)
      type(lptnc), intent(inout) :: Rho

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

      ! for looping
      integer :: ii

      do ii = 1, Rho%ll
          call destroy(Rho%AA(ii))

          if(Rho%haslambda(ii)) then
              call destroy(Rho%Lambda(ii))
          end if
      end do

      if(Rho%haslambda(Rho%ll + 1)) then
          call destroy(Rho%Lambda(Rho%ll + 1))
      end if

      deallocate(Rho%haslambda, Rho%Lambda, Rho%can, Rho%AA)

      Rho%ll = -1

  end subroutine destroy_lptnc

LPTNOps_f90.destroy_qlptn()

fortran-subroutine - September 2017 (dj, updated) Deallocate a LPTN

Arguments

RhoTYPE(qlptn), inout

deallocate the LPTN

Source Code

show / hide f90 code

  subroutine destroy_qlptn(Rho)
      type(qlptn), intent(inout) :: Rho

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

      ! for looping
      integer :: ii

      do ii = 1, Rho%ll
          call destroy(Rho%AA(ii))

          if(Rho%haslambda(ii)) then
              call destroy(Rho%Lambda(ii))
          end if
      end do

      if(Rho%haslambda(Rho%ll + 1)) then
          call destroy(Rho%Lambda(Rho%ll + 1))
      end if

      deallocate(Rho%haslambda, Rho%Lambda, Rho%can, Rho%AA)

      Rho%ll = -1

  end subroutine destroy_qlptn

LPTNOps_f90.destroy_qlptnc()

fortran-subroutine - September 2017 (dj, updated) Deallocate a LPTN

Arguments

RhoTYPE(qlptnc), inout

deallocate the LPTN

Source Code

show / hide f90 code

  subroutine destroy_qlptnc(Rho)
      type(qlptnc), intent(inout) :: Rho

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

      ! for looping
      integer :: ii

      do ii = 1, Rho%ll
          call destroy(Rho%AA(ii))

          if(Rho%haslambda(ii)) then
              call destroy(Rho%Lambda(ii))
          end if
      end do

      if(Rho%haslambda(Rho%ll + 1)) then
          call destroy(Rho%Lambda(Rho%ll + 1))
      end if

      deallocate(Rho%haslambda, Rho%Lambda, Rho%can, Rho%AA)

      Rho%ll = -1

  end subroutine destroy_qlptnc

LPTNOps_f90.distance_lptn_mps()

fortran-function - September 2017 (dj) Measure the distance between an LPTN and an MPS.

Arguments

RhoTYPE(lptn), in

Density matrix for distance measure.

PsiTYPE(mps), in

Pure state in the distance measure.

dist_typeCHARACTER, OPTIONAL, in

Specify the distance to be calculated. Only option right now is ‘F’ (fidelity, default).

Source Code

show / hide f90 code

  function distance_lptn_mps(Rho, Psi, dist_type, &
                                       errst) result(dist)
      type(lptn), intent(in) :: Rho
      type(mps), intent(in) :: Psi
      character, intent(in), optional :: dist_type
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: dist

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

      ! duplette for optional argument
      character :: dtype

      !if(present(errst)) errst = 0

      dtype = 'F'
      if(present(dist_type)) dtype = dist_type

      if(dtype == 'F') then
          dist = fidelity(Rho, Psi, errst=errst)
          !if(prop_error('distance_lptn_mps : fidelity '//&
          !              'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
      else
          errst = raise_error('distance_lptn_mps : unkown '//&
                              'dist_type', 99, errst=errst)
      end if

  end function distance_lptn_mps

LPTNOps_f90.distance_lptn_mpsc()

fortran-function - September 2017 (dj) Measure the distance between an LPTN and an MPS.

Arguments

RhoTYPE(lptn), in

Density matrix for distance measure.

PsiTYPE(mpsc), in

Pure state in the distance measure.

dist_typeCHARACTER, OPTIONAL, in

Specify the distance to be calculated. Only option right now is ‘F’ (fidelity, default).

Source Code

show / hide f90 code

  function distance_lptn_mpsc(Rho, Psi, dist_type, &
                                       errst) result(dist)
      type(lptn), intent(in) :: Rho
      type(mpsc), intent(in) :: Psi
      character, intent(in), optional :: dist_type
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: dist

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

      ! duplette for optional argument
      character :: dtype

      !if(present(errst)) errst = 0

      dtype = 'F'
      if(present(dist_type)) dtype = dist_type

      if(dtype == 'F') then
          dist = fidelity(Rho, Psi, errst=errst)
          !if(prop_error('distance_lptn_mpsc : fidelity '//&
          !              'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
      else
          errst = raise_error('distance_lptn_mpsc : unkown '//&
                              'dist_type', 99, errst=errst)
      end if

  end function distance_lptn_mpsc

LPTNOps_f90.distance_lptnc_mps()

fortran-function - September 2017 (dj) Measure the distance between an LPTN and an MPS.

Arguments

RhoTYPE(lptnc), in

Density matrix for distance measure.

PsiTYPE(mps), in

Pure state in the distance measure.

dist_typeCHARACTER, OPTIONAL, in

Specify the distance to be calculated. Only option right now is ‘F’ (fidelity, default).

Source Code

show / hide f90 code

  function distance_lptnc_mps(Rho, Psi, dist_type, &
                                       errst) result(dist)
      type(lptnc), intent(in) :: Rho
      type(mps), intent(in) :: Psi
      character, intent(in), optional :: dist_type
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: dist

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

      ! duplette for optional argument
      character :: dtype

      !if(present(errst)) errst = 0

      dtype = 'F'
      if(present(dist_type)) dtype = dist_type

      if(dtype == 'F') then
          dist = fidelity(Rho, Psi, errst=errst)
          !if(prop_error('distance_lptnc_mps : fidelity '//&
          !              'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
      else
          errst = raise_error('distance_lptnc_mps : unkown '//&
                              'dist_type', 99, errst=errst)
      end if

  end function distance_lptnc_mps

LPTNOps_f90.distance_lptnc_mpsc()

fortran-function - September 2017 (dj) Measure the distance between an LPTN and an MPS.

Arguments

RhoTYPE(lptnc), in

Density matrix for distance measure.

PsiTYPE(mpsc), in

Pure state in the distance measure.

dist_typeCHARACTER, OPTIONAL, in

Specify the distance to be calculated. Only option right now is ‘F’ (fidelity, default).

Source Code

show / hide f90 code

  function distance_lptnc_mpsc(Rho, Psi, dist_type, &
                                       errst) result(dist)
      type(lptnc), intent(in) :: Rho
      type(mpsc), intent(in) :: Psi
      character, intent(in), optional :: dist_type
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: dist

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

      ! duplette for optional argument
      character :: dtype

      !if(present(errst)) errst = 0

      dtype = 'F'
      if(present(dist_type)) dtype = dist_type

      if(dtype == 'F') then
          dist = fidelity(Rho, Psi, errst=errst)
          !if(prop_error('distance_lptnc_mpsc : fidelity '//&
          !              'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
      else
          errst = raise_error('distance_lptnc_mpsc : unkown '//&
                              'dist_type', 99, errst=errst)
      end if

  end function distance_lptnc_mpsc

LPTNOps_f90.distance_qlptn_qmps()

fortran-function - September 2017 (dj) Measure the distance between an LPTN and an MPS.

Arguments

RhoTYPE(qlptn), in

Density matrix for distance measure.

PsiTYPE(qmps), in

Pure state in the distance measure.

dist_typeCHARACTER, OPTIONAL, in

Specify the distance to be calculated. Only option right now is ‘F’ (fidelity, default).

Source Code

show / hide f90 code

  function distance_qlptn_qmps(Rho, Psi, dist_type, &
                                       errst) result(dist)
      type(qlptn), intent(in) :: Rho
      type(qmps), intent(in) :: Psi
      character, intent(in), optional :: dist_type
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: dist

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

      ! duplette for optional argument
      character :: dtype

      !if(present(errst)) errst = 0

      dtype = 'F'
      if(present(dist_type)) dtype = dist_type

      if(dtype == 'F') then
          dist = fidelity(Rho, Psi, errst=errst)
          !if(prop_error('distance_qlptn_qmps : fidelity '//&
          !              'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
      else
          errst = raise_error('distance_qlptn_qmps : unkown '//&
                              'dist_type', 99, errst=errst)
      end if

  end function distance_qlptn_qmps

LPTNOps_f90.distance_qlptn_qmpsc()

fortran-function - September 2017 (dj) Measure the distance between an LPTN and an MPS.

Arguments

RhoTYPE(qlptn), in

Density matrix for distance measure.

PsiTYPE(qmpsc), in

Pure state in the distance measure.

dist_typeCHARACTER, OPTIONAL, in

Specify the distance to be calculated. Only option right now is ‘F’ (fidelity, default).

Source Code

show / hide f90 code

  function distance_qlptn_qmpsc(Rho, Psi, dist_type, &
                                       errst) result(dist)
      type(qlptn), intent(in) :: Rho
      type(qmpsc), intent(in) :: Psi
      character, intent(in), optional :: dist_type
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: dist

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

      ! duplette for optional argument
      character :: dtype

      !if(present(errst)) errst = 0

      dtype = 'F'
      if(present(dist_type)) dtype = dist_type

      if(dtype == 'F') then
          dist = fidelity(Rho, Psi, errst=errst)
          !if(prop_error('distance_qlptn_qmpsc : fidelity '//&
          !              'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
      else
          errst = raise_error('distance_qlptn_qmpsc : unkown '//&
                              'dist_type', 99, errst=errst)
      end if

  end function distance_qlptn_qmpsc

LPTNOps_f90.distance_qlptnc_qmps()

fortran-function - September 2017 (dj) Measure the distance between an LPTN and an MPS.

Arguments

RhoTYPE(qlptnc), in

Density matrix for distance measure.

PsiTYPE(qmps), in

Pure state in the distance measure.

dist_typeCHARACTER, OPTIONAL, in

Specify the distance to be calculated. Only option right now is ‘F’ (fidelity, default).

Source Code

show / hide f90 code

  function distance_qlptnc_qmps(Rho, Psi, dist_type, &
                                       errst) result(dist)
      type(qlptnc), intent(in) :: Rho
      type(qmps), intent(in) :: Psi
      character, intent(in), optional :: dist_type
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: dist

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

      ! duplette for optional argument
      character :: dtype

      !if(present(errst)) errst = 0

      dtype = 'F'
      if(present(dist_type)) dtype = dist_type

      if(dtype == 'F') then
          dist = fidelity(Rho, Psi, errst=errst)
          !if(prop_error('distance_qlptnc_qmps : fidelity '//&
          !              'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
      else
          errst = raise_error('distance_qlptnc_qmps : unkown '//&
                              'dist_type', 99, errst=errst)
      end if

  end function distance_qlptnc_qmps

LPTNOps_f90.distance_qlptnc_qmpsc()

fortran-function - September 2017 (dj) Measure the distance between an LPTN and an MPS.

Arguments

RhoTYPE(qlptnc), in

Density matrix for distance measure.

PsiTYPE(qmpsc), in

Pure state in the distance measure.

dist_typeCHARACTER, OPTIONAL, in

Specify the distance to be calculated. Only option right now is ‘F’ (fidelity, default).

Source Code

show / hide f90 code

  function distance_qlptnc_qmpsc(Rho, Psi, dist_type, &
                                       errst) result(dist)
      type(qlptnc), intent(in) :: Rho
      type(qmpsc), intent(in) :: Psi
      character, intent(in), optional :: dist_type
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: dist

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

      ! duplette for optional argument
      character :: dtype

      !if(present(errst)) errst = 0

      dtype = 'F'
      if(present(dist_type)) dtype = dist_type

      if(dtype == 'F') then
          dist = fidelity(Rho, Psi, errst=errst)
          !if(prop_error('distance_qlptnc_qmpsc : fidelity '//&
          !              'failed.', 'LPTNOps_include.f90:1264', errst=errst)) return
      else
          errst = raise_error('distance_qlptnc_qmpsc : unkown '//&
                              'dist_type', 99, errst=errst)
      end if

  end function distance_qlptnc_qmpsc

LPTNOps_f90.fidelity_lptn_mps()

fortran-function - September 2017 (dj) Calculate the fidelity between a density matrix represented as LPTN and a state represented as MPS.

Arguments

RhoTYPE(lptn), inout

Density matrix for distance measure.

PsiTYPE(mps), in

Pure state in the distance measure.

Details

With the fidelity is . It simplifies to

The two layers of the MPS and the LPTN are contracted. After fusing the chi-links we remain with an MPS-like construct. The local dimension is represented with the kappa-links. This norm of this MPS construct yields the actual distance.

Source Code

show / hide f90 code

  function fidelity_lptn_mps(Rho, Psi, errst) result(fid)
      type(lptn), intent(in) :: Rho
      type(mps), intent(in) :: Psi
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: fid

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

      ! for looping
      integer :: ii

      ! MPS representing contraction
      type(mps) :: RP, RPc

      ! Copy of tensors
      type(tensor) :: Tensp
      type(tensor) :: Tensr

      !if(present(errst)) errst = 0

      RP%ll = Rho%ll
      RP%oc = -1

      allocate(RP%Aa(RP%ll), RP%can(RP%ll), &
               RP%haslambda(RP%ll + 1), RP%lambda(RP%ll + 1))

      RP%can = 'o'
      RP%haslambda = .false.

      do ii = 1, RP%ll
          call copy(Tensr, Rho%Aa(ii))
          call copy(Tensp, Psi%Aa(ii))

          call contr(RP%Aa(ii), Tensr, Tensp, [2], [2], transl='C', &
                     errst=errst)!permout=[1, 3, 4, 2, 5], errst=errst)
          !if(prop_error('fidelity_lptn_mps : contr '//&
          !              'failed.', 'LPTNOps_include.f90:1352', errst=errst)) return

          call transposed(RP%Aa(ii), [1, 4, 2, 3, 5], doperm=.true.)

          call fuse(RP%Aa(ii), [1, 2])
          call fuse(RP%Aa(ii), [3, 4])

          call destroy(Tensr)
          call destroy(Tensp)
      end do

      call copy(RPc, RP)

      fid = real(dot(RP, RPc, errst=errst), KIND=rKind)
      !if(prop_error('fidelity_lptn_mps : dot failed.', &
      !              'LPTNOps_include.f90:1367', errst=errst)) return

      call destroy(RP)
      call destroy(RPc)

  end function fidelity_lptn_mps

LPTNOps_f90.fidelity_lptn_mpsc()

fortran-function - September 2017 (dj) Calculate the fidelity between a density matrix represented as LPTN and a state represented as MPS.

Arguments

RhoTYPE(lptn), inout

Density matrix for distance measure.

PsiTYPE(mpsc), in

Pure state in the distance measure.

Details

With the fidelity is . It simplifies to

The two layers of the MPS and the LPTN are contracted. After fusing the chi-links we remain with an MPS-like construct. The local dimension is represented with the kappa-links. This norm of this MPS construct yields the actual distance.

Source Code

show / hide f90 code

  function fidelity_lptn_mpsc(Rho, Psi, errst) result(fid)
      type(lptn), intent(in) :: Rho
      type(mpsc), intent(in) :: Psi
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: fid

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

      ! for looping
      integer :: ii

      ! MPS representing contraction
      type(mpsc) :: RP, RPc

      ! Copy of tensors
      type(tensorc) :: Tensp
      type(tensorc) :: Tensr

      !if(present(errst)) errst = 0

      RP%ll = Rho%ll
      RP%oc = -1

      allocate(RP%Aa(RP%ll), RP%can(RP%ll), &
               RP%haslambda(RP%ll + 1), RP%lambda(RP%ll + 1))

      RP%can = 'o'
      RP%haslambda = .false.

      do ii = 1, RP%ll
          call copy(Tensr, Rho%Aa(ii))
          call copy(Tensp, Psi%Aa(ii))

          call contr(RP%Aa(ii), Tensr, Tensp, [2], [2], transl='C', &
                     errst=errst)!permout=[1, 3, 4, 2, 5], errst=errst)
          !if(prop_error('fidelity_lptn_mpsc : contr '//&
          !              'failed.', 'LPTNOps_include.f90:1352', errst=errst)) return

          call transposed(RP%Aa(ii), [1, 4, 2, 3, 5], doperm=.true.)

          call fuse(RP%Aa(ii), [1, 2])
          call fuse(RP%Aa(ii), [3, 4])

          call destroy(Tensr)
          call destroy(Tensp)
      end do

      call copy(RPc, RP)

      fid = real(dot(RP, RPc, errst=errst), KIND=rKind)
      !if(prop_error('fidelity_lptn_mpsc : dot failed.', &
      !              'LPTNOps_include.f90:1367', errst=errst)) return

      call destroy(RP)
      call destroy(RPc)

  end function fidelity_lptn_mpsc

LPTNOps_f90.fidelity_lptnc_mps()

fortran-function - September 2017 (dj) Calculate the fidelity between a density matrix represented as LPTN and a state represented as MPS.

Arguments

RhoTYPE(lptnc), inout

Density matrix for distance measure.

PsiTYPE(mps), in

Pure state in the distance measure.

Details

With the fidelity is . It simplifies to

The two layers of the MPS and the LPTN are contracted. After fusing the chi-links we remain with an MPS-like construct. The local dimension is represented with the kappa-links. This norm of this MPS construct yields the actual distance.

Source Code

show / hide f90 code

  function fidelity_lptnc_mps(Rho, Psi, errst) result(fid)
      type(lptnc), intent(in) :: Rho
      type(mps), intent(in) :: Psi
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: fid

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

      ! for looping
      integer :: ii

      ! MPS representing contraction
      type(mpsc) :: RP, RPc

      ! Copy of tensors
      type(tensorc) :: Tensp
      type(tensorc) :: Tensr

      !if(present(errst)) errst = 0

      RP%ll = Rho%ll
      RP%oc = -1

      allocate(RP%Aa(RP%ll), RP%can(RP%ll), &
               RP%haslambda(RP%ll + 1), RP%lambda(RP%ll + 1))

      RP%can = 'o'
      RP%haslambda = .false.

      do ii = 1, RP%ll
          call copy(Tensr, Rho%Aa(ii))
          call copy(Tensp, Psi%Aa(ii))

          call contr(RP%Aa(ii), Tensr, Tensp, [2], [2], transl='C', &
                     errst=errst)!permout=[1, 3, 4, 2, 5], errst=errst)
          !if(prop_error('fidelity_lptnc_mps : contr '//&
          !              'failed.', 'LPTNOps_include.f90:1352', errst=errst)) return

          call transposed(RP%Aa(ii), [1, 4, 2, 3, 5], doperm=.true.)

          call fuse(RP%Aa(ii), [1, 2])
          call fuse(RP%Aa(ii), [3, 4])

          call destroy(Tensr)
          call destroy(Tensp)
      end do

      call copy(RPc, RP)

      fid = real(dot(RP, RPc, errst=errst), KIND=rKind)
      !if(prop_error('fidelity_lptnc_mps : dot failed.', &
      !              'LPTNOps_include.f90:1367', errst=errst)) return

      call destroy(RP)
      call destroy(RPc)

  end function fidelity_lptnc_mps

LPTNOps_f90.fidelity_lptnc_mpsc()

fortran-function - September 2017 (dj) Calculate the fidelity between a density matrix represented as LPTN and a state represented as MPS.

Arguments

RhoTYPE(lptnc), inout

Density matrix for distance measure.

PsiTYPE(mpsc), in

Pure state in the distance measure.

Details

With the fidelity is . It simplifies to

The two layers of the MPS and the LPTN are contracted. After fusing the chi-links we remain with an MPS-like construct. The local dimension is represented with the kappa-links. This norm of this MPS construct yields the actual distance.

Source Code

show / hide f90 code

  function fidelity_lptnc_mpsc(Rho, Psi, errst) result(fid)
      type(lptnc), intent(in) :: Rho
      type(mpsc), intent(in) :: Psi
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: fid

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

      ! for looping
      integer :: ii

      ! MPS representing contraction
      type(mpsc) :: RP, RPc

      ! Copy of tensors
      type(tensorc) :: Tensp
      type(tensorc) :: Tensr

      !if(present(errst)) errst = 0

      RP%ll = Rho%ll
      RP%oc = -1

      allocate(RP%Aa(RP%ll), RP%can(RP%ll), &
               RP%haslambda(RP%ll + 1), RP%lambda(RP%ll + 1))

      RP%can = 'o'
      RP%haslambda = .false.

      do ii = 1, RP%ll
          call copy(Tensr, Rho%Aa(ii))
          call copy(Tensp, Psi%Aa(ii))

          call contr(RP%Aa(ii), Tensr, Tensp, [2], [2], transl='C', &
                     errst=errst)!permout=[1, 3, 4, 2, 5], errst=errst)
          !if(prop_error('fidelity_lptnc_mpsc : contr '//&
          !              'failed.', 'LPTNOps_include.f90:1352', errst=errst)) return

          call transposed(RP%Aa(ii), [1, 4, 2, 3, 5], doperm=.true.)

          call fuse(RP%Aa(ii), [1, 2])
          call fuse(RP%Aa(ii), [3, 4])

          call destroy(Tensr)
          call destroy(Tensp)
      end do

      call copy(RPc, RP)

      fid = real(dot(RP, RPc, errst=errst), KIND=rKind)
      !if(prop_error('fidelity_lptnc_mpsc : dot failed.', &
      !              'LPTNOps_include.f90:1367', errst=errst)) return

      call destroy(RP)
      call destroy(RPc)

  end function fidelity_lptnc_mpsc

LPTNOps_f90.gaugesite_qr_tensor()

fortran-subroutine - June 2017 (dj, updated) Shift gauge for two tensor to the right with a QR-decomposition.

Arguments

TlTYPE(tensor), inout

Run QR decomposition on last index vs the other ones.

TrTYPE(tensor), inout

On exit, this tensor is the new orhtogonality center.

Source Code

show / hide f90 code

  subroutine gaugesite_qr_tensor(Tl, Tr, errst)
      type(tensor), intent(inout) :: Tl, Tr
      integer, intent(out), optional :: errst

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

      ! Temporary tensor for R-matrix
      type(tensor) :: Tmp

      !if(present(errst)) errst = 0

      call qr(Tl, Tmp, [1, 2, 3], [4], errst=errst)
      !if(prop_error('gaugesite_qr_tensor: qr failed', &
      !              errst=errst)) return

      call contr_uplo(Tmp, Tr, [2], [1], errst=errst)
      !if(prop_error('gaugesite_qr_tensor: contr failed', &
      !              errst=errst)) return

      call destroy(Tmp)

  end subroutine gaugesite_qr_tensor

LPTNOps_f90.gaugesite_rq_tensor()

fortran-subroutine - June 2017 (dj, updated) Shift gauge for two tensors to the left with a RQ-decompistion.

Arguments

TlTYPE(tensor), inout

On exit, this tensor is the new orhtogonality center.

TrTYPE(tensor), inout

Run RQ decomposition on first index vs the other ones.

Source Code

show / hide f90 code

  subroutine gaugesite_rq_tensor(Tl, Tr, errst)
      type(tensor), intent(inout) :: Tl, Tr
      integer, intent(out), optional :: errst

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

      ! Temporary tensor for R-matrix
      type(tensor) :: Tmp

      !if(present(errst)) errst = 0

      call rq(Tr, Tmp, [1], [2, 3, 4], errst=errst)
      !if(prop_error('gaugesite_rq_tensor: rq failed', &
      !              errst=errst)) return

      call contr_uplo(Tmp, Tl, [1], [4], errst=errst)
      !if(prop_error('gaugesite_rq_tensor: contr failed', &
      !              errst=errst)) return

      call destroy(Tmp)

  end subroutine gaugesite_rq_tensor

LPTNOps_f90.gaugesite_qr_tensorc()

fortran-subroutine - June 2017 (dj, updated) Shift gauge for two tensor to the right with a QR-decomposition.

Arguments

TlTYPE(tensorc), inout

Run QR decomposition on last index vs the other ones.

TrTYPE(tensorc), inout

On exit, this tensor is the new orhtogonality center.

Source Code

show / hide f90 code

  subroutine gaugesite_qr_tensorc(Tl, Tr, errst)
      type(tensorc), intent(inout) :: Tl, Tr
      integer, intent(out), optional :: errst

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

      ! Temporary tensor for R-matrix
      type(tensorc) :: Tmp

      !if(present(errst)) errst = 0

      call qr(Tl, Tmp, [1, 2, 3], [4], errst=errst)
      !if(prop_error('gaugesite_qr_tensorc: qr failed', &
      !              errst=errst)) return

      call contr_uplo(Tmp, Tr, [2], [1], errst=errst)
      !if(prop_error('gaugesite_qr_tensorc: contr failed', &
      !              errst=errst)) return

      call destroy(Tmp)

  end subroutine gaugesite_qr_tensorc

LPTNOps_f90.gaugesite_rq_tensorc()

fortran-subroutine - June 2017 (dj, updated) Shift gauge for two tensors to the left with a RQ-decompistion.

Arguments

TlTYPE(tensorc), inout

On exit, this tensor is the new orhtogonality center.

TrTYPE(tensorc), inout

Run RQ decomposition on first index vs the other ones.

Source Code

show / hide f90 code

  subroutine gaugesite_rq_tensorc(Tl, Tr, errst)
      type(tensorc), intent(inout) :: Tl, Tr
      integer, intent(out), optional :: errst

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

      ! Temporary tensor for R-matrix
      type(tensorc) :: Tmp

      !if(present(errst)) errst = 0

      call rq(Tr, Tmp, [1], [2, 3, 4], errst=errst)
      !if(prop_error('gaugesite_rq_tensorc: rq failed', &
      !              errst=errst)) return

      call contr_uplo(Tmp, Tl, [1], [4], errst=errst)
      !if(prop_error('gaugesite_rq_tensorc: contr failed', &
      !              errst=errst)) return

      call destroy(Tmp)

  end subroutine gaugesite_rq_tensorc

LPTNOps_f90.gaugesite_qr_qtensor()

fortran-subroutine - June 2017 (dj, updated) Shift gauge for two tensor to the right with a QR-decomposition.

Arguments

TlTYPE(qtensor), inout

Run QR decomposition on last index vs the other ones.

TrTYPE(qtensor), inout

On exit, this tensor is the new orhtogonality center.

Source Code

show / hide f90 code

  subroutine gaugesite_qr_qtensor(Tl, Tr, errst)
      type(qtensor), intent(inout) :: Tl, Tr
      integer, intent(out), optional :: errst

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

      ! Temporary tensor for R-matrix
      type(qtensor) :: Tmp

      !if(present(errst)) errst = 0

      call qr(Tl, Tmp, [1, 2, 3], [4], errst=errst)
      !if(prop_error('gaugesite_qr_qtensor: qr failed', &
      !              errst=errst)) return

      call contr_uplo(Tmp, Tr, [2], [1], errst=errst)
      !if(prop_error('gaugesite_qr_qtensor: contr failed', &
      !              errst=errst)) return

      call destroy(Tmp)

  end subroutine gaugesite_qr_qtensor

LPTNOps_f90.gaugesite_rq_qtensor()

fortran-subroutine - June 2017 (dj, updated) Shift gauge for two tensors to the left with a RQ-decompistion.

Arguments

TlTYPE(qtensor), inout

On exit, this tensor is the new orhtogonality center.

TrTYPE(qtensor), inout

Run RQ decomposition on first index vs the other ones.

Source Code

show / hide f90 code

  subroutine gaugesite_rq_qtensor(Tl, Tr, errst)
      type(qtensor), intent(inout) :: Tl, Tr
      integer, intent(out), optional :: errst

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

      ! Temporary tensor for R-matrix
      type(qtensor) :: Tmp

      !if(present(errst)) errst = 0

      call rq(Tr, Tmp, [1], [2, 3, 4], errst=errst)
      !if(prop_error('gaugesite_rq_qtensor: rq failed', &
      !              errst=errst)) return

      call contr_uplo(Tmp, Tl, [1], [4], errst=errst)
      !if(prop_error('gaugesite_rq_qtensor: contr failed', &
      !              errst=errst)) return

      call destroy(Tmp)

  end subroutine gaugesite_rq_qtensor

LPTNOps_f90.gaugesite_qr_qtensorc()

fortran-subroutine - June 2017 (dj, updated) Shift gauge for two tensor to the right with a QR-decomposition.

Arguments

TlTYPE(qtensorc), inout

Run QR decomposition on last index vs the other ones.

TrTYPE(qtensorc), inout

On exit, this tensor is the new orhtogonality center.

Source Code

show / hide f90 code

  subroutine gaugesite_qr_qtensorc(Tl, Tr, errst)
      type(qtensorc), intent(inout) :: Tl, Tr
      integer, intent(out), optional :: errst

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

      ! Temporary tensor for R-matrix
      type(qtensorc) :: Tmp

      !if(present(errst)) errst = 0

      call qr(Tl, Tmp, [1, 2, 3], [4], errst=errst)
      !if(prop_error('gaugesite_qr_qtensorc: qr failed', &
      !              errst=errst)) return

      call contr_uplo(Tmp, Tr, [2], [1], errst=errst)
      !if(prop_error('gaugesite_qr_qtensorc: contr failed', &
      !              errst=errst)) return

      call destroy(Tmp)

  end subroutine gaugesite_qr_qtensorc

LPTNOps_f90.gaugesite_rq_qtensorc()

fortran-subroutine - June 2017 (dj, updated) Shift gauge for two tensors to the left with a RQ-decompistion.

Arguments

TlTYPE(qtensorc), inout

On exit, this tensor is the new orhtogonality center.

TrTYPE(qtensorc), inout

Run RQ decomposition on first index vs the other ones.

Source Code

show / hide f90 code

  subroutine gaugesite_rq_qtensorc(Tl, Tr, errst)
      type(qtensorc), intent(inout) :: Tl, Tr
      integer, intent(out), optional :: errst

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

      ! Temporary tensor for R-matrix
      type(qtensorc) :: Tmp

      !if(present(errst)) errst = 0

      call rq(Tr, Tmp, [1], [2, 3, 4], errst=errst)
      !if(prop_error('gaugesite_rq_qtensorc: rq failed', &
      !              errst=errst)) return

      call contr_uplo(Tmp, Tl, [1], [4], errst=errst)
      !if(prop_error('gaugesite_rq_qtensorc: contr failed', &
      !              errst=errst)) return

      call destroy(Tmp)

  end subroutine gaugesite_rq_qtensorc

LPTNOps_f90.gaugesite_rsvd_tensor()

fortran-subroutine - June 2017 (dj, updated) Shift the gauge from the left site to the right running an SVD.

Arguments

TlTYPE(tensor), inout

SVD decompose this tensor between the last index and the other ones.

LambTYPE(tensor), inout

Contains the singular values on exit.

TrTYPE(tensor), inout

On exit, this tensor is the new orthogonality center.

haslambdaLOGICAL, inout

Flag if singular values are already allocated.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Source Code

show / hide f90 code

  subroutine gaugesite_rsvd_tensor(Tl, Lamb, Tr, haslambda, &
                                        trunc, ncut, errst)
      type(tensor), intent(inout) :: Tl, Tr
      type(tensor), intent(inout) :: Lamb
      logical, intent(inout) :: haslambda
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! temporary tensors for split and contractions
      type(tensor) :: Tmp, Tl2, Tr2

      !if(present(errst)) errst = 0

      if(haslambda) call destroy(Lamb)
      haslambda = .true.

      call split(Tl2, Lamb, Tmp, Tl, [1, 2, 3], [4], multlr=1, trunc=trunc, &
                 ncut=ncut, method='Y', errst=errst)
      !if(prop_error('gaugesite_rsvd_tensor: split failed', &
      !              errst=errst)) return
      call destroy(Tl)
      call copy(Tl, Tl2)
      call destroy(Tl2)

      call contr(Tr2, Tmp, Tr, [2], [1], errst=errst)
      !if(prop_error('gaugesite_rsvd_tensor: contr failed', &
      !              errst=errst)) return

      call destroy(Tr)
      call copy(Tr, Tr2)
      call destroy(Tr2)

      call destroy(Tmp)

  end subroutine gaugesite_rsvd_tensor

LPTNOps_f90.gaugesite_lsvd_tensor()

fortran-subroutine - June 2017 (dj, updated) Shift the gauge from the right site to the left running an SVD.

Arguments

TlTYPE(tensor), inout

This tensor will be the new orthogonality center on exit.

LambTYPE(tensor), inout

Contains the singular values on exit.

TrTYPE(tensor), inout

SVD decompose this tensor between the first index and the other ones.

haslambdaLOGICAL, inout

Flag if singular values are already allocated.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Source Code

show / hide f90 code

  subroutine gaugesite_lsvd_tensor(Tl, Lamb, Tr, haslambda, &
                                        trunc, ncut, errst)
      type(tensor), intent(inout) :: Tl, Tr
      type(tensor), intent(inout) :: Lamb
      logical, intent(inout) :: haslambda
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! temporary tensors for split and contractions
      type(tensor) :: Tmp, Tl2, Tr2

      !if(present(errst)) errst = 0

      if(haslambda) call destroy(Lamb)
      haslambda = .true.

      call split(Tmp, Lamb, Tr2, Tr, [1], [2, 3, 4], multlr=-1, trunc=trunc, &
                 ncut=ncut, method='Y', errst=errst)
      !if(prop_error('gaugesite_lsvd_tensor: split failed', &
      !              errst=errst)) return
      call destroy(Tr)
      call copy(Tr, Tr2)
      call destroy(Tr2)

      call contr(Tl2, Tl, Tmp, [4], [1], errst=errst)
      !if(prop_error('gaugesite_lsvd_tensor: contr failed', &
      !              errst=errst)) return

      call destroy(Tl)
      call copy(Tl, Tl2)
      call destroy(Tl2)

      call destroy(Tmp)

  end subroutine gaugesite_lsvd_tensor

LPTNOps_f90.gaugesite_rsvd_tensorc()

fortran-subroutine - June 2017 (dj, updated) Shift the gauge from the left site to the right running an SVD.

Arguments

TlTYPE(tensorc), inout

SVD decompose this tensor between the last index and the other ones.

LambTYPE(tensor), inout

Contains the singular values on exit.

TrTYPE(tensorc), inout

On exit, this tensor is the new orthogonality center.

haslambdaLOGICAL, inout

Flag if singular values are already allocated.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Source Code

show / hide f90 code

  subroutine gaugesite_rsvd_tensorc(Tl, Lamb, Tr, haslambda, &
                                        trunc, ncut, errst)
      type(tensorc), intent(inout) :: Tl, Tr
      type(tensor), intent(inout) :: Lamb
      logical, intent(inout) :: haslambda
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! temporary tensors for split and contractions
      type(tensorc) :: Tmp, Tl2, Tr2

      !if(present(errst)) errst = 0

      if(haslambda) call destroy(Lamb)
      haslambda = .true.

      call split(Tl2, Lamb, Tmp, Tl, [1, 2, 3], [4], multlr=1, trunc=trunc, &
                 ncut=ncut, method='Y', errst=errst)
      !if(prop_error('gaugesite_rsvd_tensorc: split failed', &
      !              errst=errst)) return
      call destroy(Tl)
      call copy(Tl, Tl2)
      call destroy(Tl2)

      call contr(Tr2, Tmp, Tr, [2], [1], errst=errst)
      !if(prop_error('gaugesite_rsvd_tensorc: contr failed', &
      !              errst=errst)) return

      call destroy(Tr)
      call copy(Tr, Tr2)
      call destroy(Tr2)

      call destroy(Tmp)

  end subroutine gaugesite_rsvd_tensorc

LPTNOps_f90.gaugesite_lsvd_tensorc()

fortran-subroutine - June 2017 (dj, updated) Shift the gauge from the right site to the left running an SVD.

Arguments

TlTYPE(tensorc), inout

This tensor will be the new orthogonality center on exit.

LambTYPE(tensor), inout

Contains the singular values on exit.

TrTYPE(tensorc), inout

SVD decompose this tensor between the first index and the other ones.

haslambdaLOGICAL, inout

Flag if singular values are already allocated.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Source Code

show / hide f90 code

  subroutine gaugesite_lsvd_tensorc(Tl, Lamb, Tr, haslambda, &
                                        trunc, ncut, errst)
      type(tensorc), intent(inout) :: Tl, Tr
      type(tensor), intent(inout) :: Lamb
      logical, intent(inout) :: haslambda
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! temporary tensors for split and contractions
      type(tensorc) :: Tmp, Tl2, Tr2

      !if(present(errst)) errst = 0

      if(haslambda) call destroy(Lamb)
      haslambda = .true.

      call split(Tmp, Lamb, Tr2, Tr, [1], [2, 3, 4], multlr=-1, trunc=trunc, &
                 ncut=ncut, method='Y', errst=errst)
      !if(prop_error('gaugesite_lsvd_tensorc: split failed', &
      !              errst=errst)) return
      call destroy(Tr)
      call copy(Tr, Tr2)
      call destroy(Tr2)

      call contr(Tl2, Tl, Tmp, [4], [1], errst=errst)
      !if(prop_error('gaugesite_lsvd_tensorc: contr failed', &
      !              errst=errst)) return

      call destroy(Tl)
      call copy(Tl, Tl2)
      call destroy(Tl2)

      call destroy(Tmp)

  end subroutine gaugesite_lsvd_tensorc

LPTNOps_f90.gaugesite_rsvd_qtensor()

fortran-subroutine - June 2017 (dj, updated) Shift the gauge from the left site to the right running an SVD.

Arguments

TlTYPE(qtensor), inout

SVD decompose this tensor between the last index and the other ones.

LambTYPE(qtensor), inout

Contains the singular values on exit.

TrTYPE(qtensor), inout

On exit, this tensor is the new orthogonality center.

haslambdaLOGICAL, inout

Flag if singular values are already allocated.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Source Code

show / hide f90 code

  subroutine gaugesite_rsvd_qtensor(Tl, Lamb, Tr, haslambda, &
                                        trunc, ncut, errst)
      type(qtensor), intent(inout) :: Tl, Tr
      type(qtensor), intent(inout) :: Lamb
      logical, intent(inout) :: haslambda
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! temporary tensors for split and contractions
      type(qtensor) :: Tmp, Tl2, Tr2

      !if(present(errst)) errst = 0

      if(haslambda) call destroy(Lamb)
      haslambda = .true.

      call split(Tl2, Lamb, Tmp, Tl, [1, 2, 3], [4], multlr=1, trunc=trunc, &
                 ncut=ncut, method='Y', errst=errst)
      !if(prop_error('gaugesite_rsvd_qtensor: split failed', &
      !              errst=errst)) return
      call destroy(Tl)
      call copy(Tl, Tl2)
      call destroy(Tl2)

      call contr(Tr2, Tmp, Tr, [2], [1], errst=errst)
      !if(prop_error('gaugesite_rsvd_qtensor: contr failed', &
      !              errst=errst)) return

      call destroy(Tr)
      call copy(Tr, Tr2)
      call destroy(Tr2)

      call destroy(Tmp)

  end subroutine gaugesite_rsvd_qtensor

LPTNOps_f90.gaugesite_lsvd_qtensor()

fortran-subroutine - June 2017 (dj, updated) Shift the gauge from the right site to the left running an SVD.

Arguments

TlTYPE(qtensor), inout

This tensor will be the new orthogonality center on exit.

LambTYPE(qtensor), inout

Contains the singular values on exit.

TrTYPE(qtensor), inout

SVD decompose this tensor between the first index and the other ones.

haslambdaLOGICAL, inout

Flag if singular values are already allocated.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Source Code

show / hide f90 code

  subroutine gaugesite_lsvd_qtensor(Tl, Lamb, Tr, haslambda, &
                                        trunc, ncut, errst)
      type(qtensor), intent(inout) :: Tl, Tr
      type(qtensor), intent(inout) :: Lamb
      logical, intent(inout) :: haslambda
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! temporary tensors for split and contractions
      type(qtensor) :: Tmp, Tl2, Tr2

      !if(present(errst)) errst = 0

      if(haslambda) call destroy(Lamb)
      haslambda = .true.

      call split(Tmp, Lamb, Tr2, Tr, [1], [2, 3, 4], multlr=-1, trunc=trunc, &
                 ncut=ncut, method='Y', errst=errst)
      !if(prop_error('gaugesite_lsvd_qtensor: split failed', &
      !              errst=errst)) return
      call destroy(Tr)
      call copy(Tr, Tr2)
      call destroy(Tr2)

      call contr(Tl2, Tl, Tmp, [4], [1], errst=errst)
      !if(prop_error('gaugesite_lsvd_qtensor: contr failed', &
      !              errst=errst)) return

      call destroy(Tl)
      call copy(Tl, Tl2)
      call destroy(Tl2)

      call destroy(Tmp)

  end subroutine gaugesite_lsvd_qtensor

LPTNOps_f90.gaugesite_rsvd_qtensorc()

fortran-subroutine - June 2017 (dj, updated) Shift the gauge from the left site to the right running an SVD.

Arguments

TlTYPE(qtensorc), inout

SVD decompose this tensor between the last index and the other ones.

LambTYPE(qtensor), inout

Contains the singular values on exit.

TrTYPE(qtensorc), inout

On exit, this tensor is the new orthogonality center.

haslambdaLOGICAL, inout

Flag if singular values are already allocated.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Source Code

show / hide f90 code

  subroutine gaugesite_rsvd_qtensorc(Tl, Lamb, Tr, haslambda, &
                                        trunc, ncut, errst)
      type(qtensorc), intent(inout) :: Tl, Tr
      type(qtensor), intent(inout) :: Lamb
      logical, intent(inout) :: haslambda
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! temporary tensors for split and contractions
      type(qtensorc) :: Tmp, Tl2, Tr2

      !if(present(errst)) errst = 0

      if(haslambda) call destroy(Lamb)
      haslambda = .true.

      call split(Tl2, Lamb, Tmp, Tl, [1, 2, 3], [4], multlr=1, trunc=trunc, &
                 ncut=ncut, method='Y', errst=errst)
      !if(prop_error('gaugesite_rsvd_qtensorc: split failed', &
      !              errst=errst)) return
      call destroy(Tl)
      call copy(Tl, Tl2)
      call destroy(Tl2)

      call contr(Tr2, Tmp, Tr, [2], [1], errst=errst)
      !if(prop_error('gaugesite_rsvd_qtensorc: contr failed', &
      !              errst=errst)) return

      call destroy(Tr)
      call copy(Tr, Tr2)
      call destroy(Tr2)

      call destroy(Tmp)

  end subroutine gaugesite_rsvd_qtensorc

LPTNOps_f90.gaugesite_lsvd_qtensorc()

fortran-subroutine - June 2017 (dj, updated) Shift the gauge from the right site to the left running an SVD.

Arguments

TlTYPE(qtensorc), inout

This tensor will be the new orthogonality center on exit.

LambTYPE(qtensor), inout

Contains the singular values on exit.

TrTYPE(qtensorc), inout

SVD decompose this tensor between the first index and the other ones.

haslambdaLOGICAL, inout

Flag if singular values are already allocated.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

Source Code

show / hide f90 code

  subroutine gaugesite_lsvd_qtensorc(Tl, Lamb, Tr, haslambda, &
                                        trunc, ncut, errst)
      type(qtensorc), intent(inout) :: Tl, Tr
      type(qtensor), intent(inout) :: Lamb
      logical, intent(inout) :: haslambda
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      integer, intent(out), optional :: errst

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

      ! temporary tensors for split and contractions
      type(qtensorc) :: Tmp, Tl2, Tr2

      !if(present(errst)) errst = 0

      if(haslambda) call destroy(Lamb)
      haslambda = .true.

      call split(Tmp, Lamb, Tr2, Tr, [1], [2, 3, 4], multlr=-1, trunc=trunc, &
                 ncut=ncut, method='Y', errst=errst)
      !if(prop_error('gaugesite_lsvd_qtensorc: split failed', &
      !              errst=errst)) return
      call destroy(Tr)
      call copy(Tr, Tr2)
      call destroy(Tr2)

      call contr(Tl2, Tl, Tmp, [4], [1], errst=errst)
      !if(prop_error('gaugesite_lsvd_qtensorc: contr failed', &
      !              errst=errst)) return

      call destroy(Tl)
      call copy(Tl, Tl2)
      call destroy(Tl2)

      call destroy(Tmp)

  end subroutine gaugesite_lsvd_qtensorc

LPTNOps_f90.maxchi_lptn()

fortran-function - September 2017 (dj, updated) Get the maximal bond dimension to nearest neighbors of the LPTN.

Arguments

RhoTYPE(lptn), in

Get the maximal bond dimension present in the LPTN for the link between nearest neighbors.

Source Code

show / hide f90 code

  function maxchi_lptn(Rho) result(chi)
      type(lptn), intent(in) :: Rho
      integer :: chi

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

      ! for looping
      integer :: ii

      chi = 0

      do ii = 1, Rho%ll
          chi = max(chi, maxlineardim(Rho%Aa(ii), idx=[1, 4]))
      end do

  end function maxchi_lptn

LPTNOps_f90.maxchi_lptnc()

fortran-function - September 2017 (dj, updated) Get the maximal bond dimension to nearest neighbors of the LPTN.

Arguments

RhoTYPE(lptnc), in

Get the maximal bond dimension present in the LPTN for the link between nearest neighbors.

Source Code

show / hide f90 code

  function maxchi_lptnc(Rho) result(chi)
      type(lptnc), intent(in) :: Rho
      integer :: chi

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

      ! for looping
      integer :: ii

      chi = 0

      do ii = 1, Rho%ll
          chi = max(chi, maxlineardim(Rho%Aa(ii), idx=[1, 4]))
      end do

  end function maxchi_lptnc

LPTNOps_f90.maxchi_qlptn()

fortran-function - September 2017 (dj, updated) Get the maximal bond dimension to nearest neighbors of the LPTN.

Arguments

RhoTYPE(qlptn), in

Get the maximal bond dimension present in the LPTN for the link between nearest neighbors.

Source Code

show / hide f90 code

  function maxchi_qlptn(Rho) result(chi)
      type(qlptn), intent(in) :: Rho
      integer :: chi

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

      ! for looping
      integer :: ii

      chi = 0

      do ii = 1, Rho%ll
          chi = max(chi, maxlineardim(Rho%Aa(ii), idx=[1, 4]))
      end do

  end function maxchi_qlptn

LPTNOps_f90.maxchi_qlptnc()

fortran-function - September 2017 (dj, updated) Get the maximal bond dimension to nearest neighbors of the LPTN.

Arguments

RhoTYPE(qlptnc), in

Get the maximal bond dimension present in the LPTN for the link between nearest neighbors.

Source Code

show / hide f90 code

  function maxchi_qlptnc(Rho) result(chi)
      type(qlptnc), intent(in) :: Rho
      integer :: chi

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

      ! for looping
      integer :: ii

      chi = 0

      do ii = 1, Rho%ll
          chi = max(chi, maxlineardim(Rho%Aa(ii), idx=[1, 4]))
      end do

  end function maxchi_qlptnc

LPTNOps_f90.maxkappa_lptn()

fortran-function - September 2017 (dj, updated) Get the maximal bond dimension to conjugate tensors of the LPTN.

Arguments

RhoTYPE(lptn), in

Get the maximal bond dimension present in the LPTN for the link between the complex conjugate tensors.

Source Code

show / hide f90 code

  function maxkappa_lptn(Rho) result(kappa)
      type(lptn), intent(in) :: Rho
      integer :: kappa

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

      ! for looping
      integer :: ii

      kappa = 0

      do ii = 1, Rho%ll
          kappa = max(kappa, maxlineardim(Rho%Aa(ii), idx=[3]))
      end do

  end function maxkappa_lptn

LPTNOps_f90.maxkappa_lptnc()

fortran-function - September 2017 (dj, updated) Get the maximal bond dimension to conjugate tensors of the LPTN.

Arguments

RhoTYPE(lptnc), in

Get the maximal bond dimension present in the LPTN for the link between the complex conjugate tensors.

Source Code

show / hide f90 code

  function maxkappa_lptnc(Rho) result(kappa)
      type(lptnc), intent(in) :: Rho
      integer :: kappa

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

      ! for looping
      integer :: ii

      kappa = 0

      do ii = 1, Rho%ll
          kappa = max(kappa, maxlineardim(Rho%Aa(ii), idx=[3]))
      end do

  end function maxkappa_lptnc

LPTNOps_f90.maxkappa_qlptn()

fortran-function - September 2017 (dj, updated) Get the maximal bond dimension to conjugate tensors of the LPTN.

Arguments

RhoTYPE(qlptn), in

Get the maximal bond dimension present in the LPTN for the link between the complex conjugate tensors.

Source Code

show / hide f90 code

  function maxkappa_qlptn(Rho) result(kappa)
      type(qlptn), intent(in) :: Rho
      integer :: kappa

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

      ! for looping
      integer :: ii

      kappa = 0

      do ii = 1, Rho%ll
          kappa = max(kappa, maxlineardim(Rho%Aa(ii), idx=[3]))
      end do

  end function maxkappa_qlptn

LPTNOps_f90.maxkappa_qlptnc()

fortran-function - September 2017 (dj, updated) Get the maximal bond dimension to conjugate tensors of the LPTN.

Arguments

RhoTYPE(qlptnc), in

Get the maximal bond dimension present in the LPTN for the link between the complex conjugate tensors.

Source Code

show / hide f90 code

  function maxkappa_qlptnc(Rho) result(kappa)
      type(qlptnc), intent(in) :: Rho
      integer :: kappa

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

      ! for looping
      integer :: ii

      kappa = 0

      do ii = 1, Rho%ll
          kappa = max(kappa, maxlineardim(Rho%Aa(ii), idx=[3]))
      end do

  end function maxkappa_qlptnc

LPTNOps_f90.meas_mpo_lptn_mpo()

fortran-subroutine - November 2017 (dj) Compute the expectation value of an MPO on a LPTN.

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.

RhoTYPE(lptn), inout

Measure this density matrix.

Source Code

show / hide f90 code

  subroutine meas_mpo_lptn_mpo(val, Ham, Rho, errst)
      real(KIND=rKind) :: val
      type(mpo) :: Ham
      type(lptn) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Contracting the overlap
      type(tensorlist) :: Lmat

      !if(present(errst)) errst = 0

      ! Last site
      call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
                             errst=errst)
      !if(prop_error('meas_mpo_lptn_mpo : '//&
      !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
      !              errst=errst)) return

      ! Looping to the left
      do ii = (Rho%ll - 1), 1, (-1)
          call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
                                 errst=errst)
          !if(prop_error('meas_mpo_lptn_mpo : '//&
          !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
          !              errst=errst)) return
      end do

      val = real(trace(Lmat%Li(1)), KIND=rKind)

      call destroy(Lmat%Li(1))
      deallocate(Lmat%Li)

  end subroutine meas_mpo_lptn_mpo

LPTNOps_f90.meas_mpo_lptnc_mpo()

fortran-subroutine - November 2017 (dj) Compute the expectation value of an MPO on a LPTN.

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.

RhoTYPE(lptnc), inout

Measure this density matrix.

Source Code

show / hide f90 code

  subroutine meas_mpo_lptnc_mpo(val, Ham, Rho, errst)
      real(KIND=rKind) :: val
      type(mpo) :: Ham
      type(lptnc) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Contracting the overlap
      type(tensorlistc) :: Lmat

      !if(present(errst)) errst = 0

      ! Last site
      call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
                             errst=errst)
      !if(prop_error('meas_mpo_lptnc_mpo : '//&
      !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
      !              errst=errst)) return

      ! Looping to the left
      do ii = (Rho%ll - 1), 1, (-1)
          call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
                                 errst=errst)
          !if(prop_error('meas_mpo_lptnc_mpo : '//&
          !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
          !              errst=errst)) return
      end do

      val = real(trace(Lmat%Li(1)), KIND=rKind)

      call destroy(Lmat%Li(1))
      deallocate(Lmat%Li)

  end subroutine meas_mpo_lptnc_mpo

LPTNOps_f90.meas_mpo_lptnc_mpoc()

fortran-subroutine - November 2017 (dj) Compute the expectation value of an MPO on a LPTN.

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.

RhoTYPE(lptnc), inout

Measure this density matrix.

Source Code

show / hide f90 code

  subroutine meas_mpo_lptnc_mpoc(val, Ham, Rho, errst)
      real(KIND=rKind) :: val
      type(mpoc) :: Ham
      type(lptnc) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Contracting the overlap
      type(tensorlistc) :: Lmat

      !if(present(errst)) errst = 0

      ! Last site
      call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
                             errst=errst)
      !if(prop_error('meas_mpo_lptnc_mpoc : '//&
      !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
      !              errst=errst)) return

      ! Looping to the left
      do ii = (Rho%ll - 1), 1, (-1)
          call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
                                 errst=errst)
          !if(prop_error('meas_mpo_lptnc_mpoc : '//&
          !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
          !              errst=errst)) return
      end do

      val = real(trace(Lmat%Li(1)), KIND=rKind)

      call destroy(Lmat%Li(1))
      deallocate(Lmat%Li)

  end subroutine meas_mpo_lptnc_mpoc

LPTNOps_f90.meas_mpo_qlptn_qmpo()

fortran-subroutine - November 2017 (dj) Compute the expectation value of an MPO on a LPTN.

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.

RhoTYPE(qlptn), inout

Measure this density matrix.

Source Code

show / hide f90 code

  subroutine meas_mpo_qlptn_qmpo(val, Ham, Rho, errst)
      real(KIND=rKind) :: val
      type(qmpo) :: Ham
      type(qlptn) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Contracting the overlap
      type(qtensorlist) :: Lmat

      !if(present(errst)) errst = 0

      ! Last site
      call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
                             errst=errst)
      !if(prop_error('meas_mpo_qlptn_qmpo : '//&
      !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
      !              errst=errst)) return

      ! Looping to the left
      do ii = (Rho%ll - 1), 1, (-1)
          call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
                                 errst=errst)
          !if(prop_error('meas_mpo_qlptn_qmpo : '//&
          !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
          !              errst=errst)) return
      end do

      val = real(trace(Lmat%Li(1)), KIND=rKind)

      call destroy(Lmat%Li(1))
      deallocate(Lmat%Li)

  end subroutine meas_mpo_qlptn_qmpo

LPTNOps_f90.meas_mpo_qlptnc_qmpo()

fortran-subroutine - November 2017 (dj) Compute the expectation value of an MPO on a LPTN.

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.

RhoTYPE(qlptnc), inout

Measure this density matrix.

Source Code

show / hide f90 code

  subroutine meas_mpo_qlptnc_qmpo(val, Ham, Rho, errst)
      real(KIND=rKind) :: val
      type(qmpo) :: Ham
      type(qlptnc) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Contracting the overlap
      type(qtensorclist) :: Lmat

      !if(present(errst)) errst = 0

      ! Last site
      call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
                             errst=errst)
      !if(prop_error('meas_mpo_qlptnc_qmpo : '//&
      !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
      !              errst=errst)) return

      ! Looping to the left
      do ii = (Rho%ll - 1), 1, (-1)
          call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
                                 errst=errst)
          !if(prop_error('meas_mpo_qlptnc_qmpo : '//&
          !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
          !              errst=errst)) return
      end do

      val = real(trace(Lmat%Li(1)), KIND=rKind)

      call destroy(Lmat%Li(1))
      deallocate(Lmat%Li)

  end subroutine meas_mpo_qlptnc_qmpo

LPTNOps_f90.meas_mpo_qlptnc_qmpoc()

fortran-subroutine - November 2017 (dj) Compute the expectation value of an MPO on a LPTN.

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.

RhoTYPE(qlptnc), inout

Measure this density matrix.

Source Code

show / hide f90 code

  subroutine meas_mpo_qlptnc_qmpoc(val, Ham, Rho, errst)
      real(KIND=rKind) :: val
      type(qmpoc) :: Ham
      type(qlptnc) :: Rho
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! Contracting the overlap
      type(qtensorclist) :: Lmat

      !if(present(errst)) errst = 0

      ! Last site
      call ptm_left_mpo_lptn(Lmat, Rho%Aa(Rho%ll), Ham%Ws(Rho%ll), .true., &
                             errst=errst)
      !if(prop_error('meas_mpo_qlptnc_qmpoc : '//&
      !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1890', &
      !              errst=errst)) return

      ! Looping to the left
      do ii = (Rho%ll - 1), 1, (-1)
          call ptm_left_mpo_lptn(Lmat, Rho%Aa(ii), Ham%Ws(ii), .false., &
                                 errst=errst)
          !if(prop_error('meas_mpo_qlptnc_qmpoc : '//&
          !              'ptm_left_mpo_lptn failed.', 'LPTNOps_include.f90:1898', &
          !              errst=errst)) return
      end do

      val = real(trace(Lmat%Li(1)), KIND=rKind)

      call destroy(Lmat%Li(1))
      deallocate(Lmat%Li)

  end subroutine meas_mpo_qlptnc_qmpoc

LPTNOps_f90.ptm_left_mpo_lptn_tensor_tensor()

fortran-subroutine - November 2017 (dj) Build transfer matrix for site between a state and a Hamiltonian (or MPO).

Arguments

MatTYPE(tensorlist), inout

On exit, new transfer matrix. If ‘Matin’ is not given, this is treated as incoming transfer matrix.

BraketTYPE(tensor), in

Represent the state of the LPTN on this site.

HmatTYPE(tensor), inout

Represents the Hamiltonian on this site.

rightmostLOGICAL, in

Flag if this is the first site. If true, there is no transfer matrix on the right.

MatinTYPE(tensorlist), OPTIONAL, in

Transfer matrix of the site to the right. Not referenced if rightmost is true.

Details

In contrast to the MPS method, the LPTN method only works for the same state.

Source Code

show / hide f90 code

  subroutine ptm_left_mpo_lptn_tensor_tensor(Mat, Braket, Hmat, &
                                                     rightmost, Matin, errst)
      type(tensorlist), intent(inout) :: Mat
      type(tensor), intent(inout) :: Braket
      type(sr_matrix_tensor), intent(inout) :: Hmat
      logical, intent(in) :: rightmost
      type(tensorlist), intent(inout), optional :: Matin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, kk

      ! shortcut to row/column bond dimension of MPO-matrix
      integer :: bd

      ! temporary tensors for contraction
      type(tensor), dimension(:), allocatable :: Tens
      type(tensor) :: Tmp

      !if(present(errst)) errst = 0

      if(rightmost) then
          ! Initialize
          ! ----------

          bd = Hmat%rbd
          allocate(Mat%Li(bd))

          call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensor_tensor'//&
          !              ': contr failed.', 'LPTNOps_include.f90:1996', &
          !              errst=errst)) return

          call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensor_tensor'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2001', &
          !              errst=errst)) return

          do kk = 1, bd
              call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
                         [1, 2], [1, 2], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensor_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2009', errst=errst)) return

          end do

          call destroy(Tmp)

          return
      end if

      ! 1) Contract transfer matrix Mat with Ket and then Bra
      ! -----------------------------------------------------

      bd = Hmat%cbd
      allocate(Tens(bd))

      if(present(Matin)) then
          do ii = 1, bd
              call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensor_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2029', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensor_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2035', errst=errst)) return

              call destroy(Tmp)

          end do
      else
          do ii = 1, bd
              call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensor_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2045', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensor_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2051', errst=errst)) return

              call destroy(Tmp)
              call destroy(Mat%Li(ii))
          end do

          deallocate(Mat%Li)
      end if

      do ii = 1, bd
          call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
                         errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensor_tensor'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2064', &
          !              errst=errst)) return
      end do

      ! 2) Contract MPO to final tensor
      ! -------------------------------

      bd = Hmat%rbd
      allocate(Mat%Li(bd))

      do kk = 1, bd
          call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensor_tensor'//&
          !              ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
          !              errst=errst)) return
      end do

      do kk = 1, Hmat%cbd
          call destroy(Tens(kk))
      end do

      deallocate(Tens)

  end subroutine ptm_left_mpo_lptn_tensor_tensor

LPTNOps_f90.ptm_left_mpo_lptn_tensorc_tensor()

fortran-subroutine - November 2017 (dj) Build transfer matrix for site between a state and a Hamiltonian (or MPO).

Arguments

MatTYPE(tensorlistc), inout

On exit, new transfer matrix. If ‘Matin’ is not given, this is treated as incoming transfer matrix.

BraketTYPE(tensorc), in

Represent the state of the LPTN on this site.

HmatTYPE(tensorc), inout

Represents the Hamiltonian on this site.

rightmostLOGICAL, in

Flag if this is the first site. If true, there is no transfer matrix on the right.

MatinTYPE(tensorlistc), OPTIONAL, in

Transfer matrix of the site to the right. Not referenced if rightmost is true.

Details

In contrast to the MPS method, the LPTN method only works for the same state.

Source Code

show / hide f90 code

  subroutine ptm_left_mpo_lptn_tensorc_tensor(Mat, Braket, Hmat, &
                                                     rightmost, Matin, errst)
      type(tensorlistc), intent(inout) :: Mat
      type(tensorc), intent(inout) :: Braket
      type(sr_matrix_tensor), intent(inout) :: Hmat
      logical, intent(in) :: rightmost
      type(tensorlistc), intent(inout), optional :: Matin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, kk

      ! shortcut to row/column bond dimension of MPO-matrix
      integer :: bd

      ! temporary tensors for contraction
      type(tensorc), dimension(:), allocatable :: Tens
      type(tensorc) :: Tmp

      !if(present(errst)) errst = 0

      if(rightmost) then
          ! Initialize
          ! ----------

          bd = Hmat%rbd
          allocate(Mat%Li(bd))

          call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensorc_tensor'//&
          !              ': contr failed.', 'LPTNOps_include.f90:1996', &
          !              errst=errst)) return

          call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensorc_tensor'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2001', &
          !              errst=errst)) return

          do kk = 1, bd
              call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
                         [1, 2], [1, 2], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2009', errst=errst)) return

          end do

          call destroy(Tmp)

          return
      end if

      ! 1) Contract transfer matrix Mat with Ket and then Bra
      ! -----------------------------------------------------

      bd = Hmat%cbd
      allocate(Tens(bd))

      if(present(Matin)) then
          do ii = 1, bd
              call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2029', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2035', errst=errst)) return

              call destroy(Tmp)

          end do
      else
          do ii = 1, bd
              call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2045', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensor: contr failed.', &
              !              'LPTNOps_include.f90:2051', errst=errst)) return

              call destroy(Tmp)
              call destroy(Mat%Li(ii))
          end do

          deallocate(Mat%Li)
      end if

      do ii = 1, bd
          call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
                         errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensorc_tensor'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2064', &
          !              errst=errst)) return
      end do

      ! 2) Contract MPO to final tensor
      ! -------------------------------

      bd = Hmat%rbd
      allocate(Mat%Li(bd))

      do kk = 1, bd
          call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensorc_tensor'//&
          !              ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
          !              errst=errst)) return
      end do

      do kk = 1, Hmat%cbd
          call destroy(Tens(kk))
      end do

      deallocate(Tens)

  end subroutine ptm_left_mpo_lptn_tensorc_tensor

LPTNOps_f90.ptm_left_mpo_lptn_tensorc_tensorc()

fortran-subroutine - November 2017 (dj) Build transfer matrix for site between a state and a Hamiltonian (or MPO).

Arguments

MatTYPE(tensorlistc), inout

On exit, new transfer matrix. If ‘Matin’ is not given, this is treated as incoming transfer matrix.

BraketTYPE(tensorc), in

Represent the state of the LPTN on this site.

HmatTYPE(tensorc), inout

Represents the Hamiltonian on this site.

rightmostLOGICAL, in

Flag if this is the first site. If true, there is no transfer matrix on the right.

MatinTYPE(tensorlistc), OPTIONAL, in

Transfer matrix of the site to the right. Not referenced if rightmost is true.

Details

In contrast to the MPS method, the LPTN method only works for the same state.

Source Code

show / hide f90 code

  subroutine ptm_left_mpo_lptn_tensorc_tensorc(Mat, Braket, Hmat, &
                                                     rightmost, Matin, errst)
      type(tensorlistc), intent(inout) :: Mat
      type(tensorc), intent(inout) :: Braket
      type(sr_matrix_tensorc), intent(inout) :: Hmat
      logical, intent(in) :: rightmost
      type(tensorlistc), intent(inout), optional :: Matin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, kk

      ! shortcut to row/column bond dimension of MPO-matrix
      integer :: bd

      ! temporary tensors for contraction
      type(tensorc), dimension(:), allocatable :: Tens
      type(tensorc) :: Tmp

      !if(present(errst)) errst = 0

      if(rightmost) then
          ! Initialize
          ! ----------

          bd = Hmat%rbd
          allocate(Mat%Li(bd))

          call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensorc_tensorc'//&
          !              ': contr failed.', 'LPTNOps_include.f90:1996', &
          !              errst=errst)) return

          call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensorc_tensorc'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2001', &
          !              errst=errst)) return

          do kk = 1, bd
              call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
                         [1, 2], [1, 2], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensorc: contr failed.', &
              !              'LPTNOps_include.f90:2009', errst=errst)) return

          end do

          call destroy(Tmp)

          return
      end if

      ! 1) Contract transfer matrix Mat with Ket and then Bra
      ! -----------------------------------------------------

      bd = Hmat%cbd
      allocate(Tens(bd))

      if(present(Matin)) then
          do ii = 1, bd
              call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensorc: contr failed.', &
              !              'LPTNOps_include.f90:2029', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensorc: contr failed.', &
              !              'LPTNOps_include.f90:2035', errst=errst)) return

              call destroy(Tmp)

          end do
      else
          do ii = 1, bd
              call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensorc: contr failed.', &
              !              'LPTNOps_include.f90:2045', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_tensorc_'//&
              !              'tensorc: contr failed.', &
              !              'LPTNOps_include.f90:2051', errst=errst)) return

              call destroy(Tmp)
              call destroy(Mat%Li(ii))
          end do

          deallocate(Mat%Li)
      end if

      do ii = 1, bd
          call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
                         errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensorc_tensorc'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2064', &
          !              errst=errst)) return
      end do

      ! 2) Contract MPO to final tensor
      ! -------------------------------

      bd = Hmat%rbd
      allocate(Mat%Li(bd))

      do kk = 1, bd
          call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_tensorc_tensorc'//&
          !              ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
          !              errst=errst)) return
      end do

      do kk = 1, Hmat%cbd
          call destroy(Tens(kk))
      end do

      deallocate(Tens)

  end subroutine ptm_left_mpo_lptn_tensorc_tensorc

LPTNOps_f90.ptm_left_mpo_lptn_qtensor_qtensor()

fortran-subroutine - November 2017 (dj) Build transfer matrix for site between a state and a Hamiltonian (or MPO).

Arguments

MatTYPE(qtensorlist), inout

On exit, new transfer matrix. If ‘Matin’ is not given, this is treated as incoming transfer matrix.

BraketTYPE(qtensor), in

Represent the state of the LPTN on this site.

HmatTYPE(qtensor), inout

Represents the Hamiltonian on this site.

rightmostLOGICAL, in

Flag if this is the first site. If true, there is no transfer matrix on the right.

MatinTYPE(qtensorlist), OPTIONAL, in

Transfer matrix of the site to the right. Not referenced if rightmost is true.

Details

In contrast to the MPS method, the LPTN method only works for the same state.

Source Code

show / hide f90 code

  subroutine ptm_left_mpo_lptn_qtensor_qtensor(Mat, Braket, Hmat, &
                                                     rightmost, Matin, errst)
      type(qtensorlist), intent(inout) :: Mat
      type(qtensor), intent(inout) :: Braket
      type(sr_matrix_qtensor), intent(inout) :: Hmat
      logical, intent(in) :: rightmost
      type(qtensorlist), intent(inout), optional :: Matin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, kk

      ! shortcut to row/column bond dimension of MPO-matrix
      integer :: bd

      ! temporary tensors for contraction
      type(qtensor), dimension(:), allocatable :: Tens
      type(qtensor) :: Tmp

      !if(present(errst)) errst = 0

      if(rightmost) then
          ! Initialize
          ! ----------

          bd = Hmat%rbd
          allocate(Mat%Li(bd))

          call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensor_qtensor'//&
          !              ': contr failed.', 'LPTNOps_include.f90:1996', &
          !              errst=errst)) return

          call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensor_qtensor'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2001', &
          !              errst=errst)) return

          do kk = 1, bd
              call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
                         [1, 2], [1, 2], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2009', errst=errst)) return

          end do

          call destroy(Tmp)

          return
      end if

      ! 1) Contract transfer matrix Mat with Ket and then Bra
      ! -----------------------------------------------------

      bd = Hmat%cbd
      allocate(Tens(bd))

      if(present(Matin)) then
          do ii = 1, bd
              call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2029', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2035', errst=errst)) return

              call destroy(Tmp)

          end do
      else
          do ii = 1, bd
              call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2045', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensor_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2051', errst=errst)) return

              call destroy(Tmp)
              call destroy(Mat%Li(ii))
          end do

          deallocate(Mat%Li)
      end if

      do ii = 1, bd
          call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
                         errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensor_qtensor'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2064', &
          !              errst=errst)) return
      end do

      ! 2) Contract MPO to final tensor
      ! -------------------------------

      bd = Hmat%rbd
      allocate(Mat%Li(bd))

      do kk = 1, bd
          call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensor_qtensor'//&
          !              ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
          !              errst=errst)) return
      end do

      do kk = 1, Hmat%cbd
          call destroy(Tens(kk))
      end do

      deallocate(Tens)

  end subroutine ptm_left_mpo_lptn_qtensor_qtensor

LPTNOps_f90.ptm_left_mpo_lptn_qtensorc_qtensor()

fortran-subroutine - November 2017 (dj) Build transfer matrix for site between a state and a Hamiltonian (or MPO).

Arguments

MatTYPE(qtensorclist), inout

On exit, new transfer matrix. If ‘Matin’ is not given, this is treated as incoming transfer matrix.

BraketTYPE(qtensorc), in

Represent the state of the LPTN on this site.

HmatTYPE(qtensorc), inout

Represents the Hamiltonian on this site.

rightmostLOGICAL, in

Flag if this is the first site. If true, there is no transfer matrix on the right.

MatinTYPE(qtensorclist), OPTIONAL, in

Transfer matrix of the site to the right. Not referenced if rightmost is true.

Details

In contrast to the MPS method, the LPTN method only works for the same state.

Source Code

show / hide f90 code

  subroutine ptm_left_mpo_lptn_qtensorc_qtensor(Mat, Braket, Hmat, &
                                                     rightmost, Matin, errst)
      type(qtensorclist), intent(inout) :: Mat
      type(qtensorc), intent(inout) :: Braket
      type(sr_matrix_qtensor), intent(inout) :: Hmat
      logical, intent(in) :: rightmost
      type(qtensorclist), intent(inout), optional :: Matin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, kk

      ! shortcut to row/column bond dimension of MPO-matrix
      integer :: bd

      ! temporary tensors for contraction
      type(qtensorc), dimension(:), allocatable :: Tens
      type(qtensorc) :: Tmp

      !if(present(errst)) errst = 0

      if(rightmost) then
          ! Initialize
          ! ----------

          bd = Hmat%rbd
          allocate(Mat%Li(bd))

          call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensor'//&
          !              ': contr failed.', 'LPTNOps_include.f90:1996', &
          !              errst=errst)) return

          call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensor'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2001', &
          !              errst=errst)) return

          do kk = 1, bd
              call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
                         [1, 2], [1, 2], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2009', errst=errst)) return

          end do

          call destroy(Tmp)

          return
      end if

      ! 1) Contract transfer matrix Mat with Ket and then Bra
      ! -----------------------------------------------------

      bd = Hmat%cbd
      allocate(Tens(bd))

      if(present(Matin)) then
          do ii = 1, bd
              call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2029', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2035', errst=errst)) return

              call destroy(Tmp)

          end do
      else
          do ii = 1, bd
              call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2045', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensor: contr failed.', &
              !              'LPTNOps_include.f90:2051', errst=errst)) return

              call destroy(Tmp)
              call destroy(Mat%Li(ii))
          end do

          deallocate(Mat%Li)
      end if

      do ii = 1, bd
          call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
                         errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensor'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2064', &
          !              errst=errst)) return
      end do

      ! 2) Contract MPO to final tensor
      ! -------------------------------

      bd = Hmat%rbd
      allocate(Mat%Li(bd))

      do kk = 1, bd
          call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensor'//&
          !              ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
          !              errst=errst)) return
      end do

      do kk = 1, Hmat%cbd
          call destroy(Tens(kk))
      end do

      deallocate(Tens)

  end subroutine ptm_left_mpo_lptn_qtensorc_qtensor

LPTNOps_f90.ptm_left_mpo_lptn_qtensorc_qtensorc()

fortran-subroutine - November 2017 (dj) Build transfer matrix for site between a state and a Hamiltonian (or MPO).

Arguments

MatTYPE(qtensorclist), inout

On exit, new transfer matrix. If ‘Matin’ is not given, this is treated as incoming transfer matrix.

BraketTYPE(qtensorc), in

Represent the state of the LPTN on this site.

HmatTYPE(qtensorc), inout

Represents the Hamiltonian on this site.

rightmostLOGICAL, in

Flag if this is the first site. If true, there is no transfer matrix on the right.

MatinTYPE(qtensorclist), OPTIONAL, in

Transfer matrix of the site to the right. Not referenced if rightmost is true.

Details

In contrast to the MPS method, the LPTN method only works for the same state.

Source Code

show / hide f90 code

  subroutine ptm_left_mpo_lptn_qtensorc_qtensorc(Mat, Braket, Hmat, &
                                                     rightmost, Matin, errst)
      type(qtensorclist), intent(inout) :: Mat
      type(qtensorc), intent(inout) :: Braket
      type(sr_matrix_qtensorc), intent(inout) :: Hmat
      logical, intent(in) :: rightmost
      type(qtensorclist), intent(inout), optional :: Matin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, kk

      ! shortcut to row/column bond dimension of MPO-matrix
      integer :: bd

      ! temporary tensors for contraction
      type(qtensorc), dimension(:), allocatable :: Tens
      type(qtensorc) :: Tmp

      !if(present(errst)) errst = 0

      if(rightmost) then
          ! Initialize
          ! ----------

          bd = Hmat%rbd
          allocate(Mat%Li(bd))

          call contr(Tmp, Braket, [3, 4], [3, 4], transr='C', errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensorc'//&
          !              ': contr failed.', 'LPTNOps_include.f90:1996', &
          !              errst=errst)) return

          call transposed(Tmp, [4, 2, 1, 3], doperm=.true., errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensorc'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2001', &
          !              errst=errst)) return

          do kk = 1, bd
              call contr(Mat%Li(kk), Tmp, Hmat%Row(kk)%Op(1), &
                         [1, 2], [1, 2], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensorc: contr failed.', &
              !              'LPTNOps_include.f90:2009', errst=errst)) return

          end do

          call destroy(Tmp)

          return
      end if

      ! 1) Contract transfer matrix Mat with Ket and then Bra
      ! -----------------------------------------------------

      bd = Hmat%cbd
      allocate(Tens(bd))

      if(present(Matin)) then
          do ii = 1, bd
              call contr(Tmp, Braket, Matin%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensorc: contr failed.', &
              !              'LPTNOps_include.f90:2029', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensorc: contr failed.', &
              !              'LPTNOps_include.f90:2035', errst=errst)) return

              call destroy(Tmp)

          end do
      else
          do ii = 1, bd
              call contr(Tmp, Braket, Mat%Li(ii), [4], [1], errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensorc: contr failed.', &
              !              'LPTNOps_include.f90:2045', errst=errst)) return

              call contr(Tens(ii), Tmp, Braket, [3, 4], [3, 4], transr='C', &
                         errst=errst)
              !if(prop_error('ptm_left_mpo_lptn_qtensorc_'//&
              !              'qtensorc: contr failed.', &
              !              'LPTNOps_include.f90:2051', errst=errst)) return

              call destroy(Tmp)
              call destroy(Mat%Li(ii))
          end do

          deallocate(Mat%Li)
      end if

      do ii = 1, bd
          call transposed(Tens(ii), [4, 2, 1, 3], doperm=.true., &
                         errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensorc'//&
          !              ': transpose failed.', 'LPTNOps_include.f90:2064', &
          !              errst=errst)) return
      end do

      ! 2) Contract MPO to final tensor
      ! -------------------------------

      bd = Hmat%rbd
      allocate(Mat%Li(bd))

      do kk = 1, bd
          call contractmpol_lptn(Mat%Li(kk), kk, Hmat, Tens, errst=errst)
          !if(prop_error('ptm_left_mpo_lptn_qtensorc_qtensorc'//&
          !              ': contractmpol_lptn failed.', 'LPTNOps_include.f90:2077', &
          !              errst=errst)) return
      end do

      do kk = 1, Hmat%cbd
          call destroy(Tens(kk))
      end do

      deallocate(Tens)

  end subroutine ptm_left_mpo_lptn_qtensorc_qtensorc

LPTNOps_f90.norm_lptn()

fortran-function - September 2017 (dj) Calculate the norm of the density matrix defined as the trace.

Arguments

RhoTYPE(lptn), in

Rho is density matrix represented as LPTN with an orthogonality center.

Source Code

show / hide f90 code

  function norm_lptn(Rho, errst) result(res)
      type(lptn), intent(in) :: Rho
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: res

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

      ! copy due to permutation etc
      type(tensor) :: Rt

      call rho_kk(Rt, Rho, Rho%oc, errst=errst)
      !if(prop_error('norm_lptn : rho_kk failed.', &
      !              errst=errst)) return

      res = real(trace(Rt), KIND=rKind)

      call destroy(Rt)

  end function norm_lptn

LPTNOps_f90.norm_lptnc()

fortran-function - September 2017 (dj) Calculate the norm of the density matrix defined as the trace.

Arguments

RhoTYPE(lptnc), in

Rho is density matrix represented as LPTN with an orthogonality center.

Source Code

show / hide f90 code

  function norm_lptnc(Rho, errst) result(res)
      type(lptnc), intent(in) :: Rho
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: res

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

      ! copy due to permutation etc
      type(tensorc) :: Rt

      call rho_kk(Rt, Rho, Rho%oc, errst=errst)
      !if(prop_error('norm_lptnc : rho_kk failed.', &
      !              errst=errst)) return

      res = real(trace(Rt), KIND=rKind)

      call destroy(Rt)

  end function norm_lptnc

LPTNOps_f90.norm_qlptn()

fortran-function - September 2017 (dj) Calculate the norm of the density matrix defined as the trace.

Arguments

RhoTYPE(qlptn), in

Rho is density matrix represented as LPTN with an orthogonality center.

Source Code

show / hide f90 code

  function norm_qlptn(Rho, errst) result(res)
      type(qlptn), intent(in) :: Rho
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: res

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

      ! copy due to permutation etc
      type(qtensor) :: Rt

      call rho_kk(Rt, Rho, Rho%oc, errst=errst)
      !if(prop_error('norm_qlptn : rho_kk failed.', &
      !              errst=errst)) return

      res = real(trace(Rt), KIND=rKind)

      call destroy(Rt)

  end function norm_qlptn

LPTNOps_f90.norm_qlptnc()

fortran-function - September 2017 (dj) Calculate the norm of the density matrix defined as the trace.

Arguments

RhoTYPE(qlptnc), in

Rho is density matrix represented as LPTN with an orthogonality center.

Source Code

show / hide f90 code

  function norm_qlptnc(Rho, errst) result(res)
      type(qlptnc), intent(in) :: Rho
      integer, intent(out), optional :: errst
      real(KIND=rKind) :: res

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

      ! copy due to permutation etc
      type(qtensorc) :: Rt

      call rho_kk(Rt, Rho, Rho%oc, errst=errst)
      !if(prop_error('norm_qlptnc : rho_kk failed.', &
      !              errst=errst)) return

      res = real(trace(Rt), KIND=rKind)

      call destroy(Rt)

  end function norm_qlptnc

LPTNOps_f90.randomize_lptn()

fortran-subroutine - September 2014 (dj) Fill the tensors of a LPTN with random number.

Arguments

RhoTYPE(lptn), inout

Fill the tensor of each site with random number. This operations destroys gauges/isometry.

Source Code

show / hide f90 code

  subroutine randomize_lptn(Rho)
      type(lptn), intent(inout) :: Rho

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

      ! for looping
      integer :: ii

      ! Canonical form will be destroyed
      Rho%oc = -1
      Rho%can = 'o'

      ! Fill with random number
      do ii = 1, Rho%ll
          call randomize(Rho%AA(ii))
      end do

  end subroutine randomize_lptn

LPTNOps_f90.randomize_lptnc()

fortran-subroutine - September 2014 (dj) Fill the tensors of a LPTN with random number.

Arguments

RhoTYPE(lptnc), inout

Fill the tensor of each site with random number. This operations destroys gauges/isometry.

Source Code

show / hide f90 code

  subroutine randomize_lptnc(Rho)
      type(lptnc), intent(inout) :: Rho

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

      ! for looping
      integer :: ii

      ! Canonical form will be destroyed
      Rho%oc = -1
      Rho%can = 'o'

      ! Fill with random number
      do ii = 1, Rho%ll
          call randomize(Rho%AA(ii))
      end do

  end subroutine randomize_lptnc

LPTNOps_f90.randomize_qlptn()

fortran-subroutine - September 2014 (dj) Fill the tensors of a LPTN with random number.

Arguments

RhoTYPE(qlptn), inout

Fill the tensor of each site with random number. This operations destroys gauges/isometry.

Source Code

show / hide f90 code

  subroutine randomize_qlptn(Rho)
      type(qlptn), intent(inout) :: Rho

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

      ! for looping
      integer :: ii

      ! Canonical form will be destroyed
      Rho%oc = -1
      Rho%can = 'o'

      ! Fill with random number
      do ii = 1, Rho%ll
          call randomize(Rho%AA(ii))
      end do

  end subroutine randomize_qlptn

LPTNOps_f90.randomize_qlptnc()

fortran-subroutine - September 2014 (dj) Fill the tensors of a LPTN with random number.

Arguments

RhoTYPE(qlptnc), inout

Fill the tensor of each site with random number. This operations destroys gauges/isometry.

Source Code

show / hide f90 code

  subroutine randomize_qlptnc(Rho)
      type(qlptnc), intent(inout) :: Rho

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

      ! for looping
      integer :: ii

      ! Canonical form will be destroyed
      Rho%oc = -1
      Rho%can = 'o'

      ! Fill with random number
      do ii = 1, Rho%ll
          call randomize(Rho%AA(ii))
      end do

  end subroutine randomize_qlptnc

LPTNOps_f90.read_lptn()

fortran-subroutine - June 2016 (dj, updated) Read an LPTN given a filename and a unit (assuming you know the type already).

Arguments

RhoTYPE(lptn), in

Read LPTN in file to this LPTN

flnmCHARACTER(100), in

the LPTN is stored in this file.

unitINTEGER, in

open file on this unit

formCHARACTER, in

Binary (‘B’) or human readable (‘H’)

skipLOGICAL, OPTIONAL, in

.true. : the first two lines were already read somewhere. Do not read them here (those lines contain the information about the type of the LPTN in the file, real/complex, no symm/symmetries). Default to .false.

errflagINTEGER, out

0 : could read LPTN; 1 : type of LPTN does not correspond type of the LPTN in the file (only checked for skip1st2=false).

Details

The file for LPTN has the general form defined as below. Following these rules, it is possible to provide states to OpenLPTN. * logical if LPTN is real or complex valued (real=True, complex=False) [line 1] * logical if LPTN or qLPTN (qLPTN=True, non-symmetry LPTN=False) [line 2] * integer with number of size [line 3] * integer with position of the orthogonality center [line 4] * “H” : in a loop over the pairs of haslambda and can are written in l lines. “B” : the array of can is read, then haslambda. * In a loop over the sites of the system, the tensors of the LPTN are written. The way how to write the tensors is specified in the corresponding subroutine. * Depending on the value of haslambda, read the vector (vectorlist) with the corresponding subroutine.

Source Code

show / hide f90 code

  subroutine read_lptn(Rho, flnm, unit, form, skip, errst)
      type(lptn), intent(out) :: Rho
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! set the type of the LPTN
      logical :: is_real, is_q

      ! duplette for optional arguments
      logical :: skip_

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      if(present(skip)) then
          skip_ = skip
      else
          skip_ = .false.
      end if

      if(form == 'H') then
          ! Read the formatted file
          ! -----------------------

          if(.not. skip_) then
              open(UNIT=unit, FILE=trim(flnm), ACTION='read')
              read(unit, *) is_real
              read(unit, *) is_q

              if((is_real .eqv. .true.) .and. &
                 (is_q .eqv. .false.)) then
                  ! Everything is ok
              else
                  !errst = raise_error('read_lptn: type mismatch.', &
                  !                    99, errst=errst)
                  return
              end if
          !else
              ! Assume the user knows what he is doing and everything is ok.
          end if

          ! Read length and orthogonality center
          read(unit, *) Rho%ll
          read(unit, *) Rho%oc
          allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
                   Rho%Lambda(Rho%ll + 1))

          ! Read the canonization toghether with the haslambda
          do ii = 1, Rho%ll
              read(unit, *) Rho%can(ii), Rho%haslambda(ii)
          end do
          read(unit, *) Rho%haslambda(Rho%ll + 1)

          ! Read the tensors of the LPTN
          do ii = 1, Rho%ll
              call read(Rho%Aa(ii), unit, form)
          end do

          ! Read the values of the lambda
          do ii = 1, Rho%ll
              if(Rho%haslambda(ii)) then
                  call read(Rho%Lambda(ii), unit, form)
              end if
          end do

      elseif(form == 'B') then
          ! Read from the binary file
          ! -------------------------

          if(.not. skip_) then
              open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
                   FORM='unformatted')
              read(unit) is_real
              read(unit) is_q

              if((is_real .eqv. .true.) .and. &
                 (is_q .eqv. .false.)) then
                  ! Everything is ok
              else
                  !errst = raise_error('read_lptn: type mismatch.', &
                  !                    99, errst=errst)
                  return
              end if
          !else
              ! Assume the user knows what he is doing and everything is ok.
          end if

          ! Read length and orthogonality center
          read(unit) Rho%ll
          read(unit) Rho%oc
          allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
                   Rho%Lambda(Rho%ll + 1))

          ! Read the canonization and the haslambda as array
          read(unit) Rho%can
          read(unit) Rho%haslambda

          ! Read all the tensors
          do ii = 1, Rho%ll
              call read(Rho%Aa(ii), unit, form)
          end do

          ! Read the lambdas
          do ii = 1, Rho%ll
              if(Rho%haslambda(ii)) then
                  call read(Rho%lambda(ii), unit, form)
              end if
          end do

      else
          !errst = raise_error('read_lptn: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      close(unit)

  end subroutine read_lptn

LPTNOps_f90.read_lptnc()

fortran-subroutine - June 2016 (dj, updated) Read an LPTN given a filename and a unit (assuming you know the type already).

Arguments

RhoTYPE(lptnc), in

Read LPTN in file to this LPTN

flnmCHARACTER(100), in

the LPTN is stored in this file.

unitINTEGER, in

open file on this unit

formCHARACTER, in

Binary (‘B’) or human readable (‘H’)

skipLOGICAL, OPTIONAL, in

.true. : the first two lines were already read somewhere. Do not read them here (those lines contain the information about the type of the LPTN in the file, real/complex, no symm/symmetries). Default to .false.

errflagINTEGER, out

0 : could read LPTN; 1 : type of LPTN does not correspond type of the LPTN in the file (only checked for skip1st2=false).

Details

The file for LPTN has the general form defined as below. Following these rules, it is possible to provide states to OpenLPTN. * logical if LPTN is real or complex valued (real=True, complex=False) [line 1] * logical if LPTN or qLPTN (qLPTN=True, non-symmetry LPTN=False) [line 2] * integer with number of size [line 3] * integer with position of the orthogonality center [line 4] * “H” : in a loop over the pairs of haslambda and can are written in l lines. “B” : the array of can is read, then haslambda. * In a loop over the sites of the system, the tensors of the LPTN are written. The way how to write the tensors is specified in the corresponding subroutine. * Depending on the value of haslambda, read the vector (vectorlist) with the corresponding subroutine.

Source Code

show / hide f90 code

  subroutine read_lptnc(Rho, flnm, unit, form, skip, errst)
      type(lptnc), intent(out) :: Rho
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! set the type of the LPTN
      logical :: is_real, is_q

      ! duplette for optional arguments
      logical :: skip_

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      if(present(skip)) then
          skip_ = skip
      else
          skip_ = .false.
      end if

      if(form == 'H') then
          ! Read the formatted file
          ! -----------------------

          if(.not. skip_) then
              open(UNIT=unit, FILE=trim(flnm), ACTION='read')
              read(unit, *) is_real
              read(unit, *) is_q

              if((is_real .eqv. .false.) .and. &
                 (is_q .eqv. .false.)) then
                  ! Everything is ok
              else
                  !errst = raise_error('read_lptnc: type mismatch.', &
                  !                    99, errst=errst)
                  return
              end if
          !else
              ! Assume the user knows what he is doing and everything is ok.
          end if

          ! Read length and orthogonality center
          read(unit, *) Rho%ll
          read(unit, *) Rho%oc
          allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
                   Rho%Lambda(Rho%ll + 1))

          ! Read the canonization toghether with the haslambda
          do ii = 1, Rho%ll
              read(unit, *) Rho%can(ii), Rho%haslambda(ii)
          end do
          read(unit, *) Rho%haslambda(Rho%ll + 1)

          ! Read the tensors of the LPTN
          do ii = 1, Rho%ll
              call read(Rho%Aa(ii), unit, form)
          end do

          ! Read the values of the lambda
          do ii = 1, Rho%ll
              if(Rho%haslambda(ii)) then
                  call read(Rho%Lambda(ii), unit, form)
              end if
          end do

      elseif(form == 'B') then
          ! Read from the binary file
          ! -------------------------

          if(.not. skip_) then
              open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
                   FORM='unformatted')
              read(unit) is_real
              read(unit) is_q

              if((is_real .eqv. .false.) .and. &
                 (is_q .eqv. .false.)) then
                  ! Everything is ok
              else
                  !errst = raise_error('read_lptnc: type mismatch.', &
                  !                    99, errst=errst)
                  return
              end if
          !else
              ! Assume the user knows what he is doing and everything is ok.
          end if

          ! Read length and orthogonality center
          read(unit) Rho%ll
          read(unit) Rho%oc
          allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
                   Rho%Lambda(Rho%ll + 1))

          ! Read the canonization and the haslambda as array
          read(unit) Rho%can
          read(unit) Rho%haslambda

          ! Read all the tensors
          do ii = 1, Rho%ll
              call read(Rho%Aa(ii), unit, form)
          end do

          ! Read the lambdas
          do ii = 1, Rho%ll
              if(Rho%haslambda(ii)) then
                  call read(Rho%lambda(ii), unit, form)
              end if
          end do

      else
          !errst = raise_error('read_lptnc: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      close(unit)

  end subroutine read_lptnc

LPTNOps_f90.read_qlptn()

fortran-subroutine - June 2016 (dj, updated) Read an LPTN given a filename and a unit (assuming you know the type already).

Arguments

RhoTYPE(qlptn), in

Read LPTN in file to this LPTN

flnmCHARACTER(100), in

the LPTN is stored in this file.

unitINTEGER, in

open file on this unit

formCHARACTER, in

Binary (‘B’) or human readable (‘H’)

skipLOGICAL, OPTIONAL, in

.true. : the first two lines were already read somewhere. Do not read them here (those lines contain the information about the type of the LPTN in the file, real/complex, no symm/symmetries). Default to .false.

errflagINTEGER, out

0 : could read LPTN; 1 : type of LPTN does not correspond type of the LPTN in the file (only checked for skip1st2=false).

Details

The file for LPTN has the general form defined as below. Following these rules, it is possible to provide states to OpenLPTN. * logical if LPTN is real or complex valued (real=True, complex=False) [line 1] * logical if LPTN or qLPTN (qLPTN=True, non-symmetry LPTN=False) [line 2] * integer with number of size [line 3] * integer with position of the orthogonality center [line 4] * “H” : in a loop over the pairs of haslambda and can are written in l lines. “B” : the array of can is read, then haslambda. * In a loop over the sites of the system, the tensors of the LPTN are written. The way how to write the tensors is specified in the corresponding subroutine. * Depending on the value of haslambda, read the vector (vectorlist) with the corresponding subroutine.

Source Code

show / hide f90 code

  subroutine read_qlptn(Rho, flnm, unit, form, skip, errst)
      type(qlptn), intent(out) :: Rho
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! set the type of the LPTN
      logical :: is_real, is_q

      ! duplette for optional arguments
      logical :: skip_

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      if(present(skip)) then
          skip_ = skip
      else
          skip_ = .false.
      end if

      if(form == 'H') then
          ! Read the formatted file
          ! -----------------------

          if(.not. skip_) then
              open(UNIT=unit, FILE=trim(flnm), ACTION='read')
              read(unit, *) is_real
              read(unit, *) is_q

              if((is_real .eqv. .true.) .and. &
                 (is_q .eqv. .true.)) then
                  ! Everything is ok
              else
                  !errst = raise_error('read_qlptn: type mismatch.', &
                  !                    99, errst=errst)
                  return
              end if
          !else
              ! Assume the user knows what he is doing and everything is ok.
          end if

          ! Read length and orthogonality center
          read(unit, *) Rho%ll
          read(unit, *) Rho%oc
          allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
                   Rho%Lambda(Rho%ll + 1))

          ! Read the canonization toghether with the haslambda
          do ii = 1, Rho%ll
              read(unit, *) Rho%can(ii), Rho%haslambda(ii)
          end do
          read(unit, *) Rho%haslambda(Rho%ll + 1)

          ! Read the tensors of the LPTN
          do ii = 1, Rho%ll
              call read(Rho%Aa(ii), unit, form)
          end do

          ! Read the values of the lambda
          do ii = 1, Rho%ll
              if(Rho%haslambda(ii)) then
                  call read(Rho%Lambda(ii), unit, form)
              end if
          end do

      elseif(form == 'B') then
          ! Read from the binary file
          ! -------------------------

          if(.not. skip_) then
              open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
                   FORM='unformatted')
              read(unit) is_real
              read(unit) is_q

              if((is_real .eqv. .true.) .and. &
                 (is_q .eqv. .true.)) then
                  ! Everything is ok
              else
                  !errst = raise_error('read_qlptn: type mismatch.', &
                  !                    99, errst=errst)
                  return
              end if
          !else
              ! Assume the user knows what he is doing and everything is ok.
          end if

          ! Read length and orthogonality center
          read(unit) Rho%ll
          read(unit) Rho%oc
          allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
                   Rho%Lambda(Rho%ll + 1))

          ! Read the canonization and the haslambda as array
          read(unit) Rho%can
          read(unit) Rho%haslambda

          ! Read all the tensors
          do ii = 1, Rho%ll
              call read(Rho%Aa(ii), unit, form)
          end do

          ! Read the lambdas
          do ii = 1, Rho%ll
              if(Rho%haslambda(ii)) then
                  call read(Rho%lambda(ii), unit, form)
              end if
          end do

      else
          !errst = raise_error('read_qlptn: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      close(unit)

  end subroutine read_qlptn

LPTNOps_f90.read_qlptnc()

fortran-subroutine - June 2016 (dj, updated) Read an LPTN given a filename and a unit (assuming you know the type already).

Arguments

RhoTYPE(qlptnc), in

Read LPTN in file to this LPTN

flnmCHARACTER(100), in

the LPTN is stored in this file.

unitINTEGER, in

open file on this unit

formCHARACTER, in

Binary (‘B’) or human readable (‘H’)

skipLOGICAL, OPTIONAL, in

.true. : the first two lines were already read somewhere. Do not read them here (those lines contain the information about the type of the LPTN in the file, real/complex, no symm/symmetries). Default to .false.

errflagINTEGER, out

0 : could read LPTN; 1 : type of LPTN does not correspond type of the LPTN in the file (only checked for skip1st2=false).

Details

The file for LPTN has the general form defined as below. Following these rules, it is possible to provide states to OpenLPTN. * logical if LPTN is real or complex valued (real=True, complex=False) [line 1] * logical if LPTN or qLPTN (qLPTN=True, non-symmetry LPTN=False) [line 2] * integer with number of size [line 3] * integer with position of the orthogonality center [line 4] * “H” : in a loop over the pairs of haslambda and can are written in l lines. “B” : the array of can is read, then haslambda. * In a loop over the sites of the system, the tensors of the LPTN are written. The way how to write the tensors is specified in the corresponding subroutine. * Depending on the value of haslambda, read the vector (vectorlist) with the corresponding subroutine.

Source Code

show / hide f90 code

  subroutine read_qlptnc(Rho, flnm, unit, form, skip, errst)
      type(qlptnc), intent(out) :: Rho
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! set the type of the LPTN
      logical :: is_real, is_q

      ! duplette for optional arguments
      logical :: skip_

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      if(present(skip)) then
          skip_ = skip
      else
          skip_ = .false.
      end if

      if(form == 'H') then
          ! Read the formatted file
          ! -----------------------

          if(.not. skip_) then
              open(UNIT=unit, FILE=trim(flnm), ACTION='read')
              read(unit, *) is_real
              read(unit, *) is_q

              if((is_real .eqv. .false.) .and. &
                 (is_q .eqv. .true.)) then
                  ! Everything is ok
              else
                  !errst = raise_error('read_qlptnc: type mismatch.', &
                  !                    99, errst=errst)
                  return
              end if
          !else
              ! Assume the user knows what he is doing and everything is ok.
          end if

          ! Read length and orthogonality center
          read(unit, *) Rho%ll
          read(unit, *) Rho%oc
          allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
                   Rho%Lambda(Rho%ll + 1))

          ! Read the canonization toghether with the haslambda
          do ii = 1, Rho%ll
              read(unit, *) Rho%can(ii), Rho%haslambda(ii)
          end do
          read(unit, *) Rho%haslambda(Rho%ll + 1)

          ! Read the tensors of the LPTN
          do ii = 1, Rho%ll
              call read(Rho%Aa(ii), unit, form)
          end do

          ! Read the values of the lambda
          do ii = 1, Rho%ll
              if(Rho%haslambda(ii)) then
                  call read(Rho%Lambda(ii), unit, form)
              end if
          end do

      elseif(form == 'B') then
          ! Read from the binary file
          ! -------------------------

          if(.not. skip_) then
              open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
                   FORM='unformatted')
              read(unit) is_real
              read(unit) is_q

              if((is_real .eqv. .false.) .and. &
                 (is_q .eqv. .true.)) then
                  ! Everything is ok
              else
                  !errst = raise_error('read_qlptnc: type mismatch.', &
                  !                    99, errst=errst)
                  return
              end if
          !else
              ! Assume the user knows what he is doing and everything is ok.
          end if

          ! Read length and orthogonality center
          read(unit) Rho%ll
          read(unit) Rho%oc
          allocate(Rho%can(Rho%ll), Rho%haslambda(Rho%ll + 1), Rho%Aa(Rho%ll), &
                   Rho%Lambda(Rho%ll + 1))

          ! Read the canonization and the haslambda as array
          read(unit) Rho%can
          read(unit) Rho%haslambda

          ! Read all the tensors
          do ii = 1, Rho%ll
              call read(Rho%Aa(ii), unit, form)
          end do

          ! Read the lambdas
          do ii = 1, Rho%ll
              if(Rho%haslambda(ii)) then
                  call read(Rho%lambda(ii), unit, form)
              end if
          end do

      else
          !errst = raise_error('read_qlptnc: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      close(unit)

  end subroutine read_qlptnc

LPTNOps_f90.rho_kk_lptn()

fortran-subroutine - September 2017 (dj) Calculate the reduced density matrix represented as tensor.

Arguments

RhokkTYPE(tensor), out

The density matrix is stored in this tensor

RhoTYPE(lptn), in

Calculate reduced density matrix for this LPTN.

kkINTEGER, in

Select site where reduced density matrix should be calculated. It must be the orthogonality center.

Source Code

show / hide f90 code

  subroutine rho_kk_lptn(Rhokk, Rho, kk, errst)
      type(tensor), intent(out) :: Rhokk
      type(lptn), intent(in) :: Rho
      integer, intent(in) :: kk
      integer, intent(out), optional :: errst

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

      ! copy due to permutation etc
      type(tensor) :: Tens, Tensc

      !if(present(errst)) errst = 0

      call copy(Tens, Rho%Aa(kk))
      call copy(Tensc, Rho%Aa(kk))

      call contr(Rhokk, Tens, Tensc, [1, 3, 4], [1, 3, 4], transl='C')

      call destroy(Tens)
      call destroy(Tensc)

      ! Set hashes for rho
      !call set_hash(Rhokk, [1])
      !call sort(Rhokk)

  end subroutine rho_kk_lptn

LPTNOps_f90.rho_kk_lptnc()

fortran-subroutine - September 2017 (dj) Calculate the reduced density matrix represented as tensor.

Arguments

RhokkTYPE(tensorc), out

The density matrix is stored in this tensor

RhoTYPE(lptnc), in

Calculate reduced density matrix for this LPTN.

kkINTEGER, in

Select site where reduced density matrix should be calculated. It must be the orthogonality center.

Source Code

show / hide f90 code

  subroutine rho_kk_lptnc(Rhokk, Rho, kk, errst)
      type(tensorc), intent(out) :: Rhokk
      type(lptnc), intent(in) :: Rho
      integer, intent(in) :: kk
      integer, intent(out), optional :: errst

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

      ! copy due to permutation etc
      type(tensorc) :: Tens, Tensc

      !if(present(errst)) errst = 0

      call copy(Tens, Rho%Aa(kk))
      call copy(Tensc, Rho%Aa(kk))

      call contr(Rhokk, Tens, Tensc, [1, 3, 4], [1, 3, 4], transl='C')

      call destroy(Tens)
      call destroy(Tensc)

      ! Set hashes for rho
      !call set_hash(Rhokk, [1])
      !call sort(Rhokk)

  end subroutine rho_kk_lptnc

LPTNOps_f90.rho_kk_qlptn()

fortran-subroutine - September 2017 (dj) Calculate the reduced density matrix represented as tensor.

Arguments

RhokkTYPE(qtensor), out

The density matrix is stored in this tensor

RhoTYPE(qlptn), in

Calculate reduced density matrix for this LPTN.

kkINTEGER, in

Select site where reduced density matrix should be calculated. It must be the orthogonality center.

Source Code

show / hide f90 code

  subroutine rho_kk_qlptn(Rhokk, Rho, kk, errst)
      type(qtensor), intent(out) :: Rhokk
      type(qlptn), intent(in) :: Rho
      integer, intent(in) :: kk
      integer, intent(out), optional :: errst

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

      ! copy due to permutation etc
      type(qtensor) :: Tens, Tensc

      !if(present(errst)) errst = 0

      call copy(Tens, Rho%Aa(kk))
      call copy(Tensc, Rho%Aa(kk))

      call contr(Rhokk, Tens, Tensc, [1, 3, 4], [1, 3, 4], transl='C')

      call destroy(Tens)
      call destroy(Tensc)

      ! Set hashes for rho
      call set_hash(Rhokk, [1])
      call sort(Rhokk)

  end subroutine rho_kk_qlptn

LPTNOps_f90.rho_kk_qlptnc()

fortran-subroutine - September 2017 (dj) Calculate the reduced density matrix represented as tensor.

Arguments

RhokkTYPE(qtensorc), out

The density matrix is stored in this tensor

RhoTYPE(qlptnc), in

Calculate reduced density matrix for this LPTN.

kkINTEGER, in

Select site where reduced density matrix should be calculated. It must be the orthogonality center.

Source Code

show / hide f90 code

  subroutine rho_kk_qlptnc(Rhokk, Rho, kk, errst)
      type(qtensorc), intent(out) :: Rhokk
      type(qlptnc), intent(in) :: Rho
      integer, intent(in) :: kk
      integer, intent(out), optional :: errst

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

      ! copy due to permutation etc
      type(qtensorc) :: Tens, Tensc

      !if(present(errst)) errst = 0

      call copy(Tens, Rho%Aa(kk))
      call copy(Tensc, Rho%Aa(kk))

      call contr(Rhokk, Tens, Tensc, [1, 3, 4], [1, 3, 4], transl='C')

      call destroy(Tens)
      call destroy(Tensc)

      ! Set hashes for rho
      call set_hash(Rhokk, [1])
      call sort(Rhokk)

  end subroutine rho_kk_qlptnc

LPTNOps_f90.rhoij_init_lptn_tensor()

fortran-subroutine - September 2017 (dj) Initialize the measurement for the two-site density matrix, i.e., building the left overlap leaving the local Hilbert space uncontractred.

Arguments

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_lptn_tensor(Tenskk, Theta)
      type(tensor), intent(inout) :: Tenskk
      type(tensor), intent(out) :: Theta

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

      ! copy due to permutation
      type(tensor) :: Tmp

      call copy(Tmp, Tenskk)
      call contr(Theta, Tmp, [1, 3], [1, 3], transr='C', permout=[1, 3, 2, 4])

      call destroy(Tmp)

  end subroutine rhoij_init_lptn_tensor

LPTNOps_f90.rhoij_init_lptn_tensorc()

fortran-subroutine - September 2017 (dj) Initialize the measurement for the two-site density matrix, i.e., building the left overlap leaving the local Hilbert space uncontractred.

Arguments

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_lptn_tensorc(Tenskk, Theta)
      type(tensorc), intent(inout) :: Tenskk
      type(tensorc), intent(out) :: Theta

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

      ! copy due to permutation
      type(tensorc) :: Tmp

      call copy(Tmp, Tenskk)
      call contr(Theta, Tmp, [1, 3], [1, 3], transr='C', permout=[1, 3, 2, 4])

      call destroy(Tmp)

  end subroutine rhoij_init_lptn_tensorc

LPTNOps_f90.rhoij_init_lptn_qtensor()

fortran-subroutine - September 2017 (dj) Initialize the measurement for the two-site density matrix, i.e., building the left overlap leaving the local Hilbert space uncontractred.

Arguments

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_lptn_qtensor(Tenskk, Theta)
      type(qtensor), intent(inout) :: Tenskk
      type(qtensor), intent(out) :: Theta

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

      ! copy due to permutation
      type(qtensor) :: Tmp

      call copy(Tmp, Tenskk)
      call contr(Theta, Tmp, [1, 3], [1, 3], transr='C', permout=[1, 3, 2, 4])

      call destroy(Tmp)

  end subroutine rhoij_init_lptn_qtensor

LPTNOps_f90.rhoij_init_lptn_qtensorc()

fortran-subroutine - September 2017 (dj) Initialize the measurement for the two-site density matrix, i.e., building the left overlap leaving the local Hilbert space uncontractred.

Arguments

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_lptn_qtensorc(Tenskk, Theta)
      type(qtensorc), intent(inout) :: Tenskk
      type(qtensorc), intent(out) :: Theta

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

      ! copy due to permutation
      type(qtensorc) :: Tmp

      call copy(Tmp, Tenskk)
      call contr(Theta, Tmp, [1, 3], [1, 3], transr='C', permout=[1, 3, 2, 4])

      call destroy(Tmp)

  end subroutine rhoij_init_lptn_qtensorc

LPTNOps_f90.rhoij_meas_lptn_tensor_tensor()

fortran-subroutine - September 2017 (dj) Measure two-site reduced density matrix for sites i and j and propagate for the next measurement.

Arguments

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_lptn_tensor_tensor(Rhosij, Tensjj, ii, jj, ll, &
       Theta, PhaseOp, hasphase, skip, errst)
      type(tensor), dimension(:, :), intent(inout) :: Rhosij
      type(tensor), intent(inout) :: Tensjj
      integer, intent(in) :: ii, jj, ll
      type(tensor), intent(inout) :: Theta
      type(tensor), intent(inout) :: PhaseOp
      logical, intent(in) :: hasphase
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! duplicate of optional argument
      logical :: skip_

      ! temporary tensors
      type(tensor) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      skip_ = .false.
      if(present(skip)) skip_ = skip

      ! 1) Calculate density matrix i, j with i < j
      ! -------------------------------------------

      if(.not. skip_) then
          call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
          call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
                     permout=[1, 3, 2, 4])
          call destroy(Tmpa)
      end if

      ! 2) Propagate for the next sites
      ! -------------------------------

      if((jj < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
          call destroy(Tmpa)

          ! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
          call copy(Tmpa, Tensjj)
          call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
          call destroy(Tmpa)
          call destroy(Tmpb)
      elseif(jj < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy
          call destroy(Theta)
      end if

  end subroutine rhoij_meas_lptn_tensor_tensor

LPTNOps_f90.rhoij_meas_lptn_tensorc_tensor()

fortran-subroutine - September 2017 (dj) Measure two-site reduced density matrix for sites i and j and propagate for the next measurement.

Arguments

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_lptn_tensorc_tensor(Rhosij, Tensjj, ii, jj, ll, &
       Theta, PhaseOp, hasphase, skip, errst)
      type(tensorc), dimension(:, :), intent(inout) :: Rhosij
      type(tensorc), intent(inout) :: Tensjj
      integer, intent(in) :: ii, jj, ll
      type(tensorc), intent(inout) :: Theta
      type(tensor), intent(inout) :: PhaseOp
      logical, intent(in) :: hasphase
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! duplicate of optional argument
      logical :: skip_

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      skip_ = .false.
      if(present(skip)) skip_ = skip

      ! 1) Calculate density matrix i, j with i < j
      ! -------------------------------------------

      if(.not. skip_) then
          call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
          call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
                     permout=[1, 3, 2, 4])
          call destroy(Tmpa)
      end if

      ! 2) Propagate for the next sites
      ! -------------------------------

      if((jj < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
          call destroy(Tmpa)

          ! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
          call copy(Tmpa, Tensjj)
          call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
          call destroy(Tmpa)
          call destroy(Tmpb)
      elseif(jj < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy
          call destroy(Theta)
      end if

  end subroutine rhoij_meas_lptn_tensorc_tensor

LPTNOps_f90.rhoij_meas_lptn_tensorc_tensorc()

fortran-subroutine - September 2017 (dj) Measure two-site reduced density matrix for sites i and j and propagate for the next measurement.

Arguments

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_lptn_tensorc_tensorc(Rhosij, Tensjj, ii, jj, ll, &
       Theta, PhaseOp, hasphase, skip, errst)
      type(tensorc), dimension(:, :), intent(inout) :: Rhosij
      type(tensorc), intent(inout) :: Tensjj
      integer, intent(in) :: ii, jj, ll
      type(tensorc), intent(inout) :: Theta
      type(tensorc), intent(inout) :: PhaseOp
      logical, intent(in) :: hasphase
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! duplicate of optional argument
      logical :: skip_

      ! temporary tensors
      type(tensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      skip_ = .false.
      if(present(skip)) skip_ = skip

      ! 1) Calculate density matrix i, j with i < j
      ! -------------------------------------------

      if(.not. skip_) then
          call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
          call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
                     permout=[1, 3, 2, 4])
          call destroy(Tmpa)
      end if

      ! 2) Propagate for the next sites
      ! -------------------------------

      if((jj < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
          call destroy(Tmpa)

          ! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
          call copy(Tmpa, Tensjj)
          call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
          call destroy(Tmpa)
          call destroy(Tmpb)
      elseif(jj < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy
          call destroy(Theta)
      end if

  end subroutine rhoij_meas_lptn_tensorc_tensorc

LPTNOps_f90.rhoij_meas_lptn_qtensor_qtensor()

fortran-subroutine - September 2017 (dj) Measure two-site reduced density matrix for sites i and j and propagate for the next measurement.

Arguments

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_lptn_qtensor_qtensor(Rhosij, Tensjj, ii, jj, ll, &
       Theta, PhaseOp, hasphase, skip, errst)
      type(qtensor), dimension(:, :), intent(inout) :: Rhosij
      type(qtensor), intent(inout) :: Tensjj
      integer, intent(in) :: ii, jj, ll
      type(qtensor), intent(inout) :: Theta
      type(qtensor), intent(inout) :: PhaseOp
      logical, intent(in) :: hasphase
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! duplicate of optional argument
      logical :: skip_

      ! temporary tensors
      type(qtensor) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      skip_ = .false.
      if(present(skip)) skip_ = skip

      ! 1) Calculate density matrix i, j with i < j
      ! -------------------------------------------

      if(.not. skip_) then
          call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
          call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
                     permout=[1, 3, 2, 4])
          call destroy(Tmpa)
      end if

      ! 2) Propagate for the next sites
      ! -------------------------------

      if((jj < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
          call destroy(Tmpa)

          ! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
          call copy(Tmpa, Tensjj)
          call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
          call destroy(Tmpa)
          call destroy(Tmpb)
      elseif(jj < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy
          call destroy(Theta)
      end if

  end subroutine rhoij_meas_lptn_qtensor_qtensor

LPTNOps_f90.rhoij_meas_lptn_qtensorc_qtensor()

fortran-subroutine - September 2017 (dj) Measure two-site reduced density matrix for sites i and j and propagate for the next measurement.

Arguments

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_lptn_qtensorc_qtensor(Rhosij, Tensjj, ii, jj, ll, &
       Theta, PhaseOp, hasphase, skip, errst)
      type(qtensorc), dimension(:, :), intent(inout) :: Rhosij
      type(qtensorc), intent(inout) :: Tensjj
      integer, intent(in) :: ii, jj, ll
      type(qtensorc), intent(inout) :: Theta
      type(qtensor), intent(inout) :: PhaseOp
      logical, intent(in) :: hasphase
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! duplicate of optional argument
      logical :: skip_

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      skip_ = .false.
      if(present(skip)) skip_ = skip

      ! 1) Calculate density matrix i, j with i < j
      ! -------------------------------------------

      if(.not. skip_) then
          call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
          call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
                     permout=[1, 3, 2, 4])
          call destroy(Tmpa)
      end if

      ! 2) Propagate for the next sites
      ! -------------------------------

      if((jj < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
          call destroy(Tmpa)

          ! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
          call copy(Tmpa, Tensjj)
          call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
          call destroy(Tmpa)
          call destroy(Tmpb)
      elseif(jj < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy
          call destroy(Theta)
      end if

  end subroutine rhoij_meas_lptn_qtensorc_qtensor

LPTNOps_f90.rhoij_meas_lptn_qtensorc_qtensorc()

fortran-subroutine - September 2017 (dj) Measure two-site reduced density matrix for sites i and j and propagate for the next measurement.

Arguments

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_lptn_qtensorc_qtensorc(Rhosij, Tensjj, ii, jj, ll, &
       Theta, PhaseOp, hasphase, skip, errst)
      type(qtensorc), dimension(:, :), intent(inout) :: Rhosij
      type(qtensorc), intent(inout) :: Tensjj
      integer, intent(in) :: ii, jj, ll
      type(qtensorc), intent(inout) :: Theta
      type(qtensorc), intent(inout) :: PhaseOp
      logical, intent(in) :: hasphase
      logical, intent(in), optional :: skip
      integer, intent(out), optional :: errst

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

      ! duplicate of optional argument
      logical :: skip_

      ! temporary tensors
      type(qtensorc) :: Tmpa, Tmpb

      !if(present(errst)) errst = 0

      skip_ = .false.
      if(present(skip)) skip_ = skip

      ! 1) Calculate density matrix i, j with i < j
      ! -------------------------------------------

      if(.not. skip_) then
          call contr(Tmpa, Tensjj, [3, 4], [3, 4], transr='C')
          call contr(Rhosij(ii, jj), Theta, Tmpa, [3, 4], [1, 3], &
                     permout=[1, 3, 2, 4])
          call destroy(Tmpa)
      end if

      ! 2) Propagate for the next sites
      ! -------------------------------

      if((jj < ll) .and. hasphase) then
          ! Has a phase operator to be contracted
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Tmpb, Tmpa, PhaseOp, [4], [2])
          call destroy(Tmpa)

          ! Tmpb has ket-bra-chibra-kappa-chiket'-ldket
          call copy(Tmpa, Tensjj)
          call contr(Theta, Tmpb, Tmpa, [3, 4, 6], [1, 3, 2], transr='C')
          call destroy(Tmpa)
          call destroy(Tmpb)
      elseif(jj < ll) then
          ! No phase
          call contr(Tmpa, Theta, Tensjj, [3], [1])
          call destroy(Theta)

          ! Tmpa has ket-bra-chibra-ldket-kappa-chiket'
          call contr(Theta, Tmpa, Tensjj, [3, 4, 5], [1, 2, 3], transr='C')
          call destroy(Tmpa)
      else
          ! Destroy
          call destroy(Theta)
      end if

  end subroutine rhoij_meas_lptn_qtensorc_qtensorc

LPTNOps_f90.rho_red_lptn()

fortran-subroutine - June 2018 (dj) Build a general reduced density matrix on multiple sites.

Arguments

RedTYPE(tensor), out

On exit the reduced density matrix with the sites specified. The first half of the indices corresponds to the kets on each site. The second half corresponds to the bra-indices.

RhoTYPE(lptn), in

LPTN to build reduced density matrix from.

sitesINTEGER(*), in

List of sites for the reduced density matrix.

contLOGICAL, in

Indicator if sites are one continuous block of indices (true) or separated by indices to be traced out (false).

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

errREAL, out

Truncation error for tracking it from calling routine.

Source Code

show / hide f90 code

  subroutine rho_red_lptn(Red, Rho, sites, cont, trunc, ncut, err, errst)
      type(tensor), intent(out) :: Red
      type(lptn), intent(inout) :: Rho
      integer, dimension(:), intent(in) :: sites
      logical, intent(in) :: cont
      real(KIND=rKind), intent(in) :: trunc
      integer, intent(in) :: ncut
      real(KIND=rKind), intent(out) :: err
      integer, intent(out), optional :: errst

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

      ! for looping / indexing
      integer :: ii, jj, kk, jsub

      ! next site kept
      integer :: next

      ! number of sites kept
      integer :: nn

      ! for permutation of indices
      integer, dimension(:), allocatable :: perm

      ! temporary tensors
      type(tensor) :: Tmp, Tmpb, Tmpc

      !if(present(errst)) errst = 0

      ! Set error - always zero as no permutation needed
      err = 0.0_rKind

      nn = size(sites, 1)

      ! 1) Initialize / first site
      ! ==========================

      kk = 1
      next = sites(kk)

      if(next == 1) then
          call copy(Tmpb, Rho%Aa(1))
          call copy(Tmpc, Rho%Aa(1), trans='C')

          call contr(Tmp, Tmpb, Tmpc, [1, 3], [1, 3], errst=errst)
          !if(prop_error('rho_red_lptn : contr failed.', &
          !              'LPTNOps_include.f90:2724', errst=errst)) return

          call destroy(Tmpb)
          call destroy(Tmpc)

          kk = kk + 1
          if(kk > nn) then
              next = -1
          else
              next = sites(kk)
          end if

          jj = 3
      else
          call copy(Tmpc, Rho%Aa(1), trans='C')

          call contr(Tmp, Rho%Aa(1), Tmpc, [1, 2, 3], [1, 2, 3], errst=errst)
          !if(prop_error('rho_red_lptn : contr failed.', &
          !              'LPTNOps_include.f90:2742', errst=errst)) return

          call destroy(Tmpc)

          jj = 1
      end if

      ! 2) Loop over sites in the bulk of the system
      ! ============================================

      do ii = 2, (Rho%ll - 1)
          if(next == ii) then
              ! Keep this site
              ! --------------

              ! Contract tensor from last step
              call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
              !if(prop_error('rho_red_lptn : contr failed.', &
              !              'LPTNOps_include.f90:2760', errst=errst)) return

              call destroy(Tmp)
              call copy(Tmpc, Rho%Aa(ii), trans='C')

              call contr(Tmp, Tmpb, Tmpc, [jj, jj + 2], [1, 3], &
                         errst=errst)
              !if(prop_error('rho_red_lptn : contr failed.', &
              !              'LPTNOps_include.f90:2768', errst=errst)) return

              ! Have to permute local indices and links to next neighbor
              allocate(perm(jj + 3))
              perm = [(jsub, jsub = 1, jj + 3)]
              perm(jj + 2) = jj + 1
              perm(jj + 1) = jj + 2

              call transposed(Tmp, perm, doperm=.true., errst=errst)
              !if(prop_error('rho_red_lptn : transposed failed.', &
              !              'LPTNOps_include.f90:2778', errst=errst)) return

              deallocate(perm)
          else
              ! Trace this site out
              ! -------------------

              ! Contract tensor from last step
              call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
              !if(prop_error('rho_red_lptn : contr failed.', &
              !              'LPTNOps_include.f90:2788', errst=errst)) return

              call destroy(Tmp)
              call copy(Tmpc, Rho%Aa(ii), trans='C')

              call contr(Tmp, Tmpb, Tmpc, [jj, jj + 1, jj + 2], [1, 2, 3], &
                         errst=errst)
              !if(prop_error('rho_red_lptn : contr failed.', &
              !              'LPTNOps_include.f90:2796', errst=errst)) return

              call destroy(Tmpb)
              call destroy(Tmpc)
          end if
      end do

      ! 3) Finalize / last site
      ! =======================

      ii = Rho%ll

      if(ii == next) then
          ! Keep this site
          ! --------------

          call copy(Tmpc, Rho%Aa(ii), trans='C')
          call contr(Tmpb, Rho%Aa(ii), Tmpc, [3, 4], [3, 4], errst=errst)
          !if(prop_error('rho_red_lptn : contr failed.', &
          !              'LPTNOps_include.f90:2815', errst=errst)) return

          call destroy(Tmpc)

          call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 3], errst=errst)
          !if(prop_error('rho_red_lptn : contr failed.', &
          !              'LPTNOps_include.f90:2821', errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpb)
      else
          ! Trace this site out
          ! -------------------

          call copy(Tmpc, Rho%Aa(ii), trans='C')
          call contr(Tmpb, Rho%Aa(ii), Tmpc, [2, 3, 4], [2, 3, 4], errst=errst)
          !if(prop_error('rho_red_lptn : contr failed.', &
          !              'LPTNOps_include.f90:2832', errst=errst)) return

          call destroy(Tmpc)

          call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 2], errst=errst)
          !if(prop_error('rho_red_lptn : contr failed.', &
          !              'LPTNOps_include.f90:2838', errst=errst)) return
      end if

      ! Grouping ket and bra indices together

      allocate(perm(2 * nn))

      perm(:nn) = [(2 * ii - 1, ii = 1, nn)]
      perm(nn + 1:) = [(2 * ii, ii = 1, nn)]

      call transposed(Red, perm, doperm=.true., errst=errst)
      !if(prop_error('rho_red_MPDO_TYPE : transposed failed.', &
      !              'LPTNOps_include.f90:2850', errst=errst)) return            

      deallocate(perm)

      ! Access intentionally unused variables needed for compliance with
      ! MPS interface
      !if(cont) kk = 1
      !if(trunc < 0.0_rKind) kk = 2
      !if(ncut < 0) kk = 3

  end subroutine rho_red_lptn

LPTNOps_f90.rho_red_lptnc()

fortran-subroutine - June 2018 (dj) Build a general reduced density matrix on multiple sites.

Arguments

RedTYPE(tensorc), out

On exit the reduced density matrix with the sites specified. The first half of the indices corresponds to the kets on each site. The second half corresponds to the bra-indices.

RhoTYPE(lptnc), in

LPTN to build reduced density matrix from.

sitesINTEGER(*), in

List of sites for the reduced density matrix.

contLOGICAL, in

Indicator if sites are one continuous block of indices (true) or separated by indices to be traced out (false).

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

errREAL, out

Truncation error for tracking it from calling routine.

Source Code

show / hide f90 code

  subroutine rho_red_lptnc(Red, Rho, sites, cont, trunc, ncut, err, errst)
      type(tensorc), intent(out) :: Red
      type(lptnc), intent(inout) :: Rho
      integer, dimension(:), intent(in) :: sites
      logical, intent(in) :: cont
      real(KIND=rKind), intent(in) :: trunc
      integer, intent(in) :: ncut
      real(KIND=rKind), intent(out) :: err
      integer, intent(out), optional :: errst

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

      ! for looping / indexing
      integer :: ii, jj, kk, jsub

      ! next site kept
      integer :: next

      ! number of sites kept
      integer :: nn

      ! for permutation of indices
      integer, dimension(:), allocatable :: perm

      ! temporary tensors
      type(tensorc) :: Tmp, Tmpb, Tmpc

      !if(present(errst)) errst = 0

      ! Set error - always zero as no permutation needed
      err = 0.0_rKind

      nn = size(sites, 1)

      ! 1) Initialize / first site
      ! ==========================

      kk = 1
      next = sites(kk)

      if(next == 1) then
          call copy(Tmpb, Rho%Aa(1))
          call copy(Tmpc, Rho%Aa(1), trans='C')

          call contr(Tmp, Tmpb, Tmpc, [1, 3], [1, 3], errst=errst)
          !if(prop_error('rho_red_lptnc : contr failed.', &
          !              'LPTNOps_include.f90:2724', errst=errst)) return

          call destroy(Tmpb)
          call destroy(Tmpc)

          kk = kk + 1
          if(kk > nn) then
              next = -1
          else
              next = sites(kk)
          end if

          jj = 3
      else
          call copy(Tmpc, Rho%Aa(1), trans='C')

          call contr(Tmp, Rho%Aa(1), Tmpc, [1, 2, 3], [1, 2, 3], errst=errst)
          !if(prop_error('rho_red_lptnc : contr failed.', &
          !              'LPTNOps_include.f90:2742', errst=errst)) return

          call destroy(Tmpc)

          jj = 1
      end if

      ! 2) Loop over sites in the bulk of the system
      ! ============================================

      do ii = 2, (Rho%ll - 1)
          if(next == ii) then
              ! Keep this site
              ! --------------

              ! Contract tensor from last step
              call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
              !if(prop_error('rho_red_lptnc : contr failed.', &
              !              'LPTNOps_include.f90:2760', errst=errst)) return

              call destroy(Tmp)
              call copy(Tmpc, Rho%Aa(ii), trans='C')

              call contr(Tmp, Tmpb, Tmpc, [jj, jj + 2], [1, 3], &
                         errst=errst)
              !if(prop_error('rho_red_lptnc : contr failed.', &
              !              'LPTNOps_include.f90:2768', errst=errst)) return

              ! Have to permute local indices and links to next neighbor
              allocate(perm(jj + 3))
              perm = [(jsub, jsub = 1, jj + 3)]
              perm(jj + 2) = jj + 1
              perm(jj + 1) = jj + 2

              call transposed(Tmp, perm, doperm=.true., errst=errst)
              !if(prop_error('rho_red_lptnc : transposed failed.', &
              !              'LPTNOps_include.f90:2778', errst=errst)) return

              deallocate(perm)
          else
              ! Trace this site out
              ! -------------------

              ! Contract tensor from last step
              call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
              !if(prop_error('rho_red_lptnc : contr failed.', &
              !              'LPTNOps_include.f90:2788', errst=errst)) return

              call destroy(Tmp)
              call copy(Tmpc, Rho%Aa(ii), trans='C')

              call contr(Tmp, Tmpb, Tmpc, [jj, jj + 1, jj + 2], [1, 2, 3], &
                         errst=errst)
              !if(prop_error('rho_red_lptnc : contr failed.', &
              !              'LPTNOps_include.f90:2796', errst=errst)) return

              call destroy(Tmpb)
              call destroy(Tmpc)
          end if
      end do

      ! 3) Finalize / last site
      ! =======================

      ii = Rho%ll

      if(ii == next) then
          ! Keep this site
          ! --------------

          call copy(Tmpc, Rho%Aa(ii), trans='C')
          call contr(Tmpb, Rho%Aa(ii), Tmpc, [3, 4], [3, 4], errst=errst)
          !if(prop_error('rho_red_lptnc : contr failed.', &
          !              'LPTNOps_include.f90:2815', errst=errst)) return

          call destroy(Tmpc)

          call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 3], errst=errst)
          !if(prop_error('rho_red_lptnc : contr failed.', &
          !              'LPTNOps_include.f90:2821', errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpb)
      else
          ! Trace this site out
          ! -------------------

          call copy(Tmpc, Rho%Aa(ii), trans='C')
          call contr(Tmpb, Rho%Aa(ii), Tmpc, [2, 3, 4], [2, 3, 4], errst=errst)
          !if(prop_error('rho_red_lptnc : contr failed.', &
          !              'LPTNOps_include.f90:2832', errst=errst)) return

          call destroy(Tmpc)

          call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 2], errst=errst)
          !if(prop_error('rho_red_lptnc : contr failed.', &
          !              'LPTNOps_include.f90:2838', errst=errst)) return
      end if

      ! Grouping ket and bra indices together

      allocate(perm(2 * nn))

      perm(:nn) = [(2 * ii - 1, ii = 1, nn)]
      perm(nn + 1:) = [(2 * ii, ii = 1, nn)]

      call transposed(Red, perm, doperm=.true., errst=errst)
      !if(prop_error('rho_red_MPDO_TYPE : transposed failed.', &
      !              'LPTNOps_include.f90:2850', errst=errst)) return            

      deallocate(perm)

      ! Access intentionally unused variables needed for compliance with
      ! MPS interface
      !if(cont) kk = 1
      !if(trunc < 0.0_rKind) kk = 2
      !if(ncut < 0) kk = 3

  end subroutine rho_red_lptnc

LPTNOps_f90.rho_red_qlptn()

fortran-subroutine - June 2018 (dj) Build a general reduced density matrix on multiple sites.

Arguments

RedTYPE(qtensor), out

On exit the reduced density matrix with the sites specified. The first half of the indices corresponds to the kets on each site. The second half corresponds to the bra-indices.

RhoTYPE(qlptn), in

LPTN to build reduced density matrix from.

sitesINTEGER(*), in

List of sites for the reduced density matrix.

contLOGICAL, in

Indicator if sites are one continuous block of indices (true) or separated by indices to be traced out (false).

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

errREAL, out

Truncation error for tracking it from calling routine.

Source Code

show / hide f90 code

  subroutine rho_red_qlptn(Red, Rho, sites, cont, trunc, ncut, err, errst)
      type(qtensor), intent(out) :: Red
      type(qlptn), intent(inout) :: Rho
      integer, dimension(:), intent(in) :: sites
      logical, intent(in) :: cont
      real(KIND=rKind), intent(in) :: trunc
      integer, intent(in) :: ncut
      real(KIND=rKind), intent(out) :: err
      integer, intent(out), optional :: errst

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

      ! for looping / indexing
      integer :: ii, jj, kk, jsub

      ! next site kept
      integer :: next

      ! number of sites kept
      integer :: nn

      ! for permutation of indices
      integer, dimension(:), allocatable :: perm

      ! temporary tensors
      type(qtensor) :: Tmp, Tmpb, Tmpc

      !if(present(errst)) errst = 0

      ! Set error - always zero as no permutation needed
      err = 0.0_rKind

      nn = size(sites, 1)

      ! 1) Initialize / first site
      ! ==========================

      kk = 1
      next = sites(kk)

      if(next == 1) then
          call copy(Tmpb, Rho%Aa(1))
          call copy(Tmpc, Rho%Aa(1), trans='C')

          call contr(Tmp, Tmpb, Tmpc, [1, 3], [1, 3], errst=errst)
          !if(prop_error('rho_red_qlptn : contr failed.', &
          !              'LPTNOps_include.f90:2724', errst=errst)) return

          call destroy(Tmpb)
          call destroy(Tmpc)

          kk = kk + 1
          if(kk > nn) then
              next = -1
          else
              next = sites(kk)
          end if

          jj = 3
      else
          call copy(Tmpc, Rho%Aa(1), trans='C')

          call contr(Tmp, Rho%Aa(1), Tmpc, [1, 2, 3], [1, 2, 3], errst=errst)
          !if(prop_error('rho_red_qlptn : contr failed.', &
          !              'LPTNOps_include.f90:2742', errst=errst)) return

          call destroy(Tmpc)

          jj = 1
      end if

      ! 2) Loop over sites in the bulk of the system
      ! ============================================

      do ii = 2, (Rho%ll - 1)
          if(next == ii) then
              ! Keep this site
              ! --------------

              ! Contract tensor from last step
              call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
              !if(prop_error('rho_red_qlptn : contr failed.', &
              !              'LPTNOps_include.f90:2760', errst=errst)) return

              call destroy(Tmp)
              call copy(Tmpc, Rho%Aa(ii), trans='C')

              call contr(Tmp, Tmpb, Tmpc, [jj, jj + 2], [1, 3], &
                         errst=errst)
              !if(prop_error('rho_red_qlptn : contr failed.', &
              !              'LPTNOps_include.f90:2768', errst=errst)) return

              ! Have to permute local indices and links to next neighbor
              allocate(perm(jj + 3))
              perm = [(jsub, jsub = 1, jj + 3)]
              perm(jj + 2) = jj + 1
              perm(jj + 1) = jj + 2

              call transposed(Tmp, perm, doperm=.true., errst=errst)
              !if(prop_error('rho_red_qlptn : transposed failed.', &
              !              'LPTNOps_include.f90:2778', errst=errst)) return

              deallocate(perm)
          else
              ! Trace this site out
              ! -------------------

              ! Contract tensor from last step
              call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
              !if(prop_error('rho_red_qlptn : contr failed.', &
              !              'LPTNOps_include.f90:2788', errst=errst)) return

              call destroy(Tmp)
              call copy(Tmpc, Rho%Aa(ii), trans='C')

              call contr(Tmp, Tmpb, Tmpc, [jj, jj + 1, jj + 2], [1, 2, 3], &
                         errst=errst)
              !if(prop_error('rho_red_qlptn : contr failed.', &
              !              'LPTNOps_include.f90:2796', errst=errst)) return

              call destroy(Tmpb)
              call destroy(Tmpc)
          end if
      end do

      ! 3) Finalize / last site
      ! =======================

      ii = Rho%ll

      if(ii == next) then
          ! Keep this site
          ! --------------

          call copy(Tmpc, Rho%Aa(ii), trans='C')
          call contr(Tmpb, Rho%Aa(ii), Tmpc, [3, 4], [3, 4], errst=errst)
          !if(prop_error('rho_red_qlptn : contr failed.', &
          !              'LPTNOps_include.f90:2815', errst=errst)) return

          call destroy(Tmpc)

          call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 3], errst=errst)
          !if(prop_error('rho_red_qlptn : contr failed.', &
          !              'LPTNOps_include.f90:2821', errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpb)
      else
          ! Trace this site out
          ! -------------------

          call copy(Tmpc, Rho%Aa(ii), trans='C')
          call contr(Tmpb, Rho%Aa(ii), Tmpc, [2, 3, 4], [2, 3, 4], errst=errst)
          !if(prop_error('rho_red_qlptn : contr failed.', &
          !              'LPTNOps_include.f90:2832', errst=errst)) return

          call destroy(Tmpc)

          call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 2], errst=errst)
          !if(prop_error('rho_red_qlptn : contr failed.', &
          !              'LPTNOps_include.f90:2838', errst=errst)) return
      end if

      ! Grouping ket and bra indices together

      allocate(perm(2 * nn))

      perm(:nn) = [(2 * ii - 1, ii = 1, nn)]
      perm(nn + 1:) = [(2 * ii, ii = 1, nn)]

      call transposed(Red, perm, doperm=.true., errst=errst)
      !if(prop_error('rho_red_MPDO_TYPE : transposed failed.', &
      !              'LPTNOps_include.f90:2850', errst=errst)) return            

      deallocate(perm)

      ! Access intentionally unused variables needed for compliance with
      ! MPS interface
      !if(cont) kk = 1
      !if(trunc < 0.0_rKind) kk = 2
      !if(ncut < 0) kk = 3

  end subroutine rho_red_qlptn

LPTNOps_f90.rho_red_qlptnc()

fortran-subroutine - June 2018 (dj) Build a general reduced density matrix on multiple sites.

Arguments

RedTYPE(qtensorc), out

On exit the reduced density matrix with the sites specified. The first half of the indices corresponds to the kets on each site. The second half corresponds to the bra-indices.

RhoTYPE(qlptnc), in

LPTN to build reduced density matrix from.

sitesINTEGER(*), in

List of sites for the reduced density matrix.

contLOGICAL, in

Indicator if sites are one continuous block of indices (true) or separated by indices to be traced out (false).

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for MPS). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

errREAL, out

Truncation error for tracking it from calling routine.

Source Code

show / hide f90 code

  subroutine rho_red_qlptnc(Red, Rho, sites, cont, trunc, ncut, err, errst)
      type(qtensorc), intent(out) :: Red
      type(qlptnc), intent(inout) :: Rho
      integer, dimension(:), intent(in) :: sites
      logical, intent(in) :: cont
      real(KIND=rKind), intent(in) :: trunc
      integer, intent(in) :: ncut
      real(KIND=rKind), intent(out) :: err
      integer, intent(out), optional :: errst

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

      ! for looping / indexing
      integer :: ii, jj, kk, jsub

      ! next site kept
      integer :: next

      ! number of sites kept
      integer :: nn

      ! for permutation of indices
      integer, dimension(:), allocatable :: perm

      ! temporary tensors
      type(qtensorc) :: Tmp, Tmpb, Tmpc

      !if(present(errst)) errst = 0

      ! Set error - always zero as no permutation needed
      err = 0.0_rKind

      nn = size(sites, 1)

      ! 1) Initialize / first site
      ! ==========================

      kk = 1
      next = sites(kk)

      if(next == 1) then
          call copy(Tmpb, Rho%Aa(1))
          call copy(Tmpc, Rho%Aa(1), trans='C')

          call contr(Tmp, Tmpb, Tmpc, [1, 3], [1, 3], errst=errst)
          !if(prop_error('rho_red_qlptnc : contr failed.', &
          !              'LPTNOps_include.f90:2724', errst=errst)) return

          call destroy(Tmpb)
          call destroy(Tmpc)

          kk = kk + 1
          if(kk > nn) then
              next = -1
          else
              next = sites(kk)
          end if

          jj = 3
      else
          call copy(Tmpc, Rho%Aa(1), trans='C')

          call contr(Tmp, Rho%Aa(1), Tmpc, [1, 2, 3], [1, 2, 3], errst=errst)
          !if(prop_error('rho_red_qlptnc : contr failed.', &
          !              'LPTNOps_include.f90:2742', errst=errst)) return

          call destroy(Tmpc)

          jj = 1
      end if

      ! 2) Loop over sites in the bulk of the system
      ! ============================================

      do ii = 2, (Rho%ll - 1)
          if(next == ii) then
              ! Keep this site
              ! --------------

              ! Contract tensor from last step
              call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
              !if(prop_error('rho_red_qlptnc : contr failed.', &
              !              'LPTNOps_include.f90:2760', errst=errst)) return

              call destroy(Tmp)
              call copy(Tmpc, Rho%Aa(ii), trans='C')

              call contr(Tmp, Tmpb, Tmpc, [jj, jj + 2], [1, 3], &
                         errst=errst)
              !if(prop_error('rho_red_qlptnc : contr failed.', &
              !              'LPTNOps_include.f90:2768', errst=errst)) return

              ! Have to permute local indices and links to next neighbor
              allocate(perm(jj + 3))
              perm = [(jsub, jsub = 1, jj + 3)]
              perm(jj + 2) = jj + 1
              perm(jj + 1) = jj + 2

              call transposed(Tmp, perm, doperm=.true., errst=errst)
              !if(prop_error('rho_red_qlptnc : transposed failed.', &
              !              'LPTNOps_include.f90:2778', errst=errst)) return

              deallocate(perm)
          else
              ! Trace this site out
              ! -------------------

              ! Contract tensor from last step
              call contr(Tmpb, Tmp, Rho%Aa(ii), [jj], [1], errst=errst)
              !if(prop_error('rho_red_qlptnc : contr failed.', &
              !              'LPTNOps_include.f90:2788', errst=errst)) return

              call destroy(Tmp)
              call copy(Tmpc, Rho%Aa(ii), trans='C')

              call contr(Tmp, Tmpb, Tmpc, [jj, jj + 1, jj + 2], [1, 2, 3], &
                         errst=errst)
              !if(prop_error('rho_red_qlptnc : contr failed.', &
              !              'LPTNOps_include.f90:2796', errst=errst)) return

              call destroy(Tmpb)
              call destroy(Tmpc)
          end if
      end do

      ! 3) Finalize / last site
      ! =======================

      ii = Rho%ll

      if(ii == next) then
          ! Keep this site
          ! --------------

          call copy(Tmpc, Rho%Aa(ii), trans='C')
          call contr(Tmpb, Rho%Aa(ii), Tmpc, [3, 4], [3, 4], errst=errst)
          !if(prop_error('rho_red_qlptnc : contr failed.', &
          !              'LPTNOps_include.f90:2815', errst=errst)) return

          call destroy(Tmpc)

          call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 3], errst=errst)
          !if(prop_error('rho_red_qlptnc : contr failed.', &
          !              'LPTNOps_include.f90:2821', errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpb)
      else
          ! Trace this site out
          ! -------------------

          call copy(Tmpc, Rho%Aa(ii), trans='C')
          call contr(Tmpb, Rho%Aa(ii), Tmpc, [2, 3, 4], [2, 3, 4], errst=errst)
          !if(prop_error('rho_red_qlptnc : contr failed.', &
          !              'LPTNOps_include.f90:2832', errst=errst)) return

          call destroy(Tmpc)

          call contr(Red, Tmp, Tmpb, [jj, jj + 1], [1, 2], errst=errst)
          !if(prop_error('rho_red_qlptnc : contr failed.', &
          !              'LPTNOps_include.f90:2838', errst=errst)) return
      end if

      ! Grouping ket and bra indices together

      allocate(perm(2 * nn))

      perm(:nn) = [(2 * ii - 1, ii = 1, nn)]
      perm(nn + 1:) = [(2 * ii, ii = 1, nn)]

      call transposed(Red, perm, doperm=.true., errst=errst)
      !if(prop_error('rho_red_MPDO_TYPE : transposed failed.', &
      !              'LPTNOps_include.f90:2850', errst=errst)) return            

      deallocate(perm)

      ! Access intentionally unused variables needed for compliance with
      ! MPS interface
      !if(cont) kk = 1
      !if(trunc < 0.0_rKind) kk = 2
      !if(ncut < 0) kk = 3

  end subroutine rho_red_qlptnc

LPTNOps_f90.scale_real_lptn()

fortran-subroutine - June 2017 (dj, updated) Rescale Rho by some factor. The square is taken since X from rho = xxdagger is normalized.

Arguments

scalefactorreal, in

some real number to scale LPTN

RhoTYPE(lptn), inout

Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Details

The tensor is multiplied with sqrt(sc), after the contraction with the complex conjugate this step results in sc.

Source Code

show / hide f90 code

  subroutine scale_real_lptn(scalefactor, Rho)
      real(KIND=rKind), intent(in) :: scalefactor
      type(lptn), intent(inout) :: Rho

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

      ! scale at orthogonality center if present
      integer :: oc

      oc = max(Rho%oc, 1)
      call scale(sqrt(scalefactor), Rho%Aa(oc))

  end subroutine scale_real_lptn

LPTNOps_f90.scale_real_lptnc()

fortran-subroutine - June 2017 (dj, updated) Rescale Rho by some factor. The square is taken since X from rho = xxdagger is normalized.

Arguments

scalefactorreal, in

some real number to scale LPTN

RhoTYPE(lptnc), inout

Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Details

The tensor is multiplied with sqrt(sc), after the contraction with the complex conjugate this step results in sc.

Source Code

show / hide f90 code

  subroutine scale_real_lptnc(scalefactor, Rho)
      real(KIND=rKind), intent(in) :: scalefactor
      type(lptnc), intent(inout) :: Rho

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

      ! scale at orthogonality center if present
      integer :: oc

      oc = max(Rho%oc, 1)
      call scale(sqrt(scalefactor), Rho%Aa(oc))

  end subroutine scale_real_lptnc

LPTNOps_f90.scale_real_qlptn()

fortran-subroutine - June 2017 (dj, updated) Rescale Rho by some factor. The square is taken since X from rho = xxdagger is normalized.

Arguments

scalefactorreal, in

some real number to scale LPTN

RhoTYPE(qlptn), inout

Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Details

The tensor is multiplied with sqrt(sc), after the contraction with the complex conjugate this step results in sc.

Source Code

show / hide f90 code

  subroutine scale_real_qlptn(scalefactor, Rho)
      real(KIND=rKind), intent(in) :: scalefactor
      type(qlptn), intent(inout) :: Rho

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

      ! scale at orthogonality center if present
      integer :: oc

      oc = max(Rho%oc, 1)
      call scale(sqrt(scalefactor), Rho%Aa(oc))

  end subroutine scale_real_qlptn

LPTNOps_f90.scale_real_qlptnc()

fortran-subroutine - June 2017 (dj, updated) Rescale Rho by some factor. The square is taken since X from rho = xxdagger is normalized.

Arguments

scalefactorreal, in

some real number to scale LPTN

RhoTYPE(qlptnc), inout

Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Details

The tensor is multiplied with sqrt(sc), after the contraction with the complex conjugate this step results in sc.

Source Code

show / hide f90 code

  subroutine scale_real_qlptnc(scalefactor, Rho)
      real(KIND=rKind), intent(in) :: scalefactor
      type(qlptnc), intent(inout) :: Rho

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

      ! scale at orthogonality center if present
      integer :: oc

      oc = max(Rho%oc, 1)
      call scale(sqrt(scalefactor), Rho%Aa(oc))

  end subroutine scale_real_qlptnc

LPTNOps_f90.scale_complex_lptnc()

fortran-subroutine - June 2017 (dj, updated) Rescale Rho by some factor. The square is taken since X from rho = xxdagger is normalized.

Arguments

scalefactorcomplex, in

some real number to scale LPTN

RhoTYPE(lptnc), inout

Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Details

The tensor is multiplied with sqrt(sc), after the contraction with the complex conjugate this step results in sc.

Source Code

show / hide f90 code

  subroutine scale_complex_lptnc(scalefactor, Rho)
      complex(KIND=rKind), intent(in) :: scalefactor
      type(lptnc), intent(inout) :: Rho

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

      ! scale at orthogonality center if present
      integer :: oc

      oc = max(Rho%oc, 1)
      call scale(sqrt(scalefactor), Rho%Aa(oc))

  end subroutine scale_complex_lptnc

LPTNOps_f90.scale_complex_qlptnc()

fortran-subroutine - June 2017 (dj, updated) Rescale Rho by some factor. The square is taken since X from rho = xxdagger is normalized.

Arguments

scalefactorcomplex, in

some real number to scale LPTN

RhoTYPE(qlptnc), inout

Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Details

The tensor is multiplied with sqrt(sc), after the contraction with the complex conjugate this step results in sc.

Source Code

show / hide f90 code

  subroutine scale_complex_qlptnc(scalefactor, Rho)
      complex(KIND=rKind), intent(in) :: scalefactor
      type(qlptnc), intent(inout) :: Rho

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

      ! scale at orthogonality center if present
      integer :: oc

      oc = max(Rho%oc, 1)
      call scale(sqrt(scalefactor), Rho%Aa(oc))

  end subroutine scale_complex_qlptnc

LPTNOps_f90.set_q_kappa_qtensor()

fortran-subroutine - October 2017 (dj) Set the quantum number on the kappa link.

Arguments

QtTYPE(qtensor), inout

Tensor to be modified. The quantum numbers of the third leg connecting to the complex conjugate tensor of the LPTN will be set.

Source Code

show / hide f90 code

  subroutine set_q_kappa_qtensor(Qt, errst)
      type(qtensor), intent(inout) :: Qt
      integer, intent(out), optional :: errst

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

      ! for looping
      integer kk

      ! indices for quantum numbers
      integer :: i1, i2, j1, j2

      ! total number of converved quantities
      integer :: snqs

      !if(present(errst)) errst = 0

      snqs = sum(Qt%nqs)

      i1 = snqs + 1
      i2 = 2 * snqs

      j1 = i2 + 1
      j2 = i2 + snqs

      do kk = 1, Qt%nb
          Qt%Data(kk)%qq(j1:j2) = Qt%Data(kk)%qq(i1:i2)
      end do

  end subroutine set_q_kappa_qtensor

LPTNOps_f90.set_q_kappa_qtensorc()

fortran-subroutine - October 2017 (dj) Set the quantum number on the kappa link.

Arguments

QtTYPE(qtensorc), inout

Tensor to be modified. The quantum numbers of the third leg connecting to the complex conjugate tensor of the LPTN will be set.

Source Code

show / hide f90 code

  subroutine set_q_kappa_qtensorc(Qt, errst)
      type(qtensorc), intent(inout) :: Qt
      integer, intent(out), optional :: errst

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

      ! for looping
      integer kk

      ! indices for quantum numbers
      integer :: i1, i2, j1, j2

      ! total number of converved quantities
      integer :: snqs

      !if(present(errst)) errst = 0

      snqs = sum(Qt%nqs)

      i1 = snqs + 1
      i2 = 2 * snqs

      j1 = i2 + 1
      j2 = i2 + snqs

      do kk = 1, Qt%nb
          Qt%Data(kk)%qq(j1:j2) = Qt%Data(kk)%qq(i1:i2)
      end do

  end subroutine set_q_kappa_qtensorc

LPTNOps_f90.set_q_kappa_tensor()

fortran-subroutine - October 2017 (dj) Set the quantum number on the kappa link.

Arguments

TensTYPE(tensor), inout

Dummy subroutine to provide interface.

Source Code

show / hide f90 code

  subroutine set_q_kappa_tensor(Tens, errst)
      type(tensor), intent(inout) :: Tens
      integer, intent(out), optional :: errst

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

      !if(present(errst)) errst = 0

      ! Touch intentionally unused variables to avoid warning
      !if(.false.) print *, Tens%rank

  end subroutine set_q_kappa_tensor

LPTNOps_f90.set_q_kappa_tensorc()

fortran-subroutine - October 2017 (dj) Set the quantum number on the kappa link.

Arguments

TensTYPE(tensorc), inout

Dummy subroutine to provide interface.

Source Code

show / hide f90 code

  subroutine set_q_kappa_tensorc(Tens, errst)
      type(tensorc), intent(inout) :: Tens
      integer, intent(out), optional :: errst

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

      !if(present(errst)) errst = 0

      ! Touch intentionally unused variables to avoid warning
      !if(.false.) print *, Tens%rank

  end subroutine set_q_kappa_tensorc

LPTNOps_f90.set_0_kappa_qtensor()

fortran-subroutine - October 2017 (dj) Set the quantum number on the kappa link to zero.

Arguments

QtTYPE(qtensor), inout

Tensor to be modified. The quantum numbers of the third leg connecting to the complex conjugate tensor of the LPTN will be set to zero.

Source Code

show / hide f90 code

  subroutine set_0_kappa_qtensor(Qt, errst)
      type(qtensor), intent(inout) :: Qt
      integer, intent(out), optional :: errst

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

      ! for looping
      integer kk

      ! indices for quantum numbers
      integer :: j1, j2

      ! total number of converved quantities
      integer :: snqs

      !if(present(errst)) errst = 0

      snqs = sum(Qt%nqs)

      j1 = 2 * snqs + 1
      j2 = 3 * snqs

      do kk = 1, Qt%nb
          Qt%Data(kk)%qq(j1:j2) = 0
      end do

  end subroutine set_0_kappa_qtensor

LPTNOps_f90.set_0_kappa_qtensorc()

fortran-subroutine - October 2017 (dj) Set the quantum number on the kappa link to zero.

Arguments

QtTYPE(qtensorc), inout

Tensor to be modified. The quantum numbers of the third leg connecting to the complex conjugate tensor of the LPTN will be set to zero.

Source Code

show / hide f90 code

  subroutine set_0_kappa_qtensorc(Qt, errst)
      type(qtensorc), intent(inout) :: Qt
      integer, intent(out), optional :: errst

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

      ! for looping
      integer kk

      ! indices for quantum numbers
      integer :: j1, j2

      ! total number of converved quantities
      integer :: snqs

      !if(present(errst)) errst = 0

      snqs = sum(Qt%nqs)

      j1 = 2 * snqs + 1
      j2 = 3 * snqs

      do kk = 1, Qt%nb
          Qt%Data(kk)%qq(j1:j2) = 0
      end do

  end subroutine set_0_kappa_qtensorc

LPTNOps_f90.set_0_kappa_tensor()

fortran-subroutine - October 2017 (dj) Set the quantum number on the kappa link to zero.

Arguments

TensTYPE(tensor), inout

Dummy subroutine to provide interface.

Source Code

show / hide f90 code

  subroutine set_0_kappa_tensor(Tens, errst)
      type(tensor), intent(inout) :: Tens
      integer, intent(out), optional :: errst

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

      !if(present(errst)) errst = 0

      ! Touch intentionally unused variables to avoid warning
      !if(.false.) print *, Tens%rank

  end subroutine set_0_kappa_tensor

LPTNOps_f90.set_0_kappa_tensorc()

fortran-subroutine - October 2017 (dj) Set the quantum number on the kappa link to zero.

Arguments

TensTYPE(tensorc), inout

Dummy subroutine to provide interface.

Source Code

show / hide f90 code

  subroutine set_0_kappa_tensorc(Tens, errst)
      type(tensorc), intent(inout) :: Tens
      integer, intent(out), optional :: errst

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

      !if(present(errst)) errst = 0

      ! Touch intentionally unused variables to avoid warning
      !if(.false.) print *, Tens%rank

  end subroutine set_0_kappa_tensorc

LPTNOps_f90.swap_lptn_tensor()

fortran-subroutine - May 2018 (dj) Swap two nearest-neighbor sites in an LPTN.

Arguments

TensaTYPE(tensor), inout

The second index of this tensor is on exit contained in Tensb.

TensbTYPE(tensor), inout

The second index of this tensor is on exit contained in Tensa.

LamTYPE(tensor), inout

On exit, new singular values at splitting Tensa/Tensb.

dirINTEGER, in

Multiply singular values to Tensa for dir < 0 and to Tensa for dir > 0 to Tensb.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

cerrREAL, OPTIONAL, inout

Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine swap_lptn_tensor(Tensa, Tensb, Lam, dir, trunc, ncut, &
                                  cerr, errst)
      type(tensor), intent(inout) :: Tensa, Tensb
      type(tensor), intent(inout) :: Lam
      integer, intent(in), optional :: dir
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      real(KIND=rKind), intent(inout), optional :: cerr
      integer, intent(out), optional :: errst

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

      ! Error from single truncation
      real(KIND=rKind) :: err

      ! Represenation two-site tensor
      type(tensor) :: Theta

      !if(present(errst)) errst = 0

      call contr(Theta, Tensa, Tensb, [4], [1], errst=errst)
      !if(prop_error('swap_lptn_tensor : contr failed.', &
      !              'LPTNOps_include.f90:3162', errst=errst)) return

      call destroy(Tensa)
      call destroy(Tensb)

      call split(Tensa, Lam, Tensb, Theta, [1, 4, 5], [2, 3, 6], &
                 multlr=dir, trunc=trunc, ncut=ncut, err=err, &
                 method='Y', errst=errst)
      !if(prop_error('swap_lptn_tensor : split failed.', &
      !              'LPTNOps_include.f90:3171', errst=errst)) return

      call destroy(Theta)
      if(present(cerr)) cerr = cerr + err

  end subroutine swap_lptn_tensor

LPTNOps_f90.swap_lptn_tensorc()

fortran-subroutine - May 2018 (dj) Swap two nearest-neighbor sites in an LPTN.

Arguments

TensaTYPE(tensorc), inout

The second index of this tensor is on exit contained in Tensb.

TensbTYPE(tensorc), inout

The second index of this tensor is on exit contained in Tensa.

LamTYPE(tensor), inout

On exit, new singular values at splitting Tensa/Tensb.

dirINTEGER, in

Multiply singular values to Tensa for dir < 0 and to Tensa for dir > 0 to Tensb.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

cerrREAL, OPTIONAL, inout

Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine swap_lptn_tensorc(Tensa, Tensb, Lam, dir, trunc, ncut, &
                                  cerr, errst)
      type(tensorc), intent(inout) :: Tensa, Tensb
      type(tensor), intent(inout) :: Lam
      integer, intent(in), optional :: dir
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      real(KIND=rKind), intent(inout), optional :: cerr
      integer, intent(out), optional :: errst

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

      ! Error from single truncation
      real(KIND=rKind) :: err

      ! Represenation two-site tensor
      type(tensorc) :: Theta

      !if(present(errst)) errst = 0

      call contr(Theta, Tensa, Tensb, [4], [1], errst=errst)
      !if(prop_error('swap_lptn_tensorc : contr failed.', &
      !              'LPTNOps_include.f90:3162', errst=errst)) return

      call destroy(Tensa)
      call destroy(Tensb)

      call split(Tensa, Lam, Tensb, Theta, [1, 4, 5], [2, 3, 6], &
                 multlr=dir, trunc=trunc, ncut=ncut, err=err, &
                 method='Y', errst=errst)
      !if(prop_error('swap_lptn_tensorc : split failed.', &
      !              'LPTNOps_include.f90:3171', errst=errst)) return

      call destroy(Theta)
      if(present(cerr)) cerr = cerr + err

  end subroutine swap_lptn_tensorc

LPTNOps_f90.swap_lptn_qtensor()

fortran-subroutine - May 2018 (dj) Swap two nearest-neighbor sites in an LPTN.

Arguments

TensaTYPE(qtensor), inout

The second index of this tensor is on exit contained in Tensb.

TensbTYPE(qtensor), inout

The second index of this tensor is on exit contained in Tensa.

LamTYPE(qtensor), inout

On exit, new singular values at splitting Tensa/Tensb.

dirINTEGER, in

Multiply singular values to Tensa for dir < 0 and to Tensa for dir > 0 to Tensb.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

cerrREAL, OPTIONAL, inout

Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine swap_lptn_qtensor(Tensa, Tensb, Lam, dir, trunc, ncut, &
                                  cerr, errst)
      type(qtensor), intent(inout) :: Tensa, Tensb
      type(qtensor), intent(inout) :: Lam
      integer, intent(in), optional :: dir
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      real(KIND=rKind), intent(inout), optional :: cerr
      integer, intent(out), optional :: errst

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

      ! Error from single truncation
      real(KIND=rKind) :: err

      ! Represenation two-site tensor
      type(qtensor) :: Theta

      !if(present(errst)) errst = 0

      call contr(Theta, Tensa, Tensb, [4], [1], errst=errst)
      !if(prop_error('swap_lptn_qtensor : contr failed.', &
      !              'LPTNOps_include.f90:3162', errst=errst)) return

      call destroy(Tensa)
      call destroy(Tensb)

      call split(Tensa, Lam, Tensb, Theta, [1, 4, 5], [2, 3, 6], &
                 multlr=dir, trunc=trunc, ncut=ncut, err=err, &
                 method='Y', errst=errst)
      !if(prop_error('swap_lptn_qtensor : split failed.', &
      !              'LPTNOps_include.f90:3171', errst=errst)) return

      call destroy(Theta)
      if(present(cerr)) cerr = cerr + err

  end subroutine swap_lptn_qtensor

LPTNOps_f90.swap_lptn_qtensorc()

fortran-subroutine - May 2018 (dj) Swap two nearest-neighbor sites in an LPTN.

Arguments

TensaTYPE(qtensorc), inout

The second index of this tensor is on exit contained in Tensb.

TensbTYPE(qtensorc), inout

The second index of this tensor is on exit contained in Tensa.

LamTYPE(qtensor), inout

On exit, new singular values at splitting Tensa/Tensb.

dirINTEGER, in

Multiply singular values to Tensa for dir < 0 and to Tensa for dir > 0 to Tensb.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

cerrREAL, OPTIONAL, inout

Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine swap_lptn_qtensorc(Tensa, Tensb, Lam, dir, trunc, ncut, &
                                  cerr, errst)
      type(qtensorc), intent(inout) :: Tensa, Tensb
      type(qtensor), intent(inout) :: Lam
      integer, intent(in), optional :: dir
      real(KIND=rKind), intent(in), optional :: trunc
      integer, intent(in), optional :: ncut
      real(KIND=rKind), intent(inout), optional :: cerr
      integer, intent(out), optional :: errst

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

      ! Error from single truncation
      real(KIND=rKind) :: err

      ! Represenation two-site tensor
      type(qtensorc) :: Theta

      !if(present(errst)) errst = 0

      call contr(Theta, Tensa, Tensb, [4], [1], errst=errst)
      !if(prop_error('swap_lptn_qtensorc : contr failed.', &
      !              'LPTNOps_include.f90:3162', errst=errst)) return

      call destroy(Tensa)
      call destroy(Tensb)

      call split(Tensa, Lam, Tensb, Theta, [1, 4, 5], [2, 3, 6], &
                 multlr=dir, trunc=trunc, ncut=ncut, err=err, &
                 method='Y', errst=errst)
      !if(prop_error('swap_lptn_qtensorc : split failed.', &
      !              'LPTNOps_include.f90:3171', errst=errst)) return

      call destroy(Theta)
      if(present(cerr)) cerr = cerr + err

  end subroutine swap_lptn_qtensorc

LPTNOps_f90.transposed_lptn()

fortran-subroutine - June 2018 (dj) Permute the local Hilbert spaces.

Arguments

PsiTYPE(lptn), inout

Permute LPTN sites in-place. Error can be introduced due to SVDs.

permINTEGER(*), in

Permutation array has length equal to the number of sites L in the LPTN with unique entries 1 to L.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

cerrREAL, OPTIONAL, inout

Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine transposed_lptn(Psi, perm, trunc, ncut, cerr, errst)
      type(lptn), intent(inout) :: Psi
      integer, dimension(:), intent(in) :: perm
      real(KIND=rKind), intent(in) :: trunc
      integer, intent(in) :: ncut
      real(KIND=rKind), intent(inout), optional :: cerr
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj

      ! copy of permutation
      integer, dimension(:), allocatable :: ind

      ! renorm due to truncation
      real(KIND=rKind) :: sc

      !if(present(errst)) errst = 0

      !if(size(perm) /= Psi%ll) then
      !    errst = raise_error('transposed_lptn : rank '//&
      !                        'mismatch.', 2, errst=errst)
      !    return
      !end if

      allocate(ind(Psi%ll))

      do ii = 1, Psi%ll
          if(ind(ii) == ii) cycle

          call canonize(Psi, ind(ii))

          do jj = ind(ii), (ii + 1), -1
              if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))

              call swap_lptn(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj + 1), &
                             dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
                             errst=errst)

              Psi%can(jj) = 'r'
              Psi%can(jj - 1) = 'c'
              Psi%oc = jj - 1
          end do

          do jj = ii + 1, Psi%ll
              if(ind(jj) < ind(ii)) ind(jj) = ind(jj) + 1
          end do
      end do

      deallocate(ind)

      ! Truncation might violate normalization
      sc = norm(Psi)
      call scale(1.0_rKind / sqrt(sc), Psi)

  end subroutine transposed_lptn

LPTNOps_f90.transposed_lptnc()

fortran-subroutine - June 2018 (dj) Permute the local Hilbert spaces.

Arguments

PsiTYPE(lptnc), inout

Permute LPTN sites in-place. Error can be introduced due to SVDs.

permINTEGER(*), in

Permutation array has length equal to the number of sites L in the LPTN with unique entries 1 to L.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

cerrREAL, OPTIONAL, inout

Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine transposed_lptnc(Psi, perm, trunc, ncut, cerr, errst)
      type(lptnc), intent(inout) :: Psi
      integer, dimension(:), intent(in) :: perm
      real(KIND=rKind), intent(in) :: trunc
      integer, intent(in) :: ncut
      real(KIND=rKind), intent(inout), optional :: cerr
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj

      ! copy of permutation
      integer, dimension(:), allocatable :: ind

      ! renorm due to truncation
      real(KIND=rKind) :: sc

      !if(present(errst)) errst = 0

      !if(size(perm) /= Psi%ll) then
      !    errst = raise_error('transposed_lptnc : rank '//&
      !                        'mismatch.', 2, errst=errst)
      !    return
      !end if

      allocate(ind(Psi%ll))

      do ii = 1, Psi%ll
          if(ind(ii) == ii) cycle

          call canonize(Psi, ind(ii))

          do jj = ind(ii), (ii + 1), -1
              if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))

              call swap_lptn(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj + 1), &
                             dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
                             errst=errst)

              Psi%can(jj) = 'r'
              Psi%can(jj - 1) = 'c'
              Psi%oc = jj - 1
          end do

          do jj = ii + 1, Psi%ll
              if(ind(jj) < ind(ii)) ind(jj) = ind(jj) + 1
          end do
      end do

      deallocate(ind)

      ! Truncation might violate normalization
      sc = norm(Psi)
      call scale(1.0_rKind / sqrt(sc), Psi)

  end subroutine transposed_lptnc

LPTNOps_f90.transposed_qlptn()

fortran-subroutine - June 2018 (dj) Permute the local Hilbert spaces.

Arguments

PsiTYPE(qlptn), inout

Permute LPTN sites in-place. Error can be introduced due to SVDs.

permINTEGER(*), in

Permutation array has length equal to the number of sites L in the LPTN with unique entries 1 to L.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

cerrREAL, OPTIONAL, inout

Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine transposed_qlptn(Psi, perm, trunc, ncut, cerr, errst)
      type(qlptn), intent(inout) :: Psi
      integer, dimension(:), intent(in) :: perm
      real(KIND=rKind), intent(in) :: trunc
      integer, intent(in) :: ncut
      real(KIND=rKind), intent(inout), optional :: cerr
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj

      ! copy of permutation
      integer, dimension(:), allocatable :: ind

      ! renorm due to truncation
      real(KIND=rKind) :: sc

      !if(present(errst)) errst = 0

      !if(size(perm) /= Psi%ll) then
      !    errst = raise_error('transposed_qlptn : rank '//&
      !                        'mismatch.', 2, errst=errst)
      !    return
      !end if

      allocate(ind(Psi%ll))

      do ii = 1, Psi%ll
          if(ind(ii) == ii) cycle

          call canonize(Psi, ind(ii))

          do jj = ind(ii), (ii + 1), -1
              if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))

              call swap_lptn(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj + 1), &
                             dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
                             errst=errst)

              Psi%can(jj) = 'r'
              Psi%can(jj - 1) = 'c'
              Psi%oc = jj - 1
          end do

          do jj = ii + 1, Psi%ll
              if(ind(jj) < ind(ii)) ind(jj) = ind(jj) + 1
          end do
      end do

      deallocate(ind)

      ! Truncation might violate normalization
      sc = norm(Psi)
      call scale(1.0_rKind / sqrt(sc), Psi)

  end subroutine transposed_qlptn

LPTNOps_f90.transposed_qlptnc()

fortran-subroutine - June 2018 (dj) Permute the local Hilbert spaces.

Arguments

PsiTYPE(qlptnc), inout

Permute LPTN sites in-place. Error can be introduced due to SVDs.

permINTEGER(*), in

Permutation array has length equal to the number of sites L in the LPTN with unique entries 1 to L.

truncREAL, OPTIONAL, in

Keep infidelity below trunc (infidelity is sum of squared discarded singular values for LPTN). Default does not truncate.

ncutINTEGER, OPTIONAL, in

Maximal bond dimension / number of singular values. Default is keeping all singular values.

cerrREAL, OPTIONAL, inout

Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine transposed_qlptnc(Psi, perm, trunc, ncut, cerr, errst)
      type(qlptnc), intent(inout) :: Psi
      integer, dimension(:), intent(in) :: perm
      real(KIND=rKind), intent(in) :: trunc
      integer, intent(in) :: ncut
      real(KIND=rKind), intent(inout), optional :: cerr
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj

      ! copy of permutation
      integer, dimension(:), allocatable :: ind

      ! renorm due to truncation
      real(KIND=rKind) :: sc

      !if(present(errst)) errst = 0

      !if(size(perm) /= Psi%ll) then
      !    errst = raise_error('transposed_qlptnc : rank '//&
      !                        'mismatch.', 2, errst=errst)
      !    return
      !end if

      allocate(ind(Psi%ll))

      do ii = 1, Psi%ll
          if(ind(ii) == ii) cycle

          call canonize(Psi, ind(ii))

          do jj = ind(ii), (ii + 1), -1
              if(Psi%haslambda(jj + 1)) call destroy(Psi%Lambda(jj + 1))

              call swap_lptn(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj + 1), &
                             dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
                             errst=errst)

              Psi%can(jj) = 'r'
              Psi%can(jj - 1) = 'c'
              Psi%oc = jj - 1
          end do

          do jj = ii + 1, Psi%ll
              if(ind(jj) < ind(ii)) ind(jj) = ind(jj) + 1
          end do
      end do

      deallocate(ind)

      ! Truncation might violate normalization
      sc = norm(Psi)
      call scale(1.0_rKind / sqrt(sc), Psi)

  end subroutine transposed_qlptnc

LPTNOps_f90.write_lptn()

fortran-subroutine - August 2015 (dj) Write an LPTN to file

Arguments

RhoTYPE(lptn), in

save this LPTN

unitINTEGER, in

open file on this unit

formCHARACTER, in

Binary (‘B’), human readable (‘H’), or user-friendly (“6”).

Details

For details see the description of the order which the information is written, please see read_lptn

Source Code

show / hide f90 code

  subroutine write_lptn(Rho, unit, form, errst)
      type(lptn), intent(in) :: Rho
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! type of the LPTN
      logical :: is_real, is_q

      ! for looping
      integer :: ii

      is_real = .true.
      is_q = .false.

      if(form == "6") then
          write(unit, *) 'LPTN size, oc', Rho%ll, Rho%oc

          do ii = 1, Rho%ll
              write(unit, *) '           site i data:', ii
              write(unit, *) '           canonization', Rho%can(ii)
              write(unit, *) '           Lambda:', Rho%haslambda(ii)    

              if(Rho%haslambda(ii)) then
                  call print(Rho%Lambda(ii))
              end if
              call print(Rho%Aa(ii))
          end do

      elseif(form == 'H') then
          ! Open the formatted file
          ! -----------------------

          !open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write')

          ! Write the data type, the LPTN type, the number of sites and
          ! the orthogonality center
          write(unit, *) is_real
          write(unit, *) is_q
          write(unit, *) Rho%ll
          write(unit, *) Rho%oc

          ! Write the canonization and the haslambda together
          do ii = 1, Rho%ll
              write(unit, *) Rho%can(ii), Rho%haslambda(ii)
          end do
          write(unit, *) Rho%haslambda(Rho%ll + 1)

          ! Write the tensors of the LPTN
          do ii = 1, Rho%ll
              call write(Rho%Aa(ii), unit, form)
          end do

          ! Finally write the lambdas
          do ii = 1, Rho%ll + 1
              if(Rho%haslambda(ii)) then
                  call write(Rho%lambda(ii), unit, form)
              end if
          end do

      elseif(form == 'B') then
          ! Binary file
          ! -----------

          !open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write', &
          !     FORM='unformatted')

          ! Write the data type, the LPTN type, the number of sites and
          ! the orthogonality center
          write(unit) is_real
          write(unit) is_q
          write(unit) Rho%ll
          write(unit) Rho%oc

          ! Canonization and haslambda go as array
          write(unit) Rho%can
          write(unit) Rho%haslambda

          ! Write the tensors of the LPTN
          do ii = 1, Rho%ll
              call write(Rho%Aa(ii), unit, form)
          end do

          ! Finally write the values for the lambdas
          do ii = 1, Rho%ll + 1
              if(Rho%haslambda(ii)) then
                  call write(Rho%lambda(ii), unit, form)
              end if
          end do
      else
          !errst = raise_error('write_lptn: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      !close(unit)

  end subroutine write_lptn

LPTNOps_f90.write_lptnc()

fortran-subroutine - August 2015 (dj) Write an LPTN to file

Arguments

RhoTYPE(lptnc), in

save this LPTN

unitINTEGER, in

open file on this unit

formCHARACTER, in

Binary (‘B’), human readable (‘H’), or user-friendly (“6”).

Details

For details see the description of the order which the information is written, please see read_lptnc

Source Code

show / hide f90 code

  subroutine write_lptnc(Rho, unit, form, errst)
      type(lptnc), intent(in) :: Rho
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! type of the LPTN
      logical :: is_real, is_q

      ! for looping
      integer :: ii

      is_real = .false.
      is_q = .false.

      if(form == "6") then
          write(unit, *) 'LPTN size, oc', Rho%ll, Rho%oc

          do ii = 1, Rho%ll
              write(unit, *) '           site i data:', ii
              write(unit, *) '           canonization', Rho%can(ii)
              write(unit, *) '           Lambda:', Rho%haslambda(ii)    

              if(Rho%haslambda(ii)) then
                  call print(Rho%Lambda(ii))
              end if
              call print(Rho%Aa(ii))
          end do

      elseif(form == 'H') then
          ! Open the formatted file
          ! -----------------------

          !open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write')

          ! Write the data type, the LPTN type, the number of sites and
          ! the orthogonality center
          write(unit, *) is_real
          write(unit, *) is_q
          write(unit, *) Rho%ll
          write(unit, *) Rho%oc

          ! Write the canonization and the haslambda together
          do ii = 1, Rho%ll
              write(unit, *) Rho%can(ii), Rho%haslambda(ii)
          end do
          write(unit, *) Rho%haslambda(Rho%ll + 1)

          ! Write the tensors of the LPTN
          do ii = 1, Rho%ll
              call write(Rho%Aa(ii), unit, form)
          end do

          ! Finally write the lambdas
          do ii = 1, Rho%ll + 1
              if(Rho%haslambda(ii)) then
                  call write(Rho%lambda(ii), unit, form)
              end if
          end do

      elseif(form == 'B') then
          ! Binary file
          ! -----------

          !open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write', &
          !     FORM='unformatted')

          ! Write the data type, the LPTN type, the number of sites and
          ! the orthogonality center
          write(unit) is_real
          write(unit) is_q
          write(unit) Rho%ll
          write(unit) Rho%oc

          ! Canonization and haslambda go as array
          write(unit) Rho%can
          write(unit) Rho%haslambda

          ! Write the tensors of the LPTN
          do ii = 1, Rho%ll
              call write(Rho%Aa(ii), unit, form)
          end do

          ! Finally write the values for the lambdas
          do ii = 1, Rho%ll + 1
              if(Rho%haslambda(ii)) then
                  call write(Rho%lambda(ii), unit, form)
              end if
          end do
      else
          !errst = raise_error('write_lptnc: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      !close(unit)

  end subroutine write_lptnc

LPTNOps_f90.write_qlptn()

fortran-subroutine - August 2015 (dj) Write an LPTN to file

Arguments

RhoTYPE(qlptn), in

save this LPTN

unitINTEGER, in

open file on this unit

formCHARACTER, in

Binary (‘B’), human readable (‘H’), or user-friendly (“6”).

Details

For details see the description of the order which the information is written, please see read_qlptn

Source Code

show / hide f90 code

  subroutine write_qlptn(Rho, unit, form, errst)
      type(qlptn), intent(in) :: Rho
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! type of the LPTN
      logical :: is_real, is_q

      ! for looping
      integer :: ii

      is_real = .true.
      is_q = .true.

      if(form == "6") then
          write(unit, *) 'LPTN size, oc', Rho%ll, Rho%oc

          do ii = 1, Rho%ll
              write(unit, *) '           site i data:', ii
              write(unit, *) '           canonization', Rho%can(ii)
              write(unit, *) '           Lambda:', Rho%haslambda(ii)    

              if(Rho%haslambda(ii)) then
                  call print(Rho%Lambda(ii))
              end if
              call print(Rho%Aa(ii))
          end do

      elseif(form == 'H') then
          ! Open the formatted file
          ! -----------------------

          !open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write')

          ! Write the data type, the LPTN type, the number of sites and
          ! the orthogonality center
          write(unit, *) is_real
          write(unit, *) is_q
          write(unit, *) Rho%ll
          write(unit, *) Rho%oc

          ! Write the canonization and the haslambda together
          do ii = 1, Rho%ll
              write(unit, *) Rho%can(ii), Rho%haslambda(ii)
          end do
          write(unit, *) Rho%haslambda(Rho%ll + 1)

          ! Write the tensors of the LPTN
          do ii = 1, Rho%ll
              call write(Rho%Aa(ii), unit, form)
          end do

          ! Finally write the lambdas
          do ii = 1, Rho%ll + 1
              if(Rho%haslambda(ii)) then
                  call write(Rho%lambda(ii), unit, form)
              end if
          end do

      elseif(form == 'B') then
          ! Binary file
          ! -----------

          !open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write', &
          !     FORM='unformatted')

          ! Write the data type, the LPTN type, the number of sites and
          ! the orthogonality center
          write(unit) is_real
          write(unit) is_q
          write(unit) Rho%ll
          write(unit) Rho%oc

          ! Canonization and haslambda go as array
          write(unit) Rho%can
          write(unit) Rho%haslambda

          ! Write the tensors of the LPTN
          do ii = 1, Rho%ll
              call write(Rho%Aa(ii), unit, form)
          end do

          ! Finally write the values for the lambdas
          do ii = 1, Rho%ll + 1
              if(Rho%haslambda(ii)) then
                  call write(Rho%lambda(ii), unit, form)
              end if
          end do
      else
          !errst = raise_error('write_qlptn: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      !close(unit)

  end subroutine write_qlptn

LPTNOps_f90.write_qlptnc()

fortran-subroutine - August 2015 (dj) Write an LPTN to file

Arguments

RhoTYPE(qlptnc), in

save this LPTN

unitINTEGER, in

open file on this unit

formCHARACTER, in

Binary (‘B’), human readable (‘H’), or user-friendly (“6”).

Details

For details see the description of the order which the information is written, please see read_qlptnc

Source Code

show / hide f90 code

  subroutine write_qlptnc(Rho, unit, form, errst)
      type(qlptnc), intent(in) :: Rho
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! type of the LPTN
      logical :: is_real, is_q

      ! for looping
      integer :: ii

      is_real = .false.
      is_q = .true.

      if(form == "6") then
          write(unit, *) 'LPTN size, oc', Rho%ll, Rho%oc

          do ii = 1, Rho%ll
              write(unit, *) '           site i data:', ii
              write(unit, *) '           canonization', Rho%can(ii)
              write(unit, *) '           Lambda:', Rho%haslambda(ii)    

              if(Rho%haslambda(ii)) then
                  call print(Rho%Lambda(ii))
              end if
              call print(Rho%Aa(ii))
          end do

      elseif(form == 'H') then
          ! Open the formatted file
          ! -----------------------

          !open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write')

          ! Write the data type, the LPTN type, the number of sites and
          ! the orthogonality center
          write(unit, *) is_real
          write(unit, *) is_q
          write(unit, *) Rho%ll
          write(unit, *) Rho%oc

          ! Write the canonization and the haslambda together
          do ii = 1, Rho%ll
              write(unit, *) Rho%can(ii), Rho%haslambda(ii)
          end do
          write(unit, *) Rho%haslambda(Rho%ll + 1)

          ! Write the tensors of the LPTN
          do ii = 1, Rho%ll
              call write(Rho%Aa(ii), unit, form)
          end do

          ! Finally write the lambdas
          do ii = 1, Rho%ll + 1
              if(Rho%haslambda(ii)) then
                  call write(Rho%lambda(ii), unit, form)
              end if
          end do

      elseif(form == 'B') then
          ! Binary file
          ! -----------

          !open(UNIT=unit, FILE=trim(flnm), STATUS='replace', ACTION='write', &
          !     FORM='unformatted')

          ! Write the data type, the LPTN type, the number of sites and
          ! the orthogonality center
          write(unit) is_real
          write(unit) is_q
          write(unit) Rho%ll
          write(unit) Rho%oc

          ! Canonization and haslambda go as array
          write(unit) Rho%can
          write(unit) Rho%haslambda

          ! Write the tensors of the LPTN
          do ii = 1, Rho%ll
              call write(Rho%Aa(ii), unit, form)
          end do

          ! Finally write the values for the lambdas
          do ii = 1, Rho%ll + 1
              if(Rho%haslambda(ii)) then
                  call write(Rho%lambda(ii), unit, form)
              end if
          end do
      else
          !errst = raise_error('write_qlptnc: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      !close(unit)

  end subroutine write_qlptnc