MPSOps¶

Fortran module MPSOps: June 2017 (dj, updated)

Containing basic operations for matrix product states.

Authors

1. Jaschke
1. 1. Wall

Details

The error status can be decoded the following way

The following subroutines / functions are defined for the applicable data type

Procedure	include.f90	mpi.f90	omp.f90
copy	X
canonize	X
canonize_svd	X
destroy	X
gaugesite_rq	X
gaugesite_qr	X
gaugesite_rsvd	X
gaugesite_lsvd	X
norm	X
orthonormalize	X
perturb	X
print	X
randomize	X
read	X
scale	X
write	X

MPSOps_f90.ConstructProjectors_tensor()[source]¶

fortran-subroutine - June 2017 (dj, updated) Given a set of NE MPSs psiBs and their overlap propagators with a variational state LRAB construct a set of at most NE on-site tensors psiProjs which can be used to project the effective Hamiltonian into the orthogonal space.

Arguments

kkINTEGER, in: Build the projectors for site kk in the single site version or for sites (kk, kk + 1) in the two site version.
PsibsTYPE(mps)(*), inout: ??
LRABTYPE(tensorlist)(*), inout: The left-right overlaps.
PsiprojsTYPE(tensor)(*), POINTER, inout: On output, the projectors.
nsitesINTEGER, in: Number of sites to build the projectors on. Either single site (1) or two-sites (2).

Source Code

show / hide f90 code

  subroutine ConstructProjectors_tensor(kk, Psibs, LRab, Psiprojs, &
                                             nsites, errst)
      integer, intent(in) :: kk
      type(mps) :: Psibs(:)
      type(tensorlist) :: LRAB(:)
      type(tensor), pointer :: Psiprojs(:)
      integer, intent(in) :: nsites
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj

      ! number of overlaps, Psibs
      integer :: ne

      ! number of eigenvalues above tolerance
      integer :: nkeep

      ! Projectors before pseudoinverse
      type(tensor), pointer :: Rawpsiprojs(:)

      ! Gram matrix and its eigenvalues
      real(KIND=rKind), dimension(:, :), allocatable:: nmat
      real(KIND=rKind), dimension(:), allocatable :: ev

      ! Temporary tensors
      type(tensor) :: Tmp, Tmpb

      ! tolerance singular value inversion
      real(KIND=rKind) ::  tol

      ne = size(LRab)
      allocate(Rawpsiprojs(ne))

      ! Construct the linear forms which impose orthogonality
      ! -----------------------------------------------------

      if(nsites == 1) then
          ! One site version
          ! ................

          do jj = 1, ne
              ! Step 1:E(a,i,b)= B(j)_{a,i,b'} L(j)%l(k+1) (b' b)
              if(kk == Psibs(jj)%ll) then
                  call copy(Tmp, Psibs(jj)%Aa(kk))
              else
                  call contr(Tmp, Psibs(jj)%Aa(kk), LRab(kk)%Li(kk + 1), & 
                             [3], [1], errst=errst)
              end if

              ! Step 2: rawpsiProjs(j)(a,i,b)=L(j)%l(k)%elem(a,a') E(a',i,b)
              if(kk == 1) then
                  call copy(Rawpsiprojs(jj), Tmp)
              else
                  call contr(Rawpsiprojs(jj), LRab(jj)%Li(kk - 1), Tmp, &
                             [2], [1], errst=errst)
              end if

              call destroy(Tmp)
          end do

      elseif(nsites == 2) then
          ! Two site version
          ! ................

          do jj = 1, ne
              ! Contract left overlap
              if(kk == 1) then
                  call copy(Tmp, Psibs(jj)%Aa(kk))
              else
                  call contr(Tmp, LRab(jj)%Li(kk - 1), Psibs(jj)%Aa(kk), &
                             [2], [1], errst=errst)
              end if

              ! Contract right overlap
              if(kk + 1 == Psibs(jj)%ll) then
                  call copy(Tmpb, Psibs(jj)%Aa(kk + 1))
              else
                  call contr(Tmpb, Psibs(jj)%Aa(kk + 1), LRab(jj)%Li(kk + 2), &
                             [3], [1], errst=errst)
              end if

              ! Build two-site tensor
              call contr(Rawpsiprojs(jj), Tmp, Tmpb, &
                         [3], [1], errst=errst)

              call destroy(Tmp)
              call destroy(Tmpb)
          end do
      else
          stop 'Not implement nsites > 2'
      end if

      ! Construct the Gram matrix
      allocate(nmat(ne, ne), ev(ne))

      do ii = 1, ne
          ! Diagonal element
          nmat(ii, ii) = Dot(Rawpsiprojs(ii), Rawpsiprojs(ii))

          do jj = (ii + 1), ne
              ! Upper triangular is enough for eigd
              nmat(ii, jj) = Dot(Rawpsiprojs(ii), Rawpsiprojs(jj))
          end do
      end do

      ! Construct the pseudoinverse of the Gram matrix (default to upper)
      call eigd(nmat, ev, ne, errst=errst)
      !if(prop_error('constructprojectors_tensor: eigd failed.', &
      !              'MPSOps_include.f90:162', errst=errst)) return

      ! Tolerance for singular value inversion=NE*||N||_2 *eps
      nkeep = 0
      tol = ne * maxval(ev) * numzero

      do ii = ne, 1, (-1)
          if(ev(ii) > tol) nkeep = nkeep + 1
      end do

      ! Copy the raw projectors to the final ones

      allocate(Psiprojs(nkeep))

      do ii = 1, nkeep
          call copy(Psiprojs(ii), Rawpsiprojs(1))

          ! jj = 1
          call scale(nmat(1, ne - ii + 1), Psiprojs(ii))

          do jj = 2, ne
              call gaxpy(Psiprojs(ii), nmat(jj, ne - ii + 1), Rawpsiprojs(jj))
          end do

          call scale(1.0_rKind / sqrt(ev(ne - ii + 1)), Psiprojs(ii))
      end do

      do ii = 1, ne
          call destroy(Rawpsiprojs(ii))
      end do

      deallocate(Rawpsiprojs, ev, nmat)

  end subroutine constructprojectors_tensor

MPSOps_f90.ConstructProjectors_tensorc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Given a set of NE MPSs psiBs and their overlap propagators with a variational state LRAB construct a set of at most NE on-site tensors psiProjs which can be used to project the effective Hamiltonian into the orthogonal space.

Arguments

kkINTEGER, in: Build the projectors for site kk in the single site version or for sites (kk, kk + 1) in the two site version.
PsibsTYPE(mpsc)(*), inout: ??
LRABTYPE(tensorlistc)(*), inout: The left-right overlaps.
PsiprojsTYPE(tensorc)(*), POINTER, inout: On output, the projectors.
nsitesINTEGER, in: Number of sites to build the projectors on. Either single site (1) or two-sites (2).

Source Code

show / hide f90 code

  subroutine ConstructProjectors_tensorc(kk, Psibs, LRab, Psiprojs, &
                                             nsites, errst)
      integer, intent(in) :: kk
      type(mpsc) :: Psibs(:)
      type(tensorlistc) :: LRAB(:)
      type(tensorc), pointer :: Psiprojs(:)
      integer, intent(in) :: nsites
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj

      ! number of overlaps, Psibs
      integer :: ne

      ! number of eigenvalues above tolerance
      integer :: nkeep

      ! Projectors before pseudoinverse
      type(tensorc), pointer :: Rawpsiprojs(:)

      ! Gram matrix and its eigenvalues
      complex(KIND=rKind), dimension(:, :), allocatable:: nmat
      real(KIND=rKind), dimension(:), allocatable :: ev

      ! Temporary tensors
      type(tensorc) :: Tmp, Tmpb

      ! tolerance singular value inversion
      real(KIND=rKind) ::  tol

      ne = size(LRab)
      allocate(Rawpsiprojs(ne))

      ! Construct the linear forms which impose orthogonality
      ! -----------------------------------------------------

      if(nsites == 1) then
          ! One site version
          ! ................

          do jj = 1, ne
              ! Step 1:E(a,i,b)= B(j)_{a,i,b'} L(j)%l(k+1) (b' b)
              if(kk == Psibs(jj)%ll) then
                  call copy(Tmp, Psibs(jj)%Aa(kk))
              else
                  call contr(Tmp, Psibs(jj)%Aa(kk), LRab(kk)%Li(kk + 1), & 
                             [3], [1], errst=errst)
              end if

              ! Step 2: rawpsiProjs(j)(a,i,b)=L(j)%l(k)%elem(a,a') E(a',i,b)
              if(kk == 1) then
                  call copy(Rawpsiprojs(jj), Tmp)
              else
                  call contr(Rawpsiprojs(jj), LRab(jj)%Li(kk - 1), Tmp, &
                             [2], [1], errst=errst)
              end if

              call destroy(Tmp)
          end do

      elseif(nsites == 2) then
          ! Two site version
          ! ................

          do jj = 1, ne
              ! Contract left overlap
              if(kk == 1) then
                  call copy(Tmp, Psibs(jj)%Aa(kk))
              else
                  call contr(Tmp, LRab(jj)%Li(kk - 1), Psibs(jj)%Aa(kk), &
                             [2], [1], errst=errst)
              end if

              ! Contract right overlap
              if(kk + 1 == Psibs(jj)%ll) then
                  call copy(Tmpb, Psibs(jj)%Aa(kk + 1))
              else
                  call contr(Tmpb, Psibs(jj)%Aa(kk + 1), LRab(jj)%Li(kk + 2), &
                             [3], [1], errst=errst)
              end if

              ! Build two-site tensor
              call contr(Rawpsiprojs(jj), Tmp, Tmpb, &
                         [3], [1], errst=errst)

              call destroy(Tmp)
              call destroy(Tmpb)
          end do
      else
          stop 'Not implement nsites > 2'
      end if

      ! Construct the Gram matrix
      allocate(nmat(ne, ne), ev(ne))

      do ii = 1, ne
          ! Diagonal element
          nmat(ii, ii) = Dot(Rawpsiprojs(ii), Rawpsiprojs(ii))

          do jj = (ii + 1), ne
              ! Upper triangular is enough for eigd
              nmat(ii, jj) = Dot(Rawpsiprojs(ii), Rawpsiprojs(jj))
          end do
      end do

      ! Construct the pseudoinverse of the Gram matrix (default to upper)
      call eigd(nmat, ev, ne, errst=errst)
      !if(prop_error('constructprojectors_tensorc: eigd failed.', &
      !              'MPSOps_include.f90:162', errst=errst)) return

      ! Tolerance for singular value inversion=NE*||N||_2 *eps
      nkeep = 0
      tol = ne * maxval(ev) * numzero

      do ii = ne, 1, (-1)
          if(ev(ii) > tol) nkeep = nkeep + 1
      end do

      ! Copy the raw projectors to the final ones

      allocate(Psiprojs(nkeep))

      do ii = 1, nkeep
          call copy(Psiprojs(ii), Rawpsiprojs(1))

          ! jj = 1
          call scale(nmat(1, ne - ii + 1), Psiprojs(ii))

          do jj = 2, ne
              call gaxpy(Psiprojs(ii), nmat(jj, ne - ii + 1), Rawpsiprojs(jj))
          end do

          call scale(1.0_rKind / sqrt(ev(ne - ii + 1)), Psiprojs(ii))
      end do

      do ii = 1, ne
          call destroy(Rawpsiprojs(ii))
      end do

      deallocate(Rawpsiprojs, ev, nmat)

  end subroutine constructprojectors_tensorc

MPSOps_f90.ConstructProjectors_qtensor()[source]¶

fortran-subroutine - June 2017 (dj, updated) Given a set of NE MPSs psiBs and their overlap propagators with a variational state LRAB construct a set of at most NE on-site tensors psiProjs which can be used to project the effective Hamiltonian into the orthogonal space.

Arguments

kkINTEGER, in: Build the projectors for site kk in the single site version or for sites (kk, kk + 1) in the two site version.
PsibsTYPE(qmps)(*), inout: ??
LRABTYPE(qtensorlist)(*), inout: The left-right overlaps.
PsiprojsTYPE(qtensor)(*), POINTER, inout: On output, the projectors.
nsitesINTEGER, in: Number of sites to build the projectors on. Either single site (1) or two-sites (2).

Source Code

show / hide f90 code

  subroutine ConstructProjectors_qtensor(kk, Psibs, LRab, Psiprojs, &
                                             nsites, errst)
      integer, intent(in) :: kk
      type(qmps) :: Psibs(:)
      type(qtensorlist) :: LRAB(:)
      type(qtensor), pointer :: Psiprojs(:)
      integer, intent(in) :: nsites
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj

      ! number of overlaps, Psibs
      integer :: ne

      ! number of eigenvalues above tolerance
      integer :: nkeep

      ! Projectors before pseudoinverse
      type(qtensor), pointer :: Rawpsiprojs(:)

      ! Gram matrix and its eigenvalues
      real(KIND=rKind), dimension(:, :), allocatable:: nmat
      real(KIND=rKind), dimension(:), allocatable :: ev

      ! Temporary tensors
      type(qtensor) :: Tmp, Tmpb

      ! tolerance singular value inversion
      real(KIND=rKind) ::  tol

      ne = size(LRab)
      allocate(Rawpsiprojs(ne))

      ! Construct the linear forms which impose orthogonality
      ! -----------------------------------------------------

      if(nsites == 1) then
          ! One site version
          ! ................

          do jj = 1, ne
              ! Step 1:E(a,i,b)= B(j)_{a,i,b'} L(j)%l(k+1) (b' b)
              if(kk == Psibs(jj)%ll) then
                  call copy(Tmp, Psibs(jj)%Aa(kk))
              else
                  call contr(Tmp, Psibs(jj)%Aa(kk), LRab(kk)%Li(kk + 1), & 
                             [3], [1], errst=errst)
              end if

              ! Step 2: rawpsiProjs(j)(a,i,b)=L(j)%l(k)%elem(a,a') E(a',i,b)
              if(kk == 1) then
                  call copy(Rawpsiprojs(jj), Tmp)
              else
                  call contr(Rawpsiprojs(jj), LRab(jj)%Li(kk - 1), Tmp, &
                             [2], [1], errst=errst)
              end if

              call destroy(Tmp)
          end do

      elseif(nsites == 2) then
          ! Two site version
          ! ................

          do jj = 1, ne
              ! Contract left overlap
              if(kk == 1) then
                  call copy(Tmp, Psibs(jj)%Aa(kk))
              else
                  call contr(Tmp, LRab(jj)%Li(kk - 1), Psibs(jj)%Aa(kk), &
                             [2], [1], errst=errst)
              end if

              ! Contract right overlap
              if(kk + 1 == Psibs(jj)%ll) then
                  call copy(Tmpb, Psibs(jj)%Aa(kk + 1))
              else
                  call contr(Tmpb, Psibs(jj)%Aa(kk + 1), LRab(jj)%Li(kk + 2), &
                             [3], [1], errst=errst)
              end if

              ! Build two-site tensor
              call contr(Rawpsiprojs(jj), Tmp, Tmpb, &
                         [3], [1], errst=errst)

              call destroy(Tmp)
              call destroy(Tmpb)
          end do
      else
          stop 'Not implement nsites > 2'
      end if

      ! Construct the Gram matrix
      allocate(nmat(ne, ne), ev(ne))

      do ii = 1, ne
          ! Diagonal element
          nmat(ii, ii) = Dot(Rawpsiprojs(ii), Rawpsiprojs(ii))

          do jj = (ii + 1), ne
              ! Upper triangular is enough for eigd
              nmat(ii, jj) = Dot(Rawpsiprojs(ii), Rawpsiprojs(jj))
          end do
      end do

      ! Construct the pseudoinverse of the Gram matrix (default to upper)
      call eigd(nmat, ev, ne, errst=errst)
      !if(prop_error('constructprojectors_qtensor: eigd failed.', &
      !              'MPSOps_include.f90:162', errst=errst)) return

      ! Tolerance for singular value inversion=NE*||N||_2 *eps
      nkeep = 0
      tol = ne * maxval(ev) * numzero

      do ii = ne, 1, (-1)
          if(ev(ii) > tol) nkeep = nkeep + 1
      end do

      ! Copy the raw projectors to the final ones

      allocate(Psiprojs(nkeep))

      do ii = 1, nkeep
          call copy(Psiprojs(ii), Rawpsiprojs(1))

          ! jj = 1
          call scale(nmat(1, ne - ii + 1), Psiprojs(ii))

          do jj = 2, ne
              call gaxpy(Psiprojs(ii), nmat(jj, ne - ii + 1), Rawpsiprojs(jj))
          end do

          call scale(1.0_rKind / sqrt(ev(ne - ii + 1)), Psiprojs(ii))
      end do

      do ii = 1, ne
          call destroy(Rawpsiprojs(ii))
      end do

      deallocate(Rawpsiprojs, ev, nmat)

  end subroutine constructprojectors_qtensor

MPSOps_f90.ConstructProjectors_qtensorc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Given a set of NE MPSs psiBs and their overlap propagators with a variational state LRAB construct a set of at most NE on-site tensors psiProjs which can be used to project the effective Hamiltonian into the orthogonal space.

Arguments

kkINTEGER, in: Build the projectors for site kk in the single site version or for sites (kk, kk + 1) in the two site version.
PsibsTYPE(qmpsc)(*), inout: ??
LRABTYPE(qtensorclist)(*), inout: The left-right overlaps.
PsiprojsTYPE(qtensorc)(*), POINTER, inout: On output, the projectors.
nsitesINTEGER, in: Number of sites to build the projectors on. Either single site (1) or two-sites (2).

Source Code

show / hide f90 code

  subroutine ConstructProjectors_qtensorc(kk, Psibs, LRab, Psiprojs, &
                                             nsites, errst)
      integer, intent(in) :: kk
      type(qmpsc) :: Psibs(:)
      type(qtensorclist) :: LRAB(:)
      type(qtensorc), pointer :: Psiprojs(:)
      integer, intent(in) :: nsites
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj

      ! number of overlaps, Psibs
      integer :: ne

      ! number of eigenvalues above tolerance
      integer :: nkeep

      ! Projectors before pseudoinverse
      type(qtensorc), pointer :: Rawpsiprojs(:)

      ! Gram matrix and its eigenvalues
      complex(KIND=rKind), dimension(:, :), allocatable:: nmat
      real(KIND=rKind), dimension(:), allocatable :: ev

      ! Temporary tensors
      type(qtensorc) :: Tmp, Tmpb

      ! tolerance singular value inversion
      real(KIND=rKind) ::  tol

      ne = size(LRab)
      allocate(Rawpsiprojs(ne))

      ! Construct the linear forms which impose orthogonality
      ! -----------------------------------------------------

      if(nsites == 1) then
          ! One site version
          ! ................

          do jj = 1, ne
              ! Step 1:E(a,i,b)= B(j)_{a,i,b'} L(j)%l(k+1) (b' b)
              if(kk == Psibs(jj)%ll) then
                  call copy(Tmp, Psibs(jj)%Aa(kk))
              else
                  call contr(Tmp, Psibs(jj)%Aa(kk), LRab(kk)%Li(kk + 1), & 
                             [3], [1], errst=errst)
              end if

              ! Step 2: rawpsiProjs(j)(a,i,b)=L(j)%l(k)%elem(a,a') E(a',i,b)
              if(kk == 1) then
                  call copy(Rawpsiprojs(jj), Tmp)
              else
                  call contr(Rawpsiprojs(jj), LRab(jj)%Li(kk - 1), Tmp, &
                             [2], [1], errst=errst)
              end if

              call destroy(Tmp)
          end do

      elseif(nsites == 2) then
          ! Two site version
          ! ................

          do jj = 1, ne
              ! Contract left overlap
              if(kk == 1) then
                  call copy(Tmp, Psibs(jj)%Aa(kk))
              else
                  call contr(Tmp, LRab(jj)%Li(kk - 1), Psibs(jj)%Aa(kk), &
                             [2], [1], errst=errst)
              end if

              ! Contract right overlap
              if(kk + 1 == Psibs(jj)%ll) then
                  call copy(Tmpb, Psibs(jj)%Aa(kk + 1))
              else
                  call contr(Tmpb, Psibs(jj)%Aa(kk + 1), LRab(jj)%Li(kk + 2), &
                             [3], [1], errst=errst)
              end if

              ! Build two-site tensor
              call contr(Rawpsiprojs(jj), Tmp, Tmpb, &
                         [3], [1], errst=errst)

              call destroy(Tmp)
              call destroy(Tmpb)
          end do
      else
          stop 'Not implement nsites > 2'
      end if

      ! Construct the Gram matrix
      allocate(nmat(ne, ne), ev(ne))

      do ii = 1, ne
          ! Diagonal element
          nmat(ii, ii) = Dot(Rawpsiprojs(ii), Rawpsiprojs(ii))

          do jj = (ii + 1), ne
              ! Upper triangular is enough for eigd
              nmat(ii, jj) = Dot(Rawpsiprojs(ii), Rawpsiprojs(jj))
          end do
      end do

      ! Construct the pseudoinverse of the Gram matrix (default to upper)
      call eigd(nmat, ev, ne, errst=errst)
      !if(prop_error('constructprojectors_qtensorc: eigd failed.', &
      !              'MPSOps_include.f90:162', errst=errst)) return

      ! Tolerance for singular value inversion=NE*||N||_2 *eps
      nkeep = 0
      tol = ne * maxval(ev) * numzero

      do ii = ne, 1, (-1)
          if(ev(ii) > tol) nkeep = nkeep + 1
      end do

      ! Copy the raw projectors to the final ones

      allocate(Psiprojs(nkeep))

      do ii = 1, nkeep
          call copy(Psiprojs(ii), Rawpsiprojs(1))

          ! jj = 1
          call scale(nmat(1, ne - ii + 1), Psiprojs(ii))

          do jj = 2, ne
              call gaxpy(Psiprojs(ii), nmat(jj, ne - ii + 1), Rawpsiprojs(jj))
          end do

          call scale(1.0_rKind / sqrt(ev(ne - ii + 1)), Psiprojs(ii))
      end do

      do ii = 1, ne
          call destroy(Rawpsiprojs(ii))
      end do

      deallocate(Rawpsiprojs, ev, nmat)

  end subroutine constructprojectors_qtensorc

MPSOps_f90.copy_mps_mps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Copy a Matrix Product State.

Arguments

PsiNewTYPE(mps), out: Copy a MPS into this variable
PsiOldTYPE(mps), in: Copy this MPS to PsiNew
scalarreal, OPTIONAL, in: Scale the MPS by a factor.

Source Code

show / hide f90 code

MPSOps_f90.copy_part_mps_mps()[source]¶

fortran-subroutine - November 2017 (dj, updated) Copy parts of an MPS. Orthogonality center has to be within the extracted part.

Arguments

PsiNewTYPE(mps), out: Copy a part of an MPS into this variable
PsiOldTYPE(mps), in: Copy part of this MPS to PsiNew
firstINTEGER, in: The first site of the old MPS to be copied.
lastINTEGER, in: The last site of the old MPS to be copied.
scalarreal, OPTIONAL, in: Scale the MPS by a factor.

Details

The copy of parts of an MPS only works on continuous number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be extracted with this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.copy_mpsc_mps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Copy a Matrix Product State.

Arguments

PsiNewTYPE(mpsc), out: Copy a MPS into this variable
PsiOldTYPE(mps), in: Copy this MPS to PsiNew
scalarcomplex, OPTIONAL, in: Scale the MPS by a factor.

Source Code

show / hide f90 code

MPSOps_f90.copy_part_mpsc_mps()[source]¶

fortran-subroutine - November 2017 (dj, updated) Copy parts of an MPS. Orthogonality center has to be within the extracted part.

Arguments

PsiNewTYPE(mpsc), out: Copy a part of an MPS into this variable
PsiOldTYPE(mps), in: Copy part of this MPS to PsiNew
firstINTEGER, in: The first site of the old MPS to be copied.
lastINTEGER, in: The last site of the old MPS to be copied.
scalarcomplex, OPTIONAL, in: Scale the MPS by a factor.

Details

The copy of parts of an MPS only works on continuous number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be extracted with this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.copy_mpsc_mpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Copy a Matrix Product State.

Arguments

PsiNewTYPE(mpsc), out: Copy a MPS into this variable
PsiOldTYPE(mpsc), in: Copy this MPS to PsiNew
scalarcomplex, OPTIONAL, in: Scale the MPS by a factor.

Source Code

show / hide f90 code

MPSOps_f90.copy_part_mpsc_mpsc()[source]¶

fortran-subroutine - November 2017 (dj, updated) Copy parts of an MPS. Orthogonality center has to be within the extracted part.

Arguments

PsiNewTYPE(mpsc), out: Copy a part of an MPS into this variable
PsiOldTYPE(mpsc), in: Copy part of this MPS to PsiNew
firstINTEGER, in: The first site of the old MPS to be copied.
lastINTEGER, in: The last site of the old MPS to be copied.
scalarcomplex, OPTIONAL, in: Scale the MPS by a factor.

Details

The copy of parts of an MPS only works on continuous number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be extracted with this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.copy_qmps_qmps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Copy a Matrix Product State.

Arguments

PsiNewTYPE(qmps), out: Copy a MPS into this variable
PsiOldTYPE(qmps), in: Copy this MPS to PsiNew
scalarreal, OPTIONAL, in: Scale the MPS by a factor.

Source Code

show / hide f90 code

MPSOps_f90.copy_part_qmps_qmps()[source]¶

fortran-subroutine - November 2017 (dj, updated) Copy parts of an MPS. Orthogonality center has to be within the extracted part.

Arguments

PsiNewTYPE(qmps), out: Copy a part of an MPS into this variable
PsiOldTYPE(qmps), in: Copy part of this MPS to PsiNew
firstINTEGER, in: The first site of the old MPS to be copied.
lastINTEGER, in: The last site of the old MPS to be copied.
scalarreal, OPTIONAL, in: Scale the MPS by a factor.

Details

The copy of parts of an MPS only works on continuous number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be extracted with this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.copy_qmpsc_qmps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Copy a Matrix Product State.

Arguments

PsiNewTYPE(qmpsc), out: Copy a MPS into this variable
PsiOldTYPE(qmps), in: Copy this MPS to PsiNew
scalarcomplex, OPTIONAL, in: Scale the MPS by a factor.

Source Code

show / hide f90 code

MPSOps_f90.copy_part_qmpsc_qmps()[source]¶

fortran-subroutine - November 2017 (dj, updated) Copy parts of an MPS. Orthogonality center has to be within the extracted part.

Arguments

PsiNewTYPE(qmpsc), out: Copy a part of an MPS into this variable
PsiOldTYPE(qmps), in: Copy part of this MPS to PsiNew
firstINTEGER, in: The first site of the old MPS to be copied.
lastINTEGER, in: The last site of the old MPS to be copied.
scalarcomplex, OPTIONAL, in: Scale the MPS by a factor.

Details

The copy of parts of an MPS only works on continuous number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be extracted with this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.copy_qmpsc_qmpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Copy a Matrix Product State.

Arguments

PsiNewTYPE(qmpsc), out: Copy a MPS into this variable
PsiOldTYPE(qmpsc), in: Copy this MPS to PsiNew
scalarcomplex, OPTIONAL, in: Scale the MPS by a factor.

Source Code

show / hide f90 code

MPSOps_f90.copy_part_qmpsc_qmpsc()[source]¶

fortran-subroutine - November 2017 (dj, updated) Copy parts of an MPS. Orthogonality center has to be within the extracted part.

Arguments

PsiNewTYPE(qmpsc), out: Copy a part of an MPS into this variable
PsiOldTYPE(qmpsc), in: Copy part of this MPS to PsiNew
firstINTEGER, in: The first site of the old MPS to be copied.
lastINTEGER, in: The last site of the old MPS to be copied.
scalarcomplex, OPTIONAL, in: Scale the MPS by a factor.

Details

The copy of parts of an MPS only works on continuous number of sites. Sites 2, 3, 4 work. Sites 2, 4, 5 cannot be extracted with this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.canonize_mps()[source]¶

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

Arguments

PsiTYPE(mps), inout: Bring this MPS into a canonical form using QR decompositions.
k0INTEGER, in: This is the new orthogonality center for the MPS.
klINTEGER, OPTIONAL, in: This optional argument can provide the information where to start with gauging the MPS from the left side of the MPS. 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 MPS from the right side of the MPS. If not given, the minimum of the system size and the present orthogonality center is choosen.

Details

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

Source Code

show / hide f90 code

MPSOps_f90.canonize_svd_mps()[source]¶

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

Arguments

PsiTYPE(mps), inout: MPS 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 MPS). Default does not truncate.
ncutINTEGER, OPTIONAL, in: Maximal bond dimension / number of singular values. Default is keeping all singular values.

Details

Put the MPS into the canonical form where all matrices to the left of $k_0$ (optionally down to $k_l$ ) are gauged according to the left-handed condition $\sum_i A_i^T A_i=I$ and all matrices to the right of $k_0$ (optionally up to $k_r$ ) are gauged according to the right-handed condition $\sum_i A_i A_i^T=I$ for OBC. This routine uses the SVD decomposition, which is rank revealing and so appropriate for compression. Additionally, the Schmidt coefficients are returned and so entropies can be computed.

Source Code

show / hide f90 code

MPSOps_f90.canonize_mpsc()[source]¶

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

Arguments

PsiTYPE(mpsc), inout: Bring this MPS into a canonical form using QR decompositions.
k0INTEGER, in: This is the new orthogonality center for the MPS.
klINTEGER, OPTIONAL, in: This optional argument can provide the information where to start with gauging the MPS from the left side of the MPS. 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 MPS from the right side of the MPS. If not given, the minimum of the system size and the present orthogonality center is choosen.

Details

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

Source Code

show / hide f90 code

MPSOps_f90.canonize_svd_mpsc()[source]¶

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

Arguments

PsiTYPE(mpsc), inout: MPS 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 MPS). Default does not truncate.
ncutINTEGER, OPTIONAL, in: Maximal bond dimension / number of singular values. Default is keeping all singular values.

Details

Put the MPS into the canonical form where all matrices to the left of $k_0$ (optionally down to $k_l$ ) are gauged according to the left-handed condition $\sum_i A_i^T A_i=I$ and all matrices to the right of $k_0$ (optionally up to $k_r$ ) are gauged according to the right-handed condition $\sum_i A_i A_i^T=I$ for OBC. This routine uses the SVD decomposition, which is rank revealing and so appropriate for compression. Additionally, the Schmidt coefficients are returned and so entropies can be computed.

Source Code

show / hide f90 code

MPSOps_f90.canonize_qmps()[source]¶

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

Arguments

PsiTYPE(qmps), inout: Bring this MPS into a canonical form using QR decompositions.
k0INTEGER, in: This is the new orthogonality center for the MPS.
klINTEGER, OPTIONAL, in: This optional argument can provide the information where to start with gauging the MPS from the left side of the MPS. 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 MPS from the right side of the MPS. If not given, the minimum of the system size and the present orthogonality center is choosen.

Details

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

Source Code

show / hide f90 code

MPSOps_f90.canonize_svd_qmps()[source]¶

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

Arguments

PsiTYPE(qmps), inout: MPS 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 MPS). Default does not truncate.
ncutINTEGER, OPTIONAL, in: Maximal bond dimension / number of singular values. Default is keeping all singular values.

Details

Put the MPS into the canonical form where all matrices to the left of $k_0$ (optionally down to $k_l$ ) are gauged according to the left-handed condition $\sum_i A_i^T A_i=I$ and all matrices to the right of $k_0$ (optionally up to $k_r$ ) are gauged according to the right-handed condition $\sum_i A_i A_i^T=I$ for OBC. This routine uses the SVD decomposition, which is rank revealing and so appropriate for compression. Additionally, the Schmidt coefficients are returned and so entropies can be computed.

Source Code

show / hide f90 code

MPSOps_f90.canonize_qmpsc()[source]¶

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

Arguments

PsiTYPE(qmpsc), inout: Bring this MPS into a canonical form using QR decompositions.
k0INTEGER, in: This is the new orthogonality center for the MPS.
klINTEGER, OPTIONAL, in: This optional argument can provide the information where to start with gauging the MPS from the left side of the MPS. 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 MPS from the right side of the MPS. If not given, the minimum of the system size and the present orthogonality center is choosen.

Details

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

Source Code

show / hide f90 code

MPSOps_f90.canonize_svd_qmpsc()[source]¶

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

Arguments

PsiTYPE(qmpsc), inout: MPS 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 MPS). Default does not truncate.
ncutINTEGER, OPTIONAL, in: Maximal bond dimension / number of singular values. Default is keeping all singular values.

Details

Put the MPS into the canonical form where all matrices to the left of $k_0$ (optionally down to $k_l$ ) are gauged according to the left-handed condition $\sum_i A_i^T A_i=I$ and all matrices to the right of $k_0$ (optionally up to $k_r$ ) are gauged according to the right-handed condition $\sum_i A_i A_i^T=I$ for OBC. This routine uses the SVD decomposition, which is rank revealing and so appropriate for compression. Additionally, the Schmidt coefficients are returned and so entropies can be computed.

Source Code

show / hide f90 code

MPSOps_f90.check_mps()[source]¶

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

Arguments

PsiTYPE(mps), in: Run checks on this MPS.

Source Code

show / hide f90 code

  subroutine check_mps(Psi, errst)
      type(mps), intent(in) :: Psi
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

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

      ! temporary tensor to guarantee 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(Psi%Aa(Psi%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_mps : norm failed '//&
      !                        trim(adjustl(info)), 99, errst=errst)
      !    return
      !end if
      if(abs(normoc -  1.0_rKind) > 1e-14_rKind) stop 'check_mps: norm.'

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

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

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

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

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

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

  end subroutine check_mps

MPSOps_f90.check_mpsc()[source]¶

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

Arguments

PsiTYPE(mpsc), in: Run checks on this MPS.

Source Code

show / hide f90 code

  subroutine check_mpsc(Psi, errst)
      type(mpsc), intent(in) :: Psi
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

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

      ! temporary tensor to guarantee 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(Psi%Aa(Psi%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_mpsc : norm failed '//&
      !                        trim(adjustl(info)), 99, errst=errst)
      !    return
      !end if
      if(abs(normoc -  1.0_rKind) > 1e-14_rKind) stop 'check_mpsc: norm.'

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

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

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

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

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

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

  end subroutine check_mpsc

MPSOps_f90.check_qmps()[source]¶

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

Arguments

PsiTYPE(qmps), in: Run checks on this MPS.

Source Code

show / hide f90 code

  subroutine check_qmps(Psi, errst)
      type(qmps), intent(in) :: Psi
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

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

      ! temporary tensor to guarantee 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(Psi%Aa(Psi%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_qmps : norm failed '//&
      !                        trim(adjustl(info)), 99, errst=errst)
      !    return
      !end if
      if(abs(normoc -  1.0_rKind) > 1e-14_rKind) stop 'check_qmps: norm.'

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

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

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

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

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

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

  end subroutine check_qmps

MPSOps_f90.check_qmpsc()[source]¶

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

Arguments

PsiTYPE(qmpsc), in: Run checks on this MPS.

Source Code

show / hide f90 code

  subroutine check_qmpsc(Psi, errst)
      type(qmpsc), intent(in) :: Psi
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

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

      ! temporary tensor to guarantee 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(Psi%Aa(Psi%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_qmpsc : norm failed '//&
      !                        trim(adjustl(info)), 99, errst=errst)
      !    return
      !end if
      if(abs(normoc -  1.0_rKind) > 1e-14_rKind) stop 'check_qmpsc: norm.'

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

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

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

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

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

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

  end subroutine check_qmpsc

MPSOps_f90.destroy_mps()[source]¶

fortran-subroutine - June 2017 (dj, update) Deallocate the MPS representing the wave function.

Arguments

PsiTYPE(mps), inout: Deallocate MPS including all tensors and vectors contained in the structure.

Source Code

show / hide f90 code

MPSOps_f90.destroy_mpsc()[source]¶

fortran-subroutine - June 2017 (dj, update) Deallocate the MPS representing the wave function.

Arguments

PsiTYPE(mpsc), inout: Deallocate MPS including all tensors and vectors contained in the structure.

Source Code

show / hide f90 code

MPSOps_f90.destroy_qmps()[source]¶

fortran-subroutine - June 2017 (dj, update) Deallocate the MPS representing the wave function.

Arguments

PsiTYPE(qmps), inout: Deallocate MPS including all tensors and vectors contained in the structure.

Source Code

show / hide f90 code

MPSOps_f90.destroy_qmpsc()[source]¶

fortran-subroutine - June 2017 (dj, update) Deallocate the MPS representing the wave function.

Arguments

PsiTYPE(qmpsc), inout: Deallocate MPS including all tensors and vectors contained in the structure.

Source Code

show / hide f90 code

MPSOps_f90.distance_mps_mps()[source]¶

fortran-function - September 2017 (dj) Measure the distance between two MPSs.

Arguments

PsiATYPE(mps), inout: First quantum state to calculate a fidelity.
PsiBTYPE(mps), in: Second quantum state to calculate a fidelity.
dist_typeCHARACTER, OPTIONAL, in: Specify the distance to be calculated. Option are ‘F’ (fidelity) and ‘O’ (overlap, default).

Source Code

show / hide f90 code

MPSOps_f90.distance_mps_mpsc()[source]¶

fortran-function - September 2017 (dj) Measure the distance between two MPSs.

Arguments

PsiATYPE(mps), inout: First quantum state to calculate a fidelity.
PsiBTYPE(mpsc), in: Second quantum state to calculate a fidelity.
dist_typeCHARACTER, OPTIONAL, in: Specify the distance to be calculated. Option are ‘F’ (fidelity) and ‘O’ (overlap, default).

Source Code

show / hide f90 code

MPSOps_f90.distance_mpsc_mps()[source]¶

fortran-function - September 2017 (dj) Measure the distance between two MPSs.

Arguments

PsiATYPE(mpsc), inout: First quantum state to calculate a fidelity.
PsiBTYPE(mps), in: Second quantum state to calculate a fidelity.
dist_typeCHARACTER, OPTIONAL, in: Specify the distance to be calculated. Option are ‘F’ (fidelity) and ‘O’ (overlap, default).

Source Code

show / hide f90 code

MPSOps_f90.distance_mpsc_mpsc()[source]¶

fortran-function - September 2017 (dj) Measure the distance between two MPSs.

Arguments

PsiATYPE(mpsc), inout: First quantum state to calculate a fidelity.
PsiBTYPE(mpsc), in: Second quantum state to calculate a fidelity.
dist_typeCHARACTER, OPTIONAL, in: Specify the distance to be calculated. Option are ‘F’ (fidelity) and ‘O’ (overlap, default).

Source Code

show / hide f90 code

MPSOps_f90.distance_qmps_qmps()[source]¶

fortran-function - September 2017 (dj) Measure the distance between two MPSs.

Arguments

PsiATYPE(qmps), inout: First quantum state to calculate a fidelity.
PsiBTYPE(qmps), in: Second quantum state to calculate a fidelity.
dist_typeCHARACTER, OPTIONAL, in: Specify the distance to be calculated. Option are ‘F’ (fidelity) and ‘O’ (overlap, default).

Source Code

show / hide f90 code

MPSOps_f90.distance_qmps_qmpsc()[source]¶

fortran-function - September 2017 (dj) Measure the distance between two MPSs.

Arguments

PsiATYPE(qmps), inout: First quantum state to calculate a fidelity.
PsiBTYPE(qmpsc), in: Second quantum state to calculate a fidelity.
dist_typeCHARACTER, OPTIONAL, in: Specify the distance to be calculated. Option are ‘F’ (fidelity) and ‘O’ (overlap, default).

Source Code

show / hide f90 code

MPSOps_f90.distance_qmpsc_qmps()[source]¶

fortran-function - September 2017 (dj) Measure the distance between two MPSs.

Arguments

PsiATYPE(qmpsc), inout: First quantum state to calculate a fidelity.
PsiBTYPE(qmps), in: Second quantum state to calculate a fidelity.
dist_typeCHARACTER, OPTIONAL, in: Specify the distance to be calculated. Option are ‘F’ (fidelity) and ‘O’ (overlap, default).

Source Code

show / hide f90 code

MPSOps_f90.distance_qmpsc_qmpsc()[source]¶

fortran-function - September 2017 (dj) Measure the distance between two MPSs.

Arguments

PsiATYPE(qmpsc), inout: First quantum state to calculate a fidelity.
PsiBTYPE(qmpsc), in: Second quantum state to calculate a fidelity.
dist_typeCHARACTER, OPTIONAL, in: Specify the distance to be calculated. Option are ‘F’ (fidelity) and ‘O’ (overlap, default).

Source Code

show / hide f90 code

MPSOps_f90.dot_mps_mps()[source]¶

fortran-function - June 2017 (dj) Compute the fidelity / inner product <A,B> between two quantum states.

Arguments

PsiATYPE(mps), inout: First quantum state to calculate a fidelity.
PsiBTYPE(mps), in: Second quantum state to calculate a fidelity.

Source Code

show / hide f90 code

MPSOps_f90.dot_mps_mpsc()[source]¶

fortran-function - June 2017 (dj) Compute the fidelity / inner product <A,B> between two quantum states.

Arguments

PsiATYPE(mps), inout: First quantum state to calculate a fidelity.
PsiBTYPE(mpsc), in: Second quantum state to calculate a fidelity.

Source Code

show / hide f90 code

MPSOps_f90.dot_mpsc_mps()[source]¶

fortran-function - June 2017 (dj) Compute the fidelity / inner product <A,B> between two quantum states.

Arguments

PsiATYPE(mpsc), inout: First quantum state to calculate a fidelity.
PsiBTYPE(mps), in: Second quantum state to calculate a fidelity.

Source Code

show / hide f90 code

MPSOps_f90.dot_mpsc_mpsc()[source]¶

fortran-function - June 2017 (dj) Compute the fidelity / inner product <A,B> between two quantum states.

Arguments

PsiATYPE(mpsc), inout: First quantum state to calculate a fidelity.
PsiBTYPE(mpsc), in: Second quantum state to calculate a fidelity.

Source Code

show / hide f90 code

MPSOps_f90.dot_qmps_qmps()[source]¶

fortran-function - June 2017 (dj) Compute the fidelity / inner product <A,B> between two quantum states.

Arguments

PsiATYPE(qmps), inout: First quantum state to calculate a fidelity.
PsiBTYPE(qmps), in: Second quantum state to calculate a fidelity.

Source Code

show / hide f90 code

MPSOps_f90.dot_qmps_qmpsc()[source]¶

fortran-function - June 2017 (dj) Compute the fidelity / inner product <A,B> between two quantum states.

Arguments

PsiATYPE(qmps), inout: First quantum state to calculate a fidelity.
PsiBTYPE(qmpsc), in: Second quantum state to calculate a fidelity.

Source Code

show / hide f90 code

MPSOps_f90.dot_qmpsc_qmps()[source]¶

fortran-function - June 2017 (dj) Compute the fidelity / inner product <A,B> between two quantum states.

Arguments

PsiATYPE(qmpsc), inout: First quantum state to calculate a fidelity.
PsiBTYPE(qmps), in: Second quantum state to calculate a fidelity.

Source Code

show / hide f90 code

MPSOps_f90.dot_qmpsc_qmpsc()[source]¶

fortran-function - June 2017 (dj) Compute the fidelity / inner product <A,B> between two quantum states.

Arguments

PsiATYPE(qmpsc), inout: First quantum state to calculate a fidelity.
PsiBTYPE(qmpsc), in: Second quantum state to calculate a fidelity.

Source Code

show / hide f90 code

MPSOps_f90.gaugesite_qr_tensor()[source]¶

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

MPSOps_f90.gaugesite_rq_tensor()[source]¶

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

MPSOps_f90.gaugesite_qr_tensorc()[source]¶

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

MPSOps_f90.gaugesite_rq_tensorc()[source]¶

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

MPSOps_f90.gaugesite_qr_qtensor()[source]¶

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

MPSOps_f90.gaugesite_rq_qtensor()[source]¶

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

MPSOps_f90.gaugesite_qr_qtensorc()[source]¶

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

MPSOps_f90.gaugesite_rq_qtensorc()[source]¶

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

MPSOps_f90.gaugesite_rsvd_tensor()[source]¶

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

MPSOps_f90.gaugesite_lsvd_tensor()[source]¶

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

MPSOps_f90.gaugesite_rsvd_tensorc()[source]¶

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

MPSOps_f90.gaugesite_lsvd_tensorc()[source]¶

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

MPSOps_f90.gaugesite_rsvd_qtensor()[source]¶

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

MPSOps_f90.gaugesite_lsvd_qtensor()[source]¶

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

MPSOps_f90.gaugesite_rsvd_qtensorc()[source]¶

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

MPSOps_f90.gaugesite_lsvd_qtensorc()[source]¶

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

MPSOps_f90.maxchi_mps()[source]¶

fortran-function - July 2017 (dj, updated) Get the maximal bond dimension of the MPS.

Arguments

PsiTYPE(mps), in: Get the maximal bond dimension present in the MPS

Source Code

show / hide f90 code

MPSOps_f90.maxchi_mpsc()[source]¶

fortran-function - July 2017 (dj, updated) Get the maximal bond dimension of the MPS.

Arguments

PsiTYPE(mpsc), in: Get the maximal bond dimension present in the MPS

Source Code

show / hide f90 code

MPSOps_f90.maxchi_qmps()[source]¶

fortran-function - July 2017 (dj, updated) Get the maximal bond dimension of the MPS.

Arguments

PsiTYPE(qmps), in: Get the maximal bond dimension present in the MPS

Source Code

show / hide f90 code

MPSOps_f90.maxchi_qmpsc()[source]¶

fortran-function - July 2017 (dj, updated) Get the maximal bond dimension of the MPS.

Arguments

PsiTYPE(qmpsc), in: Get the maximal bond dimension present in the MPS

Source Code

show / hide f90 code

MPSOps_f90.maxkappa_mps()[source]¶

fortran-function - September 2017 (dj) Get the maximal bond dimension to conjugate tensor of MPS. MPS is a pure state, therefore always 1.

Arguments

PsiTYPE(mps), in: Maximal bond dimension kappa is always 1 for a pure state.

Source Code

show / hide f90 code

MPSOps_f90.maxkappa_mpsc()[source]¶

fortran-function - September 2017 (dj) Get the maximal bond dimension to conjugate tensor of MPS. MPS is a pure state, therefore always 1.

Arguments

PsiTYPE(mpsc), in: Maximal bond dimension kappa is always 1 for a pure state.

Source Code

show / hide f90 code

MPSOps_f90.maxkappa_qmps()[source]¶

fortran-function - September 2017 (dj) Get the maximal bond dimension to conjugate tensor of MPS. MPS is a pure state, therefore always 1.

Arguments

PsiTYPE(qmps), in: Maximal bond dimension kappa is always 1 for a pure state.

Source Code

show / hide f90 code

MPSOps_f90.maxkappa_qmpsc()[source]¶

fortran-function - September 2017 (dj) Get the maximal bond dimension to conjugate tensor of MPS. MPS is a pure state, therefore always 1.

Arguments

PsiTYPE(qmpsc), in: Maximal bond dimension kappa is always 1 for a pure state.

Source Code

show / hide f90 code

MPSOps_f90.mpo_dot_psi_tensor_tensor()[source]¶

fortran-subroutine - April 2016 (dj) Compute $| \phi \rangle = H | \psi \rangle$ .

Arguments

PhiTYPE(FOURtensor), out: On exit it contains $H | \psi \rangle$ .
LcTYPE(tensorlist), in: Contains the contraction of Psi with H left of the sites considered in this subroutine.
WlTYPE(tensor), in: The MPO-matrix for the left of the two sites.
WrTYPE(tensor), in: The MPO-matrix for the right of the two sites.
RcTYPE(tensorlist), in: Contains the contraction of Psi with H right of the sites considered in this subroutine.
PsilTYPE(tensor), in: Left site of the two sites considered in Psi.
PsirTYPE(tensor), in: Right site of the two sites considered in Psi.

Details

(template defined in MPSOps_include_transfer.f90)

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_tensor_tensor(Phi, Lc, Wl, Wr, Rc, &
                                               Psil, Psir, leftmost, &
                                               rightmost, errst)
      type(tensor), intent(inout) :: Phi
      type(tensorlist), intent(inout) :: Lc, Rc
      type(sr_matrix_tensor), intent(inout) :: Wl, Wr
      type(tensor), intent(inout) :: Psil, Psir
      logical, intent(in) :: leftmost, rightmost
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrices
      integer :: k1, k2, k3

      ! Result of contractions Psil-Lc / Psir-Rc
      type(tensor), dimension(:), allocatable :: Fl(:), Fr(:)

      ! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
      type(tensor), dimension(:), allocatable :: El(:), Er(:)

      ! temporary tensor
      type(tensor) :: Tmp

      ! Get bond dimensions MPO-matrices
      k1 = Wl%rbd
      k2 = Wl%cbd
      k3 = Wr%cbd

      allocate(Fl(k1), Fr(k3), El(k2), Er(k2))

      ! 1) Contractions on left tensor
      ! ------------------------------
      !
      ! a) Contract left transfer matrix with Psil.
      ! b) MPO matrix for the left site to result of previous step.

      if(leftmost) then
          ! Initialize

          do ii = 1, k2
              call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensor:'//&
              !              'contractmporone failed.', &
              !              errst=errst)) return
          end do
      else
          ! Propagate

          do ii = 1, k1
              call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensor:'//&
              !              'contr (1) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensor:'//&
              !              'contractmpor failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k2
              call destroy(Fl(ii))
          end do
      end if

      ! 2) Contractions on right tensor
      ! -------------------------------
      !
      ! a) Contract right transfer matrix with Psir.
      ! b) MPO matrix for the right site to result of previous step.

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
                          errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensor:'//&
              !              'mcontr (1) failed.', errst=errst)) return

              !call copy(Tmp, Psir)
              !call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
              !           errst=errst)
              !!if(prop_error('mpo_dot_psi_tensor_tensor:'//&
              !!              'contr (2) failed.', errst=errst)) return

              !call destroy(Tmp)
          end do
      else
          ! Propagate

          do ii = 1, k3
              call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensor:'//&
              !              'contr (3) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensor:'//&
              !              'contractmpol failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k3
              call destroy(Fr(ii))
          end do
      end if

      deallocate(Fl, Fr)

      ! 3) Contract the two sides together
      ! ----------------------------------

      ! First index
      call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
      !call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
      !if(prop_error('mpo_dot_psi_tensor_tensor:'//&
      !              'contr (4) failed.', errst=errst)) return

      call destroy(El(1))
      call destroy(Er(1))

      ! Add remaining indices
      do ii = 2, k2
          call contr(Phi, El(ii), Er(ii), [3], [1], beta=done, errst=errst)
          !call contr(Phi, El(ii), Er(ii), [2], [2], beta=done, errst=errst)
          !if(prop_error('mpo_dot_psi_tensor_tensor:'//&
          !              'contr (5) failed.', errst=errst)) return

          call destroy(El(ii))
          call destroy(Er(ii))
      end do

      deallocate(El, Er)

  end subroutine mpo_dot_psi_tensor_tensor

MPSOps_f90.mpo_dot_psi_tensor_tensorc()[source]¶

fortran-subroutine - April 2016 (dj) Compute $| \phi \rangle = H | \psi \rangle$ .

Arguments

PhiTYPE(FOURtensorc), out: On exit it contains $H | \psi \rangle$ .
LcTYPE(tensorlistc), in: Contains the contraction of Psi with H left of the sites considered in this subroutine.
WlTYPE(tensor), in: The MPO-matrix for the left of the two sites.
WrTYPE(tensor), in: The MPO-matrix for the right of the two sites.
RcTYPE(tensorlistc), in: Contains the contraction of Psi with H right of the sites considered in this subroutine.
PsilTYPE(tensorc), in: Left site of the two sites considered in Psi.
PsirTYPE(tensorc), in: Right site of the two sites considered in Psi.

Details

(template defined in MPSOps_include_transfer.f90)

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_tensor_tensorc(Phi, Lc, Wl, Wr, Rc, &
                                               Psil, Psir, leftmost, &
                                               rightmost, errst)
      type(tensorc), intent(inout) :: Phi
      type(tensorlistc), intent(inout) :: Lc, Rc
      type(sr_matrix_tensor), intent(inout) :: Wl, Wr
      type(tensorc), intent(inout) :: Psil, Psir
      logical, intent(in) :: leftmost, rightmost
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrices
      integer :: k1, k2, k3

      ! Result of contractions Psil-Lc / Psir-Rc
      type(tensorc), dimension(:), allocatable :: Fl(:), Fr(:)

      ! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
      type(tensorc), dimension(:), allocatable :: El(:), Er(:)

      ! temporary tensor
      type(tensorc) :: Tmp

      ! Get bond dimensions MPO-matrices
      k1 = Wl%rbd
      k2 = Wl%cbd
      k3 = Wr%cbd

      allocate(Fl(k1), Fr(k3), El(k2), Er(k2))

      ! 1) Contractions on left tensor
      ! ------------------------------
      !
      ! a) Contract left transfer matrix with Psil.
      ! b) MPO matrix for the left site to result of previous step.

      if(leftmost) then
          ! Initialize

          do ii = 1, k2
              call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
              !              'contractmporone failed.', &
              !              errst=errst)) return
          end do
      else
          ! Propagate

          do ii = 1, k1
              call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
              !              'contr (1) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
              !              'contractmpor failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k2
              call destroy(Fl(ii))
          end do
      end if

      ! 2) Contractions on right tensor
      ! -------------------------------
      !
      ! a) Contract right transfer matrix with Psir.
      ! b) MPO matrix for the right site to result of previous step.

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
                          errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
              !              'mcontr (1) failed.', errst=errst)) return

              !call copy(Tmp, Psir)
              !call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
              !           errst=errst)
              !!if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
              !!              'contr (2) failed.', errst=errst)) return

              !call destroy(Tmp)
          end do
      else
          ! Propagate

          do ii = 1, k3
              call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
              !              'contr (3) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
              !if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
              !              'contractmpol failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k3
              call destroy(Fr(ii))
          end do
      end if

      deallocate(Fl, Fr)

      ! 3) Contract the two sides together
      ! ----------------------------------

      ! First index
      call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
      !call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
      !if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
      !              'contr (4) failed.', errst=errst)) return

      call destroy(El(1))
      call destroy(Er(1))

      ! Add remaining indices
      do ii = 2, k2
          call contr(Phi, El(ii), Er(ii), [3], [1], beta=zone, errst=errst)
          !call contr(Phi, El(ii), Er(ii), [2], [2], beta=zone, errst=errst)
          !if(prop_error('mpo_dot_psi_tensor_tensorc:'//&
          !              'contr (5) failed.', errst=errst)) return

          call destroy(El(ii))
          call destroy(Er(ii))
      end do

      deallocate(El, Er)

  end subroutine mpo_dot_psi_tensor_tensorc

MPSOps_f90.mpo_dot_psi_tensorc_tensorc()[source]¶

fortran-subroutine - April 2016 (dj) Compute $| \phi \rangle = H | \psi \rangle$ .

Arguments

PhiTYPE(FOURtensorc), out: On exit it contains $H | \psi \rangle$ .
LcTYPE(tensorlistc), in: Contains the contraction of Psi with H left of the sites considered in this subroutine.
WlTYPE(tensorc), in: The MPO-matrix for the left of the two sites.
WrTYPE(tensorc), in: The MPO-matrix for the right of the two sites.
RcTYPE(tensorlistc), in: Contains the contraction of Psi with H right of the sites considered in this subroutine.
PsilTYPE(tensorc), in: Left site of the two sites considered in Psi.
PsirTYPE(tensorc), in: Right site of the two sites considered in Psi.

Details

(template defined in MPSOps_include_transfer.f90)

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_tensorc_tensorc(Phi, Lc, Wl, Wr, Rc, &
                                               Psil, Psir, leftmost, &
                                               rightmost, errst)
      type(tensorc), intent(inout) :: Phi
      type(tensorlistc), intent(inout) :: Lc, Rc
      type(sr_matrix_tensorc), intent(inout) :: Wl, Wr
      type(tensorc), intent(inout) :: Psil, Psir
      logical, intent(in) :: leftmost, rightmost
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrices
      integer :: k1, k2, k3

      ! Result of contractions Psil-Lc / Psir-Rc
      type(tensorc), dimension(:), allocatable :: Fl(:), Fr(:)

      ! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
      type(tensorc), dimension(:), allocatable :: El(:), Er(:)

      ! temporary tensor
      type(tensorc) :: Tmp

      ! Get bond dimensions MPO-matrices
      k1 = Wl%rbd
      k2 = Wl%cbd
      k3 = Wr%cbd

      allocate(Fl(k1), Fr(k3), El(k2), Er(k2))

      ! 1) Contractions on left tensor
      ! ------------------------------
      !
      ! a) Contract left transfer matrix with Psil.
      ! b) MPO matrix for the left site to result of previous step.

      if(leftmost) then
          ! Initialize

          do ii = 1, k2
              call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
              !if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
              !              'contractmporone failed.', &
              !              errst=errst)) return
          end do
      else
          ! Propagate

          do ii = 1, k1
              call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
              !              'contr (1) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
              !if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
              !              'contractmpor failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k2
              call destroy(Fl(ii))
          end do
      end if

      ! 2) Contractions on right tensor
      ! -------------------------------
      !
      ! a) Contract right transfer matrix with Psir.
      ! b) MPO matrix for the right site to result of previous step.

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
                          errst=errst)
              !if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
              !              'mcontr (1) failed.', errst=errst)) return

              !call copy(Tmp, Psir)
              !call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
              !           errst=errst)
              !!if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
              !!              'contr (2) failed.', errst=errst)) return

              !call destroy(Tmp)
          end do
      else
          ! Propagate

          do ii = 1, k3
              call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
              !              'contr (3) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
              !if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
              !              'contractmpol failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k3
              call destroy(Fr(ii))
          end do
      end if

      deallocate(Fl, Fr)

      ! 3) Contract the two sides together
      ! ----------------------------------

      ! First index
      call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
      !call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
      !if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
      !              'contr (4) failed.', errst=errst)) return

      call destroy(El(1))
      call destroy(Er(1))

      ! Add remaining indices
      do ii = 2, k2
          call contr(Phi, El(ii), Er(ii), [3], [1], beta=zone, errst=errst)
          !call contr(Phi, El(ii), Er(ii), [2], [2], beta=zone, errst=errst)
          !if(prop_error('mpo_dot_psi_tensorc_tensorc:'//&
          !              'contr (5) failed.', errst=errst)) return

          call destroy(El(ii))
          call destroy(Er(ii))
      end do

      deallocate(El, Er)

  end subroutine mpo_dot_psi_tensorc_tensorc

MPSOps_f90.mpo_dot_psi_qtensor_qtensor()[source]¶

fortran-subroutine - April 2016 (dj) Compute $| \phi \rangle = H | \psi \rangle$ .

Arguments

PhiTYPE(FOURqtensor), out: On exit it contains $H | \psi \rangle$ .
LcTYPE(qtensorlist), in: Contains the contraction of Psi with H left of the sites considered in this subroutine.
WlTYPE(qtensor), in: The MPO-matrix for the left of the two sites.
WrTYPE(qtensor), in: The MPO-matrix for the right of the two sites.
RcTYPE(qtensorlist), in: Contains the contraction of Psi with H right of the sites considered in this subroutine.
PsilTYPE(qtensor), in: Left site of the two sites considered in Psi.
PsirTYPE(qtensor), in: Right site of the two sites considered in Psi.

Details

(template defined in MPSOps_include_transfer.f90)

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_qtensor_qtensor(Phi, Lc, Wl, Wr, Rc, &
                                               Psil, Psir, leftmost, &
                                               rightmost, errst)
      type(qtensor), intent(inout) :: Phi
      type(qtensorlist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensor), intent(inout) :: Wl, Wr
      type(qtensor), intent(inout) :: Psil, Psir
      logical, intent(in) :: leftmost, rightmost
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrices
      integer :: k1, k2, k3

      ! Result of contractions Psil-Lc / Psir-Rc
      type(qtensor), dimension(:), allocatable :: Fl(:), Fr(:)

      ! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
      type(qtensor), dimension(:), allocatable :: El(:), Er(:)

      ! temporary tensor
      type(qtensor) :: Tmp

      ! Get bond dimensions MPO-matrices
      k1 = Wl%rbd
      k2 = Wl%cbd
      k3 = Wr%cbd

      allocate(Fl(k1), Fr(k3), El(k2), Er(k2))

      ! 1) Contractions on left tensor
      ! ------------------------------
      !
      ! a) Contract left transfer matrix with Psil.
      ! b) MPO matrix for the left site to result of previous step.

      if(leftmost) then
          ! Initialize

          do ii = 1, k2
              call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
              !              'contractmporone failed.', &
              !              errst=errst)) return
          end do
      else
          ! Propagate

          do ii = 1, k1
              call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
              !              'contr (1) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
              !              'contractmpor failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k2
              call destroy(Fl(ii))
          end do
      end if

      ! 2) Contractions on right tensor
      ! -------------------------------
      !
      ! a) Contract right transfer matrix with Psir.
      ! b) MPO matrix for the right site to result of previous step.

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
                          errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
              !              'mcontr (1) failed.', errst=errst)) return

              !call copy(Tmp, Psir)
              !call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
              !           errst=errst)
              !!if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
              !!              'contr (2) failed.', errst=errst)) return

              !call destroy(Tmp)
          end do
      else
          ! Propagate

          do ii = 1, k3
              call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
              !              'contr (3) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
              !              'contractmpol failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k3
              call destroy(Fr(ii))
          end do
      end if

      deallocate(Fl, Fr)

      ! 3) Contract the two sides together
      ! ----------------------------------

      ! First index
      call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
      !call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
      !if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
      !              'contr (4) failed.', errst=errst)) return

      call destroy(El(1))
      call destroy(Er(1))

      ! Add remaining indices
      do ii = 2, k2
          call contr(Phi, El(ii), Er(ii), [3], [1], beta=done, errst=errst)
          !call contr(Phi, El(ii), Er(ii), [2], [2], beta=done, errst=errst)
          !if(prop_error('mpo_dot_psi_qtensor_qtensor:'//&
          !              'contr (5) failed.', errst=errst)) return

          call destroy(El(ii))
          call destroy(Er(ii))
      end do

      deallocate(El, Er)

  end subroutine mpo_dot_psi_qtensor_qtensor

MPSOps_f90.mpo_dot_psi_qtensor_qtensorc()[source]¶

fortran-subroutine - April 2016 (dj) Compute $| \phi \rangle = H | \psi \rangle$ .

Arguments

PhiTYPE(FOURqtensorc), out: On exit it contains $H | \psi \rangle$ .
LcTYPE(qtensorclist), in: Contains the contraction of Psi with H left of the sites considered in this subroutine.
WlTYPE(qtensor), in: The MPO-matrix for the left of the two sites.
WrTYPE(qtensor), in: The MPO-matrix for the right of the two sites.
RcTYPE(qtensorclist), in: Contains the contraction of Psi with H right of the sites considered in this subroutine.
PsilTYPE(qtensorc), in: Left site of the two sites considered in Psi.
PsirTYPE(qtensorc), in: Right site of the two sites considered in Psi.

Details

(template defined in MPSOps_include_transfer.f90)

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_qtensor_qtensorc(Phi, Lc, Wl, Wr, Rc, &
                                               Psil, Psir, leftmost, &
                                               rightmost, errst)
      type(qtensorc), intent(inout) :: Phi
      type(qtensorclist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensor), intent(inout) :: Wl, Wr
      type(qtensorc), intent(inout) :: Psil, Psir
      logical, intent(in) :: leftmost, rightmost
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrices
      integer :: k1, k2, k3

      ! Result of contractions Psil-Lc / Psir-Rc
      type(qtensorc), dimension(:), allocatable :: Fl(:), Fr(:)

      ! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
      type(qtensorc), dimension(:), allocatable :: El(:), Er(:)

      ! temporary tensor
      type(qtensorc) :: Tmp

      ! Get bond dimensions MPO-matrices
      k1 = Wl%rbd
      k2 = Wl%cbd
      k3 = Wr%cbd

      allocate(Fl(k1), Fr(k3), El(k2), Er(k2))

      ! 1) Contractions on left tensor
      ! ------------------------------
      !
      ! a) Contract left transfer matrix with Psil.
      ! b) MPO matrix for the left site to result of previous step.

      if(leftmost) then
          ! Initialize

          do ii = 1, k2
              call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
              !              'contractmporone failed.', &
              !              errst=errst)) return
          end do
      else
          ! Propagate

          do ii = 1, k1
              call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
              !              'contr (1) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
              !              'contractmpor failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k2
              call destroy(Fl(ii))
          end do
      end if

      ! 2) Contractions on right tensor
      ! -------------------------------
      !
      ! a) Contract right transfer matrix with Psir.
      ! b) MPO matrix for the right site to result of previous step.

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
                          errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
              !              'mcontr (1) failed.', errst=errst)) return

              !call copy(Tmp, Psir)
              !call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
              !           errst=errst)
              !!if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
              !!              'contr (2) failed.', errst=errst)) return

              !call destroy(Tmp)
          end do
      else
          ! Propagate

          do ii = 1, k3
              call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
              !              'contr (3) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
              !              'contractmpol failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k3
              call destroy(Fr(ii))
          end do
      end if

      deallocate(Fl, Fr)

      ! 3) Contract the two sides together
      ! ----------------------------------

      ! First index
      call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
      !call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
      !if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
      !              'contr (4) failed.', errst=errst)) return

      call destroy(El(1))
      call destroy(Er(1))

      ! Add remaining indices
      do ii = 2, k2
          call contr(Phi, El(ii), Er(ii), [3], [1], beta=zone, errst=errst)
          !call contr(Phi, El(ii), Er(ii), [2], [2], beta=zone, errst=errst)
          !if(prop_error('mpo_dot_psi_qtensor_qtensorc:'//&
          !              'contr (5) failed.', errst=errst)) return

          call destroy(El(ii))
          call destroy(Er(ii))
      end do

      deallocate(El, Er)

  end subroutine mpo_dot_psi_qtensor_qtensorc

MPSOps_f90.mpo_dot_psi_qtensorc_qtensorc()[source]¶

fortran-subroutine - April 2016 (dj) Compute $| \phi \rangle = H | \psi \rangle$ .

Arguments

PhiTYPE(FOURqtensorc), out: On exit it contains $H | \psi \rangle$ .
LcTYPE(qtensorclist), in: Contains the contraction of Psi with H left of the sites considered in this subroutine.
WlTYPE(qtensorc), in: The MPO-matrix for the left of the two sites.
WrTYPE(qtensorc), in: The MPO-matrix for the right of the two sites.
RcTYPE(qtensorclist), in: Contains the contraction of Psi with H right of the sites considered in this subroutine.
PsilTYPE(qtensorc), in: Left site of the two sites considered in Psi.
PsirTYPE(qtensorc), in: Right site of the two sites considered in Psi.

Details

(template defined in MPSOps_include_transfer.f90)

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_qtensorc_qtensorc(Phi, Lc, Wl, Wr, Rc, &
                                               Psil, Psir, leftmost, &
                                               rightmost, errst)
      type(qtensorc), intent(inout) :: Phi
      type(qtensorclist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensorc), intent(inout) :: Wl, Wr
      type(qtensorc), intent(inout) :: Psil, Psir
      logical, intent(in) :: leftmost, rightmost
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrices
      integer :: k1, k2, k3

      ! Result of contractions Psil-Lc / Psir-Rc
      type(qtensorc), dimension(:), allocatable :: Fl(:), Fr(:)

      ! Result of contractions Psil-Lc-MPOl / Psir-Rc-MPOr
      type(qtensorc), dimension(:), allocatable :: El(:), Er(:)

      ! temporary tensor
      type(qtensorc) :: Tmp

      ! Get bond dimensions MPO-matrices
      k1 = Wl%rbd
      k2 = Wl%cbd
      k3 = Wr%cbd

      allocate(Fl(k1), Fr(k3), El(k2), Er(k2))

      ! 1) Contractions on left tensor
      ! ------------------------------
      !
      ! a) Contract left transfer matrix with Psil.
      ! b) MPO matrix for the left site to result of previous step.

      if(leftmost) then
          ! Initialize

          do ii = 1, k2
              call contractmporone(El(ii), ii, Wl, Psil, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
              !              'contractmporone failed.', &
              !              errst=errst)) return
          end do
      else
          ! Propagate

          do ii = 1, k1
              call contr(Fl(ii), Lc%Li(ii), Psil, [2], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
              !              'contr (1) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpor(El(ii), ii, Wl, Fl, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
              !              'contractmpor failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k2
              call destroy(Fl(ii))
          end do
      end if

      ! 2) Contractions on right tensor
      ! -------------------------------
      !
      ! a) Contract right transfer matrix with Psir.
      ! b) MPO matrix for the right site to result of previous step.

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call mcontr(Er(ii), Psir, Wr%Row(ii)%Op(1), [2], [2], &
                          errst=errst)
              !if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
              !              'mcontr (1) failed.', errst=errst)) return

              !call copy(Tmp, Psir)
              !call contr(Er(ii), Wr%Row(ii)%Op(1), Tmp, [2], [2], &
              !           errst=errst)
              !!if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
              !!              'contr (2) failed.', errst=errst)) return

              !call destroy(Tmp)
          end do
      else
          ! Propagate

          do ii = 1, k3
              call contr(Fr(ii), Psir, Rc%Li(ii), [3], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
              !              'contr (3) failed.', errst=errst)) return
          end do

          do ii = 1, k2
              call contractmpol(Er(ii), ii, Wr, Fr, errst=errst)
              !if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
              !              'contractmpol failed.', &
              !              errst=errst)) return
          end do

          do ii = 1, k3
              call destroy(Fr(ii))
          end do
      end if

      deallocate(Fl, Fr)

      ! 3) Contract the two sides together
      ! ----------------------------------

      ! First index
      call contr(Phi, El(1), Er(1), [3], [1], errst=errst)
      !call contr(Phi, El(1), Er(1), [2], [2], errst=errst)
      !if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
      !              'contr (4) failed.', errst=errst)) return

      call destroy(El(1))
      call destroy(Er(1))

      ! Add remaining indices
      do ii = 2, k2
          call contr(Phi, El(ii), Er(ii), [3], [1], beta=zone, errst=errst)
          !call contr(Phi, El(ii), Er(ii), [2], [2], beta=zone, errst=errst)
          !if(prop_error('mpo_dot_psi_qtensorc_qtensorc:'//&
          !              'contr (5) failed.', errst=errst)) return

          call destroy(El(ii))
          call destroy(Er(ii))
      end do

      deallocate(El, Er)

  end subroutine mpo_dot_psi_qtensorc_qtensorc

MPSOps_f90.mpo_dot_psi_n_tensor_tensor()[source]¶

fortran-subroutine - June 2017 (dj) Contract local MPO amtrices for n-sites with wave function represented on n-sites and the left right overlap.

Details

Subroutine has both, a 1 site and a 2 site version.

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_n_tensor_tensor(Phi, Lc, Wn, Rc, Psin, &
                                                 leftmost, rightmost, beta, &
                                                 errst)
      type(tensor), intent(inout) :: Phi
      type(tensorlist), intent(inout) :: Lc, Rc
      type(sr_matrix_tensor), intent(inout) :: Wn
      type(tensor), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      real(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimension
      integer :: cbd

      ! rank of the tensor
      integer :: rnk

      ! control action of contr, = or +=
      real(KIND=rKind) :: beta_

      ! intermediate result - contract with right overlap
      type(tensor), dimension(:), allocatable :: Fs

      ! intermediate tensor
      type(tensor) :: Tens

      !CHEK_if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = dzero
      end if

      rnk = rank(Psin)

      cbd = Wn%cbd
      allocate(Fs(cbd))

      if(rightmost) then
          ! Just copy the Psin equal to contracting with the identity
          call copy(Fs(1), Psin, errst=errst)
          !if(prop_error('mpo_dot_psi_n_tensor_tensor : '// &
          !              'copy (1).', errst=errst)) return

      else
          ! Contract the right overlap with Psi

          do ii = 1, cbd
              call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensor_tensor : '//&
              !              'contr (1).', errst=errst)) return
          end do
      end if

      if(leftmost) then
          do ii = 1, Wn%rbd
              ! Contract the MPO matrix with Psi-Rc
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              if(beta_ == 0.0_rKind) then
                  call copy(Phi, Tens, errst=errst)
                  !if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
                  !              'TYPE : copy (2).', errst=errst)) return
              else
                  call gaxpy(Phi, done, Tens)
              end if

              call destroy(Tens)
          end do
      else
          do ii = 1, Wn%rbd

              ! Contract the MPO matrix with (Psi-Rc)
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              ! Contract the left overlap with (Wn-Psi-Rc)
              call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
                         errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensor_tensor : '//&
              !              'contr (2).', errst=errst)) return

              call destroy(Tens)
              beta_ = done
          end do
      end if

      do ii = 1, Wn%cbd
          call destroy(Fs(ii))
      end do
      deallocate(Fs)

  end subroutine mpo_dot_psi_n_tensor_tensor

MPSOps_f90.mpo_dot_psi_n_tensor_tensorc()[source]¶

fortran-subroutine - June 2017 (dj) Contract local MPO amtrices for n-sites with wave function represented on n-sites and the left right overlap.

Details

Subroutine has both, a 1 site and a 2 site version.

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_n_tensor_tensorc(Phi, Lc, Wn, Rc, Psin, &
                                                 leftmost, rightmost, beta, &
                                                 errst)
      type(tensorc), intent(inout) :: Phi
      type(tensorlistc), intent(inout) :: Lc, Rc
      type(sr_matrix_tensor), intent(inout) :: Wn
      type(tensorc), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      complex(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimension
      integer :: cbd

      ! rank of the tensor
      integer :: rnk

      ! control action of contr, = or +=
      complex(KIND=rKind) :: beta_

      ! intermediate result - contract with right overlap
      type(tensorc), dimension(:), allocatable :: Fs

      ! intermediate tensor
      type(tensorc) :: Tens

      !CHEK_if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = zzero
      end if

      rnk = rank(Psin)

      cbd = Wn%cbd
      allocate(Fs(cbd))

      if(rightmost) then
          ! Just copy the Psin equal to contracting with the identity
          call copy(Fs(1), Psin, errst=errst)
          !if(prop_error('mpo_dot_psi_n_tensor_tensorc : '// &
          !              'copy (1).', errst=errst)) return

      else
          ! Contract the right overlap with Psi

          do ii = 1, cbd
              call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensor_tensorc : '//&
              !              'contr (1).', errst=errst)) return
          end do
      end if

      if(leftmost) then
          do ii = 1, Wn%rbd
              ! Contract the MPO matrix with Psi-Rc
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              if(beta_ == 0.0_rKind) then
                  call copy(Phi, Tens, errst=errst)
                  !if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
                  !              'TYPE : copy (2).', errst=errst)) return
              else
                  call gaxpy(Phi, zone, Tens)
              end if

              call destroy(Tens)
          end do
      else
          do ii = 1, Wn%rbd

              ! Contract the MPO matrix with (Psi-Rc)
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensor_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              ! Contract the left overlap with (Wn-Psi-Rc)
              call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
                         errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensor_tensorc : '//&
              !              'contr (2).', errst=errst)) return

              call destroy(Tens)
              beta_ = zone
          end do
      end if

      do ii = 1, Wn%cbd
          call destroy(Fs(ii))
      end do
      deallocate(Fs)

  end subroutine mpo_dot_psi_n_tensor_tensorc

MPSOps_f90.mpo_dot_psi_n_tensorc_tensorc()[source]¶

fortran-subroutine - June 2017 (dj) Contract local MPO amtrices for n-sites with wave function represented on n-sites and the left right overlap.

Details

Subroutine has both, a 1 site and a 2 site version.

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_n_tensorc_tensorc(Phi, Lc, Wn, Rc, Psin, &
                                                 leftmost, rightmost, beta, &
                                                 errst)
      type(tensorc), intent(inout) :: Phi
      type(tensorlistc), intent(inout) :: Lc, Rc
      type(sr_matrix_tensorc), intent(inout) :: Wn
      type(tensorc), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      complex(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimension
      integer :: cbd

      ! rank of the tensor
      integer :: rnk

      ! control action of contr, = or +=
      complex(KIND=rKind) :: beta_

      ! intermediate result - contract with right overlap
      type(tensorc), dimension(:), allocatable :: Fs

      ! intermediate tensor
      type(tensorc) :: Tens

      !CHEK_if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = zzero
      end if

      rnk = rank(Psin)

      cbd = Wn%cbd
      allocate(Fs(cbd))

      if(rightmost) then
          ! Just copy the Psin equal to contracting with the identity
          call copy(Fs(1), Psin, errst=errst)
          !if(prop_error('mpo_dot_psi_n_tensorc_tensorc : '// &
          !              'copy (1).', errst=errst)) return

      else
          ! Contract the right overlap with Psi

          do ii = 1, cbd
              call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensorc_tensorc : '//&
              !              'contr (1).', errst=errst)) return
          end do
      end if

      if(leftmost) then
          do ii = 1, Wn%rbd
              ! Contract the MPO matrix with Psi-Rc
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensorc_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              if(beta_ == 0.0_rKind) then
                  call copy(Phi, Tens, errst=errst)
                  !if(prop_error('mpo_dot_psi_n_tensorc_TENSOR_'// &
                  !              'TYPE : copy (2).', errst=errst)) return
              else
                  call gaxpy(Phi, zone, Tens)
              end if

              call destroy(Tens)
          end do
      else
          do ii = 1, Wn%rbd

              ! Contract the MPO matrix with (Psi-Rc)
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensorc_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              ! Contract the left overlap with (Wn-Psi-Rc)
              call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
                         errst=errst)
              !if(prop_error('mpo_dot_psi_n_tensorc_tensorc : '//&
              !              'contr (2).', errst=errst)) return

              call destroy(Tens)
              beta_ = zone
          end do
      end if

      do ii = 1, Wn%cbd
          call destroy(Fs(ii))
      end do
      deallocate(Fs)

  end subroutine mpo_dot_psi_n_tensorc_tensorc

MPSOps_f90.mpo_dot_psi_n_qtensor_qtensor()[source]¶

fortran-subroutine - June 2017 (dj) Contract local MPO amtrices for n-sites with wave function represented on n-sites and the left right overlap.

Details

Subroutine has both, a 1 site and a 2 site version.

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_n_qtensor_qtensor(Phi, Lc, Wn, Rc, Psin, &
                                                 leftmost, rightmost, beta, &
                                                 errst)
      type(qtensor), intent(inout) :: Phi
      type(qtensorlist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensor), intent(inout) :: Wn
      type(qtensor), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      real(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimension
      integer :: cbd

      ! rank of the tensor
      integer :: rnk

      ! control action of contr, = or +=
      real(KIND=rKind) :: beta_

      ! intermediate result - contract with right overlap
      type(qtensor), dimension(:), allocatable :: Fs

      ! intermediate tensor
      type(qtensor) :: Tens

      !CHEK_if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = dzero
      end if

      rnk = rank(Psin)

      cbd = Wn%cbd
      allocate(Fs(cbd))

      if(rightmost) then
          ! Just copy the Psin equal to contracting with the identity
          call copy(Fs(1), Psin, errst=errst)
          !if(prop_error('mpo_dot_psi_n_qtensor_qtensor : '// &
          !              'copy (1).', errst=errst)) return

      else
          ! Contract the right overlap with Psi

          do ii = 1, cbd
              call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensor_qtensor : '//&
              !              'contr (1).', errst=errst)) return
          end do
      end if

      if(leftmost) then
          do ii = 1, Wn%rbd
              ! Contract the MPO matrix with Psi-Rc
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              if(beta_ == 0.0_rKind) then
                  call copy(Phi, Tens, errst=errst)
                  !if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
                  !              'TYPE : copy (2).', errst=errst)) return
              else
                  call gaxpy(Phi, done, Tens)
              end if

              call destroy(Tens)
          end do
      else
          do ii = 1, Wn%rbd

              ! Contract the MPO matrix with (Psi-Rc)
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              ! Contract the left overlap with (Wn-Psi-Rc)
              call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
                         errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensor_qtensor : '//&
              !              'contr (2).', errst=errst)) return

              call destroy(Tens)
              beta_ = done
          end do
      end if

      do ii = 1, Wn%cbd
          call destroy(Fs(ii))
      end do
      deallocate(Fs)

  end subroutine mpo_dot_psi_n_qtensor_qtensor

MPSOps_f90.mpo_dot_psi_n_qtensor_qtensorc()[source]¶

fortran-subroutine - June 2017 (dj) Contract local MPO amtrices for n-sites with wave function represented on n-sites and the left right overlap.

Details

Subroutine has both, a 1 site and a 2 site version.

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_n_qtensor_qtensorc(Phi, Lc, Wn, Rc, Psin, &
                                                 leftmost, rightmost, beta, &
                                                 errst)
      type(qtensorc), intent(inout) :: Phi
      type(qtensorclist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensor), intent(inout) :: Wn
      type(qtensorc), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      complex(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimension
      integer :: cbd

      ! rank of the tensor
      integer :: rnk

      ! control action of contr, = or +=
      complex(KIND=rKind) :: beta_

      ! intermediate result - contract with right overlap
      type(qtensorc), dimension(:), allocatable :: Fs

      ! intermediate tensor
      type(qtensorc) :: Tens

      !CHEK_if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = zzero
      end if

      rnk = rank(Psin)

      cbd = Wn%cbd
      allocate(Fs(cbd))

      if(rightmost) then
          ! Just copy the Psin equal to contracting with the identity
          call copy(Fs(1), Psin, errst=errst)
          !if(prop_error('mpo_dot_psi_n_qtensor_qtensorc : '// &
          !              'copy (1).', errst=errst)) return

      else
          ! Contract the right overlap with Psi

          do ii = 1, cbd
              call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensor_qtensorc : '//&
              !              'contr (1).', errst=errst)) return
          end do
      end if

      if(leftmost) then
          do ii = 1, Wn%rbd
              ! Contract the MPO matrix with Psi-Rc
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              if(beta_ == 0.0_rKind) then
                  call copy(Phi, Tens, errst=errst)
                  !if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
                  !              'TYPE : copy (2).', errst=errst)) return
              else
                  call gaxpy(Phi, zone, Tens)
              end if

              call destroy(Tens)
          end do
      else
          do ii = 1, Wn%rbd

              ! Contract the MPO matrix with (Psi-Rc)
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensor_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              ! Contract the left overlap with (Wn-Psi-Rc)
              call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
                         errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensor_qtensorc : '//&
              !              'contr (2).', errst=errst)) return

              call destroy(Tens)
              beta_ = zone
          end do
      end if

      do ii = 1, Wn%cbd
          call destroy(Fs(ii))
      end do
      deallocate(Fs)

  end subroutine mpo_dot_psi_n_qtensor_qtensorc

MPSOps_f90.mpo_dot_psi_n_qtensorc_qtensorc()[source]¶

fortran-subroutine - June 2017 (dj) Contract local MPO amtrices for n-sites with wave function represented on n-sites and the left right overlap.

Details

Subroutine has both, a 1 site and a 2 site version.

Source Code

show / hide f90 code

  subroutine mpo_dot_psi_n_qtensorc_qtensorc(Phi, Lc, Wn, Rc, Psin, &
                                                 leftmost, rightmost, beta, &
                                                 errst)
      type(qtensorc), intent(inout) :: Phi
      type(qtensorclist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensorc), intent(inout) :: Wn
      type(qtensorc), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      complex(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimension
      integer :: cbd

      ! rank of the tensor
      integer :: rnk

      ! control action of contr, = or +=
      complex(KIND=rKind) :: beta_

      ! intermediate result - contract with right overlap
      type(qtensorc), dimension(:), allocatable :: Fs

      ! intermediate tensor
      type(qtensorc) :: Tens

      !CHEK_if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = zzero
      end if

      rnk = rank(Psin)

      cbd = Wn%cbd
      allocate(Fs(cbd))

      if(rightmost) then
          ! Just copy the Psin equal to contracting with the identity
          call copy(Fs(1), Psin, errst=errst)
          !if(prop_error('mpo_dot_psi_n_qtensorc_qtensorc : '// &
          !              'copy (1).', errst=errst)) return

      else
          ! Contract the right overlap with Psi

          do ii = 1, cbd
              call contr(Fs(ii), Psin, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensorc_qtensorc : '//&
              !              'contr (1).', errst=errst)) return
          end do
      end if

      if(leftmost) then
          do ii = 1, Wn%rbd
              ! Contract the MPO matrix with Psi-Rc
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensorc_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1552', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              if(beta_ == 0.0_rKind) then
                  call copy(Phi, Tens, errst=errst)
                  !if(prop_error('mpo_dot_psi_n_qtensorc_TENSOR_'// &
                  !              'TYPE : copy (2).', errst=errst)) return
              else
                  call gaxpy(Phi, zone, Tens)
              end if

              call destroy(Tens)
          end do
      else
          do ii = 1, Wn%rbd

              ! Contract the MPO matrix with (Psi-Rc)
              call contractmpol(Tens, ii, Wn, Fs, errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensorc_TENSOR_'// &
              !              'TYPE : contractmpol (1).', 'MPSOps_include.f90:1577', &
              !              errst=errst)) return

              !if(rnk == 3) then
              !    call transposed(Tens, [2, 1, 3], doperm=.true.)
              !elseif(rnk == 4) then
              !    call transposed(Tens, [3, 1, 2, 4], doperm=.true.)
              !end if

              ! Contract the left overlap with (Wn-Psi-Rc)
              call contr(Phi, Lc%Li(ii), Tens, [2], [1], beta=beta_, &
                         errst=errst)
              !if(prop_error('mpo_dot_psi_n_qtensorc_qtensorc : '//&
              !              'contr (2).', errst=errst)) return

              call destroy(Tens)
              beta_ = zone
          end do
      end if

      do ii = 1, Wn%cbd
          call destroy(Fs(ii))
      end do
      deallocate(Fs)

  end subroutine mpo_dot_psi_n_qtensorc_qtensorc

MPSOps_f90.mpo2_dot_psi_tensor_tensor()[source]¶

fortran-subroutine - June 2017 (dj) Multiply two-site Hamiltonian with two-site Psi.

Arguments

HPsiTYPE(tensor), inout: Contraction of 2-site Hamiltonian with 2-site Psi.
HamTYPE(tensor), inout: Contains the two-site Hamiltonian as rank-4 tensor.
PsiTYPE(tensor), inout: Rank-4 tensor representing the two sites.

Details

This it the version building the two site Hamiltonian first. The default scaling is $d^4 \kappa + \chi^2 d^4$ and avoids any step building the actual MPO. In comparison, contracting the MPO matrices should result in a scaling of $2 \kappa \chi^2 d^3$ . For large local dimension it could be worth implementing the contraction based on MPO matrices. Moreover, the cost $d^4 \kappa$ can be done beforehand and occurs only once for each Trotter step and site.

Source Code

show / hide f90 code

MPSOps_f90.mpo2_dot_psi_tensor_tensorc()[source]¶

fortran-subroutine - June 2017 (dj) Multiply two-site Hamiltonian with two-site Psi.

Arguments

HPsiTYPE(tensorc), inout: Contraction of 2-site Hamiltonian with 2-site Psi.
HamTYPE(tensor), inout: Contains the two-site Hamiltonian as rank-4 tensor.
PsiTYPE(tensorc), inout: Rank-4 tensor representing the two sites.

Details

This it the version building the two site Hamiltonian first. The default scaling is $d^4 \kappa + \chi^2 d^4$ and avoids any step building the actual MPO. In comparison, contracting the MPO matrices should result in a scaling of $2 \kappa \chi^2 d^3$ . For large local dimension it could be worth implementing the contraction based on MPO matrices. Moreover, the cost $d^4 \kappa$ can be done beforehand and occurs only once for each Trotter step and site.

Source Code

show / hide f90 code

MPSOps_f90.mpo2_dot_psi_tensorc_tensorc()[source]¶

fortran-subroutine - June 2017 (dj) Multiply two-site Hamiltonian with two-site Psi.

Arguments

HPsiTYPE(tensorc), inout: Contraction of 2-site Hamiltonian with 2-site Psi.
HamTYPE(tensorc), inout: Contains the two-site Hamiltonian as rank-4 tensor.
PsiTYPE(tensorc), inout: Rank-4 tensor representing the two sites.

Details

This it the version building the two site Hamiltonian first. The default scaling is $d^4 \kappa + \chi^2 d^4$ and avoids any step building the actual MPO. In comparison, contracting the MPO matrices should result in a scaling of $2 \kappa \chi^2 d^3$ . For large local dimension it could be worth implementing the contraction based on MPO matrices. Moreover, the cost $d^4 \kappa$ can be done beforehand and occurs only once for each Trotter step and site.

Source Code

show / hide f90 code

MPSOps_f90.mpo2_dot_psi_qtensor_qtensor()[source]¶

fortran-subroutine - June 2017 (dj) Multiply two-site Hamiltonian with two-site Psi.

Arguments

HPsiTYPE(qtensor), inout: Contraction of 2-site Hamiltonian with 2-site Psi.
HamTYPE(qtensor), inout: Contains the two-site Hamiltonian as rank-4 tensor.
PsiTYPE(qtensor), inout: Rank-4 tensor representing the two sites.

Details

This it the version building the two site Hamiltonian first. The default scaling is $d^4 \kappa + \chi^2 d^4$ and avoids any step building the actual MPO. In comparison, contracting the MPO matrices should result in a scaling of $2 \kappa \chi^2 d^3$ . For large local dimension it could be worth implementing the contraction based on MPO matrices. Moreover, the cost $d^4 \kappa$ can be done beforehand and occurs only once for each Trotter step and site.

Source Code

show / hide f90 code

MPSOps_f90.mpo2_dot_psi_qtensor_qtensorc()[source]¶

fortran-subroutine - June 2017 (dj) Multiply two-site Hamiltonian with two-site Psi.

Arguments

HPsiTYPE(qtensorc), inout: Contraction of 2-site Hamiltonian with 2-site Psi.
HamTYPE(qtensor), inout: Contains the two-site Hamiltonian as rank-4 tensor.
PsiTYPE(qtensorc), inout: Rank-4 tensor representing the two sites.

Details

This it the version building the two site Hamiltonian first. The default scaling is $d^4 \kappa + \chi^2 d^4$ and avoids any step building the actual MPO. In comparison, contracting the MPO matrices should result in a scaling of $2 \kappa \chi^2 d^3$ . For large local dimension it could be worth implementing the contraction based on MPO matrices. Moreover, the cost $d^4 \kappa$ can be done beforehand and occurs only once for each Trotter step and site.

Source Code

show / hide f90 code

MPSOps_f90.mpo2_dot_psi_qtensorc_qtensorc()[source]¶

fortran-subroutine - June 2017 (dj) Multiply two-site Hamiltonian with two-site Psi.

Arguments

HPsiTYPE(qtensorc), inout: Contraction of 2-site Hamiltonian with 2-site Psi.
HamTYPE(qtensorc), inout: Contains the two-site Hamiltonian as rank-4 tensor.
PsiTYPE(qtensorc), inout: Rank-4 tensor representing the two sites.

Details

This it the version building the two site Hamiltonian first. The default scaling is $d^4 \kappa + \chi^2 d^4$ and avoids any step building the actual MPO. In comparison, contracting the MPO matrices should result in a scaling of $2 \kappa \chi^2 d^3$ . For large local dimension it could be worth implementing the contraction based on MPO matrices. Moreover, the cost $d^4 \kappa$ can be done beforehand and occurs only once for each Trotter step and site.

Source Code

show / hide f90 code

MPSOps_f90.norm_mps()[source]¶

fortran-function - June 2017 (dj, updated) Compute the norm of Psi, assumed to have an orthogonality center.

Arguments

PsiTYPE(mps), inout: Compute the norm of this MPS with orthogonality center. If no orthogonality is installed, subroutine will crash accessing element -1)

Source Code

show / hide f90 code

MPSOps_f90.norm_mpsc()[source]¶

fortran-function - June 2017 (dj, updated) Compute the norm of Psi, assumed to have an orthogonality center.

Arguments

PsiTYPE(mpsc), inout: Compute the norm of this MPS with orthogonality center. If no orthogonality is installed, subroutine will crash accessing element -1)

Source Code

show / hide f90 code

MPSOps_f90.norm_qmps()[source]¶

fortran-function - June 2017 (dj, updated) Compute the norm of Psi, assumed to have an orthogonality center.

Arguments

PsiTYPE(qmps), inout: Compute the norm of this MPS with orthogonality center. If no orthogonality is installed, subroutine will crash accessing element -1)

Source Code

show / hide f90 code

MPSOps_f90.norm_qmpsc()[source]¶

fortran-function - June 2017 (dj, updated) Compute the norm of Psi, assumed to have an orthogonality center.

Arguments

PsiTYPE(qmpsc), inout: Compute the norm of this MPS with orthogonality center. If no orthogonality is installed, subroutine will crash accessing element -1)

Source Code

show / hide f90 code

MPSOps_f90.orthonormalize_mps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Put psi into mixed canonical form at site k0 and normalize it.

Arguments

PsiTYPE(mps), inout: Gauge this MPS with QR, get the norm and rescale it such that it has trace 1.
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.

Source Code

show / hide f90 code

MPSOps_f90.orthonormalize_mpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Put psi into mixed canonical form at site k0 and normalize it.

Arguments

PsiTYPE(mpsc), inout: Gauge this MPS with QR, get the norm and rescale it such that it has trace 1.
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.

Source Code

show / hide f90 code

MPSOps_f90.orthonormalize_qmps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Put psi into mixed canonical form at site k0 and normalize it.

Arguments

PsiTYPE(qmps), inout: Gauge this MPS with QR, get the norm and rescale it such that it has trace 1.
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.

Source Code

show / hide f90 code

MPSOps_f90.orthonormalize_qmpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Put psi into mixed canonical form at site k0 and normalize it.

Arguments

PsiTYPE(qmpsc), inout: Gauge this MPS with QR, get the norm and rescale it such that it has trace 1.
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.

Source Code

show / hide f90 code

MPSOps_f90.perturb_mps()[source]¶

fortran-subroutine - December 2018 (dj) Perturbate a MPS via a perturbation of each entry of each tensor.

Arguments

PsiTYPE(mps), inout: MPS to be perturbed.
epsilonreal, OPTIONAL, in: Scale a randomized tensor by epsilon and add to original tensor. Default to 1e-8
reorthLOGICAL, in: Re-orhtogonalize to the original oc center if true, otherwise, skip canonization. Default to no orthogonalization.

Source Code

show / hide f90 code

MPSOps_f90.perturb_mpsc()[source]¶

fortran-subroutine - December 2018 (dj) Perturbate a MPS via a perturbation of each entry of each tensor.

Arguments

PsiTYPE(mpsc), inout: MPS to be perturbed.
epsilonreal, OPTIONAL, in: Scale a randomized tensor by epsilon and add to original tensor. Default to 1e-8
reorthLOGICAL, in: Re-orhtogonalize to the original oc center if true, otherwise, skip canonization. Default to no orthogonalization.

Source Code

show / hide f90 code

MPSOps_f90.perturb_qmps()[source]¶

fortran-subroutine - December 2018 (dj) Perturbate a MPS via a perturbation of each entry of each tensor.

Arguments

PsiTYPE(qmps), inout: MPS to be perturbed.
epsilonreal, OPTIONAL, in: Scale a randomized tensor by epsilon and add to original tensor. Default to 1e-8
reorthLOGICAL, in: Re-orhtogonalize to the original oc center if true, otherwise, skip canonization. Default to no orthogonalization.

Source Code

show / hide f90 code

MPSOps_f90.perturb_qmpsc()[source]¶

fortran-subroutine - December 2018 (dj) Perturbate a MPS via a perturbation of each entry of each tensor.

Arguments

PsiTYPE(qmpsc), inout: MPS to be perturbed.
epsilonreal, OPTIONAL, in: Scale a randomized tensor by epsilon and add to original tensor. Default to 1e-8
reorthLOGICAL, in: Re-orhtogonalize to the original oc center if true, otherwise, skip canonization. Default to no orthogonalization.

Source Code

show / hide f90 code

MPSOps_f90.print_mps()[source]¶

fortran-subroutine - June 2016 (dj, updated) Write out all MPS data.

Arguments

PsiTYPE(mps), in: Print all information about the MPS.

Details

The information is written to the standard output with the following formatting: 1) infostring, Size of MPS, orthogonality center (both integers) In a loop for each site is written 2) infostring, number of the site (integer) 3) infostring, canonization (character) 4) infostring, haslambda (logical) 5) Depending on logical haslambda, lambda is printed with according function. 6) Tensor is printed with according function.

Source Code

show / hide f90 code

MPSOps_f90.print_mpsc()[source]¶

fortran-subroutine - June 2016 (dj, updated) Write out all MPS data.

Arguments

PsiTYPE(mpsc), in: Print all information about the MPS.

Details

The information is written to the standard output with the following formatting: 1) infostring, Size of MPS, orthogonality center (both integers) In a loop for each site is written 2) infostring, number of the site (integer) 3) infostring, canonization (character) 4) infostring, haslambda (logical) 5) Depending on logical haslambda, lambda is printed with according function. 6) Tensor is printed with according function.

Source Code

show / hide f90 code

MPSOps_f90.print_qmps()[source]¶

fortran-subroutine - June 2016 (dj, updated) Write out all MPS data.

Arguments

PsiTYPE(qmps), in: Print all information about the MPS.

Details

The information is written to the standard output with the following formatting: 1) infostring, Size of MPS, orthogonality center (both integers) In a loop for each site is written 2) infostring, number of the site (integer) 3) infostring, canonization (character) 4) infostring, haslambda (logical) 5) Depending on logical haslambda, lambda is printed with according function. 6) Tensor is printed with according function.

Source Code

show / hide f90 code

MPSOps_f90.print_qmpsc()[source]¶

fortran-subroutine - June 2016 (dj, updated) Write out all MPS data.

Arguments

PsiTYPE(qmpsc), in: Print all information about the MPS.

Details

The information is written to the standard output with the following formatting: 1) infostring, Size of MPS, orthogonality center (both integers) In a loop for each site is written 2) infostring, number of the site (integer) 3) infostring, canonization (character) 4) infostring, haslambda (logical) 5) Depending on logical haslambda, lambda is printed with according function. 6) Tensor is printed with according function.

Source Code

show / hide f90 code

MPSOps_f90.projected_mpo_dot_psi_n_tensor_tensor()[source]¶

fortran-subroutine - July 2017 (dj, updated) Compute the projection of Phi = H * psi, where H=L.W.R

Details

Since we need the projectors from the two site tensor, the two site algorithm is implemented.

Source Code

show / hide f90 code

  subroutine projected_mpo_dot_psi_n_tensor_tensor(Phi, Lc, Hts, Rc, &
       Psin, leftmost, rightmost, Psiprojs, beta, errst)
      type(tensor), intent(inout) :: Phi
      type(tensorlist), intent(inout) :: Lc, Rc
      type(sr_matrix_tensor), intent(inout) :: Hts
      type(tensor), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      type(tensor), pointer, intent(inout) :: Psiprojs(:)
      real(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrix
      integer :: k1, k2

      ! rank of the tensor necessary to know contraction index
      integer :: rnk

      ! control action of contr, = or +=
      real(KIND=rKind) :: beta_

      ! Temporary tensor with projection
      type(tensor) :: Gt, Tmp

      ! Temporary array of tensors
      type(tensor), dimension(:), allocatable :: Fts

      !if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = dzero
      end if

      rnk = rank(Psin)

      ! Build two-site tensor and the projections
      call project(Gt, Psin, Psiprojs)

      k1 = Hts%rbd
      k2 = Hts%cbd

      ! 1) Contractions of the right overlap
      ! ------------------------------------
      !
      ! !F^k_{a i j  b}= A_{a i b'} R^k_{b' b}

      allocate(Fts(k2))

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call copy(Fts(ii), Gt)
          end do

      else
          ! Propagate

          do ii = 1, k2
              call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('projected_mpo_dot_psi_n_tensor_'//&
              !              'tensor: contr failed.', &
              !              'MPSOps_include.f90:2002', errst=errst)) return
          end do
      end if

      call destroy(Gt)

      ! 2) Contract MPO and left transfer matrix
      ! -----------------------------------------

      call contractmpol(Gt, 1, Hts, Fts)

      if(leftmost) then
          call copy(Tmp, Gt)
      else
          call contr(Tmp, Lc%Li(1), Gt, [2], [1])
      end if

      if(beta_ == 0.0_rKind) then
          call project(Phi, Tmp, Psiprojs)
      else
          if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
          call addproject(Phi, Tmp, Psiprojs)
      end if

      call destroy(Gt)
      call destroy(Tmp)

      do ii = 2, k1
          call contractmpol(Gt, ii, Hts, Fts)

          if(leftmost) then
              call copy(Tmp, Gt)
          else
              call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
          end if

          call addproject(Phi, Tmp, Psiprojs)
          call destroy(Gt)
          call destroy(Tmp)

      end do

      do ii = 1, k2
          call destroy(Fts(ii))
      end do
      deallocate(Fts)

  end subroutine projected_mpo_dot_psi_n_tensor_tensor

MPSOps_f90.projected_mpo_dot_psi_n_tensor_tensorc()[source]¶

fortran-subroutine - July 2017 (dj, updated) Compute the projection of Phi = H * psi, where H=L.W.R

Details

Since we need the projectors from the two site tensor, the two site algorithm is implemented.

Source Code

show / hide f90 code

  subroutine projected_mpo_dot_psi_n_tensor_tensorc(Phi, Lc, Hts, Rc, &
       Psin, leftmost, rightmost, Psiprojs, beta, errst)
      type(tensorc), intent(inout) :: Phi
      type(tensorlistc), intent(inout) :: Lc, Rc
      type(sr_matrix_tensor), intent(inout) :: Hts
      type(tensorc), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      type(tensorc), pointer, intent(inout) :: Psiprojs(:)
      complex(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrix
      integer :: k1, k2

      ! rank of the tensor necessary to know contraction index
      integer :: rnk

      ! control action of contr, = or +=
      complex(KIND=rKind) :: beta_

      ! Temporary tensor with projection
      type(tensorc) :: Gt, Tmp

      ! Temporary array of tensors
      type(tensorc), dimension(:), allocatable :: Fts

      !if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = zzero
      end if

      rnk = rank(Psin)

      ! Build two-site tensor and the projections
      call project(Gt, Psin, Psiprojs)

      k1 = Hts%rbd
      k2 = Hts%cbd

      ! 1) Contractions of the right overlap
      ! ------------------------------------
      !
      ! !F^k_{a i j  b}= A_{a i b'} R^k_{b' b}

      allocate(Fts(k2))

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call copy(Fts(ii), Gt)
          end do

      else
          ! Propagate

          do ii = 1, k2
              call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('projected_mpo_dot_psi_n_tensor_'//&
              !              'tensorc: contr failed.', &
              !              'MPSOps_include.f90:2002', errst=errst)) return
          end do
      end if

      call destroy(Gt)

      ! 2) Contract MPO and left transfer matrix
      ! -----------------------------------------

      call contractmpol(Gt, 1, Hts, Fts)

      if(leftmost) then
          call copy(Tmp, Gt)
      else
          call contr(Tmp, Lc%Li(1), Gt, [2], [1])
      end if

      if(beta_ == 0.0_rKind) then
          call project(Phi, Tmp, Psiprojs)
      else
          if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
          call addproject(Phi, Tmp, Psiprojs)
      end if

      call destroy(Gt)
      call destroy(Tmp)

      do ii = 2, k1
          call contractmpol(Gt, ii, Hts, Fts)

          if(leftmost) then
              call copy(Tmp, Gt)
          else
              call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
          end if

          call addproject(Phi, Tmp, Psiprojs)
          call destroy(Gt)
          call destroy(Tmp)

      end do

      do ii = 1, k2
          call destroy(Fts(ii))
      end do
      deallocate(Fts)

  end subroutine projected_mpo_dot_psi_n_tensor_tensorc

MPSOps_f90.projected_mpo_dot_psi_n_tensorc_tensorc()[source]¶

fortran-subroutine - July 2017 (dj, updated) Compute the projection of Phi = H * psi, where H=L.W.R

Details

Since we need the projectors from the two site tensor, the two site algorithm is implemented.

Source Code

show / hide f90 code

  subroutine projected_mpo_dot_psi_n_tensorc_tensorc(Phi, Lc, Hts, Rc, &
       Psin, leftmost, rightmost, Psiprojs, beta, errst)
      type(tensorc), intent(inout) :: Phi
      type(tensorlistc), intent(inout) :: Lc, Rc
      type(sr_matrix_tensorc), intent(inout) :: Hts
      type(tensorc), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      type(tensorc), pointer, intent(inout) :: Psiprojs(:)
      complex(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrix
      integer :: k1, k2

      ! rank of the tensor necessary to know contraction index
      integer :: rnk

      ! control action of contr, = or +=
      complex(KIND=rKind) :: beta_

      ! Temporary tensor with projection
      type(tensorc) :: Gt, Tmp

      ! Temporary array of tensors
      type(tensorc), dimension(:), allocatable :: Fts

      !if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = zzero
      end if

      rnk = rank(Psin)

      ! Build two-site tensor and the projections
      call project(Gt, Psin, Psiprojs)

      k1 = Hts%rbd
      k2 = Hts%cbd

      ! 1) Contractions of the right overlap
      ! ------------------------------------
      !
      ! !F^k_{a i j  b}= A_{a i b'} R^k_{b' b}

      allocate(Fts(k2))

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call copy(Fts(ii), Gt)
          end do

      else
          ! Propagate

          do ii = 1, k2
              call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('projected_mpo_dot_psi_n_tensorc_'//&
              !              'tensorc: contr failed.', &
              !              'MPSOps_include.f90:2002', errst=errst)) return
          end do
      end if

      call destroy(Gt)

      ! 2) Contract MPO and left transfer matrix
      ! -----------------------------------------

      call contractmpol(Gt, 1, Hts, Fts)

      if(leftmost) then
          call copy(Tmp, Gt)
      else
          call contr(Tmp, Lc%Li(1), Gt, [2], [1])
      end if

      if(beta_ == 0.0_rKind) then
          call project(Phi, Tmp, Psiprojs)
      else
          if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
          call addproject(Phi, Tmp, Psiprojs)
      end if

      call destroy(Gt)
      call destroy(Tmp)

      do ii = 2, k1
          call contractmpol(Gt, ii, Hts, Fts)

          if(leftmost) then
              call copy(Tmp, Gt)
          else
              call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
          end if

          call addproject(Phi, Tmp, Psiprojs)
          call destroy(Gt)
          call destroy(Tmp)

      end do

      do ii = 1, k2
          call destroy(Fts(ii))
      end do
      deallocate(Fts)

  end subroutine projected_mpo_dot_psi_n_tensorc_tensorc

MPSOps_f90.projected_mpo_dot_psi_n_qtensor_qtensor()[source]¶

fortran-subroutine - July 2017 (dj, updated) Compute the projection of Phi = H * psi, where H=L.W.R

Details

Since we need the projectors from the two site tensor, the two site algorithm is implemented.

Source Code

show / hide f90 code

  subroutine projected_mpo_dot_psi_n_qtensor_qtensor(Phi, Lc, Hts, Rc, &
       Psin, leftmost, rightmost, Psiprojs, beta, errst)
      type(qtensor), intent(inout) :: Phi
      type(qtensorlist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensor), intent(inout) :: Hts
      type(qtensor), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      type(qtensor), pointer, intent(inout) :: Psiprojs(:)
      real(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrix
      integer :: k1, k2

      ! rank of the tensor necessary to know contraction index
      integer :: rnk

      ! control action of contr, = or +=
      real(KIND=rKind) :: beta_

      ! Temporary tensor with projection
      type(qtensor) :: Gt, Tmp

      ! Temporary array of tensors
      type(qtensor), dimension(:), allocatable :: Fts

      !if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = dzero
      end if

      rnk = rank(Psin)

      ! Build two-site tensor and the projections
      call project(Gt, Psin, Psiprojs)

      k1 = Hts%rbd
      k2 = Hts%cbd

      ! 1) Contractions of the right overlap
      ! ------------------------------------
      !
      ! !F^k_{a i j  b}= A_{a i b'} R^k_{b' b}

      allocate(Fts(k2))

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call copy(Fts(ii), Gt)
          end do

      else
          ! Propagate

          do ii = 1, k2
              call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('projected_mpo_dot_psi_n_qtensor_'//&
              !              'qtensor: contr failed.', &
              !              'MPSOps_include.f90:2002', errst=errst)) return
          end do
      end if

      call destroy(Gt)

      ! 2) Contract MPO and left transfer matrix
      ! -----------------------------------------

      call contractmpol(Gt, 1, Hts, Fts)

      if(leftmost) then
          call copy(Tmp, Gt)
      else
          call contr(Tmp, Lc%Li(1), Gt, [2], [1])
      end if

      if(beta_ == 0.0_rKind) then
          call project(Phi, Tmp, Psiprojs)
      else
          if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
          call addproject(Phi, Tmp, Psiprojs)
      end if

      call destroy(Gt)
      call destroy(Tmp)

      do ii = 2, k1
          call contractmpol(Gt, ii, Hts, Fts)

          if(leftmost) then
              call copy(Tmp, Gt)
          else
              call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
          end if

          call addproject(Phi, Tmp, Psiprojs)
          call destroy(Gt)
          call destroy(Tmp)

      end do

      do ii = 1, k2
          call destroy(Fts(ii))
      end do
      deallocate(Fts)

  end subroutine projected_mpo_dot_psi_n_qtensor_qtensor

MPSOps_f90.projected_mpo_dot_psi_n_qtensor_qtensorc()[source]¶

fortran-subroutine - July 2017 (dj, updated) Compute the projection of Phi = H * psi, where H=L.W.R

Details

Since we need the projectors from the two site tensor, the two site algorithm is implemented.

Source Code

show / hide f90 code

  subroutine projected_mpo_dot_psi_n_qtensor_qtensorc(Phi, Lc, Hts, Rc, &
       Psin, leftmost, rightmost, Psiprojs, beta, errst)
      type(qtensorc), intent(inout) :: Phi
      type(qtensorclist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensor), intent(inout) :: Hts
      type(qtensorc), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      type(qtensorc), pointer, intent(inout) :: Psiprojs(:)
      complex(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrix
      integer :: k1, k2

      ! rank of the tensor necessary to know contraction index
      integer :: rnk

      ! control action of contr, = or +=
      complex(KIND=rKind) :: beta_

      ! Temporary tensor with projection
      type(qtensorc) :: Gt, Tmp

      ! Temporary array of tensors
      type(qtensorc), dimension(:), allocatable :: Fts

      !if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = zzero
      end if

      rnk = rank(Psin)

      ! Build two-site tensor and the projections
      call project(Gt, Psin, Psiprojs)

      k1 = Hts%rbd
      k2 = Hts%cbd

      ! 1) Contractions of the right overlap
      ! ------------------------------------
      !
      ! !F^k_{a i j  b}= A_{a i b'} R^k_{b' b}

      allocate(Fts(k2))

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call copy(Fts(ii), Gt)
          end do

      else
          ! Propagate

          do ii = 1, k2
              call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('projected_mpo_dot_psi_n_qtensor_'//&
              !              'qtensorc: contr failed.', &
              !              'MPSOps_include.f90:2002', errst=errst)) return
          end do
      end if

      call destroy(Gt)

      ! 2) Contract MPO and left transfer matrix
      ! -----------------------------------------

      call contractmpol(Gt, 1, Hts, Fts)

      if(leftmost) then
          call copy(Tmp, Gt)
      else
          call contr(Tmp, Lc%Li(1), Gt, [2], [1])
      end if

      if(beta_ == 0.0_rKind) then
          call project(Phi, Tmp, Psiprojs)
      else
          if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
          call addproject(Phi, Tmp, Psiprojs)
      end if

      call destroy(Gt)
      call destroy(Tmp)

      do ii = 2, k1
          call contractmpol(Gt, ii, Hts, Fts)

          if(leftmost) then
              call copy(Tmp, Gt)
          else
              call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
          end if

          call addproject(Phi, Tmp, Psiprojs)
          call destroy(Gt)
          call destroy(Tmp)

      end do

      do ii = 1, k2
          call destroy(Fts(ii))
      end do
      deallocate(Fts)

  end subroutine projected_mpo_dot_psi_n_qtensor_qtensorc

MPSOps_f90.projected_mpo_dot_psi_n_qtensorc_qtensorc()[source]¶

fortran-subroutine - July 2017 (dj, updated) Compute the projection of Phi = H * psi, where H=L.W.R

Details

Since we need the projectors from the two site tensor, the two site algorithm is implemented.

Source Code

show / hide f90 code

  subroutine projected_mpo_dot_psi_n_qtensorc_qtensorc(Phi, Lc, Hts, Rc, &
       Psin, leftmost, rightmost, Psiprojs, beta, errst)
      type(qtensorc), intent(inout) :: Phi
      type(qtensorclist), intent(inout) :: Lc, Rc
      type(sr_matrix_qtensorc), intent(inout) :: Hts
      type(qtensorc), intent(inout) :: Psin
      logical, intent(in) :: leftmost, rightmost
      type(qtensorc), pointer, intent(inout) :: Psiprojs(:)
      complex(KIND=rKind), intent(in), optional :: beta
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! bond dimensions MPO-matrix
      integer :: k1, k2

      ! rank of the tensor necessary to know contraction index
      integer :: rnk

      ! control action of contr, = or +=
      complex(KIND=rKind) :: beta_

      ! Temporary tensor with projection
      type(qtensorc) :: Gt, Tmp

      ! Temporary array of tensors
      type(qtensorc), dimension(:), allocatable :: Fts

      !if(present(errst)) errst = 0

      if(present(beta)) then
          beta_ = beta
      else
          beta_ = zzero
      end if

      rnk = rank(Psin)

      ! Build two-site tensor and the projections
      call project(Gt, Psin, Psiprojs)

      k1 = Hts%rbd
      k2 = Hts%cbd

      ! 1) Contractions of the right overlap
      ! ------------------------------------
      !
      ! !F^k_{a i j  b}= A_{a i b'} R^k_{b' b}

      allocate(Fts(k2))

      if(rightmost) then
          ! Initialize

          do ii = 1, k2
              call copy(Fts(ii), Gt)
          end do

      else
          ! Propagate

          do ii = 1, k2
              call contr(Fts(ii), Gt, Rc%Li(ii), [rnk], [1], errst=errst)
              !if(prop_error('projected_mpo_dot_psi_n_qtensorc_'//&
              !              'qtensorc: contr failed.', &
              !              'MPSOps_include.f90:2002', errst=errst)) return
          end do
      end if

      call destroy(Gt)

      ! 2) Contract MPO and left transfer matrix
      ! -----------------------------------------

      call contractmpol(Gt, 1, Hts, Fts)

      if(leftmost) then
          call copy(Tmp, Gt)
      else
          call contr(Tmp, Lc%Li(1), Gt, [2], [1])
      end if

      if(beta_ == 0.0_rKind) then
          call project(Phi, Tmp, Psiprojs)
      else
          if(abs(beta_ - 1.0_rKind) > 1e-13_rKind) call scale(beta_, Phi)
          call addproject(Phi, Tmp, Psiprojs)
      end if

      call destroy(Gt)
      call destroy(Tmp)

      do ii = 2, k1
          call contractmpol(Gt, ii, Hts, Fts)

          if(leftmost) then
              call copy(Tmp, Gt)
          else
              call contr(Tmp, Lc%Li(ii), Gt, [2], [1])
          end if

          call addproject(Phi, Tmp, Psiprojs)
          call destroy(Gt)
          call destroy(Tmp)

      end do

      do ii = 1, k2
          call destroy(Fts(ii))
      end do
      deallocate(Fts)

  end subroutine projected_mpo_dot_psi_n_qtensorc_qtensorc

MPSOps_f90.ptm_left_state_tensor()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the right to the left. This version is for states.

Arguments

MatTYPE(tensor), inout: This is the transfer matrix right of Bra and Ket.
BraTYPE(tensor), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(tensor), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
rightmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(tensor), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{k,l} = \sum_{i,j,m} Mat_{i,j} Ket_{k,m,i} (Bra_{l,m,j})^{\ast}$ . This is executed in two steps. This is the leftmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_left_state_tensorc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the right to the left. This version is for states.

Arguments

MatTYPE(tensorc), inout: This is the transfer matrix right of Bra and Ket.
BraTYPE(tensorc), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(tensorc), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
rightmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(tensorc), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{k,l} = \sum_{i,j,m} Mat_{i,j} Ket_{k,m,i} (Bra_{l,m,j})^{\ast}$ . This is executed in two steps. This is the leftmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_left_state_qtensor()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the right to the left. This version is for states.

Arguments

MatTYPE(qtensor), inout: This is the transfer matrix right of Bra and Ket.
BraTYPE(qtensor), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(qtensor), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
rightmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(qtensor), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{k,l} = \sum_{i,j,m} Mat_{i,j} Ket_{k,m,i} (Bra_{l,m,j})^{\ast}$ . This is executed in two steps. This is the leftmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_left_state_qtensorc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the right to the left. This version is for states.

Arguments

MatTYPE(qtensorc), inout: This is the transfer matrix right of Bra and Ket.
BraTYPE(qtensorc), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(qtensorc), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
rightmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(qtensorc), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{k,l} = \sum_{i,j,m} Mat_{i,j} Ket_{k,m,i} (Bra_{l,m,j})^{\ast}$ . This is executed in two steps. This is the leftmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_right_state_tensor_tensor()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the left to the right. This version is for states.

Arguments

MatTYPE(tensor), inout: This is the transfer matrix left of Bra and Ket.
BraTYPE(tensor), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(tensor), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
leftmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(tensor), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\ast}$ . This is executed in two steps. This is the rightmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_right_state_tensor_tensorc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the left to the right. This version is for states.

Arguments

MatTYPE(tensorc), inout: This is the transfer matrix left of Bra and Ket.
BraTYPE(tensorc), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(tensorc), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
leftmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(tensorc), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\ast}$ . This is executed in two steps. This is the rightmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_right_state_tensorc_tensor()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the left to the right. This version is for states.

Arguments

MatTYPE(tensorc), inout: This is the transfer matrix left of Bra and Ket.
BraTYPE(tensorc), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(tensorc), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
leftmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(tensorc), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\ast}$ . This is executed in two steps. This is the rightmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_right_state_tensorc_tensorc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the left to the right. This version is for states.

Arguments

MatTYPE(tensorc), inout: This is the transfer matrix left of Bra and Ket.
BraTYPE(tensorc), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(tensorc), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
leftmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(tensorc), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\ast}$ . This is executed in two steps. This is the rightmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_right_state_qtensor_qtensor()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the left to the right. This version is for states.

Arguments

MatTYPE(qtensor), inout: This is the transfer matrix left of Bra and Ket.
BraTYPE(qtensor), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(qtensor), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
leftmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(qtensor), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\ast}$ . This is executed in two steps. This is the rightmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_right_state_qtensor_qtensorc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the left to the right. This version is for states.

Arguments

MatTYPE(qtensorc), inout: This is the transfer matrix left of Bra and Ket.
BraTYPE(qtensorc), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(qtensorc), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
leftmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(qtensorc), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\ast}$ . This is executed in two steps. This is the rightmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_right_state_qtensorc_qtensor()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the left to the right. This version is for states.

Arguments

MatTYPE(qtensorc), inout: This is the transfer matrix left of Bra and Ket.
BraTYPE(qtensorc), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(qtensorc), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
leftmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(qtensorc), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\ast}$ . This is executed in two steps. This is the rightmoving version.

Source Code

show / hide f90 code

MPSOps_f90.ptm_right_state_qtensorc_qtensorc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Propagate transfer matrix (PTM) moving from the left to the right. This version is for states.

Arguments

MatTYPE(qtensorc), inout: This is the transfer matrix left of Bra and Ket.
BraTYPE(qtensorc), inout: Contract conjagated of Bra into the transfer matrix. Intent inout is for contraction, but should used.
KetTYPE(qtensorc), inout: Contract Ket into the transfer matrix. Intent inout is for contraction, but should used.
leftmostLOGICAL, in: Indicate if this is the rightmost, and therefore first site, to be contracted.
MatinTYPE(qtensorc), OPTIONAL, in: If Matin is present, Matin is the present transfer matrix. It is not destroyed. If not present, Mat is assumed to be the present transfer matrix and is overwritten with the new one.

Details

The contraction is over both indices of Mat and can be written as $Mat_{l,k} = \sum_{i,j,m} Mat_{i,j} Ket_{j,m,k} Bra_{i,m,l}^{\ast}$ . This is executed in two steps. This is the rightmoving version.

Source Code

show / hide f90 code

MPSOps_f90.randomize_mps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Fill the MPS Psi with random numbers

Arguments

PsiTYPE(mps), inout: Fill the MPS with random numbers. The orthogonality center is not installed during this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.randomize_mpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Fill the MPS Psi with random numbers

Arguments

PsiTYPE(mpsc), inout: Fill the MPS with random numbers. The orthogonality center is not installed during this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.randomize_qmps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Fill the MPS Psi with random numbers

Arguments

PsiTYPE(qmps), inout: Fill the MPS with random numbers. The orthogonality center is not installed during this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.randomize_qmpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Fill the MPS Psi with random numbers

Arguments

PsiTYPE(qmpsc), inout: Fill the MPS with random numbers. The orthogonality center is not installed during this subroutine.

Source Code

show / hide f90 code

MPSOps_f90.read_mps()[source]¶

fortran-subroutine - June 2016 (dj, updated) Read an MPS given a filename and a unit (assuming you know the type already).

Arguments

PsiTYPE(mps), in: Read MPS in file to this MPS
flnmCHARACTER(100), in: the MPS 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 MPS in the file, real/complex, no symm/symmetries). Default to .false.
errflagINTEGER, out: 0 : could read MPS; 1 : type of MPS does not correspond type of the MPS in the file (only checked for skip1st2=false).
closeunitLOGICAL, OPTIONAL, in: Flag if the unit should be closed on exit. Default to true.

Details

The file for MPS has the general form defined as below. Following these rules, it is possible to provide states to OpenMPS. * logical if MPS is real or complex valued (real=True, complex=False) [line 1] * logical if MPS or qMPS (qMPS=True, non-symmetry MPS=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 MPS 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_mps(Psi, flnm, unit, form, skip, closeunit, errst)
      type(mps), intent(out) :: Psi
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      logical, intent(in), optional :: skip, closeunit
      integer, intent(out), optional :: errst

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

      ! set the type of the MPS
      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_mps: 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, *) Psi%ll
          read(unit, *) Psi%oc
          allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
                   Psi%Lambda(Psi%ll + 1))

          ! Read the canonization toghether with the haslambda
          do ii = 1, Psi%ll
              read(unit, *) Psi%can(ii), Psi%haslambda(ii)
          end do
          read(unit, *) Psi%haslambda(Psi%ll + 1)

          ! Read the tensors of the MPS
          do ii = 1, Psi%ll
              call read(Psi%Aa(ii), unit, form)
          end do

          ! Read the values of the lambda
          do ii = 1, Psi%ll
              if(Psi%haslambda(ii)) then
                  call read(Psi%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_mps: 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) Psi%ll
          read(unit) Psi%oc
          allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
                   Psi%Lambda(Psi%ll + 1))

          ! Read the canonization and the haslambda as array
          read(unit) Psi%can
          read(unit) Psi%haslambda

          ! Read all the tensors
          do ii = 1, Psi%ll
              call read(Psi%Aa(ii), unit, form)
          end do

          ! Read the lambdas
          do ii = 1, Psi%ll
              if(Psi%haslambda(ii)) then
                  call read(Psi%lambda(ii), unit, form)
              end if
          end do

      else
          !errst = raise_error('read_mps: unallowed formatting.', &
          !                    99, 'MPSOps_include.f90:2755', errst=errst)
          return
      end if

      if(present(closeunit)) then
          if(closeunit) then
              close(unit)
          end if
      else
          close(unit)
      end if

  end subroutine read_mps

MPSOps_f90.read_mpsc()[source]¶

fortran-subroutine - June 2016 (dj, updated) Read an MPS given a filename and a unit (assuming you know the type already).

Arguments

PsiTYPE(mpsc), in: Read MPS in file to this MPS
flnmCHARACTER(100), in: the MPS 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 MPS in the file, real/complex, no symm/symmetries). Default to .false.
errflagINTEGER, out: 0 : could read MPS; 1 : type of MPS does not correspond type of the MPS in the file (only checked for skip1st2=false).
closeunitLOGICAL, OPTIONAL, in: Flag if the unit should be closed on exit. Default to true.

Details

The file for MPS has the general form defined as below. Following these rules, it is possible to provide states to OpenMPS. * logical if MPS is real or complex valued (real=True, complex=False) [line 1] * logical if MPS or qMPS (qMPS=True, non-symmetry MPS=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 MPS 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_mpsc(Psi, flnm, unit, form, skip, closeunit, errst)
      type(mpsc), intent(out) :: Psi
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      logical, intent(in), optional :: skip, closeunit
      integer, intent(out), optional :: errst

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

      ! set the type of the MPS
      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_mpsc: 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, *) Psi%ll
          read(unit, *) Psi%oc
          allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
                   Psi%Lambda(Psi%ll + 1))

          ! Read the canonization toghether with the haslambda
          do ii = 1, Psi%ll
              read(unit, *) Psi%can(ii), Psi%haslambda(ii)
          end do
          read(unit, *) Psi%haslambda(Psi%ll + 1)

          ! Read the tensors of the MPS
          do ii = 1, Psi%ll
              call read(Psi%Aa(ii), unit, form)
          end do

          ! Read the values of the lambda
          do ii = 1, Psi%ll
              if(Psi%haslambda(ii)) then
                  call read(Psi%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_mpsc: 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) Psi%ll
          read(unit) Psi%oc
          allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
                   Psi%Lambda(Psi%ll + 1))

          ! Read the canonization and the haslambda as array
          read(unit) Psi%can
          read(unit) Psi%haslambda

          ! Read all the tensors
          do ii = 1, Psi%ll
              call read(Psi%Aa(ii), unit, form)
          end do

          ! Read the lambdas
          do ii = 1, Psi%ll
              if(Psi%haslambda(ii)) then
                  call read(Psi%lambda(ii), unit, form)
              end if
          end do

      else
          !errst = raise_error('read_mpsc: unallowed formatting.', &
          !                    99, 'MPSOps_include.f90:2755', errst=errst)
          return
      end if

      if(present(closeunit)) then
          if(closeunit) then
              close(unit)
          end if
      else
          close(unit)
      end if

  end subroutine read_mpsc

MPSOps_f90.read_qmps()[source]¶

fortran-subroutine - June 2016 (dj, updated) Read an MPS given a filename and a unit (assuming you know the type already).

Arguments

PsiTYPE(qmps), in: Read MPS in file to this MPS
flnmCHARACTER(100), in: the MPS 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 MPS in the file, real/complex, no symm/symmetries). Default to .false.
errflagINTEGER, out: 0 : could read MPS; 1 : type of MPS does not correspond type of the MPS in the file (only checked for skip1st2=false).
closeunitLOGICAL, OPTIONAL, in: Flag if the unit should be closed on exit. Default to true.

Details

The file for MPS has the general form defined as below. Following these rules, it is possible to provide states to OpenMPS. * logical if MPS is real or complex valued (real=True, complex=False) [line 1] * logical if MPS or qMPS (qMPS=True, non-symmetry MPS=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 MPS 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_qmps(Psi, flnm, unit, form, skip, closeunit, errst)
      type(qmps), intent(out) :: Psi
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      logical, intent(in), optional :: skip, closeunit
      integer, intent(out), optional :: errst

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

      ! set the type of the MPS
      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_qmps: 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, *) Psi%ll
          read(unit, *) Psi%oc
          allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
                   Psi%Lambda(Psi%ll + 1))

          ! Read the canonization toghether with the haslambda
          do ii = 1, Psi%ll
              read(unit, *) Psi%can(ii), Psi%haslambda(ii)
          end do
          read(unit, *) Psi%haslambda(Psi%ll + 1)

          ! Read the tensors of the MPS
          do ii = 1, Psi%ll
              call read(Psi%Aa(ii), unit, form)
          end do

          ! Read the values of the lambda
          do ii = 1, Psi%ll
              if(Psi%haslambda(ii)) then
                  call read(Psi%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_qmps: 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) Psi%ll
          read(unit) Psi%oc
          allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
                   Psi%Lambda(Psi%ll + 1))

          ! Read the canonization and the haslambda as array
          read(unit) Psi%can
          read(unit) Psi%haslambda

          ! Read all the tensors
          do ii = 1, Psi%ll
              call read(Psi%Aa(ii), unit, form)
          end do

          ! Read the lambdas
          do ii = 1, Psi%ll
              if(Psi%haslambda(ii)) then
                  call read(Psi%lambda(ii), unit, form)
              end if
          end do

      else
          !errst = raise_error('read_qmps: unallowed formatting.', &
          !                    99, 'MPSOps_include.f90:2755', errst=errst)
          return
      end if

      if(present(closeunit)) then
          if(closeunit) then
              close(unit)
          end if
      else
          close(unit)
      end if

  end subroutine read_qmps

MPSOps_f90.read_qmpsc()[source]¶

fortran-subroutine - June 2016 (dj, updated) Read an MPS given a filename and a unit (assuming you know the type already).

Arguments

PsiTYPE(qmpsc), in: Read MPS in file to this MPS
flnmCHARACTER(100), in: the MPS 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 MPS in the file, real/complex, no symm/symmetries). Default to .false.
errflagINTEGER, out: 0 : could read MPS; 1 : type of MPS does not correspond type of the MPS in the file (only checked for skip1st2=false).
closeunitLOGICAL, OPTIONAL, in: Flag if the unit should be closed on exit. Default to true.

Details

The file for MPS has the general form defined as below. Following these rules, it is possible to provide states to OpenMPS. * logical if MPS is real or complex valued (real=True, complex=False) [line 1] * logical if MPS or qMPS (qMPS=True, non-symmetry MPS=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 MPS 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_qmpsc(Psi, flnm, unit, form, skip, closeunit, errst)
      type(qmpsc), intent(out) :: Psi
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      logical, intent(in), optional :: skip, closeunit
      integer, intent(out), optional :: errst

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

      ! set the type of the MPS
      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_qmpsc: 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, *) Psi%ll
          read(unit, *) Psi%oc
          allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
                   Psi%Lambda(Psi%ll + 1))

          ! Read the canonization toghether with the haslambda
          do ii = 1, Psi%ll
              read(unit, *) Psi%can(ii), Psi%haslambda(ii)
          end do
          read(unit, *) Psi%haslambda(Psi%ll + 1)

          ! Read the tensors of the MPS
          do ii = 1, Psi%ll
              call read(Psi%Aa(ii), unit, form)
          end do

          ! Read the values of the lambda
          do ii = 1, Psi%ll
              if(Psi%haslambda(ii)) then
                  call read(Psi%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_qmpsc: 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) Psi%ll
          read(unit) Psi%oc
          allocate(Psi%can(Psi%ll), Psi%haslambda(Psi%ll + 1), Psi%Aa(Psi%ll), &
                   Psi%Lambda(Psi%ll + 1))

          ! Read the canonization and the haslambda as array
          read(unit) Psi%can
          read(unit) Psi%haslambda

          ! Read all the tensors
          do ii = 1, Psi%ll
              call read(Psi%Aa(ii), unit, form)
          end do

          ! Read the lambdas
          do ii = 1, Psi%ll
              if(Psi%haslambda(ii)) then
                  call read(Psi%lambda(ii), unit, form)
              end if
          end do

      else
          !errst = raise_error('read_qmpsc: unallowed formatting.', &
          !                    99, 'MPSOps_include.f90:2755', errst=errst)
          return
      end if

      if(present(closeunit)) then
          if(closeunit) then
              close(unit)
          end if
      else
          close(unit)
      end if

  end subroutine read_qmpsc

MPSOps_f90.read_allmps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Read MPS from file if you do not know what kind of MPS is saved.

Arguments

PsiTYPE(mps), out: On exit set if MPS representing Psi is real and has no symmetries.
PsicTYPE(mpsc), out: On exit set if MPS representing Psi is complex and has no symmetries.
PsiqTYPE(qmps), out: On exit set if MPS representing is real and has symmetries.
PsiqcTYPE(qmpsc), out: On exit set if MPS representing is complex and has symmetries.
flagINTEGER, out: 0: reading real MPS, 1: complex MPS, 2: real symmetric MPS, 3: complex symmetric MPS
flnmCHARACTER(100), in: the MPS is stored in this file.
unitINTEGER, in: open file on this unit
formCHARACTER, in: Binary (‘B’) or human readable (‘H’)

Source Code

show / hide f90 code

  subroutine read_allmps(Psi, Psic, Psiq, Psicq, flag, flnm, unit, form, &
                         errst)
      type(mps), intent(out) :: Psi
      type(mpsc), intent(out) :: Psic
      type(qmps), intent(out) :: Psiq
      type(qmpsc), intent(out) :: Psicq
      integer, intent(out) :: flag
      character(len=*), intent(in) :: flnm
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! set the type of the MPS
      logical :: is_real, is_q

      !if(present(errst)) errst = 0

      if(form == 'H') then
          ! Read the formatted file
          ! -----------------------

          open(UNIT=unit, FILE=trim(flnm), ACTION='read')

          ! Figure out what kind of MPS we need
          read(unit, *) is_real
          read(unit, *) is_q

      elseif(form == 'B') then
          ! Read from the binary file

          open(UNIT=unit, FILE=trim(flnm), ACTION='read', &
               FORM='unformatted')

          ! Figure out what kind of MPS we need
          read(unit) is_real
          read(unit) is_q

      else
          !errst = raise_error('read_MPS_TYPE: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      if(is_real .and. (.not. is_q)) then
          ! Real (no symmetries)
          flag = 0
          call read(Psi, flnm, unit, form, skip=.true., errst=errst)
      elseif(.not. is_q) then
          ! Complex (no symmetries)
          flag = 1
          call read(Psic, flnm, unit, form, skip=.true., errst=errst)
      elseif(is_real) then
          ! Real and symmetry conservation
          flag = 2
          call read(Psiq, flnm, unit, form, skip=.true.,  errst=errst)
      else
          ! Complex and symmetry conservation
          flag = 3
          call read(Psicq, flnm, unit, form, skip=.true.,  errst=errst)
      end if

      !if(prop_error('real_allmps: read failed', errst=errst)) return

  end subroutine read_allmps

MPSOps_f90.rho_block_mps()[source]¶

fortran-subroutine - June 2018 (dj) Internal subroutine to build the reduced density matrix of a continuous block of sites.

Arguments

RhoTYPE(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.
PsiTYPE(mps), inout: Pure state to build density matrix from. Intent(inout) to shift orthogonality center.
k1INTEGER, in: First site of the subsystem.
k2INTEGER, in: Last site of the subsystem.

Source Code

show / hide f90 code

MPSOps_f90.rho_block_mpsc()[source]¶

fortran-subroutine - June 2018 (dj) Internal subroutine to build the reduced density matrix of a continuous block of sites.

Arguments

RhoTYPE(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.
PsiTYPE(mpsc), inout: Pure state to build density matrix from. Intent(inout) to shift orthogonality center.
k1INTEGER, in: First site of the subsystem.
k2INTEGER, in: Last site of the subsystem.

Source Code

show / hide f90 code

MPSOps_f90.rho_block_qmps()[source]¶

fortran-subroutine - June 2018 (dj) Internal subroutine to build the reduced density matrix of a continuous block of sites.

Arguments

RhoTYPE(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.
PsiTYPE(qmps), inout: Pure state to build density matrix from. Intent(inout) to shift orthogonality center.
k1INTEGER, in: First site of the subsystem.
k2INTEGER, in: Last site of the subsystem.

Source Code

show / hide f90 code

MPSOps_f90.rho_block_qmpsc()[source]¶

fortran-subroutine - June 2018 (dj) Internal subroutine to build the reduced density matrix of a continuous block of sites.

Arguments

RhoTYPE(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.
PsiTYPE(qmpsc), inout: Pure state to build density matrix from. Intent(inout) to shift orthogonality center.
k1INTEGER, in: First site of the subsystem.
k2INTEGER, in: Last site of the subsystem.

Source Code

show / hide f90 code

MPSOps_f90.rho_kk_mps()[source]¶

fortran-subroutine - July 2017 (dj) Calculate the reduced density matrix represented as tensor.

Arguments

RhoTYPE(tensor), out: The density matrix is stored in this tensor
PsiTYPE(mps), in: Calculate reduced density matrix for this MPS.
kkINTEGER, in: Select site where reduced density matrix should be calculated. It must be the orthogonality center.

Source Code

show / hide f90 code

MPSOps_f90.rho_kk_mpsc()[source]¶

fortran-subroutine - July 2017 (dj) Calculate the reduced density matrix represented as tensor.

Arguments

RhoTYPE(tensorc), out: The density matrix is stored in this tensor
PsiTYPE(mpsc), in: Calculate reduced density matrix for this MPS.
kkINTEGER, in: Select site where reduced density matrix should be calculated. It must be the orthogonality center.

Source Code

show / hide f90 code

MPSOps_f90.rho_kk_qmps()[source]¶

fortran-subroutine - July 2017 (dj) Calculate the reduced density matrix represented as tensor.

Arguments

RhoTYPE(qtensor), out: The density matrix is stored in this tensor
PsiTYPE(qmps), in: Calculate reduced density matrix for this MPS.
kkINTEGER, in: Select site where reduced density matrix should be calculated. It must be the orthogonality center.

Source Code

show / hide f90 code

MPSOps_f90.rho_kk_qmpsc()[source]¶

fortran-subroutine - July 2017 (dj) Calculate the reduced density matrix represented as tensor.

Arguments

RhoTYPE(qtensorc), out: The density matrix is stored in this tensor
PsiTYPE(qmpsc), in: Calculate reduced density matrix for this MPS.
kkINTEGER, in: Select site where reduced density matrix should be calculated. It must be the orthogonality center.

Source Code

show / hide f90 code

MPSOps_f90.rho_red_mps()[source]¶

fortran-subroutine - June 2018 (dj) Build a general reduced density matrix on multiple sites.

Arguments

RhoTYPE(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.
PsiTYPE(mps), inout: Pure state to build density matrix from. Intent(inout) to shift orthogonality center.
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_mps(Rho, Psi, sites, cont, trunc, ncut, err, errst)
      type(tensor), intent(out) :: Rho
      type(mps), intent(inout) :: Psi
      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

      ! array for permutations and identifying partial trace indices
      integer, dimension(:), allocatable :: ind
      logical, dimension(:), allocatable :: ptind

      ! Copy of MPS for transposed (truncation might change state)
      type(mps) :: Phi

      !if(present(errst)) errst = 0
      err = 0.0_rKind

      if(cont) then
          ! Continuous block of sites - use corresponding method directly
          ! -------------------------------------------------------------

          call rho_block_mps(Rho, Psi, sites(1), &
                                  sites(size(sites, 1)), errst=errst)
          !if(prop_error('rho_red_mps : rho_block failed.', &
          !              'MPSOps_include.f90:3159', errst=errst)) return
      else
          ! Permute first, then trace out
          ! -----------------------------

          allocate(ind(Psi%ll), ptind(Psi%ll))

          ptind = .true.
          ptind(sites) = .false.

          jj = size(sites, 1)
          ind(:jj) = sites

          do ii = 1, Psi%ll
              if(ptind(ii)) then
                  jj = jj + 1
                  ind(jj) = ii
              end if
          end do

          call copy(Phi, Psi)
          call transposed(Phi, ind, trunc, ncut, err, errst=errst)
          !if(prop_error('rho_red_mps :  transposed failed.', &
          !              'MPSOps_include.f90:3182', errst=errst)) return

          jj = size(sites, 1)
          call rho_block_mps(Rho, Phi, 1, jj, errst=errst)
          !if(prop_error('rho_red_mps : rho_block failed.', &
          !              'MPSOps_include.f90:3187', errst=errst)) return

          deallocate(ind, ptind)
          call destroy(Phi)
      end if

  end subroutine rho_red_mps

MPSOps_f90.rho_red_mpsc()[source]¶

fortran-subroutine - June 2018 (dj) Build a general reduced density matrix on multiple sites.

Arguments

RhoTYPE(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.
PsiTYPE(mpsc), inout: Pure state to build density matrix from. Intent(inout) to shift orthogonality center.
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_mpsc(Rho, Psi, sites, cont, trunc, ncut, err, errst)
      type(tensorc), intent(out) :: Rho
      type(mpsc), intent(inout) :: Psi
      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

      ! array for permutations and identifying partial trace indices
      integer, dimension(:), allocatable :: ind
      logical, dimension(:), allocatable :: ptind

      ! Copy of MPS for transposed (truncation might change state)
      type(mpsc) :: Phi

      !if(present(errst)) errst = 0
      err = 0.0_rKind

      if(cont) then
          ! Continuous block of sites - use corresponding method directly
          ! -------------------------------------------------------------

          call rho_block_mpsc(Rho, Psi, sites(1), &
                                  sites(size(sites, 1)), errst=errst)
          !if(prop_error('rho_red_mpsc : rho_block failed.', &
          !              'MPSOps_include.f90:3159', errst=errst)) return
      else
          ! Permute first, then trace out
          ! -----------------------------

          allocate(ind(Psi%ll), ptind(Psi%ll))

          ptind = .true.
          ptind(sites) = .false.

          jj = size(sites, 1)
          ind(:jj) = sites

          do ii = 1, Psi%ll
              if(ptind(ii)) then
                  jj = jj + 1
                  ind(jj) = ii
              end if
          end do

          call copy(Phi, Psi)
          call transposed(Phi, ind, trunc, ncut, err, errst=errst)
          !if(prop_error('rho_red_mpsc :  transposed failed.', &
          !              'MPSOps_include.f90:3182', errst=errst)) return

          jj = size(sites, 1)
          call rho_block_mpsc(Rho, Phi, 1, jj, errst=errst)
          !if(prop_error('rho_red_mpsc : rho_block failed.', &
          !              'MPSOps_include.f90:3187', errst=errst)) return

          deallocate(ind, ptind)
          call destroy(Phi)
      end if

  end subroutine rho_red_mpsc

MPSOps_f90.rho_red_qmps()[source]¶

fortran-subroutine - June 2018 (dj) Build a general reduced density matrix on multiple sites.

Arguments

RhoTYPE(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.
PsiTYPE(qmps), inout: Pure state to build density matrix from. Intent(inout) to shift orthogonality center.
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_qmps(Rho, Psi, sites, cont, trunc, ncut, err, errst)
      type(qtensor), intent(out) :: Rho
      type(qmps), intent(inout) :: Psi
      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

      ! array for permutations and identifying partial trace indices
      integer, dimension(:), allocatable :: ind
      logical, dimension(:), allocatable :: ptind

      ! Copy of MPS for transposed (truncation might change state)
      type(qmps) :: Phi

      !if(present(errst)) errst = 0
      err = 0.0_rKind

      if(cont) then
          ! Continuous block of sites - use corresponding method directly
          ! -------------------------------------------------------------

          call rho_block_qmps(Rho, Psi, sites(1), &
                                  sites(size(sites, 1)), errst=errst)
          !if(prop_error('rho_red_qmps : rho_block failed.', &
          !              'MPSOps_include.f90:3159', errst=errst)) return
      else
          ! Permute first, then trace out
          ! -----------------------------

          allocate(ind(Psi%ll), ptind(Psi%ll))

          ptind = .true.
          ptind(sites) = .false.

          jj = size(sites, 1)
          ind(:jj) = sites

          do ii = 1, Psi%ll
              if(ptind(ii)) then
                  jj = jj + 1
                  ind(jj) = ii
              end if
          end do

          call copy(Phi, Psi)
          call transposed(Phi, ind, trunc, ncut, err, errst=errst)
          !if(prop_error('rho_red_qmps :  transposed failed.', &
          !              'MPSOps_include.f90:3182', errst=errst)) return

          jj = size(sites, 1)
          call rho_block_qmps(Rho, Phi, 1, jj, errst=errst)
          !if(prop_error('rho_red_qmps : rho_block failed.', &
          !              'MPSOps_include.f90:3187', errst=errst)) return

          deallocate(ind, ptind)
          call destroy(Phi)
      end if

  end subroutine rho_red_qmps

MPSOps_f90.rho_red_qmpsc()[source]¶

fortran-subroutine - June 2018 (dj) Build a general reduced density matrix on multiple sites.

Arguments

RhoTYPE(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.
PsiTYPE(qmpsc), inout: Pure state to build density matrix from. Intent(inout) to shift orthogonality center.
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_qmpsc(Rho, Psi, sites, cont, trunc, ncut, err, errst)
      type(qtensorc), intent(out) :: Rho
      type(qmpsc), intent(inout) :: Psi
      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

      ! array for permutations and identifying partial trace indices
      integer, dimension(:), allocatable :: ind
      logical, dimension(:), allocatable :: ptind

      ! Copy of MPS for transposed (truncation might change state)
      type(qmpsc) :: Phi

      !if(present(errst)) errst = 0
      err = 0.0_rKind

      if(cont) then
          ! Continuous block of sites - use corresponding method directly
          ! -------------------------------------------------------------

          call rho_block_qmpsc(Rho, Psi, sites(1), &
                                  sites(size(sites, 1)), errst=errst)
          !if(prop_error('rho_red_qmpsc : rho_block failed.', &
          !              'MPSOps_include.f90:3159', errst=errst)) return
      else
          ! Permute first, then trace out
          ! -----------------------------

          allocate(ind(Psi%ll), ptind(Psi%ll))

          ptind = .true.
          ptind(sites) = .false.

          jj = size(sites, 1)
          ind(:jj) = sites

          do ii = 1, Psi%ll
              if(ptind(ii)) then
                  jj = jj + 1
                  ind(jj) = ii
              end if
          end do

          call copy(Phi, Psi)
          call transposed(Phi, ind, trunc, ncut, err, errst=errst)
          !if(prop_error('rho_red_qmpsc :  transposed failed.', &
          !              'MPSOps_include.f90:3182', errst=errst)) return

          jj = size(sites, 1)
          call rho_block_qmpsc(Rho, Phi, 1, jj, errst=errst)
          !if(prop_error('rho_red_qmpsc : rho_block failed.', &
          !              'MPSOps_include.f90:3187', errst=errst)) return

          deallocate(ind, ptind)
          call destroy(Phi)
      end if

  end subroutine rho_red_qmpsc

MPSOps_f90.scale_real_mps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Rescale Psi by some factor.

Arguments

scalefactorreal, in: some real number to scale MPS
PsiTYPE(mps), inout: Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Source Code

show / hide f90 code

MPSOps_f90.scale_real_mpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Rescale Psi by some factor.

Arguments

scalefactorreal, in: some real number to scale MPS
PsiTYPE(mpsc), inout: Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Source Code

show / hide f90 code

MPSOps_f90.scale_real_qmps()[source]¶

fortran-subroutine - June 2017 (dj, updated) Rescale Psi by some factor.

Arguments

scalefactorreal, in: some real number to scale MPS
PsiTYPE(qmps), inout: Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Source Code

show / hide f90 code

MPSOps_f90.scale_real_qmpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Rescale Psi by some factor.

Arguments

scalefactorreal, in: some real number to scale MPS
PsiTYPE(qmpsc), inout: Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Source Code

show / hide f90 code

MPSOps_f90.scale_complex_mpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Rescale Psi by some factor.

Arguments

scalefactorcomplex, in: some real number to scale MPS
PsiTYPE(mpsc), inout: Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Source Code

show / hide f90 code

MPSOps_f90.scale_complex_qmpsc()[source]¶

fortran-subroutine - June 2017 (dj, updated) Rescale Psi by some factor.

Arguments

scalefactorcomplex, in: some real number to scale MPS
PsiTYPE(qmpsc), inout: Mutliply the orthogonality center (or 1 if no orthogonality center) with a scalar factor).

Source Code

show / hide f90 code

MPSOps_f90.setuplr_mps()[source]¶

fortran-subroutine - June 2017 (dj) Initialize the left-right overlaps of two states.

Arguments

LRTYPE(tensorlist), inout: Contains on exit the left-right overlaps between Psia and Psib.
PsiaTYPE(mps), inout: The first wave function for the overlap.
PsibTYPE(mps), inout: The second wave function for the overlap.
kkINTEGER, OPTIONAL, in: Center for the left-right overlap. Default to the first site kk = 1.

Details

The array of left-right overlaps in an array of length L, where L is the number of sites. There are no identities padded to the left and right boundary.

Source Code

show / hide f90 code

MPSOps_f90.setuplr_mpsc()[source]¶

fortran-subroutine - June 2017 (dj) Initialize the left-right overlaps of two states.

Arguments

LRTYPE(tensorlistc), inout: Contains on exit the left-right overlaps between Psia and Psib.
PsiaTYPE(mpsc), inout: The first wave function for the overlap.
PsibTYPE(mpsc), inout: The second wave function for the overlap.
kkINTEGER, OPTIONAL, in: Center for the left-right overlap. Default to the first site kk = 1.

Details

The array of left-right overlaps in an array of length L, where L is the number of sites. There are no identities padded to the left and right boundary.

Source Code

show / hide f90 code

MPSOps_f90.setuplr_qmps()[source]¶

fortran-subroutine - June 2017 (dj) Initialize the left-right overlaps of two states.

Arguments

LRTYPE(qtensorlist), inout: Contains on exit the left-right overlaps between Psia and Psib.
PsiaTYPE(qmps), inout: The first wave function for the overlap.
PsibTYPE(qmps), inout: The second wave function for the overlap.
kkINTEGER, OPTIONAL, in: Center for the left-right overlap. Default to the first site kk = 1.

Details

The array of left-right overlaps in an array of length L, where L is the number of sites. There are no identities padded to the left and right boundary.

Source Code

show / hide f90 code

MPSOps_f90.setuplr_qmpsc()[source]¶

fortran-subroutine - June 2017 (dj) Initialize the left-right overlaps of two states.

Arguments

LRTYPE(qtensorclist), inout: Contains on exit the left-right overlaps between Psia and Psib.
PsiaTYPE(qmpsc), inout: The first wave function for the overlap.
PsibTYPE(qmpsc), inout: The second wave function for the overlap.
kkINTEGER, OPTIONAL, in: Center for the left-right overlap. Default to the first site kk = 1.

Details

The array of left-right overlaps in an array of length L, where L is the number of sites. There are no identities padded to the left and right boundary.

Source Code

show / hide f90 code

MPSOps_f90.swap_mps_tensor()[source]¶

fortran-subroutine - May 2018 (dj) Swap two nearest-neighbor sites in an MPS.

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 MPS). 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

MPSOps_f90.swap_mps_tensorc()[source]¶

fortran-subroutine - May 2018 (dj) Swap two nearest-neighbor sites in an MPS.

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 MPS). 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

MPSOps_f90.swap_mps_qtensor()[source]¶

fortran-subroutine - May 2018 (dj) Swap two nearest-neighbor sites in an MPS.

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 MPS). 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

MPSOps_f90.swap_mps_qtensorc()[source]¶

fortran-subroutine - May 2018 (dj) Swap two nearest-neighbor sites in an MPS.

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 MPS). 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

MPSOps_f90.transposed_mps()[source]¶

fortran-subroutine - May 2018 (dj) Permute the local Hilbert spaces.

Arguments

PsiTYPE(mps), inout: Permute MPS 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 MPS with unique entries 1 to L.
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.
cerrREAL, OPTIONAL, inout: Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine transposed_mps(Psi, perm, trunc, ncut, cerr, errst)
      type(mps), 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_mps : rank '//&
      !                        'mismatch.', 2, errst=errst)
      !    return
      !end if

      ! perm is intent(in), have to copy
      allocate(ind(Psi%ll))
      ind = perm

      do ii = 1, Psi%ll
          if(ind(ii) == ii) cycle

          call canonize(Psi, ind(ii), errst=errst)
          !if(prop_error('transposed_mps : canonize failed.', &
          !              'MPSOps_include.f90:3596', errst=errst)) return

          do jj = ind(ii), (ii + 1), -1
              if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))

              call swap_mps(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj), &
                            dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
                            errst=errst)
              !if(prop_error('transposed_mps : swap failed.', &
              !              'MPSOps_include.f90:3605', errst=errst)) return

              Psi%can(jj) = 'r'
              Psi%can(jj - 1) = 'c'
              Psi%oc = jj - 1
              Psi%haslambda(jj) = .true.
          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_mps

MPSOps_f90.transposed_mpsc()[source]¶

fortran-subroutine - May 2018 (dj) Permute the local Hilbert spaces.

Arguments

PsiTYPE(mpsc), inout: Permute MPS 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 MPS with unique entries 1 to L.
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.
cerrREAL, OPTIONAL, inout: Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine transposed_mpsc(Psi, perm, trunc, ncut, cerr, errst)
      type(mpsc), 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_mpsc : rank '//&
      !                        'mismatch.', 2, errst=errst)
      !    return
      !end if

      ! perm is intent(in), have to copy
      allocate(ind(Psi%ll))
      ind = perm

      do ii = 1, Psi%ll
          if(ind(ii) == ii) cycle

          call canonize(Psi, ind(ii), errst=errst)
          !if(prop_error('transposed_mpsc : canonize failed.', &
          !              'MPSOps_include.f90:3596', errst=errst)) return

          do jj = ind(ii), (ii + 1), -1
              if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))

              call swap_mps(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj), &
                            dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
                            errst=errst)
              !if(prop_error('transposed_mpsc : swap failed.', &
              !              'MPSOps_include.f90:3605', errst=errst)) return

              Psi%can(jj) = 'r'
              Psi%can(jj - 1) = 'c'
              Psi%oc = jj - 1
              Psi%haslambda(jj) = .true.
          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_mpsc

MPSOps_f90.transposed_qmps()[source]¶

fortran-subroutine - May 2018 (dj) Permute the local Hilbert spaces.

Arguments

PsiTYPE(qmps), inout: Permute MPS 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 MPS with unique entries 1 to L.
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.
cerrREAL, OPTIONAL, inout: Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine transposed_qmps(Psi, perm, trunc, ncut, cerr, errst)
      type(qmps), 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_qmps : rank '//&
      !                        'mismatch.', 2, errst=errst)
      !    return
      !end if

      ! perm is intent(in), have to copy
      allocate(ind(Psi%ll))
      ind = perm

      do ii = 1, Psi%ll
          if(ind(ii) == ii) cycle

          call canonize(Psi, ind(ii), errst=errst)
          !if(prop_error('transposed_qmps : canonize failed.', &
          !              'MPSOps_include.f90:3596', errst=errst)) return

          do jj = ind(ii), (ii + 1), -1
              if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))

              call swap_mps(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj), &
                            dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
                            errst=errst)
              !if(prop_error('transposed_qmps : swap failed.', &
              !              'MPSOps_include.f90:3605', errst=errst)) return

              Psi%can(jj) = 'r'
              Psi%can(jj - 1) = 'c'
              Psi%oc = jj - 1
              Psi%haslambda(jj) = .true.
          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_qmps

MPSOps_f90.transposed_qmpsc()[source]¶

fortran-subroutine - May 2018 (dj) Permute the local Hilbert spaces.

Arguments

PsiTYPE(qmpsc), inout: Permute MPS 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 MPS with unique entries 1 to L.
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.
cerrREAL, OPTIONAL, inout: Cumulative error from SVDs.

Source Code

show / hide f90 code

  subroutine transposed_qmpsc(Psi, perm, trunc, ncut, cerr, errst)
      type(qmpsc), 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_qmpsc : rank '//&
      !                        'mismatch.', 2, errst=errst)
      !    return
      !end if

      ! perm is intent(in), have to copy
      allocate(ind(Psi%ll))
      ind = perm

      do ii = 1, Psi%ll
          if(ind(ii) == ii) cycle

          call canonize(Psi, ind(ii), errst=errst)
          !if(prop_error('transposed_qmpsc : canonize failed.', &
          !              'MPSOps_include.f90:3596', errst=errst)) return

          do jj = ind(ii), (ii + 1), -1
              if(Psi%haslambda(jj)) call destroy(Psi%Lambda(jj))

              call swap_mps(Psi%Aa(jj - 1), Psi%Aa(jj), Psi%Lambda(jj), &
                            dir=-1, trunc=trunc, ncut=ncut, cerr=cerr, &
                            errst=errst)
              !if(prop_error('transposed_qmpsc : swap failed.', &
              !              'MPSOps_include.f90:3605', errst=errst)) return

              Psi%can(jj) = 'r'
              Psi%can(jj - 1) = 'c'
              Psi%oc = jj - 1
              Psi%haslambda(jj) = .true.
          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_qmpsc

MPSOps_f90.updatelr_mps()[source]¶

fortran-subroutine - June 2017 (dj) Shift the left-right overlap by one site.

Arguments

LRTYPE(tensorlist), inout: Contains on exit the left-right overlaps between Psia and Psib.
PsiaTYPE(mps), inout: The first wave function for the overlap.
PsibTYPE(mps), inout: The second wave function for the overlap.
kkINTEGER, in: New center for the left-right overlap.
senseINTEGER, in: Move center of the left-right overlap to the right for sense > 0 and to the left for sense < 0.

Source Code

show / hide f90 code

MPSOps_f90.updatelr_mpsc()[source]¶

fortran-subroutine - June 2017 (dj) Shift the left-right overlap by one site.

Arguments

LRTYPE(tensorlistc), inout: Contains on exit the left-right overlaps between Psia and Psib.
PsiaTYPE(mpsc), inout: The first wave function for the overlap.
PsibTYPE(mpsc), inout: The second wave function for the overlap.
kkINTEGER, in: New center for the left-right overlap.
senseINTEGER, in: Move center of the left-right overlap to the right for sense > 0 and to the left for sense < 0.

Source Code

show / hide f90 code

MPSOps_f90.updatelr_qmps()[source]¶

fortran-subroutine - June 2017 (dj) Shift the left-right overlap by one site.

Arguments

LRTYPE(qtensorlist), inout: Contains on exit the left-right overlaps between Psia and Psib.
PsiaTYPE(qmps), inout: The first wave function for the overlap.
PsibTYPE(qmps), inout: The second wave function for the overlap.
kkINTEGER, in: New center for the left-right overlap.
senseINTEGER, in: Move center of the left-right overlap to the right for sense > 0 and to the left for sense < 0.

Source Code

show / hide f90 code

MPSOps_f90.updatelr_qmpsc()[source]¶

fortran-subroutine - June 2017 (dj) Shift the left-right overlap by one site.

Arguments

LRTYPE(qtensorclist), inout: Contains on exit the left-right overlaps between Psia and Psib.
PsiaTYPE(qmpsc), inout: The first wave function for the overlap.
PsibTYPE(qmpsc), inout: The second wave function for the overlap.
kkINTEGER, in: New center for the left-right overlap.
senseINTEGER, in: Move center of the left-right overlap to the right for sense > 0 and to the left for sense < 0.

Source Code

show / hide f90 code

MPSOps_f90.write_mps()[source]¶

fortran-subroutine - August 2015 (dj) Write an MPS to file

Arguments

PsiTYPE(mps), in: save this MPS
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_mps

Source Code

show / hide f90 code

  subroutine write_mps(Psi, unit, form, errst)
      type(mps), intent(in) :: Psi
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! type of the MPS
      logical :: is_real, is_q

      ! for looping
      integer :: ii

      is_real = .true.
      is_q = .false.

      if(form == "6") then
          write(unit, *) 'MPS size, oc', Psi%ll, Psi%oc

          do ii = 1, Psi%ll
              write(unit, *) '           site i data:', ii
              write(unit, *) '           canonization', Psi%can(ii)
              write(unit, *) '           Lambda:', Psi%haslambda(ii)    

              if(Psi%haslambda(ii)) then
                  call print(Psi%Lambda(ii))
              end if
              call print(Psi%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 MPS type, the number of sites and
          ! the orthogonality center
          write(unit, *) is_real
          write(unit, *) is_q
          write(unit, *) Psi%ll
          write(unit, *) Psi%oc

          ! Write the canonization and the haslambda together
          do ii = 1, Psi%ll
              write(unit, *) Psi%can(ii), Psi%haslambda(ii)
          end do
          write(unit, *) Psi%haslambda(Psi%ll + 1)

          ! Write the tensors of the MPS
          do ii = 1, Psi%ll
              call write(Psi%Aa(ii), unit, form)
          end do

          ! Finally write the lambdas
          do ii = 1, Psi%ll + 1
              if(Psi%haslambda(ii)) then
                  call write(Psi%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 MPS type, the number of sites and
          ! the orthogonality center
          write(unit) is_real
          write(unit) is_q
          write(unit) Psi%ll
          write(unit) Psi%oc

          ! Canonization and haslambda go as array
          write(unit) Psi%can
          write(unit) Psi%haslambda

          ! Write the tensors of the MPS
          do ii = 1, Psi%ll
              call write(Psi%Aa(ii), unit, form)
          end do

          ! Finally write the values for the lambdas
          do ii = 1, Psi%ll + 1
              if(Psi%haslambda(ii)) then
                  call write(Psi%lambda(ii), unit, form)
              end if
          end do
      else
          !errst = raise_error('write_mps: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      !close(unit)

  end subroutine write_mps

MPSOps_f90.write_mpsc()[source]¶

fortran-subroutine - August 2015 (dj) Write an MPS to file

Arguments

PsiTYPE(mpsc), in: save this MPS
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_mpsc

Source Code

show / hide f90 code

  subroutine write_mpsc(Psi, unit, form, errst)
      type(mpsc), intent(in) :: Psi
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! type of the MPS
      logical :: is_real, is_q

      ! for looping
      integer :: ii

      is_real = .false.
      is_q = .false.

      if(form == "6") then
          write(unit, *) 'MPS size, oc', Psi%ll, Psi%oc

          do ii = 1, Psi%ll
              write(unit, *) '           site i data:', ii
              write(unit, *) '           canonization', Psi%can(ii)
              write(unit, *) '           Lambda:', Psi%haslambda(ii)    

              if(Psi%haslambda(ii)) then
                  call print(Psi%Lambda(ii))
              end if
              call print(Psi%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 MPS type, the number of sites and
          ! the orthogonality center
          write(unit, *) is_real
          write(unit, *) is_q
          write(unit, *) Psi%ll
          write(unit, *) Psi%oc

          ! Write the canonization and the haslambda together
          do ii = 1, Psi%ll
              write(unit, *) Psi%can(ii), Psi%haslambda(ii)
          end do
          write(unit, *) Psi%haslambda(Psi%ll + 1)

          ! Write the tensors of the MPS
          do ii = 1, Psi%ll
              call write(Psi%Aa(ii), unit, form)
          end do

          ! Finally write the lambdas
          do ii = 1, Psi%ll + 1
              if(Psi%haslambda(ii)) then
                  call write(Psi%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 MPS type, the number of sites and
          ! the orthogonality center
          write(unit) is_real
          write(unit) is_q
          write(unit) Psi%ll
          write(unit) Psi%oc

          ! Canonization and haslambda go as array
          write(unit) Psi%can
          write(unit) Psi%haslambda

          ! Write the tensors of the MPS
          do ii = 1, Psi%ll
              call write(Psi%Aa(ii), unit, form)
          end do

          ! Finally write the values for the lambdas
          do ii = 1, Psi%ll + 1
              if(Psi%haslambda(ii)) then
                  call write(Psi%lambda(ii), unit, form)
              end if
          end do
      else
          !errst = raise_error('write_mpsc: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      !close(unit)

  end subroutine write_mpsc

MPSOps_f90.write_qmps()[source]¶

fortran-subroutine - August 2015 (dj) Write an MPS to file

Arguments

PsiTYPE(qmps), in: save this MPS
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_qmps

Source Code

show / hide f90 code

  subroutine write_qmps(Psi, unit, form, errst)
      type(qmps), intent(in) :: Psi
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! type of the MPS
      logical :: is_real, is_q

      ! for looping
      integer :: ii

      is_real = .true.
      is_q = .true.

      if(form == "6") then
          write(unit, *) 'MPS size, oc', Psi%ll, Psi%oc

          do ii = 1, Psi%ll
              write(unit, *) '           site i data:', ii
              write(unit, *) '           canonization', Psi%can(ii)
              write(unit, *) '           Lambda:', Psi%haslambda(ii)    

              if(Psi%haslambda(ii)) then
                  call print(Psi%Lambda(ii))
              end if
              call print(Psi%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 MPS type, the number of sites and
          ! the orthogonality center
          write(unit, *) is_real
          write(unit, *) is_q
          write(unit, *) Psi%ll
          write(unit, *) Psi%oc

          ! Write the canonization and the haslambda together
          do ii = 1, Psi%ll
              write(unit, *) Psi%can(ii), Psi%haslambda(ii)
          end do
          write(unit, *) Psi%haslambda(Psi%ll + 1)

          ! Write the tensors of the MPS
          do ii = 1, Psi%ll
              call write(Psi%Aa(ii), unit, form)
          end do

          ! Finally write the lambdas
          do ii = 1, Psi%ll + 1
              if(Psi%haslambda(ii)) then
                  call write(Psi%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 MPS type, the number of sites and
          ! the orthogonality center
          write(unit) is_real
          write(unit) is_q
          write(unit) Psi%ll
          write(unit) Psi%oc

          ! Canonization and haslambda go as array
          write(unit) Psi%can
          write(unit) Psi%haslambda

          ! Write the tensors of the MPS
          do ii = 1, Psi%ll
              call write(Psi%Aa(ii), unit, form)
          end do

          ! Finally write the values for the lambdas
          do ii = 1, Psi%ll + 1
              if(Psi%haslambda(ii)) then
                  call write(Psi%lambda(ii), unit, form)
              end if
          end do
      else
          !errst = raise_error('write_qmps: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      !close(unit)

  end subroutine write_qmps

MPSOps_f90.write_qmpsc()[source]¶

fortran-subroutine - August 2015 (dj) Write an MPS to file

Arguments

PsiTYPE(qmpsc), in: save this MPS
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_qmpsc

Source Code

show / hide f90 code

  subroutine write_qmpsc(Psi, unit, form, errst)
      type(qmpsc), intent(in) :: Psi
      integer, intent(in) :: unit
      character, intent(in) :: form
      integer, intent(out), optional :: errst

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

      ! type of the MPS
      logical :: is_real, is_q

      ! for looping
      integer :: ii

      is_real = .false.
      is_q = .true.

      if(form == "6") then
          write(unit, *) 'MPS size, oc', Psi%ll, Psi%oc

          do ii = 1, Psi%ll
              write(unit, *) '           site i data:', ii
              write(unit, *) '           canonization', Psi%can(ii)
              write(unit, *) '           Lambda:', Psi%haslambda(ii)    

              if(Psi%haslambda(ii)) then
                  call print(Psi%Lambda(ii))
              end if
              call print(Psi%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 MPS type, the number of sites and
          ! the orthogonality center
          write(unit, *) is_real
          write(unit, *) is_q
          write(unit, *) Psi%ll
          write(unit, *) Psi%oc

          ! Write the canonization and the haslambda together
          do ii = 1, Psi%ll
              write(unit, *) Psi%can(ii), Psi%haslambda(ii)
          end do
          write(unit, *) Psi%haslambda(Psi%ll + 1)

          ! Write the tensors of the MPS
          do ii = 1, Psi%ll
              call write(Psi%Aa(ii), unit, form)
          end do

          ! Finally write the lambdas
          do ii = 1, Psi%ll + 1
              if(Psi%haslambda(ii)) then
                  call write(Psi%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 MPS type, the number of sites and
          ! the orthogonality center
          write(unit) is_real
          write(unit) is_q
          write(unit) Psi%ll
          write(unit) Psi%oc

          ! Canonization and haslambda go as array
          write(unit) Psi%can
          write(unit) Psi%haslambda

          ! Write the tensors of the MPS
          do ii = 1, Psi%ll
              call write(Psi%Aa(ii), unit, form)
          end do

          ! Finally write the values for the lambdas
          do ii = 1, Psi%ll + 1
              if(Psi%haslambda(ii)) then
                  call write(Psi%lambda(ii), unit, form)
              end if
          end do
      else
          !errst = raise_error('write_qmpsc: unallowed formatting.', &
          !                    99, errst=errst)
          return
      end if

      !close(unit)

  end subroutine write_qmpsc